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 ;;; This and the corresponding -SET transform work equally well on non-simple
110 ;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases
111 ;;; where it actually helped with non-simple arrays -- to the contrary, it
112 ;;; only made for bigger and up 1o 100% slower code.
113 (deftransform hairy-data-vector-ref
((array index
) (simple-array t
) *)
114 "avoid runtime dispatch on array element type"
115 (let* ((type (lvar-type array
))
116 (element-ctype (array-type-upgraded-element-type type
))
117 (declared-element-ctype (array-type-declared-element-type type
)))
118 (declare (type ctype element-ctype
))
119 (when (eq *wild-type
* element-ctype
)
120 (give-up-ir1-transform
121 "Upgraded element type of array is not known at compile time."))
122 ;; (The expansion here is basically a degenerate case of
123 ;; WITH-ARRAY-DATA. Since WITH-ARRAY-DATA is implemented as a
124 ;; macro, and macros aren't expanded in transform output, we have
125 ;; to hand-expand it ourselves.)
126 (let* ((element-type-specifier (type-specifier element-ctype
)))
127 `(multiple-value-bind (array index
)
128 (%data-vector-and-index array index
)
129 (declare (type (simple-array ,element-type-specifier
1) array
))
130 ,(let ((bare-form '(data-vector-ref array index
)))
131 (if (type= element-ctype declared-element-ctype
)
133 `(the ,(type-specifier declared-element-ctype
)
136 ;;; Transform multi-dimensional array to one dimensional data vector
138 (deftransform data-vector-ref
((array index
) (simple-array t
))
139 (let ((array-type (lvar-type array
)))
140 (unless (array-type-p array-type
)
141 (give-up-ir1-transform))
142 (let ((dims (array-type-dimensions array-type
)))
143 (when (or (atom dims
) (= (length dims
) 1))
144 (give-up-ir1-transform))
145 (let ((el-type (array-type-specialized-element-type array-type
))
146 (total-size (if (member '* dims
)
149 `(data-vector-ref (truly-the (simple-array ,(type-specifier el-type
)
151 (%array-data-vector array
))
154 ;;; Transform data vector access to a form that opens up optimization
155 ;;; opportunities. On platforms that support DATA-VECTOR-REF-WITH-OFFSET
156 ;;; DATA-VECTOR-REF is not supported at all.
158 (define-source-transform data-vector-ref
(array index
)
159 `(data-vector-ref-with-offset ,array
,index
0))
162 (deftransform data-vector-ref-with-offset
((array index offset
))
163 (let ((array-type (lvar-type array
)))
164 (when (or (not (array-type-p array-type
))
165 (eql (array-type-specialized-element-type array-type
)
167 (give-up-ir1-transform))
168 ;; It shouldn't be possible to get here with anything but a non-complex
170 (aver (not (array-type-complexp array-type
)))
171 (let* ((element-type (type-specifier (array-type-specialized-element-type array-type
)))
172 (saetp (find-saetp element-type
)))
173 (when (< (sb!vm
:saetp-n-bits saetp
) sb
!vm
:n-byte-bits
)
174 (give-up-ir1-transform))
175 (fold-index-addressing 'data-vector-ref-with-offset
176 (sb!vm
:saetp-n-bits saetp
)
177 sb
!vm
:other-pointer-lowtag
178 sb
!vm
:vector-data-offset
181 (deftransform hairy-data-vector-set
((string index new-value
)
183 (let ((ctype (lvar-type string
)))
184 (if (array-type-p ctype
)
185 ;; the other transform will kick in, so that's OK
186 (give-up-ir1-transform)
188 ((simple-array character
(*))
189 (data-vector-set string index new-value
))
191 ((simple-array base-char
(*))
192 (data-vector-set string index new-value
))
193 ((simple-array nil
(*))
194 (data-vector-set string index new-value
))))))
196 ;;; This and the corresponding -REF transform work equally well on non-simple
197 ;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases
198 ;;; where it actually helped with non-simple arrays -- to the contrary, it
199 ;;; only made for bigger and up 1o 100% slower code.
200 (deftransform hairy-data-vector-set
((array index new-value
)
203 "avoid runtime dispatch on array element type"
204 (let* ((type (lvar-type array
))
205 (element-ctype (array-type-upgraded-element-type type
))
206 (declared-element-ctype (array-type-declared-element-type type
)))
207 (declare (type ctype element-ctype
))
208 (when (eq *wild-type
* element-ctype
)
209 (give-up-ir1-transform
210 "Upgraded element type of array is not known at compile time."))
211 (let ((element-type-specifier (type-specifier element-ctype
)))
212 `(multiple-value-bind (array index
)
213 (%data-vector-and-index array index
)
214 (declare (type (simple-array ,element-type-specifier
1) array
)
215 (type ,element-type-specifier new-value
))
216 ,(if (type= element-ctype declared-element-ctype
)
217 '(data-vector-set array index new-value
)
218 `(truly-the ,(type-specifier declared-element-ctype
)
219 (data-vector-set array index
220 (the ,(type-specifier declared-element-ctype
)
223 ;;; Transform multi-dimensional array to one dimensional data vector
225 (deftransform data-vector-set
((array index new-value
)
227 (let ((array-type (lvar-type array
)))
228 (unless (array-type-p array-type
)
229 (give-up-ir1-transform))
230 (let ((dims (array-type-dimensions array-type
)))
231 (when (or (atom dims
) (= (length dims
) 1))
232 (give-up-ir1-transform))
233 (let ((el-type (array-type-specialized-element-type array-type
))
234 (total-size (if (member '* dims
)
237 `(data-vector-set (truly-the (simple-array ,(type-specifier el-type
)
239 (%array-data-vector array
))
243 ;;; Transform data vector access to a form that opens up optimization
246 (define-source-transform data-vector-set
(array index new-value
)
247 `(data-vector-set-with-offset ,array
,index
0 ,new-value
))
250 (deftransform data-vector-set-with-offset
((array index offset new-value
))
251 (let ((array-type (lvar-type array
)))
252 (when (or (not (array-type-p array-type
))
253 (eql (array-type-specialized-element-type array-type
)
255 ;; We don't yet know the exact element type, but will get that
256 ;; knowledge after some more type propagation.
257 (give-up-ir1-transform))
258 (aver (not (array-type-complexp array-type
)))
259 (let* ((element-type (type-specifier (array-type-specialized-element-type array-type
)))
260 (saetp (find-saetp element-type
)))
261 (when (< (sb!vm
:saetp-n-bits saetp
) sb
!vm
:n-byte-bits
)
262 (give-up-ir1-transform))
263 (fold-index-addressing 'data-vector-set-with-offset
264 (sb!vm
:saetp-n-bits saetp
)
265 sb
!vm
:other-pointer-lowtag
266 sb
!vm
:vector-data-offset
269 (defun maybe-array-data-vector-type-specifier (array-lvar)
270 (let ((atype (lvar-type array-lvar
)))
271 (when (array-type-p atype
)
272 (let ((dims (array-type-dimensions atype
)))
273 (if (or (array-type-complexp atype
)
275 (notevery #'integerp dims
))
276 `(simple-array ,(type-specifier
277 (array-type-specialized-element-type atype
))
279 `(simple-array ,(type-specifier
280 (array-type-specialized-element-type atype
))
281 (,(apply #'* dims
))))))))
283 (macrolet ((def (name)
284 `(defoptimizer (,name derive-type
) ((array-lvar))
285 (let ((spec (maybe-array-data-vector-type-specifier array-lvar
)))
287 (specifier-type spec
))))))
288 (def %array-data-vector
)
289 (def array-storage-vector
))
291 (defoptimizer (%data-vector-and-index derive-type
) ((array index
))
292 (let ((spec (maybe-array-data-vector-type-specifier array
)))
294 (values-specifier-type `(values ,spec index
)))))
296 (deftransform %data-vector-and-index
((%array %index
)
299 ;; KLUDGE: why the percent signs? Well, ARRAY and INDEX are
300 ;; respectively exported from the CL and SB!INT packages, which
301 ;; means that they're visible to all sorts of things. If the
302 ;; compiler can prove that the call to ARRAY-HEADER-P, below, either
303 ;; returns T or NIL, it will delete the irrelevant branch. However,
304 ;; user code might have got here with a variable named CL:ARRAY, and
305 ;; quite often compiler code with a variable named SB!INT:INDEX, so
306 ;; this can generate code deletion notes for innocuous user code:
307 ;; (DEFUN F (ARRAY I) (DECLARE (SIMPLE-VECTOR ARRAY)) (AREF ARRAY I))
308 ;; -- CSR, 2003-04-01
310 ;; We do this solely for the -OR-GIVE-UP side effect, since we want
311 ;; to know that the type can be figured out in the end before we
312 ;; proceed, but we don't care yet what the type will turn out to be.
313 (upgraded-element-type-specifier-or-give-up %array
)
315 '(if (array-header-p %array
)
316 (values (%array-data-vector %array
) %index
)
317 (values %array %index
)))
319 ;;;; BIT-VECTOR hackery
321 ;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word
322 ;;; loop that does 32 bits at a time.
324 ;;; FIXME: This is a lot of repeatedly macroexpanded code. It should
325 ;;; be a function call instead.
326 (macrolet ((def (bitfun wordfun
)
327 `(deftransform ,bitfun
((bit-array-1 bit-array-2 result-bit-array
)
332 :node node
:policy
(>= speed space
))
334 ,@(unless (policy node
(zerop safety
))
335 '((unless (= (length bit-array-1
)
337 (length result-bit-array
))
338 (error "Argument and/or result bit arrays are not the same length:~
343 (let ((length (length result-bit-array
)))
345 ;; We avoid doing anything to 0-length
346 ;; bit-vectors, or rather, the memory that
347 ;; follows them. Other divisible-by-32 cases
348 ;; are handled by the (1- length), below.
351 (do ((index 0 (1+ index
))
352 ;; bit-vectors of length 1-32 need
353 ;; precisely one (SETF %VECTOR-RAW-BITS),
354 ;; done here in the epilogue. - CSR,
356 (end-1 (truncate (truly-the index
(1- length
))
359 (setf (%vector-raw-bits result-bit-array index
)
360 (,',wordfun
(%vector-raw-bits bit-array-1 index
)
361 (%vector-raw-bits bit-array-2 index
)))
363 (declare (optimize (speed 3) (safety 0))
364 (type index index end-1
))
365 (setf (%vector-raw-bits result-bit-array index
)
366 (,',wordfun
(%vector-raw-bits bit-array-1 index
)
367 (%vector-raw-bits bit-array-2 index
))))))))))
368 (def bit-and word-logical-and
)
369 (def bit-ior word-logical-or
)
370 (def bit-xor word-logical-xor
)
371 (def bit-eqv word-logical-eqv
)
372 (def bit-nand word-logical-nand
)
373 (def bit-nor word-logical-nor
)
374 (def bit-andc1 word-logical-andc1
)
375 (def bit-andc2 word-logical-andc2
)
376 (def bit-orc1 word-logical-orc1
)
377 (def bit-orc2 word-logical-orc2
))
379 (deftransform bit-not
380 ((bit-array result-bit-array
)
381 (simple-bit-vector simple-bit-vector
) *
382 :node node
:policy
(>= speed space
))
384 ,@(unless (policy node
(zerop safety
))
385 '((unless (= (length bit-array
)
386 (length result-bit-array
))
387 (error "Argument and result bit arrays are not the same length:~
389 bit-array result-bit-array
))))
390 (let ((length (length result-bit-array
)))
392 ;; We avoid doing anything to 0-length bit-vectors, or rather,
393 ;; the memory that follows them. Other divisible-by
394 ;; n-word-bits cases are handled by the (1- length), below.
397 (do ((index 0 (1+ index
))
398 ;; bit-vectors of length 1 to n-word-bits need precisely
399 ;; one (SETF %VECTOR-RAW-BITS), done here in the
400 ;; epilogue. - CSR, 2002-04-24
401 (end-1 (truncate (truly-the index
(1- length
))
404 (setf (%vector-raw-bits result-bit-array index
)
405 (word-logical-not (%vector-raw-bits bit-array index
)))
407 (declare (optimize (speed 3) (safety 0))
408 (type index index end-1
))
409 (setf (%vector-raw-bits result-bit-array index
)
410 (word-logical-not (%vector-raw-bits bit-array index
))))))))
412 (deftransform bit-vector-
= ((x y
) (simple-bit-vector simple-bit-vector
))
413 `(and (= (length x
) (length y
))
414 (let ((length (length x
)))
417 (end-1 (floor (1- length
) sb
!vm
:n-word-bits
)))
419 (let* ((extra (1+ (mod (1- length
) sb
!vm
:n-word-bits
)))
420 (mask (ash #.
(1- (ash 1 sb
!vm
:n-word-bits
))
421 (- extra sb
!vm
:n-word-bits
)))
425 ,(ecase sb
!c
:*backend-byte-order
*
428 '(- sb
!vm
:n-word-bits extra
))))
429 (%vector-raw-bits x i
)))
433 ,(ecase sb
!c
:*backend-byte-order
*
436 '(- sb
!vm
:n-word-bits extra
))))
437 (%vector-raw-bits y i
))))
438 (declare (type (integer 1 #.sb
!vm
:n-word-bits
) extra
)
439 (type sb
!vm
:word mask numx numy
))
441 (declare (type index i end-1
))
442 (let ((numx (%vector-raw-bits x i
))
443 (numy (%vector-raw-bits y i
)))
444 (declare (type sb
!vm
:word numx numy
))
445 (unless (= numx numy
)
448 (deftransform count
((item sequence
) (bit simple-bit-vector
) *
449 :policy
(>= speed space
))
450 `(let ((length (length sequence
)))
453 (do ((index 0 (1+ index
))
455 (end-1 (truncate (truly-the index
(1- length
))
458 (let* ((extra (1+ (mod (1- length
) sb
!vm
:n-word-bits
)))
459 (mask (ash #.
(1- (ash 1 sb
!vm
:n-word-bits
))
460 (- extra sb
!vm
:n-word-bits
)))
461 (bits (logand (ash mask
462 ,(ecase sb
!c
:*backend-byte-order
*
465 '(- sb
!vm
:n-word-bits extra
))))
466 (%vector-raw-bits sequence index
))))
467 (declare (type (integer 1 #.sb
!vm
:n-word-bits
) extra
))
468 (declare (type sb
!vm
:word mask bits
))
469 (incf count
(logcount bits
))
470 ,(if (constant-lvar-p item
)
471 (if (zerop (lvar-value item
))
477 (declare (type index index count end-1
)
478 (optimize (speed 3) (safety 0)))
479 (incf count
(logcount (%vector-raw-bits sequence index
)))))))
481 (deftransform fill
((sequence item
) (simple-bit-vector bit
) *
482 :policy
(>= speed space
))
483 (let ((value (if (constant-lvar-p item
)
484 (if (= (lvar-value item
) 0)
486 #.
(1- (ash 1 sb
!vm
:n-word-bits
)))
487 `(if (= item
0) 0 #.
(1- (ash 1 sb
!vm
:n-word-bits
))))))
488 `(let ((length (length sequence
))
492 (do ((index 0 (1+ index
))
493 ;; bit-vectors of length 1 to n-word-bits need precisely
494 ;; one (SETF %VECTOR-RAW-BITS), done here in the
495 ;; epilogue. - CSR, 2002-04-24
496 (end-1 (truncate (truly-the index
(1- length
))
499 (setf (%vector-raw-bits sequence index
) value
)
501 (declare (optimize (speed 3) (safety 0))
502 (type index index end-1
))
503 (setf (%vector-raw-bits sequence index
) value
))))))
505 (deftransform fill
((sequence item
) (simple-base-string base-char
) *
506 :policy
(>= speed space
))
507 (let ((value (if (constant-lvar-p item
)
508 (let* ((char (lvar-value item
))
509 (code (sb!xc
:char-code char
))
511 (dotimes (i sb
!vm
:n-word-bytes accum
)
512 (setf accum
(logior accum
(ash code
(* 8 i
))))))
513 `(let ((code (sb!xc
:char-code item
)))
514 (logior ,@(loop for i from
0 below sb
!vm
:n-word-bytes
515 collect
`(ash code
,(* 8 i
))))))))
516 `(let ((length (length sequence
))
518 (multiple-value-bind (times rem
)
519 (truncate length sb
!vm
:n-word-bytes
)
520 (do ((index 0 (1+ index
))
523 (let ((place (* times sb
!vm
:n-word-bytes
)))
524 (declare (fixnum place
))
525 (dotimes (j rem sequence
)
527 (setf (schar sequence
(the index
(+ place j
))) item
))))
528 (declare (optimize (speed 3) (safety 0))
530 (setf (%vector-raw-bits sequence index
) value
))))))
534 ;;; FIXME: The old CMU CL code used various COPY-TO/FROM-SYSTEM-AREA
535 ;;; stuff (with all the associated bit-index cruft and overflow
536 ;;; issues) even for byte moves. In SBCL, we're converting to byte
537 ;;; moves as problems are discovered with the old code, and this is
538 ;;; currently (ca. sbcl-0.6.12.30) the main interface for code in
539 ;;; SB!KERNEL and SB!SYS (e.g. i/o code). It's not clear that it's the
540 ;;; ideal interface, though, and it probably deserves some thought.
541 (deftransform %byte-blt
((src src-start dst dst-start dst-end
)
542 ((or (simple-unboxed-array (*)) system-area-pointer
)
544 (or (simple-unboxed-array (*)) system-area-pointer
)
547 ;; FIXME: CMU CL had a hairier implementation of this (back when it
548 ;; was still called (%PRIMITIVE BYTE-BLT). It had the small problem
549 ;; that it didn't work for large (>16M) values of SRC-START or
550 ;; DST-START. However, it might have been more efficient. In
551 ;; particular, I don't really know how much the foreign function
552 ;; call costs us here. My guess is that if the overhead is
553 ;; acceptable for SQRT and COS, it's acceptable here, but this
554 ;; should probably be checked. -- WHN
555 '(flet ((sapify (thing)
557 (system-area-pointer thing
)
558 ;; FIXME: The code here rather relies on the simple
559 ;; unboxed array here having byte-sized entries. That
560 ;; should be asserted explicitly, I just haven't found
561 ;; a concise way of doing it. (It would be nice to
562 ;; declare it in the DEFKNOWN too.)
563 ((simple-unboxed-array (*)) (vector-sap thing
)))))
564 (declare (inline sapify
))
565 (with-pinned-objects (dst src
)
566 (memmove (sap+ (sapify dst
) dst-start
)
567 (sap+ (sapify src
) src-start
)
568 (- dst-end dst-start
)))
571 ;;;; transforms for EQL of floating point values
573 (deftransform eql
((x y
) (single-float single-float
))
574 '(= (single-float-bits x
) (single-float-bits y
)))
577 (deftransform eql
((x y
) (double-float double-float
))
578 '(and (= (double-float-low-bits x
) (double-float-low-bits y
))
579 (= (double-float-high-bits x
) (double-float-high-bits y
))))
582 ;;;; modular functions
584 ;;; FIXME: I think that the :GOODness of a modular function boils down
585 ;;; to whether the normal definition can be used in the middle of a
586 ;;; modular arrangement. LOGAND and LOGIOR can be for all unsigned
587 ;;; modular implementations, I believe, because for all unsigned
588 ;;; arguments of a given size the result of the ordinary definition is
589 ;;; the right one. This should follow through to other logical
590 ;;; functions, such as LOGXOR, should it not? -- CSR, 2007-12-29,
591 ;;; trying to understand a comment he wrote over four years
592 ;;; previously: "FIXME: XOR? ANDC1, ANDC2? -- CSR, 2003-09-16"
593 (define-good-modular-fun logand
:untagged nil
)
594 (define-good-modular-fun logior
:untagged nil
)
595 (define-good-modular-fun logxor
:untagged nil
)
596 (macrolet ((define-good-signed-modular-funs (&rest funs
)
599 ,@(dolist (fun funs
(nreverse result
))
600 (push `(define-good-modular-fun ,fun
:untagged t
) result
)
601 (push `(define-good-modular-fun ,fun
:tagged t
) result
))))))
602 (define-good-signed-modular-funs
603 logand logandc1 logandc2 logeqv logior lognand lognor lognot
604 logorc1 logorc2 logxor
))
607 ((def (name kind width signedp
)
608 (let ((type (ecase signedp
609 ((nil) 'unsigned-byte
)
610 ((t) 'signed-byte
))))
612 (defknown ,name
(integer (integer 0)) (,type
,width
)
613 (foldable flushable movable
))
614 (define-modular-fun-optimizer ash
((integer count
) ,kind
,signedp
:width width
)
615 (when (and (<= width
,width
)
616 (or (and (constant-lvar-p count
)
617 (plusp (lvar-value count
)))
618 (csubtypep (lvar-type count
)
619 (specifier-type '(and unsigned-byte fixnum
)))))
620 (cut-to-width integer
,kind width
,signedp
)
622 (setf (gethash ',name
(modular-class-versions (find-modular-class ',kind
',signedp
)))
624 ;; This should really be dependent on SB!VM:N-WORD-BITS, but since we
625 ;; don't have a true Alpha64 port yet, we'll have to stick to
626 ;; SB!VM:N-MACHINE-WORD-BITS for the time being. --njf, 2004-08-14
627 #!+#.
(cl:if
(cl:= 32 sb
!vm
:n-machine-word-bits
) '(and) '(or))
629 #!+x86
(def sb
!vm
::ash-left-smod30
:tagged
30 t
)
630 (def sb
!vm
::ash-left-mod32
:untagged
32 nil
))
631 #!+#.
(cl:if
(cl:= 64 sb
!vm
:n-machine-word-bits
) '(and) '(or))
633 #!+x86-64
(def sb
!vm
::ash-left-smod61
:tagged
61 t
)
634 (def sb
!vm
::ash-left-mod64
:untagged
64 nil
)))
636 ;;;; word-wise logical operations
638 ;;; These transforms assume the presence of modular arithmetic to
639 ;;; generate efficient code.
641 (define-source-transform word-logical-not
(x)
642 `(logand (lognot (the sb
!vm
:word
,x
)) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
644 (deftransform word-logical-and
((x y
))
647 (deftransform word-logical-nand
((x y
))
648 '(logand (lognand x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
650 (deftransform word-logical-or
((x y
))
653 (deftransform word-logical-nor
((x y
))
654 '(logand (lognor x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
656 (deftransform word-logical-xor
((x y
))
659 (deftransform word-logical-eqv
((x y
))
660 '(logand (logeqv x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
662 (deftransform word-logical-orc1
((x y
))
663 '(logand (logorc1 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
665 (deftransform word-logical-orc2
((x y
))
666 '(logand (logorc2 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
668 (deftransform word-logical-andc1
((x y
))
669 '(logand (logandc1 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
671 (deftransform word-logical-andc2
((x y
))
672 '(logand (logandc2 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
675 ;;; There are two different ways the multiplier can be recoded. The
676 ;;; more obvious is to shift X by the correct amount for each bit set
677 ;;; in Y and to sum the results. But if there is a string of bits that
678 ;;; are all set, you can add X shifted by one more then the bit
679 ;;; position of the first set bit and subtract X shifted by the bit
680 ;;; position of the last set bit. We can't use this second method when
681 ;;; the high order bit is bit 31 because shifting by 32 doesn't work
683 (defun ub32-strength-reduce-constant-multiply (arg num
)
684 (declare (type (unsigned-byte 32) num
))
685 (let ((adds 0) (shifts 0)
686 (result nil
) first-one
)
687 (labels ((add (next-factor)
690 (progn (incf adds
) `(+ ,result
,next-factor
))
692 (declare (inline add
))
695 (when (not (logbitp bitpos num
))
696 (add (if (= (1+ first-one
) bitpos
)
697 ;; There is only a single bit in the string.
698 (progn (incf shifts
) `(ash ,arg
,first-one
))
699 ;; There are at least two.
703 `(- (ash ,arg
,bitpos
)
704 (ash ,arg
,first-one
)))))
705 (setf first-one nil
))
706 (when (logbitp bitpos num
)
707 (setf first-one bitpos
))))
709 (cond ((= first-one
31))
710 ((= first-one
30) (incf shifts
) (add `(ash ,arg
30)))
714 (add `(- (ash ,arg
31)
715 (ash ,arg
,first-one
)))))
717 (add `(ash ,arg
31))))
718 (values (if (plusp adds
)
719 `(logand ,result
#.
(1- (ash 1 32))) ; using modular arithmetic
725 ;;; Transform GET-LISP-OBJ-ADDRESS for constant immediates, since the normal
726 ;;; VOP can't handle them.
728 (deftransform sb
!vm
::get-lisp-obj-address
((obj) ((constant-arg fixnum
)))
729 (ash (lvar-value obj
) sb
!vm
::n-fixnum-tag-bits
))
731 (deftransform sb
!vm
::get-lisp-obj-address
((obj) ((constant-arg character
)))
732 (logior sb
!vm
::character-widetag
733 (ash (char-code (lvar-value obj
)) sb
!vm
::n-widetag-bits
)))