X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fsap.lisp;h=3f5ae15f0ae260862bfdc92c72f9c226f3c56c78;hb=51e63f301624e39febdd85b5feba19b7c980f307;hp=052b427e58e990c77b349edaa237a1e34eef431d;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/compiler/x86/sap.lisp b/src/compiler/x86/sap.lisp index 052b427..3f5ae15 100644 --- a/src/compiler/x86/sap.lisp +++ b/src/compiler/x86/sap.lisp @@ -19,7 +19,7 @@ (:results (y :scs (sap-reg))) (:note "pointer to SAP coercion") (:generator 1 - (loadw y x sap-pointer-slot other-pointer-type))) + (loadw y x sap-pointer-slot other-pointer-lowtag))) (define-move-vop move-to-sap :move (descriptor-reg) (sap-reg)) @@ -30,18 +30,18 @@ (:note "SAP to pointer coercion") (:node-var node) (:generator 20 - (with-fixed-allocation (res sap-type sap-size node) - (storew sap res sap-pointer-slot other-pointer-type)))) + (with-fixed-allocation (res sap-widetag sap-size node) + (storew sap res sap-pointer-slot other-pointer-lowtag)))) (define-move-vop move-from-sap :move (sap-reg) (descriptor-reg)) ;;; Move untagged sap values. (define-vop (sap-move) (:args (x :target y - :scs (sap-reg) - :load-if (not (location= x y)))) + :scs (sap-reg) + :load-if (not (location= x y)))) (:results (y :scs (sap-reg) - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:note "SAP move") (:effects) (:affected) @@ -51,11 +51,11 @@ (sap-reg) (sap-reg)) ;;; Move untagged sap arguments/return-values. -(define-vop (move-sap-argument) +(define-vop (move-sap-arg) (:args (x :target y - :scs (sap-reg)) - (fp :scs (any-reg) - :load-if (not (sc-is y sap-reg)))) + :scs (sap-reg)) + (fp :scs (any-reg) + :load-if (not (sc-is y sap-reg)))) (:results (y)) (:note "SAP argument move") (:generator 0 @@ -64,18 +64,24 @@ (move y x)) (sap-stack (if (= (tn-offset fp) esp-offset) - (storew x fp (tn-offset y)) ; c-call - (storew x fp (- (1+ (tn-offset y))))))))) -(define-move-vop move-sap-argument :move-argument + (storew x fp (tn-offset y)) ; c-call + (storew x fp (- (1+ (tn-offset y))))))))) +(define-move-vop move-sap-arg :move-arg (descriptor-reg sap-reg) (sap-reg)) -;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a +;;; Use standard MOVE-ARG + coercion to move an untagged sap to a ;;; descriptor passing location. -(define-move-vop move-argument :move-argument +(define-move-vop move-arg :move-arg (sap-reg) (descriptor-reg)) ;;;; SAP-INT and INT-SAP +;;; The function SAP-INT is used to generate an integer corresponding +;;; to the system area pointer, suitable for passing to the kernel +;;; interfaces (which want all addresses specified as integers). The +;;; function INT-SAP is used to do the opposite conversion. The +;;; integer representation of a SAP is the byte offset of the SAP from +;;; the start of the address space. (define-vop (sap-int) (:args (sap :scs (sap-reg) :target int)) (:arg-types system-area-pointer) @@ -85,7 +91,6 @@ (:policy :fast-safe) (:generator 1 (move int sap))) - (define-vop (int-sap) (:args (int :scs (unsigned-reg) :target sap)) (:arg-types unsigned-num) @@ -101,34 +106,34 @@ (define-vop (pointer+) (:translate sap+) (:args (ptr :scs (sap-reg) :target res - :load-if (not (location= ptr res))) - (offset :scs (signed-reg immediate))) + :load-if (not (location= ptr res))) + (offset :scs (signed-reg immediate))) (:arg-types system-area-pointer signed-num) (:results (res :scs (sap-reg) :from (:argument 0) - :load-if (not (location= ptr res)))) + :load-if (not (location= ptr res)))) (:result-types system-area-pointer) (:policy :fast-safe) (:generator 1 (cond ((and (sc-is ptr sap-reg) (sc-is res sap-reg) - (not (location= ptr res))) - (sc-case offset - (signed-reg - (inst lea res (make-ea :dword :base ptr :index offset :scale 1))) - (immediate - (inst lea res (make-ea :dword :base ptr - :disp (tn-value offset)))))) - (t - (move res ptr) - (sc-case offset - (signed-reg - (inst add res offset)) - (immediate - (inst add res (tn-value offset)))))))) + (not (location= ptr res))) + (sc-case offset + (signed-reg + (inst lea res (make-ea :dword :base ptr :index offset :scale 1))) + (immediate + (inst lea res (make-ea :dword :base ptr + :disp (tn-value offset)))))) + (t + (move res ptr) + (sc-case offset + (signed-reg + (inst add res offset)) + (immediate + (inst add res (tn-value offset)))))))) (define-vop (pointer-) (:translate sap-) (:args (ptr1 :scs (sap-reg) :target res) - (ptr2 :scs (sap-reg))) + (ptr2 :scs (sap-reg))) (:arg-types system-area-pointer system-area-pointer) (:policy :fast-safe) (:results (res :scs (signed-reg) :from (:argument 0))) @@ -140,290 +145,286 @@ ;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET (macrolet ((def-system-ref-and-set (ref-name - set-name - sc - type - size - &optional signed) - (let ((ref-name-c (symbolicate ref-name "-C")) - (set-name-c (symbolicate set-name "-C")) - (temp-sc (symbolicate size "-REG"))) - `(progn - (define-vop (,ref-name) - (:translate ,ref-name) - (:policy :fast-safe) - (:args (sap :scs (sap-reg)) - (offset :scs (signed-reg))) - (:arg-types system-area-pointer signed-num) - ,@(unless (eq size :dword) - `((:temporary (:sc ,temp-sc - :from (:eval 0) - :to (:eval 1)) - temp))) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 5 - (inst mov ,(if (eq size :dword) 'result 'temp) - (make-ea ,size :base sap :index offset)) - ,@(unless (eq size :dword) - `((inst ,(if signed 'movsx 'movzx) - result temp))))) - (define-vop (,ref-name-c) - (:translate ,ref-name) - (:policy :fast-safe) - (:args (sap :scs (sap-reg))) - (:arg-types system-area-pointer - (:constant (signed-byte 32))) - (:info offset) - ,@(unless (eq size :dword) - `((:temporary (:sc ,temp-sc - :from (:eval 0) - :to (:eval 1)) - temp))) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 4 - (inst mov ,(if (eq size :dword) 'result 'temp) - (make-ea ,size :base sap :disp offset)) - ,@(unless (eq size :dword) - `((inst ,(if signed 'movsx 'movzx) - result temp))))) - (define-vop (,set-name) - (:translate ,set-name) - (:policy :fast-safe) - (:args (sap :scs (sap-reg) :to (:eval 0)) - (offset :scs (signed-reg) :to (:eval 0)) - (value :scs (,sc) - :target ,(if (eq size :dword) - 'result - 'temp))) - (:arg-types system-area-pointer signed-num ,type) - ,@(unless (eq size :dword) - `((:temporary (:sc ,temp-sc :offset eax-offset - :from (:argument 2) :to (:result 0) - :target result) - temp))) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 5 - ,@(unless (eq size :dword) - `((move eax-tn value))) - (inst mov (make-ea ,size - :base sap - :index offset) - ,(if (eq size :dword) 'value 'temp)) - (move result - ,(if (eq size :dword) 'value 'eax-tn)))) - (define-vop (,set-name-c) - (:translate ,set-name) - (:policy :fast-safe) - (:args (sap :scs (sap-reg) :to (:eval 0)) - (value :scs (,sc) - :target ,(if (eq size :dword) - 'result - 'temp))) - (:arg-types system-area-pointer - (:constant (signed-byte 32)) ,type) - (:info offset) - ,@(unless (eq size :dword) - `((:temporary (:sc ,temp-sc :offset eax-offset - :from (:argument 2) :to (:result 0) - :target result) - temp))) - (:results (result :scs (,sc))) - (:result-types ,type) - (:generator 4 - ,@(unless (eq size :dword) - `((move eax-tn value))) - (inst mov - (make-ea ,size :base sap :disp offset) - ,(if (eq size :dword) 'value 'temp)) - (move result ,(if (eq size :dword) - 'value - 'eax-tn)))))))) + set-name + sc + type + size + &optional signed) + (let ((temp-sc (symbolicate size "-REG")) + (element-size (ecase size + (:byte 1) + (:word 2) + (:dword 4)))) + `(progn + (define-vop (,ref-name) + (:translate ,ref-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg)) + (offset :scs (signed-reg immediate))) + (:info disp) + (:arg-types system-area-pointer signed-num + (:constant (constant-displacement 0 ; lowtag + ,element-size + 0))) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 5 + ,(let ((mov-inst (cond + ((eq size :dword) 'mov) + (signed 'movsx) + (t 'movzx)))) + `(sc-case offset + (immediate + (inst ,mov-inst result + (make-ea ,size :base sap + :disp (+ (tn-value offset) + (* ,element-size disp))))) + (t (inst ,mov-inst result + (make-ea ,size :base sap + :index offset + :disp (* ,element-size disp)))))))) + (define-vop (,set-name) + (:translate ,set-name) + (:policy :fast-safe) + (:args (sap :scs (sap-reg) :to (:eval 0)) + (offset :scs (signed-reg immediate) :to (:eval 0)) + (value :scs (,sc) + :target ,(if (eq size :dword) + 'result + 'temp))) + (:info disp) + (:arg-types system-area-pointer signed-num + (:constant (constant-displacement 0 ; lowtag + ,element-size + 0)) + ,type) + ,@(unless (eq size :dword) + `((:temporary (:sc ,temp-sc :offset eax-offset + :from (:argument 2) :to (:result 0) + :target result) + temp))) + (:results (result :scs (,sc))) + (:result-types ,type) + (:generator 5 + ,@(unless (eq size :dword) + `((move eax-tn value))) + (inst mov (sc-case offset + (immediate + (make-ea ,size :base sap + :disp (+ (tn-value offset) + (* ,element-size disp)))) + (t (make-ea ,size + :base sap + :index offset + :disp (* ,element-size disp)))) + ,(if (eq size :dword) 'value 'temp)) + (move result + ,(if (eq size :dword) 'value 'eax-tn)))))))) - (def-system-ref-and-set sap-ref-8 %set-sap-ref-8 + (def-system-ref-and-set sb!c::sap-ref-8-with-offset sb!c::%set-sap-ref-8-with-offset unsigned-reg positive-fixnum :byte nil) - (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8 + (def-system-ref-and-set sb!c::signed-sap-ref-8-with-offset sb!c::%set-signed-sap-ref-8-with-offset signed-reg tagged-num :byte t) - (def-system-ref-and-set sap-ref-16 %set-sap-ref-16 + (def-system-ref-and-set sb!c::sap-ref-16-with-offset sb!c::%set-sap-ref-16-with-offset unsigned-reg positive-fixnum :word nil) - (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16 + (def-system-ref-and-set sb!c::signed-sap-ref-16-with-offset sb!c::%set-signed-sap-ref-16-with-offset signed-reg tagged-num :word t) - (def-system-ref-and-set sap-ref-32 %set-sap-ref-32 + (def-system-ref-and-set sb!c::sap-ref-32-with-offset sb!c::%set-sap-ref-32-with-offset unsigned-reg unsigned-num :dword nil) - (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32 + (def-system-ref-and-set sb!c::signed-sap-ref-32-with-offset sb!c::%set-signed-sap-ref-32-with-offset signed-reg signed-num :dword t) - (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap + (def-system-ref-and-set sb!c::sap-ref-sap-with-offset sb!c::%set-sap-ref-sap-with-offset sap-reg system-area-pointer :dword)) ;;;; SAP-REF-DOUBLE -(define-vop (sap-ref-double) - (:translate sap-ref-double) +(define-vop (sap-ref-double-with-offset) + (:translate sb!c::sap-ref-double-with-offset) (:policy :fast-safe) (:args (sap :scs (sap-reg)) - (offset :scs (signed-reg))) - (:arg-types system-area-pointer signed-num) + (offset :scs (signed-reg immediate))) + (:info disp) + (:arg-types system-area-pointer signed-num + (:constant (constant-displacement 0 ; lowtag + 8 ; double-float size + 0))) (:results (result :scs (double-reg))) (:result-types double-float) (:generator 5 - (with-empty-tn@fp-top(result) - (inst fldd (make-ea :dword :base sap :index offset))))) + (sc-case offset + (immediate + (aver (zerop disp)) + (with-empty-tn@fp-top(result) + (inst fldd (make-ea :dword :base sap :disp (tn-value offset))))) + (t + (with-empty-tn@fp-top(result) + (inst fldd (make-ea :dword :base sap :index offset + :disp (* 4 disp)))))))) -(define-vop (sap-ref-double-c) - (:translate sap-ref-double) - (:policy :fast-safe) - (:args (sap :scs (sap-reg))) - (:arg-types system-area-pointer (:constant (signed-byte 32))) - (:info offset) - (:results (result :scs (double-reg))) - (:result-types double-float) - (:generator 4 - (with-empty-tn@fp-top(result) - (inst fldd (make-ea :dword :base sap :disp offset))))) - -(define-vop (%set-sap-ref-double) - (:translate %set-sap-ref-double) +(define-vop (%set-sap-ref-double-with-offset) + (:translate sb!c::%set-sap-ref-double-with-offset) (:policy :fast-safe) (:args (sap :scs (sap-reg) :to (:eval 0)) - (offset :scs (signed-reg) :to (:eval 0)) - (value :scs (double-reg))) - (:arg-types system-area-pointer signed-num double-float) + (offset :scs (signed-reg) :to (:eval 0)) + (value :scs (double-reg))) + (:info disp) + (:arg-types system-area-pointer signed-num + (:constant (constant-displacement 0 ; lowtag + 8 ; double-float size + 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)) - (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)) - (cond ((zerop (tn-offset result)) - ;; The result is in ST0. - (inst fstd value)) - (t - ;; Neither value or result are in ST0. - (unless (location= value result) - (inst fstd result)) - (inst fxch value))))))) + ;; Value is in ST0. + (inst fstd (make-ea :dword :base sap :index offset + :disp (* 8 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))) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value)) + (t + ;; Neither value or result are in ST0. + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) -(define-vop (%set-sap-ref-double-c) - (:translate %set-sap-ref-double) +(define-vop (%set-sap-ref-double-with-offset-c) + (:translate sb!c::%set-sap-ref-double-with-offset) (:policy :fast-safe) (:args (sap :scs (sap-reg) :to (:eval 0)) - (value :scs (double-reg))) - (:arg-types system-area-pointer (:constant (signed-byte 32)) double-float) - (:info offset) + (value :scs (double-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 32)) + (:constant (constant-displacement 0 ; lowtag + 8 ; double-float size + 0)) + double-float) + (:info offset disp) (:results (result :scs (double-reg))) (:result-types double-float) (:generator 4 + (aver (zerop disp)) (cond ((zerop (tn-offset value)) - ;; Value is in ST0. - (inst fstd (make-ea :dword :base sap :disp offset)) - (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 :disp offset)) - (cond ((zerop (tn-offset result)) - ;; The result is in ST0. - (inst fstd value)) - (t - ;; Neither value or result are in ST0. - (unless (location= value result) - (inst fstd result)) - (inst fxch value))))))) + ;; Value is in ST0. + (inst fstd (make-ea :dword :base sap :disp offset)) + (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 :disp offset)) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value)) + (t + ;; Neither value or result are in ST0. + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) ;;;; SAP-REF-SINGLE -(define-vop (sap-ref-single) - (:translate sap-ref-single) +(define-vop (sap-ref-single-with-offset) + (:translate sb!c::sap-ref-single-with-offset) (:policy :fast-safe) (:args (sap :scs (sap-reg)) - (offset :scs (signed-reg))) - (:arg-types system-area-pointer signed-num) + (offset :scs (signed-reg immediate))) + (:info disp) + (:arg-types system-area-pointer signed-num + (:constant (constant-displacement 0 ; lowtag + 4 ; single-float size + 0))) (:results (result :scs (single-reg))) (:result-types single-float) (:generator 5 - (with-empty-tn@fp-top(result) - (inst fld (make-ea :dword :base sap :index offset))))) + (sc-case offset + (immediate + (aver (zerop disp)) + (with-empty-tn@fp-top(result) + (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)))))))) -(define-vop (sap-ref-single-c) - (:translate sap-ref-single) - (:policy :fast-safe) - (:args (sap :scs (sap-reg))) - (:arg-types system-area-pointer (:constant (signed-byte 32))) - (:info offset) - (:results (result :scs (single-reg))) - (:result-types single-float) - (:generator 4 - (with-empty-tn@fp-top(result) - (inst fld (make-ea :dword :base sap :disp offset))))) - -(define-vop (%set-sap-ref-single) - (:translate %set-sap-ref-single) +(define-vop (%set-sap-ref-single-with-offset) + (:translate sb!c::%set-sap-ref-single-with-offset) (:policy :fast-safe) (:args (sap :scs (sap-reg) :to (:eval 0)) - (offset :scs (signed-reg) :to (:eval 0)) - (value :scs (single-reg))) - (:arg-types system-area-pointer signed-num single-float) + (offset :scs (signed-reg) :to (:eval 0)) + (value :scs (single-reg))) + (:info disp) + (:arg-types system-area-pointer signed-num + (:constant (constant-displacement 0 ; lowtag + 4 ; single-float size + 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)) - (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)) - (cond ((zerop (tn-offset result)) - ;; The result is in ST0. - (inst fst value)) - (t - ;; Neither value or result are in ST0 - (unless (location= value result) - (inst fst result)) - (inst fxch value))))))) + ;; Value is in ST0 + (inst fst (make-ea :dword :base sap :index offset + :disp (* 4 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))) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fst value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fst result)) + (inst fxch value))))))) -(define-vop (%set-sap-ref-single-c) - (:translate %set-sap-ref-single) +(define-vop (%set-sap-ref-single-with-offset-c) + (:translate sb!c::%set-sap-ref-single-with-offset) (:policy :fast-safe) (:args (sap :scs (sap-reg) :to (:eval 0)) - (value :scs (single-reg))) - (:arg-types system-area-pointer (:constant (signed-byte 32)) single-float) - (:info offset) + (value :scs (single-reg))) + (:arg-types system-area-pointer (:constant (signed-byte 32)) + (:constant (constant-displacement 0 ; lowtag + 4 ; single-float size + 0)) + single-float) + (:info offset disp) (:results (result :scs (single-reg))) (:result-types single-float) (:generator 4 + (aver (zerop disp)) (cond ((zerop (tn-offset value)) - ;; Value is in ST0 - (inst fst (make-ea :dword :base sap :disp offset)) - (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 :disp offset)) - (cond ((zerop (tn-offset result)) - ;; The result is in ST0. - (inst fst value)) - (t - ;; Neither value or result are in ST0 - (unless (location= value result) - (inst fst result)) - (inst fxch value))))))) + ;; Value is in ST0 + (inst fst (make-ea :dword :base sap :disp offset)) + (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 :disp offset)) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fst value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fst result)) + (inst fxch value))))))) ;;;; SAP-REF-LONG @@ -431,13 +432,13 @@ (:translate sap-ref-long) (:policy :fast-safe) (:args (sap :scs (sap-reg)) - (offset :scs (signed-reg))) + (offset :scs (signed-reg))) (:arg-types system-area-pointer signed-num) (:results (result :scs (#!+long-float long-reg #!-long-float double-reg))) (:result-types #!+long-float long-float #!-long-float double-float) (:generator 5 (with-empty-tn@fp-top(result) - (inst fldl (make-ea :dword :base sap :index offset))))) + (inst fldl (make-ea :dword :base sap :index offset))))) (define-vop (sap-ref-long-c) (:translate sap-ref-long) @@ -449,37 +450,37 @@ (:result-types #!+long-float long-float #!-long-float double-float) (:generator 4 (with-empty-tn@fp-top(result) - (inst fldl (make-ea :dword :base sap :disp offset))))) + (inst fldl (make-ea :dword :base sap :disp offset))))) #!+long-float (define-vop (%set-sap-ref-long) (:translate %set-sap-ref-long) (:policy :fast-safe) (:args (sap :scs (sap-reg) :to (:eval 0)) - (offset :scs (signed-reg) :to (:eval 0)) - (value :scs (long-reg))) + (offset :scs (signed-reg) :to (:eval 0)) + (value :scs (long-reg))) (:arg-types system-area-pointer signed-num long-float) (:results (result :scs (long-reg))) (:result-types long-float) (:generator 5 (cond ((zerop (tn-offset value)) - ;; Value is in ST0 - (store-long-float (make-ea :dword :base sap :index offset)) - (unless (zerop (tn-offset result)) - ;; Value is in ST0 but not result. - (inst fstd result))) - (t - ;; Value is not in ST0. - (inst fxch value) - (store-long-float (make-ea :dword :base sap :index offset)) - (cond ((zerop (tn-offset result)) - ;; The result is in ST0. - (inst fstd value)) - (t - ;; Neither value or result are in ST0 - (unless (location= value result) - (inst fstd result)) - (inst fxch value))))))) + ;; Value is in ST0 + (store-long-float (make-ea :dword :base sap :index offset)) + (unless (zerop (tn-offset result)) + ;; Value is in ST0 but not result. + (inst fstd result))) + (t + ;; Value is not in ST0. + (inst fxch value) + (store-long-float (make-ea :dword :base sap :index offset)) + (cond ((zerop (tn-offset result)) + ;; The result is in ST0. + (inst fstd value)) + (t + ;; Neither value or result are in ST0 + (unless (location= value result) + (inst fstd result)) + (inst fxch value))))))) ;;; noise to convert normal lisp data objects into SAPs @@ -491,4 +492,26 @@ (:result-types system-area-pointer) (:generator 2 (move sap vector) - (inst add sap (- (* vector-data-offset word-bytes) other-pointer-type)))) + (inst add + sap + (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)))) + +;;; Transforms for 64-bit SAP accessors. + +(deftransform sap-ref-64 ((sap offset) (* *)) + '(logior (sap-ref-32 sap offset) + (ash (sap-ref-32 sap (+ offset 4)) 32))) + +(deftransform signed-sap-ref-64 ((sap offset) (* *)) + '(logior (sap-ref-32 sap offset) + (ash (signed-sap-ref-32 sap (+ offset 4)) 32))) + +(deftransform %set-sap-ref-64 ((sap offset value) (* * *)) + '(progn + (%set-sap-ref-32 sap offset (logand value #xffffffff)) + (%set-sap-ref-32 sap (+ offset 4) (ash value -32)))) + +(deftransform %set-signed-sap-ref-64 ((sap offset value) (* * *)) + '(progn + (%set-sap-ref-32 sap offset (logand value #xffffffff)) + (%set-signed-sap-ref-32 sap (+ offset 4) (ash value -32))))