From: Christophe Rhodes Date: Sat, 22 Aug 2009 15:43:20 +0000 (+0000) Subject: x86 sap fixes X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=7d10bcf57926aa6709eeb2e09ca447af9e96f141;p=sbcl.git 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 --- 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 (+ ) 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 --- 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 --- 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 --- 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 --- 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"