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 (unless (and (constant-lvar-p constant
)
54 ;; we lose if the remaining argument isn't a fixnum
55 (csubtypep (lvar-type x
) (specifier-type 'fixnum
)))
56 (give-up-ir1-transform))
57 (let ((value (lvar-value constant
))
59 (unless (and (integerp value
)
60 (sb!vm
::foldable-constant-offset-p
61 element-size lowtag data-offset
62 (setf new-offset
(funcall func
(lvar-value offset
)
64 (give-up-ir1-transform "constant is too large for inlining"))
65 (splice-fun-args index func
2)
66 `(lambda (thing index off1 off2
,@(when setter-p
68 (declare (ignore off1 off2
))
69 (,fun-name thing index
',new-offset
,@(when setter-p
73 (deftransform sb
!bignum
:%bignum-ref-with-offset
74 ((bignum index offset
) * * :node node
)
75 (fold-index-addressing 'sb
!bignum
:%bignum-ref-with-offset
76 sb
!vm
:n-word-bits sb
!vm
:other-pointer-lowtag
77 sb
!vm
:bignum-digits-offset
80 ;;; The layout is stored in slot 0.
81 ;;; *** These next two transforms should be the only code, aside from
82 ;;; some parts of the C runtime, with knowledge of the layout index.
83 (define-source-transform %instance-layout
(x)
84 `(truly-the layout
(%instance-ref
,x
0)))
85 (define-source-transform %set-instance-layout
(x val
)
86 `(%instance-set
,x
0 (the layout
,val
)))
87 (define-source-transform %funcallable-instance-layout
(x)
88 `(truly-the layout
(%funcallable-instance-info
,x
0)))
89 (define-source-transform %set-funcallable-instance-layout
(x val
)
90 `(setf (%funcallable-instance-info
,x
0) (the layout
,val
)))
92 ;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
94 (deftransform hairy-data-vector-ref
((string index
) (simple-string t
))
95 (let ((ctype (lvar-type string
)))
96 (if (array-type-p ctype
)
97 ;; the other transform will kick in, so that's OK
98 (give-up-ir1-transform)
100 ((simple-array character
(*))
101 (data-vector-ref string index
))
103 ((simple-array base-char
(*))
104 (data-vector-ref string index
))
105 ((simple-array nil
(*))
106 (data-nil-vector-ref string index
))))))
108 ;;; This and the corresponding -SET transform work equally well on non-simple
109 ;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases
110 ;;; where it actually helped with non-simple arrays -- to the contrary, it
111 ;;; only made for bigger and up to 100% slower code.
112 (deftransform hairy-data-vector-ref
((array index
) (simple-array t
) *)
113 "avoid runtime dispatch on array element type"
114 (let* ((type (lvar-type array
))
115 (element-ctype (array-type-upgraded-element-type type
))
116 (declared-element-ctype (array-type-declared-element-type type
)))
117 (declare (type ctype element-ctype
))
118 (when (eq *wild-type
* element-ctype
)
119 (give-up-ir1-transform
120 "Upgraded element type of array is not known at compile time."))
121 ;; (The expansion here is basically a degenerate case of
122 ;; WITH-ARRAY-DATA. Since WITH-ARRAY-DATA is implemented as a
123 ;; macro, and macros aren't expanded in transform output, we have
124 ;; to hand-expand it ourselves.)
125 (let* ((element-type-specifier (type-specifier element-ctype
)))
126 `(multiple-value-bind (array index
)
127 (%data-vector-and-index array index
)
128 (declare (type (simple-array ,element-type-specifier
1) array
))
129 ,(let ((bare-form '(data-vector-ref array index
)))
130 (cond ((eql element-ctype
*empty-type
*)
131 `(data-nil-vector-ref array index
))
132 ((type= element-ctype declared-element-ctype
)
135 `(the ,(type-specifier declared-element-ctype
)
138 ;;; Transform multi-dimensional array to one dimensional data vector
140 (deftransform data-vector-ref
((array index
) (simple-array t
))
141 (let ((array-type (lvar-type array
)))
142 (unless (array-type-p array-type
)
143 (give-up-ir1-transform))
144 (let ((dims (array-type-dimensions array-type
)))
145 (when (or (atom dims
) (= (length dims
) 1))
146 (give-up-ir1-transform))
147 (let ((el-type (array-type-specialized-element-type array-type
))
148 (total-size (if (member '* dims
)
151 `(data-vector-ref (truly-the (simple-array ,(type-specifier el-type
)
153 (%array-data-vector array
))
156 ;;; Transform data vector access to a form that opens up optimization
157 ;;; opportunities. On platforms that support DATA-VECTOR-REF-WITH-OFFSET
158 ;;; DATA-VECTOR-REF is not supported at all.
160 (define-source-transform data-vector-ref
(array index
)
161 `(data-vector-ref-with-offset ,array
,index
0))
164 (deftransform data-vector-ref-with-offset
((array index offset
))
165 (let ((array-type (lvar-type array
)))
166 (when (or (not (array-type-p array-type
))
167 (eql (array-type-specialized-element-type array-type
)
169 (give-up-ir1-transform))
170 ;; It shouldn't be possible to get here with anything but a non-complex
172 (aver (not (array-type-complexp array-type
)))
173 (let* ((element-type (type-specifier (array-type-specialized-element-type array-type
)))
174 (saetp (find-saetp element-type
)))
175 (when (< (sb!vm
:saetp-n-bits saetp
) sb
!vm
:n-byte-bits
)
176 (give-up-ir1-transform))
177 (fold-index-addressing 'data-vector-ref-with-offset
178 (sb!vm
:saetp-n-bits saetp
)
179 sb
!vm
:other-pointer-lowtag
180 sb
!vm
:vector-data-offset
183 (deftransform hairy-data-vector-set
((string index new-value
)
185 (let ((ctype (lvar-type string
)))
186 (if (array-type-p ctype
)
187 ;; the other transform will kick in, so that's OK
188 (give-up-ir1-transform)
190 ((simple-array character
(*))
191 (data-vector-set string index new-value
))
193 ((simple-array base-char
(*))
194 (data-vector-set string index new-value
))
195 ((simple-array nil
(*))
196 (data-vector-set string index new-value
))))))
198 ;;; This and the corresponding -REF transform work equally well on non-simple
199 ;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases
200 ;;; where it actually helped with non-simple arrays -- to the contrary, it
201 ;;; only made for bigger and up 1o 100% slower code.
202 (deftransform hairy-data-vector-set
((array index new-value
)
205 "avoid runtime dispatch on array element type"
206 (let* ((type (lvar-type array
))
207 (element-ctype (array-type-upgraded-element-type type
))
208 (declared-element-ctype (array-type-declared-element-type type
)))
209 (declare (type ctype element-ctype
))
210 (when (eq *wild-type
* element-ctype
)
211 (give-up-ir1-transform
212 "Upgraded element type of array is not known at compile time."))
213 (let ((element-type-specifier (type-specifier element-ctype
)))
214 `(multiple-value-bind (array index
)
215 (%data-vector-and-index array index
)
216 (declare (type (simple-array ,element-type-specifier
1) array
)
217 (type ,element-type-specifier new-value
))
218 ,(if (type= element-ctype declared-element-ctype
)
219 '(data-vector-set array index new-value
)
220 `(truly-the ,(type-specifier declared-element-ctype
)
221 (data-vector-set array index
222 (the ,(type-specifier declared-element-ctype
)
225 ;;; Transform multi-dimensional array to one dimensional data vector
227 (deftransform data-vector-set
((array index new-value
)
229 (let ((array-type (lvar-type array
)))
230 (unless (array-type-p array-type
)
231 (give-up-ir1-transform))
232 (let ((dims (array-type-dimensions array-type
)))
233 (when (or (atom dims
) (= (length dims
) 1))
234 (give-up-ir1-transform))
235 (let ((el-type (array-type-specialized-element-type array-type
))
236 (total-size (if (member '* dims
)
239 `(data-vector-set (truly-the (simple-array ,(type-specifier el-type
)
241 (%array-data-vector array
))
245 ;;; Transform data vector access to a form that opens up optimization
248 (define-source-transform data-vector-set
(array index new-value
)
249 `(data-vector-set-with-offset ,array
,index
0 ,new-value
))
252 (deftransform data-vector-set-with-offset
((array index offset new-value
))
253 (let ((array-type (lvar-type array
)))
254 (when (or (not (array-type-p array-type
))
255 (eql (array-type-specialized-element-type array-type
)
257 ;; We don't yet know the exact element type, but will get that
258 ;; knowledge after some more type propagation.
259 (give-up-ir1-transform))
260 (aver (not (array-type-complexp array-type
)))
261 (let* ((element-type (type-specifier (array-type-specialized-element-type array-type
)))
262 (saetp (find-saetp element-type
)))
263 (when (< (sb!vm
:saetp-n-bits saetp
) sb
!vm
:n-byte-bits
)
264 (give-up-ir1-transform))
265 (fold-index-addressing 'data-vector-set-with-offset
266 (sb!vm
:saetp-n-bits saetp
)
267 sb
!vm
:other-pointer-lowtag
268 sb
!vm
:vector-data-offset
271 (defun maybe-array-data-vector-type-specifier (array-lvar)
272 (let ((atype (lvar-type array-lvar
)))
273 (when (array-type-p atype
)
274 (let ((dims (array-type-dimensions atype
)))
275 (if (or (array-type-complexp atype
)
277 (notevery #'integerp dims
))
278 `(simple-array ,(type-specifier
279 (array-type-specialized-element-type atype
))
281 `(simple-array ,(type-specifier
282 (array-type-specialized-element-type atype
))
283 (,(apply #'* dims
))))))))
285 (macrolet ((def (name)
286 `(defoptimizer (,name derive-type
) ((array-lvar))
287 (let ((spec (maybe-array-data-vector-type-specifier array-lvar
)))
289 (specifier-type spec
))))))
290 (def %array-data-vector
)
291 (def array-storage-vector
))
293 (defoptimizer (%data-vector-and-index derive-type
) ((array index
))
294 (declare (ignore index
))
295 (let ((spec (maybe-array-data-vector-type-specifier array
)))
297 (values-specifier-type `(values ,spec index
)))))
299 (deftransform %data-vector-and-index
((%array %index
)
302 ;; KLUDGE: why the percent signs? Well, ARRAY and INDEX are
303 ;; respectively exported from the CL and SB!INT packages, which
304 ;; means that they're visible to all sorts of things. If the
305 ;; compiler can prove that the call to ARRAY-HEADER-P, below, either
306 ;; returns T or NIL, it will delete the irrelevant branch. However,
307 ;; user code might have got here with a variable named CL:ARRAY, and
308 ;; quite often compiler code with a variable named SB!INT:INDEX, so
309 ;; this can generate code deletion notes for innocuous user code:
310 ;; (DEFUN F (ARRAY I) (DECLARE (SIMPLE-VECTOR ARRAY)) (AREF ARRAY I))
311 ;; -- CSR, 2003-04-01
313 ;; We do this solely for the -OR-GIVE-UP side effect, since we want
314 ;; to know that the type can be figured out in the end before we
315 ;; proceed, but we don't care yet what the type will turn out to be.
316 (upgraded-element-type-specifier-or-give-up %array
)
318 '(if (array-header-p %array
)
319 (values (%array-data-vector %array
) %index
)
320 (values %array %index
)))
322 ;;;; BIT-VECTOR hackery
324 ;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word
325 ;;; loop that does 32 bits at a time.
327 ;;; FIXME: This is a lot of repeatedly macroexpanded code. It should
328 ;;; be a function call instead.
329 (macrolet ((def (bitfun wordfun
)
330 `(deftransform ,bitfun
((bit-array-1 bit-array-2 result-bit-array
)
335 :node node
:policy
(>= speed space
))
337 ,@(unless (policy node
(zerop safety
))
338 '((unless (= (length bit-array-1
)
340 (length result-bit-array
))
341 (error "Argument and/or result bit arrays are not the same length:~
346 (let ((length (length result-bit-array
)))
348 ;; We avoid doing anything to 0-length
349 ;; bit-vectors, or rather, the memory that
350 ;; follows them. Other divisible-by-32 cases
351 ;; are handled by the (1- length), below.
354 (do ((index 0 (1+ index
))
355 ;; bit-vectors of length 1-32 need
356 ;; precisely one (SETF %VECTOR-RAW-BITS),
357 ;; done here in the epilogue. - CSR,
359 (end-1 (truncate (truly-the index
(1- length
))
362 (setf (%vector-raw-bits result-bit-array index
)
363 (,',wordfun
(%vector-raw-bits bit-array-1 index
)
364 (%vector-raw-bits bit-array-2 index
)))
366 (declare (optimize (speed 3) (safety 0))
367 (type index index end-1
))
368 (setf (%vector-raw-bits result-bit-array index
)
369 (,',wordfun
(%vector-raw-bits bit-array-1 index
)
370 (%vector-raw-bits bit-array-2 index
))))))))))
371 (def bit-and word-logical-and
)
372 (def bit-ior word-logical-or
)
373 (def bit-xor word-logical-xor
)
374 (def bit-eqv word-logical-eqv
)
375 (def bit-nand word-logical-nand
)
376 (def bit-nor word-logical-nor
)
377 (def bit-andc1 word-logical-andc1
)
378 (def bit-andc2 word-logical-andc2
)
379 (def bit-orc1 word-logical-orc1
)
380 (def bit-orc2 word-logical-orc2
))
382 (deftransform bit-not
383 ((bit-array result-bit-array
)
384 (simple-bit-vector simple-bit-vector
) *
385 :node node
:policy
(>= speed space
))
387 ,@(unless (policy node
(zerop safety
))
388 '((unless (= (length bit-array
)
389 (length result-bit-array
))
390 (error "Argument and result bit arrays are not the same length:~
392 bit-array result-bit-array
))))
393 (let ((length (length result-bit-array
)))
395 ;; We avoid doing anything to 0-length bit-vectors, or rather,
396 ;; the memory that follows them. Other divisible-by
397 ;; n-word-bits cases are handled by the (1- length), below.
400 (do ((index 0 (1+ index
))
401 ;; bit-vectors of length 1 to n-word-bits need precisely
402 ;; one (SETF %VECTOR-RAW-BITS), done here in the
403 ;; epilogue. - CSR, 2002-04-24
404 (end-1 (truncate (truly-the index
(1- length
))
407 (setf (%vector-raw-bits result-bit-array index
)
408 (word-logical-not (%vector-raw-bits bit-array index
)))
410 (declare (optimize (speed 3) (safety 0))
411 (type index index end-1
))
412 (setf (%vector-raw-bits result-bit-array index
)
413 (word-logical-not (%vector-raw-bits bit-array index
))))))))
415 (deftransform bit-vector-
= ((x y
) (simple-bit-vector simple-bit-vector
))
416 `(and (= (length x
) (length y
))
417 (let ((length (length x
)))
420 (end-1 (floor (1- length
) sb
!vm
:n-word-bits
)))
422 (let* ((extra (1+ (mod (1- length
) sb
!vm
:n-word-bits
)))
423 (mask (ash #.
(1- (ash 1 sb
!vm
:n-word-bits
))
424 (- extra sb
!vm
:n-word-bits
)))
428 ,(ecase sb
!c
:*backend-byte-order
*
431 '(- sb
!vm
:n-word-bits extra
))))
432 (%vector-raw-bits x i
)))
436 ,(ecase sb
!c
:*backend-byte-order
*
439 '(- sb
!vm
:n-word-bits extra
))))
440 (%vector-raw-bits y i
))))
441 (declare (type (integer 1 #.sb
!vm
:n-word-bits
) extra
)
442 (type sb
!vm
:word mask numx numy
))
444 (declare (type index i end-1
))
445 (let ((numx (%vector-raw-bits x i
))
446 (numy (%vector-raw-bits y i
)))
447 (declare (type sb
!vm
:word numx numy
))
448 (unless (= numx numy
)
451 (deftransform count
((item sequence
) (bit simple-bit-vector
) *
452 :policy
(>= speed space
))
453 `(let ((length (length sequence
)))
456 (do ((index 0 (1+ index
))
458 (end-1 (truncate (truly-the index
(1- length
))
461 ;; "(mod (1- length) ...)" is the bit index within the word
462 ;; of the array index of the ultimate bit to be examined.
463 ;; "1+" it is the number of bits in that word.
464 ;; But I don't get why people are allowed to store random data that
465 ;; we mask off, as if we could accomodate all possible ways that
466 ;; unsafe code can spew bits where they don't belong.
467 ;; Does it have to do with %shrink-vector, perhaps?
468 ;; Some rationale would be nice...
469 (let* ((extra (1+ (mod (1- length
) sb
!vm
:n-word-bits
)))
470 (mask (ash #.
(1- (ash 1 sb
!vm
:n-word-bits
))
471 (- extra sb
!vm
:n-word-bits
)))
472 ;; The above notwithstanding, for big-endian wouldn't it
473 ;; be possible to write this expression as a single shift?
474 ;; (LOGAND MOST-POSITIVE-WORD (ASH most-positive-word (- n-word-bits extra)))
475 ;; rather than a right-shift to fill in zeros on the left
476 ;; then by a left-shift to left-align the 1s?
477 (bits (logand (ash mask
478 ,(ecase sb
!c
:*backend-byte-order
*
481 '(- sb
!vm
:n-word-bits extra
))))
482 (%vector-raw-bits sequence index
))))
483 (declare (type (integer 1 #.sb
!vm
:n-word-bits
) extra
))
484 (declare (type sb
!vm
:word mask bits
))
485 (incf count
(logcount bits
))
486 ,(if (constant-lvar-p item
)
487 (if (zerop (lvar-value item
))
493 (declare (type index index count end-1
)
494 (optimize (speed 3) (safety 0)))
495 (incf count
(logcount (%vector-raw-bits sequence index
)))))))
497 (deftransform fill
((sequence item
) (simple-bit-vector bit
) *
498 :policy
(>= speed space
))
499 (let ((value (if (constant-lvar-p item
)
500 (if (= (lvar-value item
) 0)
502 #.
(1- (ash 1 sb
!vm
:n-word-bits
)))
503 `(if (= item
0) 0 #.
(1- (ash 1 sb
!vm
:n-word-bits
))))))
504 `(let ((length (length sequence
))
508 (do ((index 0 (1+ index
))
509 ;; bit-vectors of length 1 to n-word-bits need precisely
510 ;; one (SETF %VECTOR-RAW-BITS), done here in the
511 ;; epilogue. - CSR, 2002-04-24
512 (end-1 (truncate (truly-the index
(1- length
))
515 (setf (%vector-raw-bits sequence index
) value
)
517 (declare (optimize (speed 3) (safety 0))
518 (type index index end-1
))
519 (setf (%vector-raw-bits sequence index
) value
))))))
521 (deftransform fill
((sequence item
) (simple-base-string base-char
) *
522 :policy
(>= speed space
))
523 (let ((value (if (constant-lvar-p item
)
524 (let* ((char (lvar-value item
))
525 (code (sb!xc
:char-code char
))
527 (dotimes (i sb
!vm
:n-word-bytes accum
)
528 (setf accum
(logior accum
(ash code
(* 8 i
))))))
529 `(let ((code (sb!xc
:char-code item
)))
530 (logior ,@(loop for i from
0 below sb
!vm
:n-word-bytes
531 collect
`(ash code
,(* 8 i
))))))))
532 `(let ((length (length sequence
))
534 (multiple-value-bind (times rem
)
535 (truncate length sb
!vm
:n-word-bytes
)
536 (do ((index 0 (1+ index
))
539 (let ((place (* times sb
!vm
:n-word-bytes
)))
540 (declare (fixnum place
))
541 (dotimes (j rem sequence
)
543 (setf (schar sequence
(the index
(+ place j
))) item
))))
544 (declare (optimize (speed 3) (safety 0))
546 (setf (%vector-raw-bits sequence index
) value
))))))
550 ;;; FIXME: The old CMU CL code used various COPY-TO/FROM-SYSTEM-AREA
551 ;;; stuff (with all the associated bit-index cruft and overflow
552 ;;; issues) even for byte moves. In SBCL, we're converting to byte
553 ;;; moves as problems are discovered with the old code, and this is
554 ;;; currently (ca. sbcl-0.6.12.30) the main interface for code in
555 ;;; SB!KERNEL and SB!SYS (e.g. i/o code). It's not clear that it's the
556 ;;; ideal interface, though, and it probably deserves some thought.
557 (deftransform %byte-blt
((src src-start dst dst-start dst-end
)
558 ((or (simple-unboxed-array (*)) system-area-pointer
)
560 (or (simple-unboxed-array (*)) system-area-pointer
)
563 ;; FIXME: CMU CL had a hairier implementation of this (back when it
564 ;; was still called (%PRIMITIVE BYTE-BLT). It had the small problem
565 ;; that it didn't work for large (>16M) values of SRC-START or
566 ;; DST-START. However, it might have been more efficient. In
567 ;; particular, I don't really know how much the foreign function
568 ;; call costs us here. My guess is that if the overhead is
569 ;; acceptable for SQRT and COS, it's acceptable here, but this
570 ;; should probably be checked. -- WHN
571 '(flet ((sapify (thing)
573 (system-area-pointer thing
)
574 ;; FIXME: The code here rather relies on the simple
575 ;; unboxed array here having byte-sized entries. That
576 ;; should be asserted explicitly, I just haven't found
577 ;; a concise way of doing it. (It would be nice to
578 ;; declare it in the DEFKNOWN too.)
579 ((simple-unboxed-array (*)) (vector-sap thing
)))))
580 (declare (inline sapify
))
581 (with-pinned-objects (dst src
)
582 (memmove (sap+ (sapify dst
) dst-start
)
583 (sap+ (sapify src
) src-start
)
584 (- dst-end dst-start
)))
587 ;;;; transforms for EQL of floating point values
589 (deftransform eql
((x y
) (single-float single-float
))
590 '(= (single-float-bits x
) (single-float-bits y
)))
593 (deftransform eql
((x y
) (double-float double-float
))
594 '(and (= (double-float-low-bits x
) (double-float-low-bits y
))
595 (= (double-float-high-bits x
) (double-float-high-bits y
))))
598 ;;;; modular functions
600 ;;; FIXME: I think that the :GOODness of a modular function boils down
601 ;;; to whether the normal definition can be used in the middle of a
602 ;;; modular arrangement. LOGAND and LOGIOR can be for all unsigned
603 ;;; modular implementations, I believe, because for all unsigned
604 ;;; arguments of a given size the result of the ordinary definition is
605 ;;; the right one. This should follow through to other logical
606 ;;; functions, such as LOGXOR, should it not? -- CSR, 2007-12-29,
607 ;;; trying to understand a comment he wrote over four years
608 ;;; previously: "FIXME: XOR? ANDC1, ANDC2? -- CSR, 2003-09-16"
609 (define-good-modular-fun logand
:untagged nil
)
610 (define-good-modular-fun logior
:untagged nil
)
611 (define-good-modular-fun logxor
:untagged nil
)
612 (macrolet ((define-good-signed-modular-funs (&rest funs
)
615 ,@(dolist (fun funs
(nreverse result
))
616 (push `(define-good-modular-fun ,fun
:untagged t
) result
)
617 (push `(define-good-modular-fun ,fun
:tagged t
) result
))))))
618 (define-good-signed-modular-funs
619 logand logandc1 logandc2 logeqv logior lognand lognor lognot
620 logorc1 logorc2 logxor
))
623 ((def (name kind width signedp
)
624 (let ((type (ecase signedp
625 ((nil) 'unsigned-byte
)
626 ((t) 'signed-byte
))))
628 (defknown ,name
(integer (integer 0)) (,type
,width
)
629 (foldable flushable movable
))
630 (define-modular-fun-optimizer ash
((integer count
) ,kind
,signedp
:width width
)
631 (when (and (<= width
,width
)
632 (or (and (constant-lvar-p count
)
633 (plusp (lvar-value count
)))
634 (csubtypep (lvar-type count
)
635 (specifier-type '(and unsigned-byte fixnum
)))))
636 (cut-to-width integer
,kind width
,signedp
)
638 (setf (gethash ',name
(modular-class-versions (find-modular-class ',kind
',signedp
)))
640 ;; This should really be dependent on SB!VM:N-WORD-BITS, but since we
641 ;; don't have a true Alpha64 port yet, we'll have to stick to
642 ;; SB!VM:N-MACHINE-WORD-BITS for the time being. --njf, 2004-08-14
644 #!+(or x86 x86-64 arm
)
645 (def sb
!vm
::ash-left-modfx
646 :tagged
,(- sb
!vm
:n-word-bits sb
!vm
:n-fixnum-tag-bits
) t
)
647 (def ,(intern (format nil
"ASH-LEFT-MOD~D" sb
!vm
:n-machine-word-bits
)
649 :untagged
,sb
!vm
:n-machine-word-bits nil
)))
651 ;;;; word-wise logical operations
653 ;;; These transforms assume the presence of modular arithmetic to
654 ;;; generate efficient code.
656 (define-source-transform word-logical-not
(x)
657 `(logand (lognot (the sb
!vm
:word
,x
)) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
659 (deftransform word-logical-and
((x y
))
662 (deftransform word-logical-nand
((x y
))
663 '(logand (lognand x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
665 (deftransform word-logical-or
((x y
))
668 (deftransform word-logical-nor
((x y
))
669 '(logand (lognor x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
671 (deftransform word-logical-xor
((x y
))
674 (deftransform word-logical-eqv
((x y
))
675 '(logand (logeqv x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
677 (deftransform word-logical-orc1
((x y
))
678 '(logand (logorc1 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
680 (deftransform word-logical-orc2
((x y
))
681 '(logand (logorc2 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
683 (deftransform word-logical-andc1
((x y
))
684 '(logand (logandc1 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
686 (deftransform word-logical-andc2
((x y
))
687 '(logand (logandc2 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
690 ;;; There are two different ways the multiplier can be recoded. The
691 ;;; more obvious is to shift X by the correct amount for each bit set
692 ;;; in Y and to sum the results. But if there is a string of bits that
693 ;;; are all set, you can add X shifted by one more then the bit
694 ;;; position of the first set bit and subtract X shifted by the bit
695 ;;; position of the last set bit. We can't use this second method when
696 ;;; the high order bit is bit 31 because shifting by 32 doesn't work
698 (defun ub32-strength-reduce-constant-multiply (arg num
)
699 (declare (type (unsigned-byte 32) num
))
700 (let ((adds 0) (shifts 0)
701 (result nil
) first-one
)
702 (labels ((add (next-factor)
705 (progn (incf adds
) `(+ ,result
,next-factor
))
707 (declare (inline add
))
710 (when (not (logbitp bitpos num
))
711 (add (if (= (1+ first-one
) bitpos
)
712 ;; There is only a single bit in the string.
713 (progn (incf shifts
) `(ash ,arg
,first-one
))
714 ;; There are at least two.
718 `(- (ash ,arg
,bitpos
)
719 (ash ,arg
,first-one
)))))
720 (setf first-one nil
))
721 (when (logbitp bitpos num
)
722 (setf first-one bitpos
))))
724 (cond ((= first-one
31))
725 ((= first-one
30) (incf shifts
) (add `(ash ,arg
30)))
729 (add `(- (ash ,arg
31)
730 (ash ,arg
,first-one
)))))
732 (add `(ash ,arg
31))))
733 (values (if (plusp adds
)
734 `(logand ,result
#.
(1- (ash 1 32))) ; using modular arithmetic
740 ;;; Transform GET-LISP-OBJ-ADDRESS for constant immediates, since the normal
741 ;;; VOP can't handle them.
743 (deftransform sb
!vm
::get-lisp-obj-address
((obj) ((constant-arg fixnum
)))
744 (ash (lvar-value obj
) sb
!vm
::n-fixnum-tag-bits
))
746 (deftransform sb
!vm
::get-lisp-obj-address
((obj) ((constant-arg character
)))
747 (logior sb
!vm
::character-widetag
748 (ash (char-code (lvar-value obj
)) sb
!vm
::n-widetag-bits
)))