1.0.24.11: stack allocation support for HPPA
[sbcl.git] / src / compiler / generic / vm-tran.lisp
1 ;;;; implementation-dependent transforms
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!C")
13
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))
18 #!-long-float
19 (define-source-transform long-float-p (x) `(double-float-p ,x))
20
21 (define-source-transform compiled-function-p (x)
22   #!-sb-eval
23   `(functionp ,x)
24   #!+sb-eval
25   (once-only ((x x))
26     `(and (functionp ,x)
27           (not (sb!eval:interpreted-function-p ,x)))))
28
29 (define-source-transform char-int (x)
30   `(char-code ,x))
31
32 (deftransform abs ((x) (rational))
33   '(if (< x 0) (- x) x))
34
35 ;;; We don't want to clutter the bignum code.
36 #!+(or x86 x86-64)
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))
47
48 #!+(or x86 x86-64)
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
64                                             '(value)))
65            (,fun-name thing index (,func off2 off1) ,@(when setter-p
66                                                         '(value))))))))
67
68 #!+(or x86 x86-64)
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
74                          index offset))
75
76 #!+x86
77 (progn
78 (define-source-transform sb!kernel:%vector-raw-bits (thing index)
79   `(sb!kernel:%raw-bits-with-offset ,thing ,index 2))
80
81 (define-source-transform sb!kernel:%raw-bits (thing index)
82   `(sb!kernel:%raw-bits-with-offset ,thing ,index 0))
83
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))
86
87 (define-source-transform sb!kernel:%set-raw-bits (thing index value)
88   `(sb!kernel:%set-raw-bits-with-offset ,thing ,index 0 ,value))
89
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
93                          0 index offset))
94
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
98                          0 index offset t))
99 ) ; PROGN
100
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)))
110 \f
111 ;;;; character support
112
113 ;;; In our implementation there are really only BASE-CHARs.
114 #+nil
115 (define-source-transform characterp (obj)
116   `(base-char-p ,obj))
117 \f
118 ;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
119
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)
125         `(etypecase string
126           ((simple-array character (*))
127            (data-vector-ref string index))
128           #!+sb-unicode
129           ((simple-array base-char (*))
130            (data-vector-ref string index))
131           ((simple-array nil (*))
132            (data-vector-ref string index))))))
133
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)
152                 bare-form
153                 `(the ,(type-specifier declared-element-ctype)
154                       ,bare-form)))))))
155
156 ;;; Transform multi-dimensional array to one dimensional data vector
157 ;;; access.
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)
167                             '*
168                             (reduce #'* dims))))
169         `(data-vector-ref (truly-the (simple-array ,(type-specifier el-type)
170                                                    (,total-size))
171                                      (%array-data-vector array))
172                           index)))))
173
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.
177 #!+(or x86 x86-64)
178 (define-source-transform data-vector-ref (array index)
179   `(data-vector-ref-with-offset ,array ,index 0))
180
181 #!+(or x86 x86-64)
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)
186                    *wild-type*))
187       (give-up-ir1-transform))
188     ;; It shouldn't be possible to get here with anything but a non-complex
189     ;; vector.
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
199                              index offset))))
200
201 (deftransform hairy-data-vector-set ((string index new-value)
202                                      (simple-string t t))
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)
207         `(etypecase string
208           ((simple-array character (*))
209            (data-vector-set string index new-value))
210           #!+sb-unicode
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))))))
215
216 (deftransform hairy-data-vector-set ((array index new-value)
217                                      (array t t)
218                                      *)
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)
236                        new-value))))))))
237
238 ;;; Transform multi-dimensional array to one dimensional data vector
239 ;;; access.
240 (deftransform data-vector-set ((array index new-value)
241                                (simple-array t t))
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)
250                             '*
251                             (reduce #'* dims))))
252         `(data-vector-set (truly-the (simple-array ,(type-specifier el-type)
253                                                    (,total-size))
254                                      (%array-data-vector array))
255                           index
256                           new-value)))))
257
258 ;;; Transform data vector access to a form that opens up optimization
259 ;;; opportunities.
260 #!+(or x86 x86-64)
261 (define-source-transform data-vector-set (array index new-value)
262   `(data-vector-set-with-offset ,array ,index 0 ,new-value))
263
264 #!+(or x86 x86-64)
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)
269                    *wild-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
282                              index offset t))))
283
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))
290                               (*))
291                 index)))))
292
293 (deftransform %data-vector-and-index ((%array %index)
294                                       (simple-array t)
295                                       *)
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
306
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)
311
312   '(if (array-header-p %array)
313        (values (%array-data-vector %array) %index)
314        (values %array %index)))
315
316 ;;; transforms for getting at simple arrays of (UNSIGNED-BYTE N) when (< N 8)
317 ;;;
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?)
322 #+nil
323 (macrolet
324     ((frob (type bits)
325        (let ((elements-per-word (truncate sb!vm:n-word-bits bits)))
326          `(progn
327             (deftransform data-vector-ref ((vector index)
328                                            (,type *))
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)
337                                            (,type * *))
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)))
342                                (:big-endian
343                                 '(byte ,bits (- sb!vm:n-word-bits
344                                                 (* (1+ bit) ,bits)))))
345                             (%raw-bits vector (+ word sb!vm:vector-data-offset)))
346                        new-value)))))))
347   (frob simple-bit-vector 1)
348   (frob (simple-array (unsigned-byte 2) (*)) 2)
349   (frob (simple-array (unsigned-byte 4) (*)) 4))
350 \f
351 ;;;; BIT-VECTOR hackery
352
353 ;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word
354 ;;; loop that does 32 bits at a time.
355 ;;;
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)
360                                      (simple-bit-vector
361                                       simple-bit-vector
362                                       simple-bit-vector)
363                                      *
364                                      :node node :policy (>= speed space))
365                 `(progn
366                    ,@(unless (policy node (zerop safety))
367                              '((unless (= (length bit-array-1)
368                                           (length bit-array-2)
369                                           (length result-bit-array))
370                                  (error "Argument and/or result bit arrays are not the same length:~
371                          ~%  ~S~%  ~S  ~%  ~S"
372                                         bit-array-1
373                                         bit-array-2
374                                         result-bit-array))))
375                   (let ((length (length result-bit-array)))
376                     (if (= length 0)
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.
381                         ;; CSR, 2002-04-24
382                         result-bit-array
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))))
391                             ((>= index end-1)
392                              (setf (%raw-bits result-bit-array index)
393                                    (,',wordfun (%raw-bits bit-array-1 index)
394                                                (%raw-bits bit-array-2 index)))
395                              result-bit-array)
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))
411
412 (deftransform bit-not
413               ((bit-array result-bit-array)
414                (simple-bit-vector simple-bit-vector) *
415                :node node :policy (>= speed space))
416   `(progn
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:~
421                      ~%  ~S~%  ~S"
422                     bit-array result-bit-array))))
423     (let ((length (length result-bit-array)))
424       (if (= length 0)
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.
428           ;; CSR, 2002-04-24
429           result-bit-array
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))))
437               ((>= index end-1)
438                (setf (%raw-bits result-bit-array index)
439                      (word-logical-not (%raw-bits bit-array index)))
440                result-bit-array)
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))))))))
445
446 (deftransform bit-vector-= ((x y) (simple-bit-vector simple-bit-vector))
447   `(and (= (length x) (length y))
448         (let ((length (length x)))
449           (or (= length 0)
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))))
453                    ((>= i end-1)
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)))
457                            (numx
458                             (logand
459                              (ash mask
460                                   ,(ecase sb!c:*backend-byte-order*
461                                      (:little-endian 0)
462                                      (:big-endian
463                                       '(- sb!vm:n-word-bits extra))))
464                              (%raw-bits x i)))
465                            (numy
466                             (logand
467                              (ash mask
468                                   ,(ecase sb!c:*backend-byte-order*
469                                      (:little-endian 0)
470                                      (:big-endian
471                                       '(- sb!vm:n-word-bits extra))))
472                              (%raw-bits y i))))
473                       (declare (type (integer 1 #.sb!vm:n-word-bits) extra)
474                                (type sb!vm:word mask numx numy))
475                       (= 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)
481                     (return nil))))))))
482
483 (deftransform count ((item sequence) (bit simple-bit-vector) *
484                      :policy (>= speed space))
485   `(let ((length (length sequence)))
486     (if (zerop length)
487         0
488         (do ((index sb!vm:vector-data-offset (1+ index))
489              (count 0)
490              (end-1 (+ sb!vm:vector-data-offset
491                        (truncate (truly-the index (1- length))
492                                  sb!vm:n-word-bits))))
493             ((>= index end-1)
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*
499                                                (:little-endian 0)
500                                                (:big-endian
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))
508                         '(- length count)
509                         'count)
510                     '(if (zerop item)
511                          (- length count)
512                          count))))
513           (declare (type index index count end-1)
514                    (optimize (speed 3) (safety 0)))
515           (incf count (logcount (%raw-bits sequence index)))))))
516
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)
521                        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))
525            (value ,value))
526        (if (= length 0)
527            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))))
535                ((>= index end-1)
536                 (setf (%raw-bits sequence index) value)
537                 sequence)
538              (declare (optimize (speed 3) (safety 0))
539                       (type index index end-1))
540              (setf (%raw-bits sequence index) value))))))
541
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))
547                           (accum 0))
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))
554            (value ,value))
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)))
559             ((>= index end)
560              (let ((place (* times sb!vm:n-word-bytes)))
561                (declare (fixnum place))
562                (dotimes (j rem sequence)
563                  (declare (index j))
564                  (setf (schar sequence (the index (+ place j))) item))))
565           (declare (optimize (speed 3) (safety 0))
566                    (type index index))
567           (setf (%raw-bits sequence index) value))))))
568 \f
569 ;;;; %BYTE-BLT
570
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)
580                           index
581                           (or (simple-unboxed-array (*)) system-area-pointer)
582                           index
583                           index))
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)
593             (etypecase 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)))
606      (values)))
607 \f
608 ;;;; transforms for EQL of floating point values
609
610 (deftransform eql ((x y) (single-float single-float))
611   '(= (single-float-bits x) (single-float-bits y)))
612
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))))
616
617 \f
618 ;;;; modular functions
619 ;;;
620 ;;; FIXME: I think that the :GOODness of a modular function boils down
621 ;;; to whether the normal definition can be used in the middle of a
622 ;;; modular arrangement.  LOGAND and LOGIOR can be for all unsigned
623 ;;; modular implementations, I believe, because for all unsigned
624 ;;; arguments of a given size the result of the ordinary definition is
625 ;;; the right one.  This should follow through to other logical
626 ;;; functions, such as LOGXOR, should it not?  -- CSR, 2007-12-29,
627 ;;; trying to understand a comment he wrote over four years
628 ;;; previously: "FIXME: XOR? ANDC1, ANDC2?  -- CSR, 2003-09-16"
629 (define-good-modular-fun logand :untagged nil)
630 (define-good-modular-fun logior :untagged nil)
631 (define-good-modular-fun logxor :untagged nil)
632 (macrolet ((define-good-signed-modular-funs (&rest funs)
633              (let (result)
634                `(progn
635                  ,@(dolist (fun funs (nreverse result))
636                      (push `(define-good-modular-fun ,fun :untagged t) result)
637                      (push `(define-good-modular-fun ,fun :tagged t) result))))))
638   (define-good-signed-modular-funs
639       logand logandc1 logandc2 logeqv logior lognand lognor lognot
640       logorc1 logorc2 logxor))
641
642 (macrolet
643     ((def (name kind width signedp)
644        (let ((type (ecase signedp
645                      ((nil) 'unsigned-byte)
646                      ((t) 'signed-byte))))
647          `(progn
648             (defknown ,name (integer (integer 0)) (,type ,width)
649                       (foldable flushable movable))
650             (define-modular-fun-optimizer ash ((integer count) ,kind ,signedp :width width)
651               (when (and (<= width ,width)
652                          (or (and (constant-lvar-p count)
653                                   (plusp (lvar-value count)))
654                              (csubtypep (lvar-type count)
655                                         (specifier-type '(and unsigned-byte fixnum)))))
656                 (cut-to-width integer ,kind width ,signedp)
657                 ',name))
658             (setf (gethash ',name (modular-class-versions (find-modular-class ',kind ',signedp)))
659                   `(ash ,',width))))))
660   ;; This should really be dependent on SB!VM:N-WORD-BITS, but since we
661   ;; don't have a true Alpha64 port yet, we'll have to stick to
662   ;; SB!VM:N-MACHINE-WORD-BITS for the time being.  --njf, 2004-08-14
663   #!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or))
664   (progn
665     #!+x86 (def sb!vm::ash-left-smod30 :tagged 30 t)
666     (def sb!vm::ash-left-mod32 :untagged 32 nil))
667   #!+#.(cl:if (cl:= 64 sb!vm:n-machine-word-bits) '(and) '(or))
668   (progn
669     #!+x86-64 (def sb!vm::ash-left-smod61 :tagged 61 t)
670     (def sb!vm::ash-left-mod64 :untagged 64 nil)))
671 \f
672 ;;;; word-wise logical operations
673
674 ;;; These transforms assume the presence of modular arithmetic to
675 ;;; generate efficient code.
676
677 (define-source-transform word-logical-not (x)
678   `(logand (lognot (the sb!vm:word ,x)) #.(1- (ash 1 sb!vm:n-word-bits))))
679
680 (deftransform word-logical-and ((x y))
681   '(logand x y))
682
683 (deftransform word-logical-nand ((x y))
684   '(logand (lognand x y) #.(1- (ash 1 sb!vm:n-word-bits))))
685
686 (deftransform word-logical-or ((x y))
687   '(logior x y))
688
689 (deftransform word-logical-nor ((x y))
690   '(logand (lognor x y) #.(1- (ash 1 sb!vm:n-word-bits))))
691
692 (deftransform word-logical-xor ((x y))
693   '(logxor x y))
694
695 (deftransform word-logical-eqv ((x y))
696   '(logand (logeqv x y) #.(1- (ash 1 sb!vm:n-word-bits))))
697
698 (deftransform word-logical-orc1 ((x y))
699   '(logand (logorc1 x y) #.(1- (ash 1 sb!vm:n-word-bits))))
700
701 (deftransform word-logical-orc2 ((x y))
702   '(logand (logorc2 x y) #.(1- (ash 1 sb!vm:n-word-bits))))
703
704 (deftransform word-logical-andc1 ((x y))
705   '(logand (logandc1 x y) #.(1- (ash 1 sb!vm:n-word-bits))))
706
707 (deftransform word-logical-andc2 ((x y))
708   '(logand (logandc2 x y) #.(1- (ash 1 sb!vm:n-word-bits))))
709
710 \f
711 ;;; There are two different ways the multiplier can be recoded. The
712 ;;; more obvious is to shift X by the correct amount for each bit set
713 ;;; in Y and to sum the results. But if there is a string of bits that
714 ;;; are all set, you can add X shifted by one more then the bit
715 ;;; position of the first set bit and subtract X shifted by the bit
716 ;;; position of the last set bit. We can't use this second method when
717 ;;; the high order bit is bit 31 because shifting by 32 doesn't work
718 ;;; too well.
719 (defun ub32-strength-reduce-constant-multiply (arg num)
720   (declare (type (unsigned-byte 32) num))
721   (let ((adds 0) (shifts 0)
722         (result nil) first-one)
723     (labels ((add (next-factor)
724                (setf result
725                      (if result
726                          (progn (incf adds) `(+ ,result ,next-factor))
727                          next-factor))))
728       (declare (inline add))
729       (dotimes (bitpos 32)
730         (if first-one
731             (when (not (logbitp bitpos num))
732               (add (if (= (1+ first-one) bitpos)
733                        ;; There is only a single bit in the string.
734                        (progn (incf shifts) `(ash ,arg ,first-one))
735                        ;; There are at least two.
736                        (progn
737                          (incf adds)
738                          (incf shifts 2)
739                          `(- (ash ,arg ,bitpos)
740                              (ash ,arg ,first-one)))))
741               (setf first-one nil))
742             (when (logbitp bitpos num)
743               (setf first-one bitpos))))
744       (when first-one
745         (cond ((= first-one 31))
746               ((= first-one 30) (incf shifts) (add `(ash ,arg 30)))
747               (t
748                (incf shifts 2)
749                (incf adds)
750                (add `(- (ash ,arg 31)
751                         (ash ,arg ,first-one)))))
752         (incf shifts)
753         (add `(ash ,arg 31))))
754     (values (if (plusp adds)
755                 `(logand ,result #.(1- (ash 1 32))) ; using modular arithmetic
756                 result)
757             adds
758             shifts)))
759
760 \f
761 ;;; Transform GET-LISP-OBJ-ADDRESS for constant immediates, since the normal
762 ;;; VOP can't handle them.
763
764 (deftransform sb!vm::get-lisp-obj-address ((obj) ((constant-arg fixnum)))
765   (ash (lvar-value obj) sb!vm::n-fixnum-tag-bits))
766
767 (deftransform sb!vm::get-lisp-obj-address ((obj) ((constant-arg character)))
768   (logior sb!vm::character-widetag
769           (ash (char-code (lvar-value obj)) sb!vm::n-widetag-bits)))