1.0.5.42: fix (setf aref) on single-float vectors

[sbcl.git] / src / compiler / generic / vm-tran.lisp

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 860cb3a..9d1108a 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -33,7 +33,7 @@
   '(if (< x 0) (- x) x))
 
 ;;; We don't want to clutter the bignum code.
-#!+x86
+#!+(or x86 x86-64)
 (define-source-transform sb!bignum:%bignum-ref (bignum index)
   ;; KLUDGE: We use TRULY-THE here because even though the bignum code
   ;; is (currently) compiled with (SAFETY 0), the compiler insists on
@@ -45,7 +45,7 @@
   `(sb!bignum:%bignum-ref-with-offset ,bignum
                                       (truly-the bignum-index ,index) 0))
 
-#!+x86
+#!+(or x86 x86-64)
 (defun fold-index-addressing (fun-name element-size lowtag data-offset
                               index offset &optional setter-p)
   (multiple-value-bind (func index-args) (extract-fun-args index '(+ -) 2)
@@ -65,7 +65,7 @@
            (,fun-name thing index (,func off2 off1) ,@(when setter-p
                                                         '(value))))))))
 
-#!+x86
+#!+(or x86 x86-64)
 (deftransform sb!bignum:%bignum-ref-with-offset
     ((bignum index offset) * * :node node)
   (fold-index-addressing 'sb!bignum:%bignum-ref-with-offset
@@ -73,6 +73,31 @@
                          sb!vm:bignum-digits-offset
                          index offset))
 
+#!+x86
+(progn
+(define-source-transform sb!kernel:%vector-raw-bits (thing index)
+  `(sb!kernel:%raw-bits-with-offset ,thing ,index 2))
+
+(define-source-transform sb!kernel:%raw-bits (thing index)
+  `(sb!kernel:%raw-bits-with-offset ,thing ,index 0))
+
+(define-source-transform sb!kernel:%set-vector-raw-bits (thing index value)
+  `(sb!kernel:%set-raw-bits-with-offset ,thing ,index 2 ,value))
+
+(define-source-transform sb!kernel:%set-raw-bits (thing index value)
+  `(sb!kernel:%set-raw-bits-with-offset ,thing ,index 0 ,value))
+
+(deftransform sb!kernel:%raw-bits-with-offset ((thing index offset) * * :node node)
+  (fold-index-addressing 'sb!kernel:%raw-bits-with-offset
+                         sb!vm:n-word-bits sb!vm:other-pointer-lowtag
+                         0 index offset))
+
+(deftransform sb!kernel:%set-raw-bits-with-offset ((thing index offset value) * *)
+  (fold-index-addressing 'sb!kernel:%set-raw-bits-with-offset
+                         sb!vm:n-word-bits sb!vm:other-pointer-lowtag
+                         0 index offset t))
+) ; PROGN
+
 ;;; The layout is stored in slot 0.
 (define-source-transform %instance-layout (x)
   `(truly-the layout (%instance-ref ,x 0)))
@@ -148,33 +173,29 @@
 
 ;;; Transform data vector access to a form that opens up optimization
 ;;; opportunities.
-#!+x86
-(deftransform data-vector-ref ((array index) ((or simple-unboxed-array
+#!+(or x86 x86-64)
+(deftransform data-vector-ref ((array index) ((or (simple-unboxed-array (*))
                                                   simple-vector)
                                               t))
   (let ((array-type (lvar-type array)))
     (unless (array-type-p array-type)
       (give-up-ir1-transform))
     (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
-           (saetp (find element-type
-                        sb!vm:*specialized-array-element-type-properties*
-                        :key #'sb!vm:saetp-specifier :test #'equal)))
+           (saetp (find-saetp element-type)))
       (unless (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)
         (give-up-ir1-transform))
       `(data-vector-ref-with-offset array index 0))))
 
-#!+x86
+#!+(or x86 x86-64)
 (deftransform data-vector-ref-with-offset ((array index offset)
-                                           ((or simple-unboxed-array
+                                           ((or (simple-unboxed-array (*))
                                                 simple-vector)
                                             t t))
   (let ((array-type (lvar-type array)))
     (unless (array-type-p array-type)
       (give-up-ir1-transform))
     (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
-           (saetp (find element-type
-                        sb!vm:*specialized-array-element-type-properties*
-                        :key #'sb!vm:saetp-specifier :test #'equal)))
+           (saetp (find-saetp element-type)))
       (aver (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits))
       (fold-index-addressing 'data-vector-ref-with-offset
                              (sb!vm:saetp-n-bits saetp)
@@ -241,33 +262,29 @@
 
 ;;; Transform data vector access to a form that opens up optimization
 ;;; opportunities.
-#!+x86
+#!+(or x86 x86-64)
 (deftransform data-vector-set ((array index new-value)
-                               ((or simple-unboxed-array simple-vector)
+                               ((or (simple-unboxed-array (*)) simple-vector)
                                 t t))
   (let ((array-type (lvar-type array)))
     (unless (array-type-p array-type)
       (give-up-ir1-transform))
     (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
-           (saetp (find element-type
-                        sb!vm:*specialized-array-element-type-properties*
-                        :key #'sb!vm:saetp-specifier :test #'equal)))
+           (saetp (find-saetp element-type)))
       (unless (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)
         (give-up-ir1-transform))
       `(data-vector-set-with-offset array index 0 new-value))))
 
-#!+x86
+#!+(or x86 x86-64)
 (deftransform data-vector-set-with-offset ((array index offset new-value)
-                                           ((or simple-unboxed-array
+                                           ((or (simple-unboxed-array (*))
                                                 simple-vector)
                                             t t t))
   (let ((array-type (lvar-type array)))
     (unless (array-type-p array-type)
       (give-up-ir1-transform))
     (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
-           (saetp (find element-type
-                        sb!vm:*specialized-array-element-type-properties*
-                        :key #'sb!vm:saetp-specifier :test #'equal)))
+           (saetp (find-saetp element-type)))
       (aver (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits))
       (fold-index-addressing 'data-vector-set-with-offset
                              (sb!vm:saetp-n-bits saetp)
@@ -732,3 +749,14 @@
                 result)
             adds
             shifts)))
+
+\f
+;;; Transform GET-LISP-OBJ-ADDRESS for constant immediates, since the normal
+;;; VOP can't handle them.
+
+(deftransform sb!vm::get-lisp-obj-address ((obj) ((constant-arg fixnum)))
+  (ash (lvar-value obj) sb!vm::n-fixnum-tag-bits))
+
+(deftransform sb!vm::get-lisp-obj-address ((obj) ((constant-arg character)))
+  (logior sb!vm::character-widetag
+          (ash (char-code (lvar-value obj)) sb!vm::n-widetag-bits)))