x86 sap fixes

The sap-ref-with-offset stuff was wrong in that the displacement was
multiplied by a notional element size, rather than being uniformly
treated as a number of bytes.  Mostly this codepath wasn't exposed at
all (other than with sap-ref-8, which worked by "accident"), but
attempts to implement UTF-16, which requires (sap-ref-16 sap (+ offset
2)), showed up the problem.

diff --git a/NEWS b/NEWS
index 4a12630..ba67a50 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -69,6 +69,9 @@ changes relative to sbcl-1.0.30:
     information about some array types. (thanks to Luis Oliveira)
   * bug fix: moderately complex combinations of inline expansions could
     be miscompiled if the result was declared to be dynamic extent.
+  * bug fix: on x86, SAP-REF of sizes greater than 8 bits with offsets of the
+    form (+ <variable> <integer>) were miscompiled under certain
+    circumstances.
   * bug fix: in some cases no compiler note about failure to stack allocate
     was emitted, even if the objects were in fact heap allocated.
   * bug fix: minor violation of "otherwise inaccessible" rule for stack

diff --git a/src/compiler/saptran.lisp b/src/compiler/saptran.lisp
index ea6b603..066572e 100644 (file)
--- a/src/compiler/saptran.lisp
+++ b/src/compiler/saptran.lisp
@@ -108,9 +108,8 @@
          '(lambda (sap offset1 offset2)
             (sap+ sap (+ offset1 offset2))))))
 
-(macrolet ((def (fun element-size &optional setp value-type)
-             (declare (ignorable value-type)
-                      #!-x86 (ignore element-size))
+(macrolet ((def (fun &optional setp value-type)
+             (declare (ignorable value-type) (ignore element-size))
              `(progn
                 (deftransform ,fun ((sap offset ,@(when setp `(new-value))) * *)
                   (splice-fun-args sap 'sap+ 2)
@@ -137,34 +136,34 @@
                         (deftransform ,with-offset-fun ((sap offset disp
                                                              ,@(when setp `(new-value))) * *)
                           (fold-index-addressing ',with-offset-fun
-                                                 ,element-size
+                                                 8 ; all sap-offsets are in bytes
                                                  0 ; lowtag
                                                  0 ; data offset
                                                  offset disp ,setp))))))))
-  (def sap-ref-8 8)
-  (def %set-sap-ref-8 8 t (unsigned-byte 8))
-  (def signed-sap-ref-8 8)
-  (def %set-signed-sap-ref-8 8 t (signed-byte 8))
-  (def sap-ref-16 16)
-  (def %set-sap-ref-16 16 t (unsigned-byte 16))
-  (def signed-sap-ref-16 16)
-  (def %set-signed-sap-ref-16 16 t (signed-byte 16))
-  (def sap-ref-32 32)
-  (def %set-sap-ref-32 32 t (unsigned-byte 32))
-  (def signed-sap-ref-32 32)
-  (def %set-signed-sap-ref-32 32 t (signed-byte 32))
-  (def sap-ref-64 64)
-  (def %set-sap-ref-64 64 t (unsigned-byte 64))
-  (def signed-sap-ref-64 64)
-  (def %set-signed-sap-ref-64 64 t (signed-byte 64))
-  (def sap-ref-sap sb!vm:n-word-bits)
-  (def %set-sap-ref-sap sb!vm:n-word-bits t system-area-pointer)
-  (def sap-ref-single 32)
-  (def %set-sap-ref-single 32 t single-float)
-  (def sap-ref-double 64)
-  (def %set-sap-ref-double 64 t double-float)
-  #!+long-float (def sap-ref-long 96)
-  #!+long-float (def %set-sap-ref-long 96 t 8))
+  (def sap-ref-8)
+  (def %set-sap-ref-8 t (unsigned-byte 8))
+  (def signed-sap-ref-8)
+  (def %set-signed-sap-ref-8 t (signed-byte 8))
+  (def sap-ref-16)
+  (def %set-sap-ref-16 t (unsigned-byte 16))
+  (def signed-sap-ref-16)
+  (def %set-signed-sap-ref-16 t (signed-byte 16))
+  (def sap-ref-32)
+  (def %set-sap-ref-32 t (unsigned-byte 32))
+  (def signed-sap-ref-32)
+  (def %set-signed-sap-ref-32 t (signed-byte 32))
+  (def sap-ref-64)
+  (def %set-sap-ref-64 t (unsigned-byte 64))
+  (def signed-sap-ref-64)
+  (def %set-signed-sap-ref-64 t (signed-byte 64))
+  (def sap-ref-sap)
+  (def %set-sap-ref-sap t system-area-pointer)
+  (def sap-ref-single)
+  (def %set-sap-ref-single t single-float)
+  (def sap-ref-double)
+  (def %set-sap-ref-double t double-float)
+  #!+long-float (def sap-ref-long)
+  #!+long-float (def %set-sap-ref-long t long-float))
 
 (macrolet ((def (fun args 32-bit 64-bit)
                `(deftransform ,fun (,args)

diff --git a/src/compiler/x86/sap.lisp b/src/compiler/x86/sap.lisp
index eb46d70..f248b3a 100644 (file)
--- a/src/compiler/x86/sap.lisp
+++ b/src/compiler/x86/sap.lisp
@@ -150,11 +150,7 @@
                                     type
                                     size
                                     &optional signed)
-             (let ((temp-sc (symbolicate size "-REG"))
-                   (element-size (ecase size
-                                   (:byte 1)
-                                   (:word 2)
-                                   (:dword 4))))
+             (let ((temp-sc (symbolicate size "-REG")))
                `(progn
                   (define-vop (,ref-name)
                     (:translate ,ref-name)
@@ -163,9 +159,7 @@
                            (offset :scs (signed-reg immediate)))
                     (:info disp)
                     (:arg-types system-area-pointer signed-num
-                                (:constant (constant-displacement 0 ; lowtag
-                                                                  ,element-size
-                                                                  0)))
+                                (:constant (constant-displacement 0 1 0)))
                     (:results (result :scs (,sc)))
                     (:result-types ,type)
                     (:generator 5
@@ -177,12 +171,11 @@
                             (immediate
                              (inst ,mov-inst result
                                    (make-ea ,size :base sap
-                                            :disp (+ (tn-value offset)
-                                                     (* ,element-size disp)))))
+                                            :disp (+ (tn-value offset) disp))))
                             (t (inst ,mov-inst result
                                      (make-ea ,size :base sap
                                               :index offset
-                                              :disp (* ,element-size disp))))))))
+                                              :disp disp)))))))
                   (define-vop (,set-name)
                     (:translate ,set-name)
                     (:policy :fast-safe)
@@ -194,9 +187,7 @@
                                                'temp)))
                     (:info disp)
                     (:arg-types system-area-pointer signed-num
-                                (:constant (constant-displacement 0 ; lowtag
-                                                                  ,element-size
-                                                                  0))
+                                (:constant (constant-displacement 0 1 0))
                                 ,type)
                     ,@(unless (eq size :dword)
                         `((:temporary (:sc ,temp-sc :offset eax-offset
@@ -212,11 +203,11 @@
                                          (immediate
                                           (make-ea ,size :base sap
                                                    :disp (+ (tn-value offset)
-                                                            (* ,element-size disp))))
+                                                            disp)))
                                          (t (make-ea ,size
                                                      :base sap
                                                      :index offset
-                                                     :disp (* ,element-size disp))))
+                                                     :disp disp)))
                             ,(if (eq size :dword) 'value 'temp))
                       (move result
                             ,(if (eq size :dword) 'value 'eax-tn))))))))
@@ -245,9 +236,7 @@
          (offset :scs (signed-reg immediate)))
   (:info disp)
   (:arg-types system-area-pointer signed-num
-              (:constant (constant-displacement 0 ; lowtag
-                                                8 ; double-float size
-                                                0)))
+              (:constant (constant-displacement 0 1 0)))
   (:results (result :scs (double-reg)))
   (:result-types double-float)
   (:generator 5
@@ -259,7 +248,7 @@
        (t
         (with-empty-tn@fp-top(result)
           (inst fldd (make-ea :dword :base sap :index offset
-                              :disp (* 4 disp))))))))
+                              :disp disp)))))))
 
 (define-vop (%set-sap-ref-double-with-offset)
   (:translate sb!c::%set-sap-ref-double-with-offset)
@@ -269,25 +258,21 @@
          (value :scs (double-reg)))
   (:info disp)
   (:arg-types system-area-pointer signed-num
-              (:constant (constant-displacement 0 ; lowtag
-                                                8 ; double-float size
-                                                0))
+              (:constant (constant-displacement 0 1 0))
               double-float)
   (:results (result :scs (double-reg)))
   (:result-types double-float)
   (:generator 5
     (cond ((zerop (tn-offset value))
            ;; Value is in ST0.
-           (inst fstd (make-ea :dword :base sap :index offset
-                               :disp (* 8 disp)))
+           (inst fstd (make-ea :dword :base sap :index offset :disp disp))
            (unless (zerop (tn-offset result))
              ;; Value is in ST0 but not result.
              (inst fstd result)))
           (t
            ;; Value is not in ST0.
            (inst fxch value)
-           (inst fstd (make-ea :dword :base sap :index offset
-                               :disp (* 8 disp)))
+           (inst fstd (make-ea :dword :base sap :index offset :disp disp))
            (cond ((zerop (tn-offset result))
                   ;; The result is in ST0.
                   (inst fstd value))
@@ -303,9 +288,7 @@
   (:args (sap :scs (sap-reg) :to (:eval 0))
          (value :scs (double-reg)))
   (:arg-types system-area-pointer (:constant (signed-byte 32))
-              (:constant (constant-displacement 0 ; lowtag
-                                                8 ; double-float size
-                                                0))
+              (:constant (constant-displacement 0 1 0))
               double-float)
   (:info offset disp)
   (:results (result :scs (double-reg)))
@@ -340,9 +323,7 @@
          (offset :scs (signed-reg immediate)))
   (:info disp)
   (:arg-types system-area-pointer signed-num
-              (:constant (constant-displacement 0 ; lowtag
-                                                4 ; single-float size
-                                                0)))
+              (:constant (constant-displacement 0 1 0)))
   (:results (result :scs (single-reg)))
   (:result-types single-float)
   (:generator 5
@@ -353,8 +334,7 @@
           (inst fld (make-ea :dword :base sap :disp (tn-value offset)))))
        (t
         (with-empty-tn@fp-top(result)
-          (inst fld (make-ea :dword :base sap :index offset
-                             :disp (* 4 disp))))))))
+          (inst fld (make-ea :dword :base sap :index offset :disp disp)))))))
 
 (define-vop (%set-sap-ref-single-with-offset)
   (:translate sb!c::%set-sap-ref-single-with-offset)
@@ -364,25 +344,21 @@
          (value :scs (single-reg)))
   (:info disp)
   (:arg-types system-area-pointer signed-num
-              (:constant (constant-displacement 0 ; lowtag
-                                                4 ; single-float size
-                                                0))
+              (:constant (constant-displacement 0 1 0))
               single-float)
   (:results (result :scs (single-reg)))
   (:result-types single-float)
   (:generator 5
     (cond ((zerop (tn-offset value))
            ;; Value is in ST0
-           (inst fst (make-ea :dword :base sap :index offset
-                              :disp (* 4 disp)))
+           (inst fst (make-ea :dword :base sap :index offset :disp disp))
            (unless (zerop (tn-offset result))
              ;; Value is in ST0 but not result.
              (inst fst result)))
           (t
            ;; Value is not in ST0.
            (inst fxch value)
-           (inst fst (make-ea :dword :base sap :index offset
-                              :disp (* 4 disp)))
+           (inst fst (make-ea :dword :base sap :index offset :disp disp))
            (cond ((zerop (tn-offset result))
                   ;; The result is in ST0.
                   (inst fst value))
@@ -398,9 +374,7 @@
   (:args (sap :scs (sap-reg) :to (:eval 0))
          (value :scs (single-reg)))
   (:arg-types system-area-pointer (:constant (signed-byte 32))
-              (:constant (constant-displacement 0 ; lowtag
-                                                4 ; single-float size
-                                                0))
+              (:constant (constant-displacement 0 1 0))
               single-float)
   (:info offset disp)
   (:results (result :scs (single-reg)))

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index ff16e82..e3a1caf 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3288,3 +3288,15 @@
         (test 'not-a-float)
         (when (member name '(decode-float integer-decode-float))
           (test sb-ext:single-float-positive-infinity))))))
+
+(with-test (:name :sap-ref-16)
+  (let* ((fun (compile nil `(lambda (x y)
+                              (declare (type sb-sys:system-area-pointer x)
+                                       (type (integer 0 100) y))
+                              (sb-sys:sap-ref-16 x (+ 4 y)))))
+         (vector (coerce '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
+                         '(simple-array (unsigned-byte 8) (*))))
+         (sap (sb-sys:vector-sap vector))
+         (ret (funcall fun sap 0)))
+    ;; test for either endianness
+    (assert (or (= ret (+ (* 5 256) 4)) (= ret (+ (* 4 256) 5))))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 2e6b4eb..08ce1a5 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.30.46"
+"1.0.30.47"