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
78 (define-source-transform sb!kernel:%vector-raw-bits (thing index)
79 `(sb!kernel:%raw-bits-with-offset ,thing ,index 2))
81 (define-source-transform sb!kernel:%raw-bits (thing index)
82 `(sb!kernel:%raw-bits-with-offset ,thing ,index 0))
84 (define-source-transform sb!kernel:%set-vector-raw-bits (thing index value)
85 `(sb!kernel:%set-raw-bits-with-offset ,thing ,index 2 ,value))
87 (define-source-transform sb!kernel:%set-raw-bits (thing index value)
88 `(sb!kernel:%set-raw-bits-with-offset ,thing ,index 0 ,value))
90 (deftransform sb!kernel:%raw-bits-with-offset ((thing index offset) * * :node node)
91 (fold-index-addressing 'sb!kernel:%raw-bits-with-offset
92 sb!vm:n-word-bits sb!vm:other-pointer-lowtag
95 (deftransform sb!kernel:%set-raw-bits-with-offset ((thing index offset value) * *)
96 (fold-index-addressing 'sb!kernel:%set-raw-bits-with-offset
97 sb!vm:n-word-bits sb!vm:other-pointer-lowtag
101 ;;; The layout is stored in slot 0.
102 (define-source-transform %instance-layout (x)
103 `(truly-the layout (%instance-ref ,x 0)))
104 (define-source-transform %set-instance-layout (x val)
105 `(%instance-set ,x 0 (the layout ,val)))
106 (define-source-transform %funcallable-instance-layout (x)
107 `(truly-the layout (%funcallable-instance-info ,x 0)))
108 (define-source-transform %set-funcallable-instance-layout (x val)
109 `(setf (%funcallable-instance-info ,x 0) (the layout ,val)))
111 ;;;; character support
113 ;;; In our implementation there are really only BASE-CHARs.
115 (define-source-transform characterp (obj)
118 ;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
120 (deftransform hairy-data-vector-ref ((string index) (simple-string t))
121 (let ((ctype (lvar-type string)))
122 (if (array-type-p ctype)
123 ;; the other transform will kick in, so that's OK
124 (give-up-ir1-transform)
126 ((simple-array character (*))
127 (data-vector-ref string index))
129 ((simple-array base-char (*))
130 (data-vector-ref string index))
131 ((simple-array nil (*))
132 (data-vector-ref string index))))))
134 (deftransform hairy-data-vector-ref ((array index) (array t) *)
135 "avoid runtime dispatch on array element type"
136 (let ((element-ctype (extract-upgraded-element-type array))
137 (declared-element-ctype (extract-declared-element-type array)))
138 (declare (type ctype element-ctype))
139 (when (eq *wild-type* element-ctype)
140 (give-up-ir1-transform
141 "Upgraded element type of array is not known at compile time."))
142 ;; (The expansion here is basically a degenerate case of
143 ;; WITH-ARRAY-DATA. Since WITH-ARRAY-DATA is implemented as a
144 ;; macro, and macros aren't expanded in transform output, we have
145 ;; to hand-expand it ourselves.)
146 (let* ((element-type-specifier (type-specifier element-ctype)))
147 `(multiple-value-bind (array index)
148 (%data-vector-and-index array index)
149 (declare (type (simple-array ,element-type-specifier 1) array))
150 ,(let ((bare-form '(data-vector-ref array index)))
151 (if (type= element-ctype declared-element-ctype)
153 `(the ,(type-specifier declared-element-ctype)
156 ;;; Transform multi-dimensional array to one dimensional data vector
158 (deftransform data-vector-ref ((array index) (simple-array t))
159 (let ((array-type (lvar-type array)))
160 (unless (array-type-p array-type)
161 (give-up-ir1-transform))
162 (let ((dims (array-type-dimensions array-type)))
163 (when (or (atom dims) (= (length dims) 1))
164 (give-up-ir1-transform))
165 (let ((el-type (array-type-specialized-element-type array-type))
166 (total-size (if (member '* dims)
169 `(data-vector-ref (truly-the (simple-array ,(type-specifier el-type)
171 (%array-data-vector array))
174 ;;; Transform data vector access to a form that opens up optimization
177 (deftransform data-vector-ref ((array index) ((or (simple-unboxed-array (*))
180 (let ((array-type (lvar-type array)))
181 (unless (array-type-p array-type)
182 (give-up-ir1-transform))
183 (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
184 (saetp (find-saetp element-type)))
185 (unless (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)
186 (give-up-ir1-transform))
187 `(data-vector-ref-with-offset array index 0))))
190 (deftransform data-vector-ref-with-offset ((array index offset)
191 ((or (simple-unboxed-array (*))
194 (let ((array-type (lvar-type array)))
195 (unless (array-type-p array-type)
196 (give-up-ir1-transform))
197 (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
198 (saetp (find-saetp element-type)))
199 (aver (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits))
200 (fold-index-addressing 'data-vector-ref-with-offset
201 (sb!vm:saetp-n-bits saetp)
202 sb!vm:other-pointer-lowtag
203 sb!vm:vector-data-offset
206 (deftransform hairy-data-vector-set ((string index new-value)
208 (let ((ctype (lvar-type string)))
209 (if (array-type-p ctype)
210 ;; the other transform will kick in, so that's OK
211 (give-up-ir1-transform)
213 ((simple-array character (*))
214 (data-vector-set string index new-value))
216 ((simple-array base-char (*))
217 (data-vector-set string index new-value))
218 ((simple-array nil (*))
219 (data-vector-set string index new-value))))))
221 (deftransform hairy-data-vector-set ((array index new-value)
224 "avoid runtime dispatch on array element type"
225 (let ((element-ctype (extract-upgraded-element-type array))
226 (declared-element-ctype (extract-declared-element-type array)))
227 (declare (type ctype element-ctype))
228 (when (eq *wild-type* element-ctype)
229 (give-up-ir1-transform
230 "Upgraded element type of array is not known at compile time."))
231 (let ((element-type-specifier (type-specifier element-ctype)))
232 `(multiple-value-bind (array index)
233 (%data-vector-and-index array index)
234 (declare (type (simple-array ,element-type-specifier 1) array)
235 (type ,element-type-specifier new-value))
236 ,(if (type= element-ctype declared-element-ctype)
237 '(data-vector-set array index new-value)
238 `(truly-the ,(type-specifier declared-element-ctype)
239 (data-vector-set array index
240 (the ,(type-specifier declared-element-ctype)
243 ;;; Transform multi-dimensional array to one dimensional data vector
245 (deftransform data-vector-set ((array index new-value)
247 (let ((array-type (lvar-type array)))
248 (unless (array-type-p array-type)
249 (give-up-ir1-transform))
250 (let ((dims (array-type-dimensions array-type)))
251 (when (or (atom dims) (= (length dims) 1))
252 (give-up-ir1-transform))
253 (let ((el-type (array-type-specialized-element-type array-type))
254 (total-size (if (member '* dims)
257 `(data-vector-set (truly-the (simple-array ,(type-specifier el-type)
259 (%array-data-vector array))
263 ;;; Transform data vector access to a form that opens up optimization
266 (deftransform data-vector-set ((array index new-value)
267 ((or (simple-unboxed-array (*)) simple-vector)
269 (let ((array-type (lvar-type array)))
270 (unless (array-type-p array-type)
271 (give-up-ir1-transform))
272 (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
273 (saetp (find-saetp element-type)))
274 (unless (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)
275 (give-up-ir1-transform))
276 `(data-vector-set-with-offset array index 0 new-value))))
279 (deftransform data-vector-set-with-offset ((array index offset new-value)
280 ((or (simple-unboxed-array (*))
283 (let ((array-type (lvar-type array)))
284 (unless (array-type-p array-type)
285 (give-up-ir1-transform))
286 (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
287 (saetp (find-saetp element-type)))
288 (aver (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits))
289 (fold-index-addressing 'data-vector-set-with-offset
290 (sb!vm:saetp-n-bits saetp)
291 sb!vm:other-pointer-lowtag
292 sb!vm:vector-data-offset
295 (defoptimizer (%data-vector-and-index derive-type) ((array index))
296 (let ((atype (lvar-type array)))
297 (when (array-type-p atype)
298 (values-specifier-type
299 `(values (simple-array ,(type-specifier
300 (array-type-specialized-element-type atype))
304 (deftransform %data-vector-and-index ((%array %index)
307 ;; KLUDGE: why the percent signs? Well, ARRAY and INDEX are
308 ;; respectively exported from the CL and SB!INT packages, which
309 ;; means that they're visible to all sorts of things. If the
310 ;; compiler can prove that the call to ARRAY-HEADER-P, below, either
311 ;; returns T or NIL, it will delete the irrelevant branch. However,
312 ;; user code might have got here with a variable named CL:ARRAY, and
313 ;; quite often compiler code with a variable named SB!INT:INDEX, so
314 ;; this can generate code deletion notes for innocuous user code:
315 ;; (DEFUN F (ARRAY I) (DECLARE (SIMPLE-VECTOR ARRAY)) (AREF ARRAY I))
316 ;; -- CSR, 2003-04-01
318 ;; We do this solely for the -OR-GIVE-UP side effect, since we want
319 ;; to know that the type can be figured out in the end before we
320 ;; proceed, but we don't care yet what the type will turn out to be.
321 (upgraded-element-type-specifier-or-give-up %array)
323 '(if (array-header-p %array)
324 (values (%array-data-vector %array) %index)
325 (values %array %index)))
327 ;;; transforms for getting at simple arrays of (UNSIGNED-BYTE N) when (< N 8)
329 ;;; FIXME: In CMU CL, these were commented out with #+NIL. Why? Should
330 ;;; we fix them or should we delete them? (Perhaps these definitions
331 ;;; predate the various DATA-VECTOR-REF-FOO VOPs which have
332 ;;; (:TRANSLATE DATA-VECTOR-REF), and are redundant now?)
336 (let ((elements-per-word (truncate sb!vm:n-word-bits bits)))
338 (deftransform data-vector-ref ((vector index)
340 `(multiple-value-bind (word bit)
341 (floor index ,',elements-per-word)
342 (ldb ,(ecase sb!vm:target-byte-order
343 (:little-endian '(byte ,bits (* bit ,bits)))
344 (:big-endian '(byte ,bits (- sb!vm:n-word-bits
345 (* (1+ bit) ,bits)))))
346 (%raw-bits vector (+ word sb!vm:vector-data-offset)))))
347 (deftransform data-vector-set ((vector index new-value)
349 `(multiple-value-bind (word bit)
350 (floor index ,',elements-per-word)
351 (setf (ldb ,(ecase sb!vm:target-byte-order
352 (:little-endian '(byte ,bits (* bit ,bits)))
354 '(byte ,bits (- sb!vm:n-word-bits
355 (* (1+ bit) ,bits)))))
356 (%raw-bits vector (+ word sb!vm:vector-data-offset)))
358 (frob simple-bit-vector 1)
359 (frob (simple-array (unsigned-byte 2) (*)) 2)
360 (frob (simple-array (unsigned-byte 4) (*)) 4))
362 ;;;; BIT-VECTOR hackery
364 ;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word
365 ;;; loop that does 32 bits at a time.
367 ;;; FIXME: This is a lot of repeatedly macroexpanded code. It should
368 ;;; be a function call instead.
369 (macrolet ((def (bitfun wordfun)
370 `(deftransform ,bitfun ((bit-array-1 bit-array-2 result-bit-array)
375 :node node :policy (>= speed space))
377 ,@(unless (policy node (zerop safety))
378 '((unless (= (length bit-array-1)
380 (length result-bit-array))
381 (error "Argument and/or result bit arrays are not the same length:~
386 (let ((length (length result-bit-array)))
388 ;; We avoid doing anything to 0-length
389 ;; bit-vectors, or rather, the memory that
390 ;; follows them. Other divisible-by-32 cases
391 ;; are handled by the (1- length), below.
394 (do ((index sb!vm:vector-data-offset (1+ index))
395 (end-1 (+ sb!vm:vector-data-offset
396 ;; bit-vectors of length 1-32
397 ;; need precisely one (SETF
398 ;; %RAW-BITS), done here in the
399 ;; epilogue. - CSR, 2002-04-24
400 (truncate (truly-the index (1- length))
401 sb!vm:n-word-bits))))
403 (setf (%raw-bits result-bit-array index)
404 (,',wordfun (%raw-bits bit-array-1 index)
405 (%raw-bits bit-array-2 index)))
407 (declare (optimize (speed 3) (safety 0))
408 (type index index end-1))
409 (setf (%raw-bits result-bit-array index)
410 (,',wordfun (%raw-bits bit-array-1 index)
411 (%raw-bits bit-array-2 index))))))))))
412 (def bit-and word-logical-and)
413 (def bit-ior word-logical-or)
414 (def bit-xor word-logical-xor)
415 (def bit-eqv word-logical-eqv)
416 (def bit-nand word-logical-nand)
417 (def bit-nor word-logical-nor)
418 (def bit-andc1 word-logical-andc1)
419 (def bit-andc2 word-logical-andc2)
420 (def bit-orc1 word-logical-orc1)
421 (def bit-orc2 word-logical-orc2))
423 (deftransform bit-not
424 ((bit-array result-bit-array)
425 (simple-bit-vector simple-bit-vector) *
426 :node node :policy (>= speed space))
428 ,@(unless (policy node (zerop safety))
429 '((unless (= (length bit-array)
430 (length result-bit-array))
431 (error "Argument and result bit arrays are not the same length:~
433 bit-array result-bit-array))))
434 (let ((length (length result-bit-array)))
436 ;; We avoid doing anything to 0-length bit-vectors, or rather,
437 ;; the memory that follows them. Other divisible-by
438 ;; n-word-bits cases are handled by the (1- length), below.
441 (do ((index sb!vm:vector-data-offset (1+ index))
442 (end-1 (+ sb!vm:vector-data-offset
443 ;; bit-vectors of length 1 to n-word-bits need
444 ;; precisely one (SETF %RAW-BITS), done here in
445 ;; the epilogue. - CSR, 2002-04-24
446 (truncate (truly-the index (1- length))
447 sb!vm:n-word-bits))))
449 (setf (%raw-bits result-bit-array index)
450 (word-logical-not (%raw-bits bit-array index)))
452 (declare (optimize (speed 3) (safety 0))
453 (type index index end-1))
454 (setf (%raw-bits result-bit-array index)
455 (word-logical-not (%raw-bits bit-array index))))))))
457 (deftransform bit-vector-= ((x y) (simple-bit-vector simple-bit-vector))
458 `(and (= (length x) (length y))
459 (let ((length (length x)))
461 (do* ((i sb!vm:vector-data-offset (+ i 1))
462 (end-1 (+ sb!vm:vector-data-offset
463 (floor (1- length) sb!vm:n-word-bits))))
465 (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
466 (mask (ash #.(1- (ash 1 sb!vm:n-word-bits))
467 (- extra sb!vm:n-word-bits)))
471 ,(ecase sb!c:*backend-byte-order*
474 '(- sb!vm:n-word-bits extra))))
479 ,(ecase sb!c:*backend-byte-order*
482 '(- sb!vm:n-word-bits extra))))
484 (declare (type (integer 1 #.sb!vm:n-word-bits) extra)
485 (type sb!vm:word mask numx numy))
487 (declare (type index i end-1))
488 (let ((numx (%raw-bits x i))
489 (numy (%raw-bits y i)))
490 (declare (type sb!vm:word numx numy))
491 (unless (= numx numy)
494 (deftransform count ((item sequence) (bit simple-bit-vector) *
495 :policy (>= speed space))
496 `(let ((length (length sequence)))
499 (do ((index sb!vm:vector-data-offset (1+ index))
501 (end-1 (+ sb!vm:vector-data-offset
502 (truncate (truly-the index (1- length))
503 sb!vm:n-word-bits))))
505 (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
506 (mask (ash #.(1- (ash 1 sb!vm:n-word-bits))
507 (- extra sb!vm:n-word-bits)))
508 (bits (logand (ash mask
509 ,(ecase sb!c:*backend-byte-order*
512 '(- sb!vm:n-word-bits extra))))
513 (%raw-bits sequence index))))
514 (declare (type (integer 1 #.sb!vm:n-word-bits) extra))
515 (declare (type sb!vm:word mask bits))
516 (incf count (logcount bits))
517 ,(if (constant-lvar-p item)
518 (if (zerop (lvar-value item))
524 (declare (type index index count end-1)
525 (optimize (speed 3) (safety 0)))
526 (incf count (logcount (%raw-bits sequence index)))))))
528 (deftransform fill ((sequence item) (simple-bit-vector bit) *
529 :policy (>= speed space))
530 (let ((value (if (constant-lvar-p item)
531 (if (= (lvar-value item) 0)
533 #.(1- (ash 1 sb!vm:n-word-bits)))
534 `(if (= item 0) 0 #.(1- (ash 1 sb!vm:n-word-bits))))))
535 `(let ((length (length sequence))
539 (do ((index sb!vm:vector-data-offset (1+ index))
540 (end-1 (+ sb!vm:vector-data-offset
541 ;; bit-vectors of length 1 to n-word-bits need
542 ;; precisely one (SETF %RAW-BITS), done here
543 ;; in the epilogue. - CSR, 2002-04-24
544 (truncate (truly-the index (1- length))
545 sb!vm:n-word-bits))))
547 (setf (%raw-bits sequence index) value)
549 (declare (optimize (speed 3) (safety 0))
550 (type index index end-1))
551 (setf (%raw-bits sequence index) value))))))
553 (deftransform fill ((sequence item) (simple-base-string base-char) *
554 :policy (>= speed space))
555 (let ((value (if (constant-lvar-p item)
556 (let* ((char (lvar-value item))
557 (code (sb!xc:char-code char))
559 (dotimes (i sb!vm:n-word-bytes accum)
560 (setf accum (logior accum (ash code (* 8 i))))))
561 `(let ((code (sb!xc:char-code item)))
562 (logior ,@(loop for i from 0 below sb!vm:n-word-bytes
563 collect `(ash code ,(* 8 i))))))))
564 `(let ((length (length sequence))
566 (multiple-value-bind (times rem)
567 (truncate length sb!vm:n-word-bytes)
568 (do ((index sb!vm:vector-data-offset (1+ index))
569 (end (+ times sb!vm:vector-data-offset)))
571 (let ((place (* times sb!vm:n-word-bytes)))
572 (declare (fixnum place))
573 (dotimes (j rem sequence)
575 (setf (schar sequence (the index (+ place j))) item))))
576 (declare (optimize (speed 3) (safety 0))
578 (setf (%raw-bits sequence index) value))))))
582 ;;; FIXME: The old CMU CL code used various COPY-TO/FROM-SYSTEM-AREA
583 ;;; stuff (with all the associated bit-index cruft and overflow
584 ;;; issues) even for byte moves. In SBCL, we're converting to byte
585 ;;; moves as problems are discovered with the old code, and this is
586 ;;; currently (ca. sbcl-0.6.12.30) the main interface for code in
587 ;;; SB!KERNEL and SB!SYS (e.g. i/o code). It's not clear that it's the
588 ;;; ideal interface, though, and it probably deserves some thought.
589 (deftransform %byte-blt ((src src-start dst dst-start dst-end)
590 ((or (simple-unboxed-array (*)) system-area-pointer)
592 (or (simple-unboxed-array (*)) system-area-pointer)
595 ;; FIXME: CMU CL had a hairier implementation of this (back when it
596 ;; was still called (%PRIMITIVE BYTE-BLT). It had the small problem
597 ;; that it didn't work for large (>16M) values of SRC-START or
598 ;; DST-START. However, it might have been more efficient. In
599 ;; particular, I don't really know how much the foreign function
600 ;; call costs us here. My guess is that if the overhead is
601 ;; acceptable for SQRT and COS, it's acceptable here, but this
602 ;; should probably be checked. -- WHN
603 '(flet ((sapify (thing)
605 (system-area-pointer thing)
606 ;; FIXME: The code here rather relies on the simple
607 ;; unboxed array here having byte-sized entries. That
608 ;; should be asserted explicitly, I just haven't found
609 ;; a concise way of doing it. (It would be nice to
610 ;; declare it in the DEFKNOWN too.)
611 ((simple-unboxed-array (*)) (vector-sap thing)))))
612 (declare (inline sapify))
614 (memmove (sap+ (sapify dst) dst-start)
615 (sap+ (sapify src) src-start)
616 (- dst-end dst-start)))
619 ;;;; transforms for EQL of floating point values
621 (deftransform eql ((x y) (single-float single-float))
622 '(= (single-float-bits x) (single-float-bits y)))
624 (deftransform eql ((x y) (double-float double-float))
625 '(and (= (double-float-low-bits x) (double-float-low-bits y))
626 (= (double-float-high-bits x) (double-float-high-bits y))))
629 ;;;; modular functions
630 (define-good-modular-fun logand :unsigned)
631 (define-good-modular-fun logior :unsigned)
632 ;;; FIXME: XOR? ANDC1, ANDC2? -- CSR, 2003-09-16
635 ((def (name class width)
636 (let ((type (ecase class
637 (:unsigned 'unsigned-byte)
638 (:signed 'signed-byte))))
640 (defknown ,name (integer (integer 0)) (,type ,width)
641 (foldable flushable movable))
642 (define-modular-fun-optimizer ash ((integer count) ,class :width width)
643 (when (and (<= width ,width)
644 (or (and (constant-lvar-p count)
645 (plusp (lvar-value count)))
646 (csubtypep (lvar-type count)
647 (specifier-type '(and unsigned-byte fixnum)))))
648 (cut-to-width integer ,class width)
650 (setf (gethash ',name (modular-class-versions (find-modular-class ',class)))
652 ;; This should really be dependent on SB!VM:N-WORD-BITS, but since we
653 ;; don't have a true Alpha64 port yet, we'll have to stick to
654 ;; SB!VM:N-MACHINE-WORD-BITS for the time being. --njf, 2004-08-14
655 #!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or))
657 #!+x86 (def sb!vm::ash-left-smod30 :signed 30)
658 (def sb!vm::ash-left-mod32 :unsigned 32))
659 #!+#.(cl:if (cl:= 64 sb!vm:n-machine-word-bits) '(and) '(or))
661 #!+x86-64 (def sb!vm::ash-left-smod61 :signed 61)
662 (def sb!vm::ash-left-mod64 :unsigned 64)))
665 ;;;; word-wise logical operations
667 ;;; These transforms assume the presence of modular arithmetic to
668 ;;; generate efficient code.
670 (define-source-transform word-logical-not (x)
671 `(logand (lognot (the sb!vm:word ,x)) #.(1- (ash 1 sb!vm:n-word-bits))))
673 (deftransform word-logical-and ((x y))
676 (deftransform word-logical-nand ((x y))
677 '(logand (lognand x y) #.(1- (ash 1 sb!vm:n-word-bits))))
679 (deftransform word-logical-or ((x y))
682 (deftransform word-logical-nor ((x y))
683 '(logand (lognor x y) #.(1- (ash 1 sb!vm:n-word-bits))))
685 (deftransform word-logical-xor ((x y))
688 (deftransform word-logical-eqv ((x y))
689 '(logand (logeqv x y) #.(1- (ash 1 sb!vm:n-word-bits))))
691 (deftransform word-logical-orc1 ((x y))
692 '(logand (logorc1 x y) #.(1- (ash 1 sb!vm:n-word-bits))))
694 (deftransform word-logical-orc2 ((x y))
695 '(logand (logorc2 x y) #.(1- (ash 1 sb!vm:n-word-bits))))
697 (deftransform word-logical-andc1 ((x y))
698 '(logand (logandc1 x y) #.(1- (ash 1 sb!vm:n-word-bits))))
700 (deftransform word-logical-andc2 ((x y))
701 '(logand (logandc2 x y) #.(1- (ash 1 sb!vm:n-word-bits))))
704 ;;; There are two different ways the multiplier can be recoded. The
705 ;;; more obvious is to shift X by the correct amount for each bit set
706 ;;; in Y and to sum the results. But if there is a string of bits that
707 ;;; are all set, you can add X shifted by one more then the bit
708 ;;; position of the first set bit and subtract X shifted by the bit
709 ;;; position of the last set bit. We can't use this second method when
710 ;;; the high order bit is bit 31 because shifting by 32 doesn't work
712 (defun ub32-strength-reduce-constant-multiply (arg num)
713 (declare (type (unsigned-byte 32) num))
714 (let ((adds 0) (shifts 0)
715 (result nil) first-one)
716 (labels ((add (next-factor)
719 (progn (incf adds) `(+ ,result ,next-factor))
721 (declare (inline add))
724 (when (not (logbitp bitpos num))
725 (add (if (= (1+ first-one) bitpos)
726 ;; There is only a single bit in the string.
727 (progn (incf shifts) `(ash ,arg ,first-one))
728 ;; There are at least two.
732 `(- (ash ,arg ,bitpos)
733 (ash ,arg ,first-one)))))
734 (setf first-one nil))
735 (when (logbitp bitpos num)
736 (setf first-one bitpos))))
738 (cond ((= first-one 31))
739 ((= first-one 30) (incf shifts) (add `(ash ,arg 30)))
743 (add `(- (ash ,arg 31)
744 (ash ,arg ,first-one)))))
746 (add `(ash ,arg 31))))
747 (values (if (plusp adds)
748 `(logand ,result #.(1- (ash 1 32))) ; using modular arithmetic
754 ;;; Transform GET-LISP-OBJ-ADDRESS for constant immediates, since the normal
755 ;;; VOP can't handle them.
757 (deftransform sb!vm::get-lisp-obj-address ((obj) ((constant-arg fixnum)))
758 (ash (lvar-value obj) sb!vm::n-fixnum-tag-bits))
760 (deftransform sb!vm::get-lisp-obj-address ((obj) ((constant-arg character)))
761 (logior sb!vm::character-widetag
762 (ash (char-code (lvar-value obj)) sb!vm::n-widetag-bits)))