1 ;;;; implementation-dependent transforms
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 ;;; We need to define these predicates, since the TYPEP source
15 ;;; transform picks whichever predicate was defined last when there
16 ;;; are multiple predicates for equivalent types.
17 (define-source-transform short-float-p
(x) `(single-float-p ,x
))
19 (define-source-transform long-float-p
(x) `(double-float-p ,x
))
21 (define-source-transform compiled-function-p
(x)
27 (not (sb!eval
:interpreted-function-p
,x
)))))
29 (define-source-transform char-int
(x)
32 (deftransform abs
((x) (rational))
33 '(if (< x
0) (- x
) x
))
35 ;;; We don't want to clutter the bignum code.
37 (define-source-transform sb
!bignum
:%bignum-ref
(bignum index
)
38 ;; KLUDGE: We use TRULY-THE here because even though the bignum code
39 ;; is (currently) compiled with (SAFETY 0), the compiler insists on
40 ;; inserting CAST nodes to ensure that INDEX is of the correct type.
41 ;; These CAST nodes do not generate any type checks, but they do
42 ;; interfere with the operation of FOLD-INDEX-ADDRESSING, below.
43 ;; This scenario is a problem for the more user-visible case of
44 ;; folding as well. --njf, 2006-12-01
45 `(sb!bignum
:%bignum-ref-with-offset
,bignum
46 (truly-the bignum-index
,index
) 0))
49 (defun fold-index-addressing (fun-name element-size lowtag data-offset
50 index offset
&optional setter-p
)
51 (multiple-value-bind (func index-args
) (extract-fun-args index
'(+ -
) 2)
52 (destructuring-bind (x constant
) index-args
53 (declare (ignorable x
))
54 (unless (constant-lvar-p constant
)
55 (give-up-ir1-transform))
56 (let ((value (lvar-value constant
)))
57 (unless (and (integerp value
)
58 (sb!vm
::foldable-constant-offset-p
59 element-size lowtag data-offset
60 (funcall func value
(lvar-value offset
))))
61 (give-up-ir1-transform "constant is too large for inlining"))
62 (splice-fun-args index func
2)
63 `(lambda (thing index off1 off2
,@(when setter-p
65 (,fun-name thing index
(,func off2 off1
) ,@(when setter-p
69 (deftransform sb
!bignum
:%bignum-ref-with-offset
70 ((bignum index offset
) * * :node node
)
71 (fold-index-addressing 'sb
!bignum
:%bignum-ref-with-offset
72 sb
!vm
:n-word-bits sb
!vm
:other-pointer-lowtag
73 sb
!vm
:bignum-digits-offset
76 ;;; The layout is stored in slot 0.
77 (define-source-transform %instance-layout
(x)
78 `(truly-the layout
(%instance-ref
,x
0)))
79 (define-source-transform %set-instance-layout
(x val
)
80 `(%instance-set
,x
0 (the layout
,val
)))
81 (define-source-transform %funcallable-instance-layout
(x)
82 `(truly-the layout
(%funcallable-instance-info
,x
0)))
83 (define-source-transform %set-funcallable-instance-layout
(x val
)
84 `(setf (%funcallable-instance-info
,x
0) (the layout
,val
)))
86 ;;;; character support
88 ;;; In our implementation there are really only BASE-CHARs.
90 (define-source-transform characterp
(obj)
93 ;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
95 (deftransform hairy-data-vector-ref
((string index
) (simple-string t
))
96 (let ((ctype (lvar-type string
)))
97 (if (array-type-p ctype
)
98 ;; the other transform will kick in, so that's OK
99 (give-up-ir1-transform)
101 ((simple-array character
(*))
102 (data-vector-ref string index
))
104 ((simple-array base-char
(*))
105 (data-vector-ref string index
))
106 ((simple-array nil
(*))
107 (data-vector-ref string index
))))))
109 (deftransform hairy-data-vector-ref
((array index
) (array t
) *)
110 "avoid runtime dispatch on array element type"
111 (let ((element-ctype (extract-upgraded-element-type array
))
112 (declared-element-ctype (extract-declared-element-type array
)))
113 (declare (type ctype element-ctype
))
114 (when (eq *wild-type
* element-ctype
)
115 (give-up-ir1-transform
116 "Upgraded element type of array is not known at compile time."))
117 ;; (The expansion here is basically a degenerate case of
118 ;; WITH-ARRAY-DATA. Since WITH-ARRAY-DATA is implemented as a
119 ;; macro, and macros aren't expanded in transform output, we have
120 ;; to hand-expand it ourselves.)
121 (let* ((element-type-specifier (type-specifier element-ctype
)))
122 `(multiple-value-bind (array index
)
123 (%data-vector-and-index array index
)
124 (declare (type (simple-array ,element-type-specifier
1) array
))
125 ,(let ((bare-form '(data-vector-ref array index
)))
126 (if (type= element-ctype declared-element-ctype
)
128 `(the ,(type-specifier declared-element-ctype
)
131 ;;; Transform multi-dimensional array to one dimensional data vector
133 (deftransform data-vector-ref
((array index
) (simple-array t
))
134 (let ((array-type (lvar-type array
)))
135 (unless (array-type-p array-type
)
136 (give-up-ir1-transform))
137 (let ((dims (array-type-dimensions array-type
)))
138 (when (or (atom dims
) (= (length dims
) 1))
139 (give-up-ir1-transform))
140 (let ((el-type (array-type-specialized-element-type array-type
))
141 (total-size (if (member '* dims
)
144 `(data-vector-ref (truly-the (simple-array ,(type-specifier el-type
)
146 (%array-data-vector array
))
149 ;;; Transform data vector access to a form that opens up optimization
152 (deftransform data-vector-ref
((array index
) ((or simple-unboxed-array
155 (let ((array-type (lvar-type array
)))
156 (unless (array-type-p array-type
)
157 (give-up-ir1-transform))
158 (let* ((element-type (type-specifier (array-type-specialized-element-type array-type
)))
159 (saetp (find element-type
160 sb
!vm
:*specialized-array-element-type-properties
*
161 :key
#'sb
!vm
:saetp-specifier
:test
#'equal
)))
162 (unless (>= (sb!vm
:saetp-n-bits saetp
) sb
!vm
:n-byte-bits
)
163 (give-up-ir1-transform))
164 `(data-vector-ref-with-offset array index
0))))
167 (deftransform data-vector-ref-with-offset
((array index offset
)
168 ((or simple-unboxed-array
171 (let ((array-type (lvar-type array
)))
172 (unless (array-type-p array-type
)
173 (give-up-ir1-transform))
174 (let* ((element-type (type-specifier (array-type-specialized-element-type array-type
)))
175 (saetp (find element-type
176 sb
!vm
:*specialized-array-element-type-properties
*
177 :key
#'sb
!vm
:saetp-specifier
:test
#'equal
)))
178 (aver (>= (sb!vm
:saetp-n-bits saetp
) sb
!vm
:n-byte-bits
))
179 (fold-index-addressing 'data-vector-ref-with-offset
180 (sb!vm
:saetp-n-bits saetp
)
181 sb
!vm
:other-pointer-lowtag
182 sb
!vm
:vector-data-offset
185 (deftransform hairy-data-vector-set
((string index new-value
)
187 (let ((ctype (lvar-type string
)))
188 (if (array-type-p ctype
)
189 ;; the other transform will kick in, so that's OK
190 (give-up-ir1-transform)
192 ((simple-array character
(*))
193 (data-vector-set string index new-value
))
195 ((simple-array base-char
(*))
196 (data-vector-set string index new-value
))
197 ((simple-array nil
(*))
198 (data-vector-set string index new-value
))))))
200 (deftransform hairy-data-vector-set
((array index new-value
)
203 "avoid runtime dispatch on array element type"
204 (let ((element-ctype (extract-upgraded-element-type array
))
205 (declared-element-ctype (extract-declared-element-type array
)))
206 (declare (type ctype element-ctype
))
207 (when (eq *wild-type
* element-ctype
)
208 (give-up-ir1-transform
209 "Upgraded element type of array is not known at compile time."))
210 (let ((element-type-specifier (type-specifier element-ctype
)))
211 `(multiple-value-bind (array index
)
212 (%data-vector-and-index array index
)
213 (declare (type (simple-array ,element-type-specifier
1) array
)
214 (type ,element-type-specifier new-value
))
215 ,(if (type= element-ctype declared-element-ctype
)
216 '(data-vector-set array index new-value
)
217 `(truly-the ,(type-specifier declared-element-ctype
)
218 (data-vector-set array index
219 (the ,(type-specifier declared-element-ctype
)
222 ;;; Transform multi-dimensional array to one dimensional data vector
224 (deftransform data-vector-set
((array index new-value
)
226 (let ((array-type (lvar-type array
)))
227 (unless (array-type-p array-type
)
228 (give-up-ir1-transform))
229 (let ((dims (array-type-dimensions array-type
)))
230 (when (or (atom dims
) (= (length dims
) 1))
231 (give-up-ir1-transform))
232 (let ((el-type (array-type-specialized-element-type array-type
))
233 (total-size (if (member '* dims
)
236 `(data-vector-set (truly-the (simple-array ,(type-specifier el-type
)
238 (%array-data-vector array
))
242 ;;; Transform data vector access to a form that opens up optimization
245 (deftransform data-vector-set
((array index new-value
)
246 ((or simple-unboxed-array simple-vector
)
248 (let ((array-type (lvar-type array
)))
249 (unless (array-type-p array-type
)
250 (give-up-ir1-transform))
251 (let* ((element-type (type-specifier (array-type-specialized-element-type array-type
)))
252 (saetp (find element-type
253 sb
!vm
:*specialized-array-element-type-properties
*
254 :key
#'sb
!vm
:saetp-specifier
:test
#'equal
)))
255 (unless (>= (sb!vm
:saetp-n-bits saetp
) sb
!vm
:n-byte-bits
)
256 (give-up-ir1-transform))
257 `(data-vector-set-with-offset array index
0 new-value
))))
260 (deftransform data-vector-set-with-offset
((array index offset new-value
)
261 ((or simple-unboxed-array
264 (let ((array-type (lvar-type array
)))
265 (unless (array-type-p array-type
)
266 (give-up-ir1-transform))
267 (let* ((element-type (type-specifier (array-type-specialized-element-type array-type
)))
268 (saetp (find element-type
269 sb
!vm
:*specialized-array-element-type-properties
*
270 :key
#'sb
!vm
:saetp-specifier
:test
#'equal
)))
271 (aver (>= (sb!vm
:saetp-n-bits saetp
) sb
!vm
:n-byte-bits
))
272 (fold-index-addressing 'data-vector-set-with-offset
273 (sb!vm
:saetp-n-bits saetp
)
274 sb
!vm
:other-pointer-lowtag
275 sb
!vm
:vector-data-offset
278 (defoptimizer (%data-vector-and-index derive-type
) ((array index
))
279 (let ((atype (lvar-type array
)))
280 (when (array-type-p atype
)
281 (values-specifier-type
282 `(values (simple-array ,(type-specifier
283 (array-type-specialized-element-type atype
))
287 (deftransform %data-vector-and-index
((%array %index
)
290 ;; KLUDGE: why the percent signs? Well, ARRAY and INDEX are
291 ;; respectively exported from the CL and SB!INT packages, which
292 ;; means that they're visible to all sorts of things. If the
293 ;; compiler can prove that the call to ARRAY-HEADER-P, below, either
294 ;; returns T or NIL, it will delete the irrelevant branch. However,
295 ;; user code might have got here with a variable named CL:ARRAY, and
296 ;; quite often compiler code with a variable named SB!INT:INDEX, so
297 ;; this can generate code deletion notes for innocuous user code:
298 ;; (DEFUN F (ARRAY I) (DECLARE (SIMPLE-VECTOR ARRAY)) (AREF ARRAY I))
299 ;; -- CSR, 2003-04-01
301 ;; We do this solely for the -OR-GIVE-UP side effect, since we want
302 ;; to know that the type can be figured out in the end before we
303 ;; proceed, but we don't care yet what the type will turn out to be.
304 (upgraded-element-type-specifier-or-give-up %array
)
306 '(if (array-header-p %array
)
307 (values (%array-data-vector %array
) %index
)
308 (values %array %index
)))
310 ;;; transforms for getting at simple arrays of (UNSIGNED-BYTE N) when (< N 8)
312 ;;; FIXME: In CMU CL, these were commented out with #+NIL. Why? Should
313 ;;; we fix them or should we delete them? (Perhaps these definitions
314 ;;; predate the various DATA-VECTOR-REF-FOO VOPs which have
315 ;;; (:TRANSLATE DATA-VECTOR-REF), and are redundant now?)
319 (let ((elements-per-word (truncate sb
!vm
:n-word-bits bits
)))
321 (deftransform data-vector-ref
((vector index
)
323 `(multiple-value-bind (word bit
)
324 (floor index
,',elements-per-word
)
325 (ldb ,(ecase sb
!vm
:target-byte-order
326 (:little-endian
'(byte ,bits
(* bit
,bits
)))
327 (:big-endian
'(byte ,bits
(- sb
!vm
:n-word-bits
328 (* (1+ bit
) ,bits
)))))
329 (%raw-bits vector
(+ word sb
!vm
:vector-data-offset
)))))
330 (deftransform data-vector-set
((vector index new-value
)
332 `(multiple-value-bind (word bit
)
333 (floor index
,',elements-per-word
)
334 (setf (ldb ,(ecase sb
!vm
:target-byte-order
335 (:little-endian
'(byte ,bits
(* bit
,bits
)))
337 '(byte ,bits
(- sb
!vm
:n-word-bits
338 (* (1+ bit
) ,bits
)))))
339 (%raw-bits vector
(+ word sb
!vm
:vector-data-offset
)))
341 (frob simple-bit-vector
1)
342 (frob (simple-array (unsigned-byte 2) (*)) 2)
343 (frob (simple-array (unsigned-byte 4) (*)) 4))
345 ;;;; BIT-VECTOR hackery
347 ;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word
348 ;;; loop that does 32 bits at a time.
350 ;;; FIXME: This is a lot of repeatedly macroexpanded code. It should
351 ;;; be a function call instead.
352 (macrolet ((def (bitfun wordfun
)
353 `(deftransform ,bitfun
((bit-array-1 bit-array-2 result-bit-array
)
358 :node node
:policy
(>= speed space
))
360 ,@(unless (policy node
(zerop safety
))
361 '((unless (= (length bit-array-1
)
363 (length result-bit-array
))
364 (error "Argument and/or result bit arrays are not the same length:~
369 (let ((length (length result-bit-array
)))
371 ;; We avoid doing anything to 0-length
372 ;; bit-vectors, or rather, the memory that
373 ;; follows them. Other divisible-by-32 cases
374 ;; are handled by the (1- length), below.
377 (do ((index sb
!vm
:vector-data-offset
(1+ index
))
378 (end-1 (+ sb
!vm
:vector-data-offset
379 ;; bit-vectors of length 1-32
380 ;; need precisely one (SETF
381 ;; %RAW-BITS), done here in the
382 ;; epilogue. - CSR, 2002-04-24
383 (truncate (truly-the index
(1- length
))
384 sb
!vm
:n-word-bits
))))
386 (setf (%raw-bits result-bit-array index
)
387 (,',wordfun
(%raw-bits bit-array-1 index
)
388 (%raw-bits bit-array-2 index
)))
390 (declare (optimize (speed 3) (safety 0))
391 (type index index end-1
))
392 (setf (%raw-bits result-bit-array index
)
393 (,',wordfun
(%raw-bits bit-array-1 index
)
394 (%raw-bits bit-array-2 index
))))))))))
395 (def bit-and word-logical-and
)
396 (def bit-ior word-logical-or
)
397 (def bit-xor word-logical-xor
)
398 (def bit-eqv word-logical-eqv
)
399 (def bit-nand word-logical-nand
)
400 (def bit-nor word-logical-nor
)
401 (def bit-andc1 word-logical-andc1
)
402 (def bit-andc2 word-logical-andc2
)
403 (def bit-orc1 word-logical-orc1
)
404 (def bit-orc2 word-logical-orc2
))
406 (deftransform bit-not
407 ((bit-array result-bit-array
)
408 (simple-bit-vector simple-bit-vector
) *
409 :node node
:policy
(>= speed space
))
411 ,@(unless (policy node
(zerop safety
))
412 '((unless (= (length bit-array
)
413 (length result-bit-array
))
414 (error "Argument and result bit arrays are not the same length:~
416 bit-array result-bit-array
))))
417 (let ((length (length result-bit-array
)))
419 ;; We avoid doing anything to 0-length bit-vectors, or rather,
420 ;; the memory that follows them. Other divisible-by
421 ;; n-word-bits cases are handled by the (1- length), below.
424 (do ((index sb
!vm
:vector-data-offset
(1+ index
))
425 (end-1 (+ sb
!vm
:vector-data-offset
426 ;; bit-vectors of length 1 to n-word-bits need
427 ;; precisely one (SETF %RAW-BITS), done here in
428 ;; the epilogue. - CSR, 2002-04-24
429 (truncate (truly-the index
(1- length
))
430 sb
!vm
:n-word-bits
))))
432 (setf (%raw-bits result-bit-array index
)
433 (word-logical-not (%raw-bits bit-array index
)))
435 (declare (optimize (speed 3) (safety 0))
436 (type index index end-1
))
437 (setf (%raw-bits result-bit-array index
)
438 (word-logical-not (%raw-bits bit-array index
))))))))
440 (deftransform bit-vector-
= ((x y
) (simple-bit-vector simple-bit-vector
))
441 `(and (= (length x
) (length y
))
442 (let ((length (length x
)))
444 (do* ((i sb
!vm
:vector-data-offset
(+ i
1))
445 (end-1 (+ sb
!vm
:vector-data-offset
446 (floor (1- length
) sb
!vm
:n-word-bits
))))
448 (let* ((extra (1+ (mod (1- length
) sb
!vm
:n-word-bits
)))
449 (mask (ash #.
(1- (ash 1 sb
!vm
:n-word-bits
))
450 (- extra sb
!vm
:n-word-bits
)))
454 ,(ecase sb
!c
:*backend-byte-order
*
457 '(- sb
!vm
:n-word-bits extra
))))
462 ,(ecase sb
!c
:*backend-byte-order
*
465 '(- sb
!vm
:n-word-bits extra
))))
467 (declare (type (integer 1 #.sb
!vm
:n-word-bits
) extra
)
468 (type sb
!vm
:word mask numx numy
))
470 (declare (type index i end-1
))
471 (let ((numx (%raw-bits x i
))
472 (numy (%raw-bits y i
)))
473 (declare (type sb
!vm
:word numx numy
))
474 (unless (= numx numy
)
477 (deftransform count
((item sequence
) (bit simple-bit-vector
) *
478 :policy
(>= speed space
))
479 `(let ((length (length sequence
)))
482 (do ((index sb
!vm
:vector-data-offset
(1+ index
))
484 (end-1 (+ sb
!vm
:vector-data-offset
485 (truncate (truly-the index
(1- length
))
486 sb
!vm
:n-word-bits
))))
488 (let* ((extra (1+ (mod (1- length
) sb
!vm
:n-word-bits
)))
489 (mask (ash #.
(1- (ash 1 sb
!vm
:n-word-bits
))
490 (- extra sb
!vm
:n-word-bits
)))
491 (bits (logand (ash mask
492 ,(ecase sb
!c
:*backend-byte-order
*
495 '(- sb
!vm
:n-word-bits extra
))))
496 (%raw-bits sequence index
))))
497 (declare (type (integer 1 #.sb
!vm
:n-word-bits
) extra
))
498 (declare (type sb
!vm
:word mask bits
))
499 (incf count
(logcount bits
))
500 ,(if (constant-lvar-p item
)
501 (if (zerop (lvar-value item
))
507 (declare (type index index count end-1
)
508 (optimize (speed 3) (safety 0)))
509 (incf count
(logcount (%raw-bits sequence index
)))))))
511 (deftransform fill
((sequence item
) (simple-bit-vector bit
) *
512 :policy
(>= speed space
))
513 (let ((value (if (constant-lvar-p item
)
514 (if (= (lvar-value item
) 0)
516 #.
(1- (ash 1 sb
!vm
:n-word-bits
)))
517 `(if (= item
0) 0 #.
(1- (ash 1 sb
!vm
:n-word-bits
))))))
518 `(let ((length (length sequence
))
522 (do ((index sb
!vm
:vector-data-offset
(1+ index
))
523 (end-1 (+ sb
!vm
:vector-data-offset
524 ;; bit-vectors of length 1 to n-word-bits need
525 ;; precisely one (SETF %RAW-BITS), done here
526 ;; in the epilogue. - CSR, 2002-04-24
527 (truncate (truly-the index
(1- length
))
528 sb
!vm
:n-word-bits
))))
530 (setf (%raw-bits sequence index
) value
)
532 (declare (optimize (speed 3) (safety 0))
533 (type index index end-1
))
534 (setf (%raw-bits sequence index
) value
))))))
536 (deftransform fill
((sequence item
) (simple-base-string base-char
) *
537 :policy
(>= speed space
))
538 (let ((value (if (constant-lvar-p item
)
539 (let* ((char (lvar-value item
))
540 (code (sb!xc
:char-code char
))
542 (dotimes (i sb
!vm
:n-word-bytes accum
)
543 (setf accum
(logior accum
(ash code
(* 8 i
))))))
544 `(let ((code (sb!xc
:char-code item
)))
545 (logior ,@(loop for i from
0 below sb
!vm
:n-word-bytes
546 collect
`(ash code
,(* 8 i
))))))))
547 `(let ((length (length sequence
))
549 (multiple-value-bind (times rem
)
550 (truncate length sb
!vm
:n-word-bytes
)
551 (do ((index sb
!vm
:vector-data-offset
(1+ index
))
552 (end (+ times sb
!vm
:vector-data-offset
)))
554 (let ((place (* times sb
!vm
:n-word-bytes
)))
555 (declare (fixnum place
))
556 (dotimes (j rem sequence
)
558 (setf (schar sequence
(the index
(+ place j
))) item
))))
559 (declare (optimize (speed 3) (safety 0))
561 (setf (%raw-bits sequence index
) value
))))))
565 ;;; FIXME: The old CMU CL code used various COPY-TO/FROM-SYSTEM-AREA
566 ;;; stuff (with all the associated bit-index cruft and overflow
567 ;;; issues) even for byte moves. In SBCL, we're converting to byte
568 ;;; moves as problems are discovered with the old code, and this is
569 ;;; currently (ca. sbcl-0.6.12.30) the main interface for code in
570 ;;; SB!KERNEL and SB!SYS (e.g. i/o code). It's not clear that it's the
571 ;;; ideal interface, though, and it probably deserves some thought.
572 (deftransform %byte-blt
((src src-start dst dst-start dst-end
)
573 ((or (simple-unboxed-array (*)) system-area-pointer
)
575 (or (simple-unboxed-array (*)) system-area-pointer
)
578 ;; FIXME: CMU CL had a hairier implementation of this (back when it
579 ;; was still called (%PRIMITIVE BYTE-BLT). It had the small problem
580 ;; that it didn't work for large (>16M) values of SRC-START or
581 ;; DST-START. However, it might have been more efficient. In
582 ;; particular, I don't really know how much the foreign function
583 ;; call costs us here. My guess is that if the overhead is
584 ;; acceptable for SQRT and COS, it's acceptable here, but this
585 ;; should probably be checked. -- WHN
586 '(flet ((sapify (thing)
588 (system-area-pointer thing
)
589 ;; FIXME: The code here rather relies on the simple
590 ;; unboxed array here having byte-sized entries. That
591 ;; should be asserted explicitly, I just haven't found
592 ;; a concise way of doing it. (It would be nice to
593 ;; declare it in the DEFKNOWN too.)
594 ((simple-unboxed-array (*)) (vector-sap thing
)))))
595 (declare (inline sapify
))
597 (memmove (sap+ (sapify dst
) dst-start
)
598 (sap+ (sapify src
) src-start
)
599 (- dst-end dst-start
)))
602 ;;;; transforms for EQL of floating point values
604 (deftransform eql
((x y
) (single-float single-float
))
605 '(= (single-float-bits x
) (single-float-bits y
)))
607 (deftransform eql
((x y
) (double-float double-float
))
608 '(and (= (double-float-low-bits x
) (double-float-low-bits y
))
609 (= (double-float-high-bits x
) (double-float-high-bits y
))))
612 ;;;; modular functions
613 (define-good-modular-fun logand
:unsigned
)
614 (define-good-modular-fun logior
:unsigned
)
615 ;;; FIXME: XOR? ANDC1, ANDC2? -- CSR, 2003-09-16
618 ((def (name class width
)
619 (let ((type (ecase class
620 (:unsigned
'unsigned-byte
)
621 (:signed
'signed-byte
))))
623 (defknown ,name
(integer (integer 0)) (,type
,width
)
624 (foldable flushable movable
))
625 (define-modular-fun-optimizer ash
((integer count
) ,class
:width width
)
626 (when (and (<= width
,width
)
627 (or (and (constant-lvar-p count
)
628 (plusp (lvar-value count
)))
629 (csubtypep (lvar-type count
)
630 (specifier-type '(and unsigned-byte fixnum
)))))
631 (cut-to-width integer
,class width
)
633 (setf (gethash ',name
(modular-class-versions (find-modular-class ',class
)))
635 ;; This should really be dependent on SB!VM:N-WORD-BITS, but since we
636 ;; don't have a true Alpha64 port yet, we'll have to stick to
637 ;; SB!VM:N-MACHINE-WORD-BITS for the time being. --njf, 2004-08-14
638 #!+#.
(cl:if
(cl:= 32 sb
!vm
:n-machine-word-bits
) '(and) '(or))
640 #!+x86
(def sb
!vm
::ash-left-smod30
:signed
30)
641 (def sb
!vm
::ash-left-mod32
:unsigned
32))
642 #!+#.
(cl:if
(cl:= 64 sb
!vm
:n-machine-word-bits
) '(and) '(or))
644 #!+x86-64
(def sb
!vm
::ash-left-smod61
:signed
61)
645 (def sb
!vm
::ash-left-mod64
:unsigned
64)))
648 ;;;; word-wise logical operations
650 ;;; These transforms assume the presence of modular arithmetic to
651 ;;; generate efficient code.
653 (define-source-transform word-logical-not
(x)
654 `(logand (lognot (the sb
!vm
:word
,x
)) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
656 (deftransform word-logical-and
((x y
))
659 (deftransform word-logical-nand
((x y
))
660 '(logand (lognand x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
662 (deftransform word-logical-or
((x y
))
665 (deftransform word-logical-nor
((x y
))
666 '(logand (lognor x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
668 (deftransform word-logical-xor
((x y
))
671 (deftransform word-logical-eqv
((x y
))
672 '(logand (logeqv x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
674 (deftransform word-logical-orc1
((x y
))
675 '(logand (logorc1 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
677 (deftransform word-logical-orc2
((x y
))
678 '(logand (logorc2 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
680 (deftransform word-logical-andc1
((x y
))
681 '(logand (logandc1 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
683 (deftransform word-logical-andc2
((x y
))
684 '(logand (logandc2 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
687 ;;; There are two different ways the multiplier can be recoded. The
688 ;;; more obvious is to shift X by the correct amount for each bit set
689 ;;; in Y and to sum the results. But if there is a string of bits that
690 ;;; are all set, you can add X shifted by one more then the bit
691 ;;; position of the first set bit and subtract X shifted by the bit
692 ;;; position of the last set bit. We can't use this second method when
693 ;;; the high order bit is bit 31 because shifting by 32 doesn't work
695 (defun ub32-strength-reduce-constant-multiply (arg num
)
696 (declare (type (unsigned-byte 32) num
))
697 (let ((adds 0) (shifts 0)
698 (result nil
) first-one
)
699 (labels ((add (next-factor)
702 (progn (incf adds
) `(+ ,result
,next-factor
))
704 (declare (inline add
))
707 (when (not (logbitp bitpos num
))
708 (add (if (= (1+ first-one
) bitpos
)
709 ;; There is only a single bit in the string.
710 (progn (incf shifts
) `(ash ,arg
,first-one
))
711 ;; There are at least two.
715 `(- (ash ,arg
,bitpos
)
716 (ash ,arg
,first-one
)))))
717 (setf first-one nil
))
718 (when (logbitp bitpos num
)
719 (setf first-one bitpos
))))
721 (cond ((= first-one
31))
722 ((= first-one
30) (incf shifts
) (add `(ash ,arg
30)))
726 (add `(- (ash ,arg
31)
727 (ash ,arg
,first-one
)))))
729 (add `(ash ,arg
31))))
730 (values (if (plusp adds
)
731 `(logand ,result
#.
(1- (ash 1 32))) ; using modular arithmetic
737 ;;; Transform GET-LISP-OBJ-ADDRESS for constant immediates, since the normal
738 ;;; VOP can't handle them.
740 (deftransform sb
!vm
::get-lisp-obj-address
((obj) ((constant-arg fixnum
)))
741 (ash (lvar-value obj
) sb
!vm
::n-fixnum-tag-bits
))
743 (deftransform sb
!vm
::get-lisp-obj-address
((obj) ((constant-arg character
)))
744 (logior sb
!vm
::character-widetag
745 (ash (char-code (lvar-value obj
)) sb
!vm
::n-widetag-bits
)))