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)
24 #!+sb-fasteval
(not (sb!interpreter
:interpreted-function-p
,x
))
25 #!+sb-eval
(not (sb!eval
:interpreted-function-p
,x
)))))
27 (define-source-transform char-int
(x)
30 (deftransform abs
((x) (rational))
31 '(if (< x
0) (- x
) x
))
33 (deftransform make-symbol
((string) (simple-string))
34 `(%make-symbol
0 string
))
37 (define-source-transform %make-symbol
(kind string
)
38 (declare (ignore kind
))
39 ;; Set "logically read-only" bit in pname.
40 `(sb!vm
::%%make-symbol
(set-header-data ,string
,sb
!vm
:+vector-shareable
+)))
42 ;;; We don't want to clutter the bignum code.
44 (define-source-transform sb
!bignum
:%bignum-ref
(bignum index
)
45 ;; KLUDGE: We use TRULY-THE here because even though the bignum code
46 ;; is (currently) compiled with (SAFETY 0), the compiler insists on
47 ;; inserting CAST nodes to ensure that INDEX is of the correct type.
48 ;; These CAST nodes do not generate any type checks, but they do
49 ;; interfere with the operation of FOLD-INDEX-ADDRESSING, below.
50 ;; This scenario is a problem for the more user-visible case of
51 ;; folding as well. --njf, 2006-12-01
52 `(sb!bignum
:%bignum-ref-with-offset
,bignum
53 (truly-the bignum-index
,index
) 0))
56 (defun fold-index-addressing (fun-name element-size lowtag data-offset
57 index offset
&optional setter-p
)
58 (multiple-value-bind (func index-args
) (extract-fun-args index
'(+ -
) 2)
59 (destructuring-bind (x constant
) index-args
60 (unless (and (constant-lvar-p constant
)
61 ;; we lose if the remaining argument isn't a fixnum
62 (csubtypep (lvar-type x
) (specifier-type 'fixnum
)))
63 (give-up-ir1-transform))
64 (let ((value (lvar-value constant
))
66 (unless (and (integerp value
)
67 (sb!vm
::foldable-constant-offset-p
68 element-size lowtag data-offset
69 (setf new-offset
(funcall func
(lvar-value offset
)
71 (give-up-ir1-transform "constant is too large for inlining"))
72 (splice-fun-args index func
2)
73 `(lambda (thing index off1 off2
,@(when setter-p
75 (declare (ignore off1 off2
))
76 (,fun-name thing index
',new-offset
,@(when setter-p
80 (deftransform sb
!bignum
:%bignum-ref-with-offset
81 ((bignum index offset
) * * :node node
)
82 (fold-index-addressing 'sb
!bignum
:%bignum-ref-with-offset
83 sb
!vm
:n-word-bits sb
!vm
:other-pointer-lowtag
84 sb
!vm
:bignum-digits-offset
87 ;;; The layout is stored in slot 0.
88 ;;; *** These next two transforms should be the only code, aside from
89 ;;; some parts of the C runtime, with knowledge of the layout index.
90 #!-compact-instance-header
92 (define-source-transform %instance-layout
(x)
93 `(truly-the layout
(%instance-ref
,x
0)))
94 (define-source-transform %set-instance-layout
(x val
)
95 `(%instance-set
,x
0 (the layout
,val
)))
96 (define-source-transform %funcallable-instance-layout
(x)
97 `(truly-the layout
(%funcallable-instance-info
,x
0)))
98 (define-source-transform %set-funcallable-instance-layout
(x val
)
99 `(setf (%funcallable-instance-info
,x
0) (the layout
,val
))))
101 ;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
103 (deftransform hairy-data-vector-ref
((string index
) (simple-string t
))
104 (let ((ctype (lvar-type string
)))
105 (if (array-type-p ctype
)
106 ;; the other transform will kick in, so that's OK
107 (give-up-ir1-transform)
109 ((simple-array character
(*))
110 (data-vector-ref string index
))
112 ((simple-array base-char
(*))
113 (data-vector-ref string index
))
114 ((simple-array nil
(*))
115 (data-nil-vector-ref string index
))))))
117 ;;; This and the corresponding -SET transform work equally well on non-simple
118 ;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases
119 ;;; where it actually helped with non-simple arrays -- to the contrary, it
120 ;;; only made for bigger and up to 100% slower code.
121 (deftransform hairy-data-vector-ref
((array index
) (simple-array t
) *)
122 "avoid runtime dispatch on array element type"
123 (let* ((type (lvar-type array
))
124 (element-ctype (array-type-upgraded-element-type type
))
125 (declared-element-ctype (array-type-declared-element-type type
)))
126 (declare (type ctype element-ctype
))
127 (when (eq *wild-type
* element-ctype
)
128 (give-up-ir1-transform
129 "Upgraded element type of array is not known at compile time."))
130 ;; (The expansion here is basically a degenerate case of
131 ;; WITH-ARRAY-DATA. Since WITH-ARRAY-DATA is implemented as a
132 ;; macro, and macros aren't expanded in transform output, we have
133 ;; to hand-expand it ourselves.)
134 (let* ((element-type-specifier (type-specifier element-ctype
)))
135 `(multiple-value-bind (array index
)
136 (%data-vector-and-index array index
)
137 (declare (type (simple-array ,element-type-specifier
1) array
))
138 ,(let ((bare-form '(data-vector-ref array index
)))
139 (cond ((eql element-ctype
*empty-type
*)
140 `(data-nil-vector-ref array index
))
141 ((type= element-ctype declared-element-ctype
)
144 `(the ,(type-specifier declared-element-ctype
)
147 ;;; Transform multi-dimensional array to one dimensional data vector
149 (deftransform data-vector-ref
((array index
) (simple-array t
))
150 (let ((array-type (lvar-type array
)))
151 (unless (array-type-p array-type
)
152 (give-up-ir1-transform))
153 (let ((dims (array-type-dimensions array-type
)))
154 (when (or (atom dims
) (= (length dims
) 1))
155 (give-up-ir1-transform))
156 (let ((el-type (array-type-specialized-element-type array-type
))
157 (total-size (if (member '* dims
)
160 `(data-vector-ref (truly-the (simple-array ,(type-specifier el-type
)
165 ;;; Transform data vector access to a form that opens up optimization
166 ;;; opportunities. On platforms that support DATA-VECTOR-REF-WITH-OFFSET
167 ;;; DATA-VECTOR-REF is not supported at all.
169 (define-source-transform data-vector-ref
(array index
)
170 `(data-vector-ref-with-offset ,array
,index
0))
173 (deftransform data-vector-ref-with-offset
((array index offset
))
174 (let ((array-type (lvar-type array
)))
175 (when (or (not (array-type-p array-type
))
176 (eql (array-type-specialized-element-type array-type
)
178 (give-up-ir1-transform))
179 ;; It shouldn't be possible to get here with anything but a non-complex
181 (aver (not (array-type-complexp array-type
)))
182 (let* ((element-type (type-specifier (array-type-specialized-element-type array-type
)))
183 (saetp (find-saetp element-type
)))
184 (when (< (sb!vm
:saetp-n-bits saetp
) sb
!vm
:n-byte-bits
)
185 (give-up-ir1-transform))
186 (fold-index-addressing 'data-vector-ref-with-offset
187 (sb!vm
:saetp-n-bits saetp
)
188 sb
!vm
:other-pointer-lowtag
189 sb
!vm
:vector-data-offset
192 (deftransform hairy-data-vector-set
((string index new-value
)
194 (let ((ctype (lvar-type string
)))
195 (if (array-type-p ctype
)
196 ;; the other transform will kick in, so that's OK
197 (give-up-ir1-transform)
199 ((simple-array character
(*))
200 (data-vector-set string index
(the* (character :context
:aref
) new-value
)))
202 ((simple-array base-char
(*))
203 (data-vector-set string index
(the* (base-char :context
:aref
207 (%type-check-error
/c string
'nil-array-accessed-error nil
))))))
209 ;;; This and the corresponding -REF transform work equally well on non-simple
210 ;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases
211 ;;; where it actually helped with non-simple arrays -- to the contrary, it
212 ;;; only made for bigger and up 1o 100% slower code.
213 (deftransform hairy-data-vector-set
((array index new-value
)
216 "avoid runtime dispatch on array element type"
217 (let* ((type (lvar-type array
))
218 (element-ctype (array-type-upgraded-element-type type
))
219 (declared-element-ctype (array-type-declared-element-type type
)))
220 (declare (type ctype element-ctype
))
221 (when (eq *wild-type
* element-ctype
)
222 (give-up-ir1-transform
223 "Upgraded element type of array is not known at compile time."))
224 (let ((element-type-specifier (type-specifier element-ctype
)))
225 `(multiple-value-bind (array index
)
226 (%data-vector-and-index array index
)
227 (declare (type (simple-array ,element-type-specifier
1) array
)
228 (type ,element-type-specifier new-value
))
229 ,(if (type= element-ctype declared-element-ctype
)
230 '(data-vector-set array index new-value
)
231 `(truly-the ,(type-specifier declared-element-ctype
)
232 (data-vector-set array index
233 (the ,(type-specifier declared-element-ctype
)
236 ;;; Transform multi-dimensional array to one dimensional data vector
238 (deftransform data-vector-set
((array index new-value
)
240 (let ((array-type (lvar-type array
)))
241 (unless (array-type-p array-type
)
242 (give-up-ir1-transform))
243 (let ((dims (array-type-dimensions array-type
)))
244 (when (or (atom dims
) (= (length dims
) 1))
245 (give-up-ir1-transform))
246 (let ((el-type (array-type-specialized-element-type array-type
))
247 (total-size (if (member '* dims
)
250 `(data-vector-set (truly-the (simple-array ,(type-specifier el-type
)
256 ;;; Transform data vector access to a form that opens up optimization
259 (define-source-transform data-vector-set
(array index new-value
)
260 `(data-vector-set-with-offset ,array
,index
0 ,new-value
))
263 (deftransform data-vector-set-with-offset
((array index offset new-value
))
264 (let ((array-type (lvar-type array
)))
265 (when (or (not (array-type-p array-type
))
266 (eql (array-type-specialized-element-type array-type
)
268 ;; We don't yet know the exact element type, but will get that
269 ;; knowledge after some more type propagation.
270 (give-up-ir1-transform))
271 (aver (not (array-type-complexp array-type
)))
272 (let* ((element-type (type-specifier (array-type-specialized-element-type array-type
)))
273 (saetp (find-saetp element-type
)))
274 (when (< (sb!vm
:saetp-n-bits saetp
) sb
!vm
:n-byte-bits
)
275 (give-up-ir1-transform))
276 (fold-index-addressing 'data-vector-set-with-offset
277 (sb!vm
:saetp-n-bits saetp
)
278 sb
!vm
:other-pointer-lowtag
279 sb
!vm
:vector-data-offset
282 (defun simple-array-storage-vector-type (type)
283 (let ((dims (array-type-dimensions type
)))
284 (cond ((array-type-complexp type
)
287 `(simple-array ,(type-specifier
288 (array-type-specialized-element-type type
))
289 (,(if (and (listp dims
)
290 (every #'integerp dims
))
294 (defoptimizer (array-storage-vector derive-type
) ((array))
295 (let ((atype (lvar-type array
)))
296 (when (array-type-p atype
)
297 (specifier-type (or (simple-array-storage-vector-type atype
)
298 `(simple-array ,(type-specifier
299 (array-type-specialized-element-type atype
))
302 (deftransform array-storage-vector
((array) ((simple-array * (*))))
305 (defoptimizer (%array-data derive-type
) ((array))
306 (let ((atype (lvar-type array
)))
307 (when (array-type-p atype
)
309 (simple-array-storage-vector-type atype
)
310 `(array ,(type-specifier
311 (array-type-specialized-element-type atype
))))))))
313 (defoptimizer (%data-vector-and-index derive-type
) ((array index
))
314 (let ((atype (lvar-type array
))
315 (index-type (lvar-type index
)))
316 (when (array-type-p atype
)
317 (values-specifier-type
319 (simple-array-storage-vector-type atype
)
320 `(simple-array ,(type-specifier
321 (array-type-specialized-element-type atype
))
323 ,(if (and (integer-type-p index-type
)
324 (numeric-type-low index-type
))
325 `(integer ,(numeric-type-low index-type
)
326 (,sb
!xc
:array-dimension-limit
))
329 (deftransform %data-vector-and-index
((%array %index
)
332 ;; KLUDGE: why the percent signs? Well, ARRAY and INDEX are
333 ;; respectively exported from the CL and SB!INT packages, which
334 ;; means that they're visible to all sorts of things. If the
335 ;; compiler can prove that the call to ARRAY-HEADER-P, below, either
336 ;; returns T or NIL, it will delete the irrelevant branch. However,
337 ;; user code might have got here with a variable named CL:ARRAY, and
338 ;; quite often compiler code with a variable named SB!INT:INDEX, so
339 ;; this can generate code deletion notes for innocuous user code:
340 ;; (DEFUN F (ARRAY I) (DECLARE (SIMPLE-VECTOR ARRAY)) (AREF ARRAY I))
341 ;; -- CSR, 2003-04-01
343 ;; We do this solely for the -OR-GIVE-UP side effect, since we want
344 ;; to know that the type can be figured out in the end before we
345 ;; proceed, but we don't care yet what the type will turn out to be.
346 (upgraded-element-type-specifier-or-give-up %array
)
348 '(if (array-header-p %array
)
349 (values (%array-data %array
) %index
)
350 (values %array %index
)))
352 ;;;; BIT-VECTOR hackery
354 ;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word
355 ;;; loop that does 32 bits at a time.
357 ;;; FIXME: This is a lot of repeatedly macroexpanded code. It should
358 ;;; be a function call instead.
359 (macrolet ((def (bitfun wordfun
)
360 `(deftransform ,bitfun
((bit-array-1 bit-array-2 result-bit-array
)
365 :node node
:policy
(>= speed space
))
367 ,@(unless (policy node
(zerop safety
))
368 '((unless (= (length bit-array-1
)
370 (length result-bit-array
))
371 (error "Argument and/or result bit arrays are not the same length:~
376 (let ((length (length result-bit-array
)))
378 ;; We avoid doing anything to 0-length
379 ;; bit-vectors, or rather, the memory that
380 ;; follows them. Other divisible-by-32 cases
381 ;; are handled by the (1- length), below.
384 (do ((index 0 (1+ index
))
385 ;; bit-vectors of length 1-32 need
386 ;; precisely one (SETF %VECTOR-RAW-BITS),
387 ;; done here in the epilogue. - CSR,
389 (end-1 (truncate (truly-the index
(1- length
))
392 (setf (%vector-raw-bits result-bit-array index
)
393 (,',wordfun
(%vector-raw-bits bit-array-1 index
)
394 (%vector-raw-bits bit-array-2 index
)))
396 (declare (optimize (speed 3) (safety 0))
397 (type index index end-1
))
398 (setf (%vector-raw-bits result-bit-array index
)
399 (,',wordfun
(%vector-raw-bits bit-array-1 index
)
400 (%vector-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 0 (1+ index
))
431 ;; bit-vectors of length 1 to n-word-bits need precisely
432 ;; one (SETF %VECTOR-RAW-BITS), done here in the
433 ;; epilogue. - CSR, 2002-04-24
434 (end-1 (truncate (truly-the index
(1- length
))
437 (setf (%vector-raw-bits result-bit-array index
)
438 (word-logical-not (%vector-raw-bits bit-array index
)))
440 (declare (optimize (speed 3) (safety 0))
441 (type index index end-1
))
442 (setf (%vector-raw-bits result-bit-array index
)
443 (word-logical-not (%vector-raw-bits bit-array index
))))))))
445 (deftransform bit-vector-
= ((x y
) (simple-bit-vector simple-bit-vector
))
446 `(and (= (length x
) (length y
))
447 (let ((length (length x
)))
450 (end-1 (floor (1- length
) sb
!vm
:n-word-bits
)))
452 (let* ((extra (1+ (mod (1- length
) sb
!vm
:n-word-bits
)))
453 (mask (ash #.
(1- (ash 1 sb
!vm
:n-word-bits
))
454 (- extra sb
!vm
:n-word-bits
)))
458 ,(ecase sb
!c
:*backend-byte-order
*
461 '(- sb
!vm
:n-word-bits extra
))))
462 (%vector-raw-bits x i
)))
466 ,(ecase sb
!c
:*backend-byte-order
*
469 '(- sb
!vm
:n-word-bits extra
))))
470 (%vector-raw-bits y i
))))
471 (declare (type (integer 1 #.sb
!vm
:n-word-bits
) extra
)
472 (type sb
!vm
:word mask numx numy
))
474 (declare (type index i end-1
))
475 (let ((numx (%vector-raw-bits x i
))
476 (numy (%vector-raw-bits y i
)))
477 (declare (type sb
!vm
:word numx numy
))
478 (unless (= numx numy
)
481 (deftransform count
((item sequence
) (bit simple-bit-vector
) *
482 :policy
(>= speed space
))
483 `(let ((length (length sequence
)))
486 (do ((index 0 (1+ index
))
488 (end-1 (truncate (truly-the index
(1- length
))
491 ;; "(mod (1- length) ...)" is the bit index within the word
492 ;; of the array index of the ultimate bit to be examined.
493 ;; "1+" it is the number of bits in that word.
494 ;; But I don't get why people are allowed to store random data that
495 ;; we mask off, as if we could accomodate all possible ways that
496 ;; unsafe code can spew bits where they don't belong.
497 ;; Does it have to do with %shrink-vector, perhaps?
498 ;; Some rationale would be nice...
499 (let* ((extra (1+ (mod (1- length
) sb
!vm
:n-word-bits
)))
500 (mask (ash #.
(1- (ash 1 sb
!vm
:n-word-bits
))
501 (- extra sb
!vm
:n-word-bits
)))
502 ;; The above notwithstanding, for big-endian wouldn't it
503 ;; be possible to write this expression as a single shift?
504 ;; (LOGAND MOST-POSITIVE-WORD (ASH most-positive-word (- n-word-bits extra)))
505 ;; rather than a right-shift to fill in zeros on the left
506 ;; then by a left-shift to left-align the 1s?
507 (bits (logand (ash mask
508 ,(ecase sb
!c
:*backend-byte-order
*
511 '(- sb
!vm
:n-word-bits extra
))))
512 (%vector-raw-bits sequence index
))))
513 (declare (type (integer 1 #.sb
!vm
:n-word-bits
) extra
))
514 (declare (type sb
!vm
:word mask bits
))
515 (incf count
(logcount bits
))
516 ,(if (constant-lvar-p item
)
517 (if (zerop (lvar-value item
))
523 (declare (type index index count end-1
)
524 (optimize (speed 3) (safety 0)))
525 (incf count
(logcount (%vector-raw-bits sequence index
)))))))
527 (deftransform fill
((sequence item
) (simple-bit-vector bit
) *
528 :policy
(>= speed space
))
529 (let ((value (if (constant-lvar-p item
)
530 (if (= (lvar-value item
) 0)
532 #.
(1- (ash 1 sb
!vm
:n-word-bits
)))
533 `(if (= item
0) 0 #.
(1- (ash 1 sb
!vm
:n-word-bits
))))))
534 `(let ((length (length sequence
))
538 (do ((index 0 (1+ index
))
539 ;; bit-vectors of length 1 to n-word-bits need precisely
540 ;; one (SETF %VECTOR-RAW-BITS), done here in the
541 ;; epilogue. - CSR, 2002-04-24
542 (end-1 (truncate (truly-the index
(1- length
))
545 (setf (%vector-raw-bits sequence index
) value
)
547 (declare (optimize (speed 3) (safety 0))
548 (type index index end-1
))
549 (setf (%vector-raw-bits sequence index
) value
))))))
551 (deftransform fill
((sequence item
) (simple-base-string base-char
) *
552 :policy
(>= speed space
))
553 (let ((value (if (constant-lvar-p item
)
554 (let* ((char (lvar-value item
))
555 (code (sb!xc
:char-code char
))
557 (dotimes (i sb
!vm
:n-word-bytes accum
)
558 (setf accum
(logior accum
(ash code
(* 8 i
))))))
559 `(let ((code (sb!xc
:char-code item
)))
560 (logior ,@(loop for i from
0 below sb
!vm
:n-word-bytes
561 collect
`(ash code
,(* 8 i
))))))))
562 `(let ((length (length sequence
))
564 (multiple-value-bind (times rem
)
565 (truncate length sb
!vm
:n-word-bytes
)
566 (do ((index 0 (1+ index
))
569 (let ((place (* times sb
!vm
:n-word-bytes
)))
570 (declare (fixnum place
))
571 (dotimes (j rem sequence
)
573 (setf (schar sequence
(the index
(+ place j
))) item
))))
574 (declare (optimize (speed 3) (safety 0))
576 (setf (%vector-raw-bits sequence index
) value
))))))
580 ;;; FIXME: The old CMU CL code used various COPY-TO/FROM-SYSTEM-AREA
581 ;;; stuff (with all the associated bit-index cruft and overflow
582 ;;; issues) even for byte moves. In SBCL, we're converting to byte
583 ;;; moves as problems are discovered with the old code, and this is
584 ;;; currently (ca. sbcl-0.6.12.30) the main interface for code in
585 ;;; SB!KERNEL and SB!SYS (e.g. i/o code). It's not clear that it's the
586 ;;; ideal interface, though, and it probably deserves some thought.
587 (deftransform %byte-blt
((src src-start dst dst-start dst-end
)
588 ((or (simple-unboxed-array (*)) system-area-pointer
)
590 (or (simple-unboxed-array (*)) system-area-pointer
)
593 ;; FIXME: CMU CL had a hairier implementation of this (back when it
594 ;; was still called (%PRIMITIVE BYTE-BLT). It had the small problem
595 ;; that it didn't work for large (>16M) values of SRC-START or
596 ;; DST-START. However, it might have been more efficient. In
597 ;; particular, I don't really know how much the foreign function
598 ;; call costs us here. My guess is that if the overhead is
599 ;; acceptable for SQRT and COS, it's acceptable here, but this
600 ;; should probably be checked. -- WHN
601 '(flet ((sapify (thing)
603 (system-area-pointer thing
)
604 ;; FIXME: The code here rather relies on the simple
605 ;; unboxed array here having byte-sized entries. That
606 ;; should be asserted explicitly, I just haven't found
607 ;; a concise way of doing it. (It would be nice to
608 ;; declare it in the DEFKNOWN too.)
609 ((simple-unboxed-array (*)) (vector-sap thing
)))))
610 (declare (inline sapify
))
611 (with-pinned-objects (dst src
)
612 (memmove (sap+ (sapify dst
) dst-start
)
613 (sap+ (sapify src
) src-start
)
614 (- dst-end dst-start
)))
617 ;;;; transforms for EQL of floating point values
619 (deftransform eql
((x y
) (single-float single-float
))
620 '(= (single-float-bits x
) (single-float-bits y
)))
623 (deftransform eql
((x y
) (double-float double-float
))
624 '(and (= (double-float-low-bits x
) (double-float-low-bits y
))
625 (= (double-float-high-bits x
) (double-float-high-bits y
))))
628 ;;;; modular functions
630 ;;; FIXME: I think that the :GOODness of a modular function boils down
631 ;;; to whether the normal definition can be used in the middle of a
632 ;;; modular arrangement. LOGAND and LOGIOR can be for all unsigned
633 ;;; modular implementations, I believe, because for all unsigned
634 ;;; arguments of a given size the result of the ordinary definition is
635 ;;; the right one. This should follow through to other logical
636 ;;; functions, such as LOGXOR, should it not? -- CSR, 2007-12-29,
637 ;;; trying to understand a comment he wrote over four years
638 ;;; previously: "FIXME: XOR? ANDC1, ANDC2? -- CSR, 2003-09-16"
639 (define-good-modular-fun logand
:untagged nil
)
640 (define-good-modular-fun logior
:untagged nil
)
641 (define-good-modular-fun logxor
:untagged nil
)
642 (macrolet ((define-good-signed-modular-funs (&rest funs
)
645 ,@(dolist (fun funs
(nreverse result
))
646 (push `(define-good-modular-fun ,fun
:untagged t
) result
)
647 (push `(define-good-modular-fun ,fun
:tagged t
) result
))))))
648 (define-good-signed-modular-funs
649 logand logandc1 logandc2 logeqv logior lognand lognor lognot
650 logorc1 logorc2 logxor
))
653 ((def (name kind width signedp
)
654 (let ((type (ecase signedp
655 ((nil) 'unsigned-byte
)
656 ((t) 'signed-byte
))))
658 (defknown ,name
(integer (integer 0)) (,type
,width
)
659 (foldable flushable movable
))
660 (define-modular-fun-optimizer ash
((integer count
) ,kind
,signedp
:width width
)
661 (when (and (<= width
,width
)
662 (or (and (constant-lvar-p count
)
663 (plusp (lvar-value count
)))
664 (csubtypep (lvar-type count
)
665 (specifier-type '(and unsigned-byte fixnum
)))))
666 (cut-to-width integer
,kind width
,signedp
)
668 (setf (gethash ',name
(modular-class-versions (find-modular-class ',kind
',signedp
)))
670 ;; This should really be dependent on SB!VM:N-WORD-BITS, but since we
671 ;; don't have a true Alpha64 port yet, we'll have to stick to
672 ;; SB!VM:N-MACHINE-WORD-BITS for the time being. --njf, 2004-08-14
674 #!+(or x86 x86-64 arm arm64
)
675 (def sb
!vm
::ash-left-modfx
676 :tagged
,(- sb
!vm
:n-word-bits sb
!vm
:n-fixnum-tag-bits
) t
)
677 (def ,(intern (format nil
"ASH-LEFT-MOD~D" sb
!vm
:n-machine-word-bits
)
679 :untagged
,sb
!vm
:n-machine-word-bits nil
)))
681 ;;;; word-wise logical operations
683 ;;; These transforms assume the presence of modular arithmetic to
684 ;;; generate efficient code.
686 (define-source-transform word-logical-not
(x)
687 `(logand (lognot (the sb
!vm
:word
,x
)) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
689 (deftransform word-logical-and
((x y
))
692 (deftransform word-logical-nand
((x y
))
693 '(logand (lognand x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
695 (deftransform word-logical-or
((x y
))
698 (deftransform word-logical-nor
((x y
))
699 '(logand (lognor x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
701 (deftransform word-logical-xor
((x y
))
704 (deftransform word-logical-eqv
((x y
))
705 '(logand (logeqv x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
707 (deftransform word-logical-orc1
((x y
))
708 '(logand (logorc1 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
710 (deftransform word-logical-orc2
((x y
))
711 '(logand (logorc2 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
713 (deftransform word-logical-andc1
((x y
))
714 '(logand (logandc1 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
716 (deftransform word-logical-andc2
((x y
))
717 '(logand (logandc2 x y
) #.
(1- (ash 1 sb
!vm
:n-word-bits
))))
720 ;;; There are two different ways the multiplier can be recoded. The
721 ;;; more obvious is to shift X by the correct amount for each bit set
722 ;;; in Y and to sum the results. But if there is a string of bits that
723 ;;; are all set, you can add X shifted by one more then the bit
724 ;;; position of the first set bit and subtract X shifted by the bit
725 ;;; position of the last set bit. We can't use this second method when
726 ;;; the high order bit is bit 31 because shifting by 32 doesn't work
728 (defun ub32-strength-reduce-constant-multiply (arg num
)
729 (declare (type (unsigned-byte 32) num
))
730 (let ((adds 0) (shifts 0)
731 (result nil
) first-one
)
732 (labels ((add (next-factor)
735 (progn (incf adds
) `(+ ,result
,next-factor
))
737 (declare (inline add
))
740 (when (not (logbitp bitpos num
))
741 (add (if (= (1+ first-one
) bitpos
)
742 ;; There is only a single bit in the string.
743 (progn (incf shifts
) `(ash ,arg
,first-one
))
744 ;; There are at least two.
748 `(- (ash ,arg
,bitpos
)
749 (ash ,arg
,first-one
)))))
750 (setf first-one nil
))
751 (when (logbitp bitpos num
)
752 (setf first-one bitpos
))))
754 (cond ((= first-one
31))
755 ((= first-one
30) (incf shifts
) (add `(ash ,arg
30)))
759 (add `(- (ash ,arg
31)
760 (ash ,arg
,first-one
)))))
762 (add `(ash ,arg
31))))
763 (values (if (plusp adds
)
764 `(logand ,result
#.
(1- (ash 1 32))) ; using modular arithmetic
770 ;;; Transform GET-LISP-OBJ-ADDRESS for constant immediates, since the normal
771 ;;; VOP can't handle them.
773 (deftransform sb
!vm
::get-lisp-obj-address
((obj) ((constant-arg fixnum
)))
774 (ash (lvar-value obj
) sb
!vm
::n-fixnum-tag-bits
))
776 (deftransform sb
!vm
::get-lisp-obj-address
((obj) ((constant-arg character
)))
777 (logior sb
!vm
::character-widetag
778 (ash (char-code (lvar-value obj
)) sb
!vm
::n-widetag-bits
)))
780 ;; So that the PCL code walker doesn't observe any use of %PRIMITIVE,
781 ;; MAKE-UNBOUND-MARKER is an ordinary function, not a macro.
783 (defun make-unbound-marker () ; for interpreters
784 (sb!sys
:%primitive make-unbound-marker
))
785 ;; Get the main compiler to transform MAKE-UNBOUND-MARKER
786 ;; without the fopcompiler seeing it - the fopcompiler does
787 ;; expand compiler-macros, but not source-transforms -
788 ;; because %PRIMITIVE is not generally fopcompilable.
789 (sb!c
:define-source-transform make-unbound-marker
()
790 `(sb!sys
:%primitive make-unbound-marker
))