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
175 ;;; opportunities. On platforms that support DATA-VECTOR-REF-WITH-OFFSET
176 ;;; DATA-VECTOR-REF is not supported at all.
178 (define-source-transform data-vector-ref
(array index
)
179 `(data-vector-ref-with-offset ,array
,index
0))
182 (deftransform data-vector-ref-with-offset
((array index offset
))
183 (let ((array-type (lvar-type array
)))
184 (when (or (not (array-type-p array-type
))
185 (eql (array-type-specialized-element-type array-type
)
187 (give-up-ir1-transform))
188 ;; It shouldn't be possible to get here with anything but a non-complex
190 (aver (not (array-type-complexp array-type
)))
191 (let* ((element-type (type-specifier (array-type-specialized-element-type array-type
)))
192 (saetp (find-saetp element-type
)))
193 (when (< (sb!vm
:saetp-n-bits saetp
) sb
!vm
:n-byte-bits
)
194 (give-up-ir1-transform))
195 (fold-index-addressing 'data-vector-ref-with-offset
196 (sb!vm
:saetp-n-bits saetp
)
197 sb
!vm
:other-pointer-lowtag
198 sb
!vm
:vector-data-offset
201 (deftransform hairy-data-vector-set
((string index new-value
)
203 (let ((ctype (lvar-type string
)))
204 (if (array-type-p ctype
)
205 ;; the other transform will kick in, so that's OK
206 (give-up-ir1-transform)
208 ((simple-array character
(*))
209 (data-vector-set string index new-value
))
211 ((simple-array base-char
(*))
212 (data-vector-set string index new-value
))
213 ((simple-array nil
(*))
214 (data-vector-set string index new-value
))))))
216 (deftransform hairy-data-vector-set
((array index new-value
)
219 "avoid runtime dispatch on array element type"
220 (let ((element-ctype (extract-upgraded-element-type array
))
221 (declared-element-ctype (extract-declared-element-type array
)))
222 (declare (type ctype element-ctype
))
223 (when (eq *wild-type
* element-ctype
)
224 (give-up-ir1-transform
225 "Upgraded element type of array is not known at compile time."))
226 (let ((element-type-specifier (type-specifier element-ctype
)))
227 `(multiple-value-bind (array index
)
228 (%data-vector-and-index array index
)
229 (declare (type (simple-array ,element-type-specifier
1) array
)
230 (type ,element-type-specifier new-value
))
231 ,(if (type= element-ctype declared-element-ctype
)
232 '(data-vector-set array index new-value
)
233 `(truly-the ,(type-specifier declared-element-ctype
)
234 (data-vector-set array index
235 (the ,(type-specifier declared-element-ctype
)
238 ;;; Transform multi-dimensional array to one dimensional data vector
240 (deftransform data-vector-set
((array index new-value
)
242 (let ((array-type (lvar-type array
)))
243 (unless (array-type-p array-type
)
244 (give-up-ir1-transform))
245 (let ((dims (array-type-dimensions array-type
)))
246 (when (or (atom dims
) (= (length dims
) 1))
247 (give-up-ir1-transform))
248 (let ((el-type (array-type-specialized-element-type array-type
))
249 (total-size (if (member '* dims
)
252 `(data-vector-set (truly-the (simple-array ,(type-specifier el-type
)
254 (%array-data-vector array
))
258 ;;; Transform data vector access to a form that opens up optimization
261 (define-source-transform data-vector-set
(array index new-value
)
262 `(data-vector-set-with-offset ,array
,index
0 ,new-value
))
265 (deftransform data-vector-set-with-offset
((array index offset new-value
))
266 (let ((array-type (lvar-type array
)))
267 (when (or (not (array-type-p array-type
))
268 (eql (array-type-specialized-element-type array-type
)
270 ;; We don't yet know the exact element type, but will get that
271 ;; knowledge after some more type propagation.
272 (give-up-ir1-transform))
273 (aver (not (array-type-complexp array-type
)))
274 (let* ((element-type (type-specifier (array-type-specialized-element-type array-type
)))
275 (saetp (find-saetp element-type
)))
276 (when (< (sb!vm
:saetp-n-bits saetp
) sb
!vm
:n-byte-bits
)
277 (give-up-ir1-transform))
278 (fold-index-addressing 'data-vector-set-with-offset
279 (sb!vm
:saetp-n-bits saetp
)
280 sb
!vm
:other-pointer-lowtag
281 sb
!vm
:vector-data-offset
284 (defoptimizer (%data-vector-and-index derive-type
) ((array index
))
285 (let ((atype (lvar-type array
)))
286 (when (array-type-p atype
)
287 (values-specifier-type
288 `(values (simple-array ,(type-specifier
289 (array-type-specialized-element-type atype
))
293 (deftransform %data-vector-and-index
((%array %index
)
296 ;; KLUDGE: why the percent signs? Well, ARRAY and INDEX are
297 ;; respectively exported from the CL and SB!INT packages, which
298 ;; means that they're visible to all sorts of things. If the
299 ;; compiler can prove that the call to ARRAY-HEADER-P, below, either
300 ;; returns T or NIL, it will delete the irrelevant branch. However,
301 ;; user code might have got here with a variable named CL:ARRAY, and
302 ;; quite often compiler code with a variable named SB!INT:INDEX, so
303 ;; this can generate code deletion notes for innocuous user code:
304 ;; (DEFUN F (ARRAY I) (DECLARE (SIMPLE-VECTOR ARRAY)) (AREF ARRAY I))
305 ;; -- CSR, 2003-04-01
307 ;; We do this solely for the -OR-GIVE-UP side effect, since we want
308 ;; to know that the type can be figured out in the end before we
309 ;; proceed, but we don't care yet what the type will turn out to be.
310 (upgraded-element-type-specifier-or-give-up %array
)
312 '(if (array-header-p %array
)
313 (values (%array-data-vector %array
) %index
)
314 (values %array %index
)))
316 ;;; transforms for getting at simple arrays of (UNSIGNED-BYTE N) when (< N 8)
318 ;;; FIXME: In CMU CL, these were commented out with #+NIL. Why? Should
319 ;;; we fix them or should we delete them? (Perhaps these definitions
320 ;;; predate the various DATA-VECTOR-REF-FOO VOPs which have
321 ;;; (:TRANSLATE DATA-VECTOR-REF), and are redundant now?)
325 (let ((elements-per-word (truncate sb
!vm
:n-word-bits bits
)))
327 (deftransform data-vector-ref
((vector index
)
329 `(multiple-value-bind (word bit
)
330 (floor index
,',elements-per-word
)
331 (ldb ,(ecase sb
!vm
:target-byte-order
332 (:little-endian
'(byte ,bits
(* bit
,bits
)))
333 (:big-endian
'(byte ,bits
(- sb
!vm
:n-word-bits
334 (* (1+ bit
) ,bits
)))))
335 (%raw-bits vector
(+ word sb
!vm
:vector-data-offset
)))))
336 (deftransform data-vector-set
((vector index new-value
)
338 `(multiple-value-bind (word bit
)
339 (floor index
,',elements-per-word
)
340 (setf (ldb ,(ecase sb
!vm
:target-byte-order
341 (:little-endian
'(byte ,bits
(* bit
,bits
)))
343 '(byte ,bits
(- sb
!vm
:n-word-bits
344 (* (1+ bit
) ,bits
)))))
345 (%raw-bits vector
(+ word sb
!vm
:vector-data-offset
)))
347 (frob simple-bit-vector
1)
348 (frob (simple-array (unsigned-byte 2) (*)) 2)
349 (frob (simple-array (unsigned-byte 4) (*)) 4))
351 ;;;; BIT-VECTOR hackery
353 ;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word
354 ;;; loop that does 32 bits at a time.
356 ;;; FIXME: This is a lot of repeatedly macroexpanded code. It should
357 ;;; be a function call instead.
358 (macrolet ((def (bitfun wordfun
)
359 `(deftransform ,bitfun
((bit-array-1 bit-array-2 result-bit-array
)
364 :node node
:policy
(>= speed space
))
366 ,@(unless (policy node
(zerop safety
))
367 '((unless (= (length bit-array-1
)
369 (length result-bit-array
))
370 (error "Argument and/or result bit arrays are not the same length:~
375 (let ((length (length result-bit-array
)))
377 ;; We avoid doing anything to 0-length
378 ;; bit-vectors, or rather, the memory that
379 ;; follows them. Other divisible-by-32 cases
380 ;; are handled by the (1- length), below.
383 (do ((index sb
!vm
:vector-data-offset
(1+ index
))
384 (end-1 (+ sb
!vm
:vector-data-offset
385 ;; bit-vectors of length 1-32
386 ;; need precisely one (SETF
387 ;; %RAW-BITS), done here in the
388 ;; epilogue. - CSR, 2002-04-24
389 (truncate (truly-the index
(1- length
))
390 sb
!vm
:n-word-bits
))))
392 (setf (%raw-bits result-bit-array index
)
393 (,',wordfun
(%raw-bits bit-array-1 index
)
394 (%raw-bits bit-array-2 index
)))
396 (declare (optimize (speed 3) (safety 0))
397 (type index index end-1
))
398 (setf (%raw-bits result-bit-array index
)
399 (,',wordfun
(%raw-bits bit-array-1 index
)
400 (%raw-bits bit-array-2 index
))))))))))
401 (def bit-and word-logical-and
)
402 (def bit-ior word-logical-or
)
403 (def bit-xor word-logical-xor
)
404 (def bit-eqv word-logical-eqv
)
405 (def bit-nand word-logical-nand
)
406 (def bit-nor word-logical-nor
)
407 (def bit-andc1 word-logical-andc1
)
408 (def bit-andc2 word-logical-andc2
)
409 (def bit-orc1 word-logical-orc1
)
410 (def bit-orc2 word-logical-orc2
))
412 (deftransform bit-not
413 ((bit-array result-bit-array
)
414 (simple-bit-vector simple-bit-vector
) *
415 :node node
:policy
(>= speed space
))
417 ,@(unless (policy node
(zerop safety
))
418 '((unless (= (length bit-array
)
419 (length result-bit-array
))
420 (error "Argument and result bit arrays are not the same length:~
422 bit-array result-bit-array
))))
423 (let ((length (length result-bit-array
)))
425 ;; We avoid doing anything to 0-length bit-vectors, or rather,
426 ;; the memory that follows them. Other divisible-by
427 ;; n-word-bits cases are handled by the (1- length), below.
430 (do ((index sb
!vm
:vector-data-offset
(1+ index
))
431 (end-1 (+ sb
!vm
:vector-data-offset
432 ;; bit-vectors of length 1 to n-word-bits need
433 ;; precisely one (SETF %RAW-BITS), done here in
434 ;; the epilogue. - CSR, 2002-04-24
435 (truncate (truly-the index
(1- length
))
436 sb
!vm
:n-word-bits
))))
438 (setf (%raw-bits result-bit-array index
)
439 (word-logical-not (%raw-bits bit-array index
)))
441 (declare (optimize (speed 3) (safety 0))
442 (type index index end-1
))
443 (setf (%raw-bits result-bit-array index
)
444 (word-logical-not (%raw-bits bit-array index
))))))))
446 (deftransform bit-vector-
= ((x y
) (simple-bit-vector simple-bit-vector
))
447 `(and (= (length x
) (length y
))
448 (let ((length (length x
)))
450 (do* ((i sb
!vm
:vector-data-offset
(+ i
1))
451 (end-1 (+ sb
!vm
:vector-data-offset
452 (floor (1- length
) sb
!vm
:n-word-bits
))))
454 (let* ((extra (1+ (mod (1- length
) sb
!vm
:n-word-bits
)))
455 (mask (ash #.
(1- (ash 1 sb
!vm
:n-word-bits
))
456 (- extra sb
!vm
:n-word-bits
)))
460 ,(ecase sb
!c
:*backend-byte-order
*
463 '(- sb
!vm
:n-word-bits extra
))))
468 ,(ecase sb
!c
:*backend-byte-order
*
471 '(- sb
!vm
:n-word-bits extra
))))
473 (declare (type (integer 1 #.sb
!vm
:n-word-bits
) extra
)
474 (type sb
!vm
:word mask numx numy
))
476 (declare (type index i end-1
))
477 (let ((numx (%raw-bits x i
))
478 (numy (%raw-bits y i
)))
479 (declare (type sb
!vm
:word numx numy
))
480 (unless (= numx numy
)
483 (deftransform count
((item sequence
) (bit simple-bit-vector
) *
484 :policy
(>= speed space
))
485 `(let ((length (length sequence
)))
488 (do ((index sb
!vm
:vector-data-offset
(1+ index
))
490 (end-1 (+ sb
!vm
:vector-data-offset
491 (truncate (truly-the index
(1- length
))
492 sb
!vm
:n-word-bits
))))
494 (let* ((extra (1+ (mod (1- length
) sb
!vm
:n-word-bits
)))
495 (mask (ash #.
(1- (ash 1 sb
!vm
:n-word-bits
))
496 (- extra sb
!vm
:n-word-bits
)))
497 (bits (logand (ash mask
498 ,(ecase sb
!c
:*backend-byte-order
*
501 '(- sb
!vm
:n-word-bits extra
))))
502 (%raw-bits sequence index
))))
503 (declare (type (integer 1 #.sb
!vm
:n-word-bits
) extra
))
504 (declare (type sb
!vm
:word mask bits
))
505 (incf count
(logcount bits
))
506 ,(if (constant-lvar-p item
)
507 (if (zerop (lvar-value item
))
513 (declare (type index index count end-1
)
514 (optimize (speed 3) (safety 0)))
515 (incf count
(logcount (%raw-bits sequence index
)))))))
517 (deftransform fill
((sequence item
) (simple-bit-vector bit
) *
518 :policy
(>= speed space
))
519 (let ((value (if (constant-lvar-p item
)
520 (if (= (lvar-value item
) 0)
522 #.
(1- (ash 1 sb
!vm
:n-word-bits
)))
523 `(if (= item
0) 0 #.
(1- (ash 1 sb
!vm
:n-word-bits
))))))
524 `(let ((length (length sequence
))
528 (do ((index sb
!vm
:vector-data-offset
(1+ index
))
529 (end-1 (+ sb
!vm
:vector-data-offset
530 ;; bit-vectors of length 1 to n-word-bits need
531 ;; precisely one (SETF %RAW-BITS), done here
532 ;; in the epilogue. - CSR, 2002-04-24
533 (truncate (truly-the index
(1- length
))
534 sb
!vm
:n-word-bits
))))
536 (setf (%raw-bits sequence index
) value
)
538 (declare (optimize (speed 3) (safety 0))
539 (type index index end-1
))
540 (setf (%raw-bits sequence index
) value
))))))
542 (deftransform fill
((sequence item
) (simple-base-string base-char
) *
543 :policy
(>= speed space
))
544 (let ((value (if (constant-lvar-p item
)
545 (let* ((char (lvar-value item
))
546 (code (sb!xc
:char-code char
))
548 (dotimes (i sb
!vm
:n-word-bytes accum
)
549 (setf accum
(logior accum
(ash code
(* 8 i
))))))
550 `(let ((code (sb!xc
:char-code item
)))
551 (logior ,@(loop for i from
0 below sb
!vm
:n-word-bytes
552 collect
`(ash code
,(* 8 i
))))))))
553 `(let ((length (length sequence
))
555 (multiple-value-bind (times rem
)
556 (truncate length sb
!vm
:n-word-bytes
)
557 (do ((index sb
!vm
:vector-data-offset
(1+ index
))
558 (end (+ times sb
!vm
:vector-data-offset
)))
560 (let ((place (* times sb
!vm
:n-word-bytes
)))
561 (declare (fixnum place
))
562 (dotimes (j rem sequence
)
564 (setf (schar sequence
(the index
(+ place j
))) item
))))
565 (declare (optimize (speed 3) (safety 0))
567 (setf (%raw-bits sequence index
) value
))))))
571 ;;; FIXME: The old CMU CL code used various COPY-TO/FROM-SYSTEM-AREA
572 ;;; stuff (with all the associated bit-index cruft and overflow
573 ;;; issues) even for byte moves. In SBCL, we're converting to byte
574 ;;; moves as problems are discovered with the old code, and this is
575 ;;; currently (ca. sbcl-0.6.12.30) the main interface for code in
576 ;;; SB!KERNEL and SB!SYS (e.g. i/o code). It's not clear that it's the
577 ;;; ideal interface, though, and it probably deserves some thought.
578 (deftransform %byte-blt
((src src-start dst dst-start dst-end
)
579 ((or (simple-unboxed-array (*)) system-area-pointer
)
581 (or (simple-unboxed-array (*)) system-area-pointer
)
584 ;; FIXME: CMU CL had a hairier implementation of this (back when it
585 ;; was still called (%PRIMITIVE BYTE-BLT). It had the small problem
586 ;; that it didn't work for large (>16M) values of SRC-START or
587 ;; DST-START. However, it might have been more efficient. In
588 ;; particular, I don't really know how much the foreign function
589 ;; call costs us here. My guess is that if the overhead is
590 ;; acceptable for SQRT and COS, it's acceptable here, but this
591 ;; should probably be checked. -- WHN
592 '(flet ((sapify (thing)
594 (system-area-pointer thing
)
595 ;; FIXME: The code here rather relies on the simple
596 ;; unboxed array here having byte-sized entries. That
597 ;; should be asserted explicitly, I just haven't found
598 ;; a concise way of doing it. (It would be nice to
599 ;; declare it in the DEFKNOWN too.)
600 ((simple-unboxed-array (*)) (vector-sap thing
)))))
601 (declare (inline sapify
))
602 (with-pinned-objects (dst src
)
603 (memmove (sap+ (sapify dst
) dst-start
)
604 (sap+ (sapify src
) src-start
)
605 (- dst-end dst-start
)))
608 ;;;; transforms for EQL of floating point values
610 (deftransform eql
((x y
) (single-float single-float
))
611 '(= (single-float-bits x
) (single-float-bits y
)))
613 (deftransform eql
((x y
) (double-float double-float
))
614 '(and (= (double-float-low-bits x
) (double-float-low-bits y
))
615 (= (double-float-high-bits x
) (double-float-high-bits y
))))
618 ;;;; modular functions
619 (define-good-modular-fun logand
:unsigned
)
620 (define-good-modular-fun logior
:unsigned
)
621 ;;; FIXME: XOR? ANDC1, ANDC2? -- CSR, 2003-09-16
624 ((def (name class width
)
625 (let ((type (ecase class
626 (:unsigned
'unsigned-byte
)
627 (:signed
'signed-byte
))))
629 (defknown ,name
(integer (integer 0)) (,type
,width
)
630 (foldable flushable movable
))
631 (define-modular-fun-optimizer ash
((integer count
) ,class
:width width
)
632 (when (and (<= width
,width
)
633 (or (and (constant-lvar-p count
)
634 (plusp (lvar-value count
)))
635 (csubtypep (lvar-type count
)
636 (specifier-type '(and unsigned-byte fixnum
)))))
637 (cut-to-width integer
,class width
)
639 (setf (gethash ',name
(modular-class-versions (find-modular-class ',class
)))
641 ;; This should really be dependent on SB!VM:N-WORD-BITS, but since we
642 ;; don't have a true Alpha64 port yet, we'll have to stick to
643 ;; SB!VM:N-MACHINE-WORD-BITS for the time being. --njf, 2004-08-14
644 #!+#.
(cl:if
(cl:= 32 sb
!vm
:n-machine-word-bits
) '(and) '(or))
646 #!+x86
(def sb
!vm
::ash-left-smod30
:signed
30)
647 (def sb
!vm
::ash-left-mod32
:unsigned
32))
648 #!+#.
(cl:if
(cl:= 64 sb
!vm
:n-machine-word-bits
) '(and) '(or))
650 #!+x86-64
(def sb
!vm
::ash-left-smod61
:signed
61)
651 (def sb
!vm
::ash-left-mod64
:unsigned
64)))
654 ;;;; word-wise logical operations
656 ;;; These transforms assume the presence of modular arithmetic to
657 ;;; generate efficient code.
659 (define-source-transform word-logical-not
(x)
660 `(logand (lognot (the sb
!vm
:word
,x
)) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
662 (deftransform word-logical-and
((x y
))
665 (deftransform word-logical-nand
((x y
))
666 '(logand (lognand x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
668 (deftransform word-logical-or
((x y
))
671 (deftransform word-logical-nor
((x y
))
672 '(logand (lognor x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
674 (deftransform word-logical-xor
((x y
))
677 (deftransform word-logical-eqv
((x y
))
678 '(logand (logeqv x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
680 (deftransform word-logical-orc1
((x y
))
681 '(logand (logorc1 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
683 (deftransform word-logical-orc2
((x y
))
684 '(logand (logorc2 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
686 (deftransform word-logical-andc1
((x y
))
687 '(logand (logandc1 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
689 (deftransform word-logical-andc2
((x y
))
690 '(logand (logandc2 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
693 ;;; There are two different ways the multiplier can be recoded. The
694 ;;; more obvious is to shift X by the correct amount for each bit set
695 ;;; in Y and to sum the results. But if there is a string of bits that
696 ;;; are all set, you can add X shifted by one more then the bit
697 ;;; position of the first set bit and subtract X shifted by the bit
698 ;;; position of the last set bit. We can't use this second method when
699 ;;; the high order bit is bit 31 because shifting by 32 doesn't work
701 (defun ub32-strength-reduce-constant-multiply (arg num
)
702 (declare (type (unsigned-byte 32) num
))
703 (let ((adds 0) (shifts 0)
704 (result nil
) first-one
)
705 (labels ((add (next-factor)
708 (progn (incf adds
) `(+ ,result
,next-factor
))
710 (declare (inline add
))
713 (when (not (logbitp bitpos num
))
714 (add (if (= (1+ first-one
) bitpos
)
715 ;; There is only a single bit in the string.
716 (progn (incf shifts
) `(ash ,arg
,first-one
))
717 ;; There are at least two.
721 `(- (ash ,arg
,bitpos
)
722 (ash ,arg
,first-one
)))))
723 (setf first-one nil
))
724 (when (logbitp bitpos num
)
725 (setf first-one bitpos
))))
727 (cond ((= first-one
31))
728 ((= first-one
30) (incf shifts
) (add `(ash ,arg
30)))
732 (add `(- (ash ,arg
31)
733 (ash ,arg
,first-one
)))))
735 (add `(ash ,arg
31))))
736 (values (if (plusp adds
)
737 `(logand ,result
#.
(1- (ash 1 32))) ; using modular arithmetic
743 ;;; Transform GET-LISP-OBJ-ADDRESS for constant immediates, since the normal
744 ;;; VOP can't handle them.
746 (deftransform sb
!vm
::get-lisp-obj-address
((obj) ((constant-arg fixnum
)))
747 (ash (lvar-value obj
) sb
!vm
::n-fixnum-tag-bits
))
749 (deftransform sb
!vm
::get-lisp-obj-address
((obj) ((constant-arg character
)))
750 (logior sb
!vm
::character-widetag
751 (ash (char-code (lvar-value obj
)) sb
!vm
::n-widetag-bits
)))