0.8.3.44:
[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   `(functionp ,x))
23
24 (define-source-transform char-int (x)
25   `(char-code ,x))
26
27 (deftransform abs ((x) (rational))
28   '(if (< x 0) (- x) x))
29
30 ;;; The layout is stored in slot 0.
31 (define-source-transform %instance-layout (x)
32   `(truly-the layout (%instance-ref ,x 0)))
33 (define-source-transform %set-instance-layout (x val)
34   `(%instance-set ,x 0 (the layout ,val)))
35 \f
36 ;;;; character support
37
38 ;;; In our implementation there are really only BASE-CHARs.
39 (define-source-transform characterp (obj)
40   `(base-char-p ,obj))
41 \f
42 ;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
43
44 (deftransform hairy-data-vector-ref ((string index) (simple-string t))
45   (let ((ctype (continuation-type string)))
46     (if (array-type-p ctype)
47         ;; the other transform will kick in, so that's OK
48         (give-up-ir1-transform)
49         `(etypecase string
50           ((simple-array character (*)) (data-vector-ref string index))
51           ((simple-array nil (*)) (data-vector-ref string index))))))
52
53 (deftransform hairy-data-vector-ref ((array index) (array t) * :important t)
54   "avoid runtime dispatch on array element type"
55   (let ((element-ctype (extract-upgraded-element-type array))
56         (declared-element-ctype (extract-declared-element-type array)))
57     (declare (type ctype element-ctype))
58     (when (eq *wild-type* element-ctype)
59       (give-up-ir1-transform
60        "Upgraded element type of array is not known at compile time."))
61     ;; (The expansion here is basically a degenerate case of
62     ;; WITH-ARRAY-DATA. Since WITH-ARRAY-DATA is implemented as a
63     ;; macro, and macros aren't expanded in transform output, we have
64     ;; to hand-expand it ourselves.)
65     (let ((element-type-specifier (type-specifier element-ctype)))
66       `(multiple-value-bind (array index)
67            (%data-vector-and-index array index)
68          (declare (type (simple-array ,element-type-specifier 1) array))
69          ,(let ((bare-form '(data-vector-ref array index)))
70             (if (type= element-ctype declared-element-ctype)
71                 bare-form
72                 `(the ,(type-specifier declared-element-ctype)
73                       ,bare-form)))))))
74
75 (deftransform data-vector-ref ((array index)
76                                (simple-array t))
77   (let ((array-type (continuation-type array)))
78     (unless (array-type-p array-type)
79       (give-up-ir1-transform))
80     (let ((dims (array-type-dimensions array-type)))
81       (when (or (atom dims) (= (length dims) 1))
82         (give-up-ir1-transform))
83       (let ((el-type (array-type-specialized-element-type array-type))
84             (total-size (if (member '* dims)
85                             '*
86                             (reduce #'* dims))))
87         `(data-vector-ref (truly-the (simple-array ,(type-specifier el-type)
88                                                    (,total-size))
89                                      (%array-data-vector array))
90                           index)))))
91
92 (deftransform hairy-data-vector-set ((string index new-value)
93                                      (simple-string t t))
94   (let ((ctype (continuation-type string)))
95     (if (array-type-p ctype)
96         ;; the other transform will kick in, so that's OK
97         (give-up-ir1-transform)
98         `(etypecase string
99           ((simple-array character (*))
100            (data-vector-set string index new-value))
101           ((simple-array nil (*))
102            (data-vector-set string index new-value))))))
103
104 (deftransform hairy-data-vector-set ((array index new-value)
105                                      (array t t)
106                                      *
107                                      :important t)
108   "avoid runtime dispatch on array element type"
109   (let ((element-ctype (extract-upgraded-element-type array))
110         (declared-element-ctype (extract-declared-element-type array)))
111     (declare (type ctype element-ctype))
112     (when (eq *wild-type* element-ctype)
113       (give-up-ir1-transform
114        "Upgraded element type of array is not known at compile time."))
115     (let ((element-type-specifier (type-specifier element-ctype)))
116       `(multiple-value-bind (array index)
117            (%data-vector-and-index array index)
118          (declare (type (simple-array ,element-type-specifier 1) array)
119                   (type ,element-type-specifier new-value))
120          ,(if (type= element-ctype declared-element-ctype)
121               '(data-vector-set array index new-value)
122               `(truly-the ,(type-specifier declared-element-ctype)
123                  (data-vector-set array index
124                   (the ,(type-specifier declared-element-ctype)
125                        new-value))))))))
126
127 (deftransform data-vector-set ((array index new-value)
128                                (simple-array t t))
129   (let ((array-type (continuation-type array)))
130     (unless (array-type-p array-type)
131       (give-up-ir1-transform))
132     (let ((dims (array-type-dimensions array-type)))
133       (when (or (atom dims) (= (length dims) 1))
134         (give-up-ir1-transform))
135       (let ((el-type (array-type-specialized-element-type array-type))
136             (total-size (if (member '* dims)
137                             '*
138                             (reduce #'* dims))))
139         `(data-vector-set (truly-the (simple-array ,(type-specifier el-type)
140                                                    (,total-size))
141                                      (%array-data-vector array))
142                           index
143                           new-value)))))
144
145 (defoptimizer (%data-vector-and-index derive-type) ((array index))
146   (let ((atype (continuation-type array)))
147     (when (array-type-p atype)
148       (values-specifier-type
149        `(values (simple-array ,(type-specifier
150                                 (array-type-specialized-element-type atype))
151                               (*))
152                 index)))))
153
154 (deftransform %data-vector-and-index ((%array %index)
155                                       (simple-array t)
156                                       *
157                                       :important t)
158   ;; KLUDGE: why the percent signs?  Well, ARRAY and INDEX are
159   ;; respectively exported from the CL and SB!INT packages, which
160   ;; means that they're visible to all sorts of things.  If the
161   ;; compiler can prove that the call to ARRAY-HEADER-P, below, either
162   ;; returns T or NIL, it will delete the irrelevant branch.  However,
163   ;; user code might have got here with a variable named CL:ARRAY, and
164   ;; quite often compiler code with a variable named SB!INT:INDEX, so
165   ;; this can generate code deletion notes for innocuous user code:
166   ;; (DEFUN F (ARRAY I) (DECLARE (SIMPLE-VECTOR ARRAY)) (AREF ARRAY I))
167   ;; -- CSR, 2003-04-01
168
169   ;; We do this solely for the -OR-GIVE-UP side effect, since we want
170   ;; to know that the type can be figured out in the end before we
171   ;; proceed, but we don't care yet what the type will turn out to be.
172   (upgraded-element-type-specifier-or-give-up %array)
173
174   '(if (array-header-p %array)
175        (values (%array-data-vector %array) %index)
176        (values %array %index)))
177
178 ;;; transforms for getting at simple arrays of (UNSIGNED-BYTE N) when (< N 8)
179 ;;;
180 ;;; FIXME: In CMU CL, these were commented out with #+NIL. Why? Should
181 ;;; we fix them or should we delete them? (Perhaps these definitions
182 ;;; predate the various DATA-VECTOR-REF-FOO VOPs which have
183 ;;; (:TRANSLATE DATA-VECTOR-REF), and are redundant now?)
184 #+nil
185 (macrolet
186     ((frob (type bits)
187        (let ((elements-per-word (truncate sb!vm:n-word-bits bits)))
188          `(progn
189             (deftransform data-vector-ref ((vector index)
190                                            (,type *))
191               `(multiple-value-bind (word bit)
192                    (floor index ,',elements-per-word)
193                  (ldb ,(ecase sb!vm:target-byte-order
194                          (:little-endian '(byte ,bits (* bit ,bits)))
195                          (:big-endian '(byte ,bits (- sb!vm:n-word-bits
196                                                       (* (1+ bit) ,bits)))))
197                       (%raw-bits vector (+ word sb!vm:vector-data-offset)))))
198             (deftransform data-vector-set ((vector index new-value)
199                                            (,type * *))
200               `(multiple-value-bind (word bit)
201                    (floor index ,',elements-per-word)
202                  (setf (ldb ,(ecase sb!vm:target-byte-order
203                                (:little-endian '(byte ,bits (* bit ,bits)))
204                                (:big-endian
205                                 '(byte ,bits (- sb!vm:n-word-bits
206                                                 (* (1+ bit) ,bits)))))
207                             (%raw-bits vector (+ word sb!vm:vector-data-offset)))
208                        new-value)))))))
209   (frob simple-bit-vector 1)
210   (frob (simple-array (unsigned-byte 2) (*)) 2)
211   (frob (simple-array (unsigned-byte 4) (*)) 4))
212 \f
213 ;;;; BIT-VECTOR hackery
214
215 ;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word
216 ;;; loop that does 32 bits at a time.
217 ;;;
218 ;;; FIXME: This is a lot of repeatedly macroexpanded code. It should
219 ;;; be a function call instead.
220 (macrolet ((def (bitfun wordfun)
221              `(deftransform ,bitfun ((bit-array-1 bit-array-2 result-bit-array)
222                                      (simple-bit-vector
223                                       simple-bit-vector
224                                       simple-bit-vector)
225                                      *
226                                      :node node :policy (>= speed space))
227                 `(progn
228                    ,@(unless (policy node (zerop safety))
229                              '((unless (= (length bit-array-1)
230                                           (length bit-array-2)
231                                           (length result-bit-array))
232                                  (error "Argument and/or result bit arrays are not the same length:~
233                          ~%  ~S~%  ~S  ~%  ~S"
234                                         bit-array-1
235                                         bit-array-2
236                                         result-bit-array))))
237                   (let ((length (length result-bit-array)))
238                     (if (= length 0)
239                         ;; We avoid doing anything to 0-length
240                         ;; bit-vectors, or rather, the memory that
241                         ;; follows them. Other divisible-by-32 cases
242                         ;; are handled by the (1- length), below.
243                         ;; CSR, 2002-04-24
244                         result-bit-array
245                         (do ((index sb!vm:vector-data-offset (1+ index))
246                              (end-1 (+ sb!vm:vector-data-offset
247                                        ;; bit-vectors of length 1-32
248                                        ;; need precisely one (SETF
249                                        ;; %RAW-BITS), done here in the
250                                        ;; epilogue. - CSR, 2002-04-24
251                                        (truncate (truly-the index (1- length))
252                                                  sb!vm:n-word-bits))))
253                             ((= index end-1)
254                              (setf (%raw-bits result-bit-array index)
255                                    (,',wordfun (%raw-bits bit-array-1 index)
256                                                (%raw-bits bit-array-2 index)))
257                              result-bit-array)
258                           (declare (optimize (speed 3) (safety 0))
259                                    (type index index end-1))
260                           (setf (%raw-bits result-bit-array index)
261                                 (,',wordfun (%raw-bits bit-array-1 index)
262                                             (%raw-bits bit-array-2 index))))))))))
263  (def bit-and 32bit-logical-and)
264  (def bit-ior 32bit-logical-or)
265  (def bit-xor 32bit-logical-xor)
266  (def bit-eqv 32bit-logical-eqv)
267  (def bit-nand 32bit-logical-nand)
268  (def bit-nor 32bit-logical-nor)
269  (def bit-andc1 32bit-logical-andc1)
270  (def bit-andc2 32bit-logical-andc2)
271  (def bit-orc1 32bit-logical-orc1)
272  (def bit-orc2 32bit-logical-orc2))
273
274 (deftransform bit-not
275               ((bit-array result-bit-array)
276                (simple-bit-vector simple-bit-vector) *
277                :node node :policy (>= speed space))
278   `(progn
279      ,@(unless (policy node (zerop safety))
280          '((unless (= (length bit-array)
281                       (length result-bit-array))
282              (error "Argument and result bit arrays are not the same length:~
283                      ~%  ~S~%  ~S"
284                     bit-array result-bit-array))))
285     (let ((length (length result-bit-array)))
286       (if (= length 0)
287           ;; We avoid doing anything to 0-length bit-vectors, or
288           ;; rather, the memory that follows them. Other
289           ;; divisible-by-32 cases are handled by the (1- length),
290           ;; below.  CSR, 2002-04-24
291           result-bit-array
292           (do ((index sb!vm:vector-data-offset (1+ index))
293                (end-1 (+ sb!vm:vector-data-offset
294                          ;; bit-vectors of length 1-32 need precisely
295                          ;; one (SETF %RAW-BITS), done here in the
296                          ;; epilogue. - CSR, 2002-04-24
297                          (truncate (truly-the index (1- length))
298                                    sb!vm:n-word-bits))))
299               ((= index end-1)
300                (setf (%raw-bits result-bit-array index)
301                      (32bit-logical-not (%raw-bits bit-array index)))
302                result-bit-array)
303             (declare (optimize (speed 3) (safety 0))
304                      (type index index end-1))
305             (setf (%raw-bits result-bit-array index)
306                   (32bit-logical-not (%raw-bits bit-array index))))))))
307
308 (deftransform bit-vector-= ((x y) (simple-bit-vector simple-bit-vector))
309   `(and (= (length x) (length y))
310         (let ((length (length x)))
311           (or (= length 0)
312               (do* ((i sb!vm:vector-data-offset (+ i 1))
313                     (end-1 (+ sb!vm:vector-data-offset
314                               (floor (1- length) sb!vm:n-word-bits))))
315                    ((= i end-1)
316                     (let* ((extra (mod length sb!vm:n-word-bits))
317                            (mask (1- (ash 1 extra)))
318                            (numx
319                             (logand
320                              (ash mask
321                                   ,(ecase sb!c:*backend-byte-order*
322                                      (:little-endian 0)
323                                      (:big-endian
324                                       '(- sb!vm:n-word-bits extra))))
325                              (%raw-bits x i)))
326                            (numy
327                             (logand
328                              (ash mask
329                                   ,(ecase sb!c:*backend-byte-order*
330                                      (:little-endian 0)
331                                      (:big-endian
332                                       '(- sb!vm:n-word-bits extra))))
333                              (%raw-bits y i))))
334                       (declare (type (integer 0 31) extra)
335                                (type (unsigned-byte 32) mask numx numy))
336                       (= numx numy)))
337                 (declare (type index i end-1))
338                 (let ((numx (%raw-bits x i))
339                       (numy (%raw-bits y i)))
340                   (declare (type (unsigned-byte 32) numx numy))
341                   (unless (= numx numy)
342                     (return nil))))))))
343
344 (deftransform fill ((sequence item) (simple-bit-vector bit) *
345                     :policy (>= speed space))
346   (let ((value (if (constant-continuation-p item)
347                    (if (= (continuation-value item) 0)
348                        0
349                        #.(1- (ash 1 32)))
350                    `(if (= item 0) 0 #.(1- (ash 1 32))))))
351     `(let ((length (length sequence))
352            (value ,value))
353        (if (= length 0)
354            sequence
355            (do ((index sb!vm:vector-data-offset (1+ index))
356                 (end-1 (+ sb!vm:vector-data-offset
357                           ;; bit-vectors of length 1-32 need precisely
358                           ;; one (SETF %RAW-BITS), done here in the
359                           ;; epilogue. - CSR, 2002-04-24
360                           (truncate (truly-the index (1- length))
361                                     sb!vm:n-word-bits))))
362                ((= index end-1)
363                 (setf (%raw-bits sequence index) value)
364                 sequence)
365              (declare (optimize (speed 3) (safety 0))
366                       (type index index end-1))
367              (setf (%raw-bits sequence index) value))))))
368
369 (deftransform fill ((sequence item) (simple-base-string base-char) *
370                     :policy (>= speed space))
371   (let ((value (if (constant-continuation-p item)
372                    (let* ((char (continuation-value item))
373                           (code (sb!xc:char-code char)))
374                      (logior code (ash code 8) (ash code 16) (ash code 24)))
375                    `(let ((code (sb!xc:char-code item)))
376                      (logior code (ash code 8) (ash code 16) (ash code 24))))))
377     `(let ((length (length sequence))
378            (value ,value))
379       (multiple-value-bind (times rem)
380           (truncate length 4)
381         (do ((index sb!vm:vector-data-offset (1+ index))
382              (end (+ times sb!vm:vector-data-offset)))
383             ((= index end)
384              (let ((place (* times 4)))
385                (declare (fixnum place))
386                (dotimes (j rem sequence)
387                  (declare (index j))
388                  (setf (schar sequence (the index (+ place j))) item))))
389           (declare (optimize (speed 3) (safety 0))
390                    (type index index))
391           (setf (%raw-bits sequence index) value))))))
392 \f
393 ;;;; %BYTE-BLT
394
395 ;;; FIXME: The old CMU CL code used various COPY-TO/FROM-SYSTEM-AREA
396 ;;; stuff (with all the associated bit-index cruft and overflow
397 ;;; issues) even for byte moves. In SBCL, we're converting to byte
398 ;;; moves as problems are discovered with the old code, and this is
399 ;;; currently (ca. sbcl-0.6.12.30) the main interface for code in
400 ;;; SB!KERNEL and SB!SYS (e.g. i/o code). It's not clear that it's the
401 ;;; ideal interface, though, and it probably deserves some thought.
402 (deftransform %byte-blt ((src src-start dst dst-start dst-end)
403                          ((or (simple-unboxed-array (*)) system-area-pointer)
404                           index
405                           (or (simple-unboxed-array (*)) system-area-pointer)
406                           index
407                           index))
408   ;; FIXME: CMU CL had a hairier implementation of this (back when it
409   ;; was still called (%PRIMITIVE BYTE-BLT). It had the small problem
410   ;; that it didn't work for large (>16M) values of SRC-START or
411   ;; DST-START. However, it might have been more efficient. In
412   ;; particular, I don't really know how much the foreign function
413   ;; call costs us here. My guess is that if the overhead is
414   ;; acceptable for SQRT and COS, it's acceptable here, but this
415   ;; should probably be checked. -- WHN
416   '(flet ((sapify (thing)
417             (etypecase thing
418               (system-area-pointer thing)
419               ;; FIXME: The code here rather relies on the simple
420               ;; unboxed array here having byte-sized entries. That
421               ;; should be asserted explicitly, I just haven't found
422               ;; a concise way of doing it. (It would be nice to
423               ;; declare it in the DEFKNOWN too.)
424               ((simple-unboxed-array (*)) (vector-sap thing)))))
425      (declare (inline sapify))
426      (without-gcing
427       (memmove (sap+ (sapify dst) dst-start)
428                (sap+ (sapify src) src-start)
429                (- dst-end dst-start)))
430      (values)))
431 \f
432 ;;;; transforms for EQL of floating point values
433
434 (deftransform eql ((x y) (single-float single-float))
435   '(= (single-float-bits x) (single-float-bits y)))
436
437 (deftransform eql ((x y) (double-float double-float))
438   '(and (= (double-float-low-bits x) (double-float-low-bits y))
439         (= (double-float-high-bits x) (double-float-high-bits y))))
440
441 \f
442 ;;;; 32-bit operations
443 #!-x86 ; on X86 it is a modular function
444 (deftransform lognot ((x) ((unsigned-byte 32)) *
445                       :node node
446                       :result result)
447   "32-bit implementation"
448   (let ((dest (continuation-dest result)))
449     (unless (and (combination-p dest)
450                  (eq (continuation-fun-name (combination-fun dest))
451                      'logand))
452       (give-up-ir1-transform))
453     (unless (some (lambda (arg)
454                     (csubtypep (continuation-type arg)
455                                (specifier-type '(unsigned-byte 32))))
456                   (combination-args dest))
457       (give-up-ir1-transform))
458     (setf (node-derived-type node)
459           (values-specifier-type '(values (unsigned-byte 32) &optional)))
460     '(32bit-logical-not x)))
461
462 (define-good-modular-fun logand)
463 (define-good-modular-fun logior)
464 \f
465 ;;; There are two different ways the multiplier can be recoded. The
466 ;;; more obvious is to shift X by the correct amount for each bit set
467 ;;; in Y and to sum the results. But if there is a string of bits that
468 ;;; are all set, you can add X shifted by one more then the bit
469 ;;; position of the first set bit and subtract X shifted by the bit
470 ;;; position of the last set bit. We can't use this second method when
471 ;;; the high order bit is bit 31 because shifting by 32 doesn't work
472 ;;; too well.
473 (defun ub32-strength-reduce-constant-multiply (arg num)
474   (declare (type (unsigned-byte 32) numb))
475   (let ((adds 0) (shifts 0)
476         (result nil) first-one)
477     (labels ((tub32 (x) `(truly-the (unsigned-byte 32) ,x))
478              (add (next-factor)
479                (setf result
480                      (tub32
481                       (if result
482                           (progn (incf adds) `(+ ,result ,(tub32 next-factor)))
483                           next-factor)))))
484       (declare (inline add))
485       (dotimes (bitpos 32)
486         (if first-one
487             (when (not (logbitp bitpos num))
488               (add (if (= (1+ first-one) bitpos)
489                        ;; There is only a single bit in the string.
490                        (progn (incf shifts) `(ash ,arg ,first-one))
491                        ;; There are at least two.
492                        (progn
493                          (incf adds)
494                          (incf shifts 2)
495                          `(- ,(tub32 `(ash ,arg ,bitpos))
496                              ,(tub32 `(ash ,arg ,first-one))))))
497               (setf first-one nil))
498             (when (logbitp bitpos num)
499               (setf first-one bitpos))))
500       (when first-one
501         (cond ((= first-one 31))
502               ((= first-one 30) (incf shifts) (add `(ash ,arg 30)))
503               (t
504                (incf shifts 2)
505                (incf adds)
506                (add `(- ,(tub32 `(ash ,arg 31)) 
507                         ,(tub32 `(ash ,arg ,first-one))))))
508         (incf shifts)
509         (add `(ash ,arg 31))))
510     (values result adds shifts)))