diff --git a/compiler/rt/sap.lisp b/compiler/rt/sap.lisp index 66d027efb1e2896e4e4a12a045bb438121186891..82271f5bb9b6a5744bde2d8abb7d7d6efc030a9a 100644 --- a/compiler/rt/sap.lisp +++ b/compiler/rt/sap.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/sap.lisp,v 1.9 1991/10/03 13:28:26 ram Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/rt/sap.lisp,v 1.10 1992/03/09 20:35:07 wlott Exp $ ;;; ;;; This file contains the IBM RT VM definition of SAP operations. ;;; @@ -171,25 +171,22 @@ ;;; (the machines address units). Translate and signed-translate are the Lisp ;;; function calls for which these VOP's are in-line expansions. ;;; -(defmacro define-system-ref (name shift - translate result-sc result-type +(defmacro define-system-ref (name size translate result-sc result-type &optional signed-translate signed-result-sc signed-result-type) (let ((access-form - (ecase shift - (0 ;want a byte, indexed in bytes. + (ecase size + (:byte '((inst lc result base offset) (when signed (inst sl result 24) (inst sar result 24)))) - (1 ;Want 16 bits. Incoming offset is in 16-bit quantities. - ;Offset here is in bytes. + (:halfword '((if signed (inst lha result base offset) (inst lh result base offset)))) - (2 ;Want 32 bits. Incoming offset is in 32-bit quantities. - ;Offset here is in bytes. + (:word '(signed ; suppress silly warnings. (inst l result base offset))))) (name-c (symbolicate name "-C"))) @@ -200,20 +197,18 @@ (:args (base :scs (sap-reg))) (:results (result :scs (,result-sc))) (:result-types ,result-type) - (:arg-types system-area-pointer - (:constant (signed-byte ,(- 16 shift)))) + (:arg-types system-area-pointer (:constant (unsigned-byte 15))) (:info offset) (:variant-vars signed) (:variant nil) (:generator 5 - (let ((offset (ash offset ,shift))) - ,@access-form))) + ,@access-form)) (define-vop (,name) (:policy :fast-safe) (:translate ,translate) (:args (object :scs (sap-reg) :to (:eval 0)) - (offset :scs (any-reg) :target base)) + (offset :scs (unsigned-reg) :target base)) (:results (result :scs (,result-sc))) (:arg-types system-area-pointer positive-fixnum) (:result-types ,result-type) @@ -222,12 +217,6 @@ (:variant nil) (:generator 7 (move base offset) - ;; - ;; We shift right because the offset has fixnum lowtag. Effectively - ;; the index has already been multiplied by 4. - ,@(let ((adj (- 2 shift))) - (unless (zerop adj) - `((inst sr base ,adj)))) (inst a base object) (let ((offset 0)) ,@access-form))) @@ -247,19 +236,19 @@ ) ;eval-when -(define-system-ref 8bit-system-ref 0 +(define-system-ref 8bit-system-ref :byte sap-ref-8 unsigned-reg positive-fixnum signed-sap-ref-8 signed-reg tagged-num) -(define-system-ref 16bit-system-ref 1 +(define-system-ref 16bit-system-ref :halfword sap-ref-16 unsigned-reg positive-fixnum signed-sap-ref-16 signed-reg tagged-num) -(define-system-ref 32bit-system-ref 2 +(define-system-ref 32bit-system-ref :word sap-ref-32 unsigned-reg unsigned-num signed-sap-ref-32 signed-reg signed-num) -(define-system-ref sap-system-ref 2 +(define-system-ref sap-system-ref :word sap-ref-sap sap-reg system-area-pointer) @@ -273,17 +262,12 @@ ;;; (the machines address units). Translate and signed-translate are the Lisp ;;; function calls for which these VOP's are in-line expansions. ;;; -(defmacro define-system-set (name shift translate data-scs data-type) +(defmacro define-system-set (name :size translate data-scs data-type) (let ((set-form - (ecase shift - (0 ;Want a byte. Incoming offset is in bytes. No shifting. - '(inst stc data base offset)) - (1 ;Want 16 bits. Incoming offset is in 16-bit quantities. - ;Offset here is in bytes. - '(inst sth data base offset)) - (2 ;Want 32 bits. Incoming offset is in 32-bit quantities. - ;Offset here is in bytes. - '(inst st data base offset)))) + (ecase :size + (:byte '(inst stc data base offset)) + (:halfword '(inst sth data base offset)) + (:word '(inst st data base offset)))) (name-c (symbolicate name "-C"))) `(progn (define-vop (,name-c) @@ -292,21 +276,20 @@ (:args (base :scs (sap-reg)) (data :scs (,@data-scs) :target result :to (:result 0))) (:arg-types system-area-pointer - (:constant (signed-byte ,(- 16 shift))) + (:constant (unsigned-byte 15)) ,data-type) (:results (result :scs (,@data-scs))) (:result-types ,data-type) (:info offset) (:generator 5 - (let ((offset (ash offset ,shift))) - ,set-form) + ,set-form (move result data))) (define-vop (,name) (:policy :fast-safe) (:translate ,translate) (:args (object :scs (sap-reg) :to (:eval 0)) - (offset :scs (any-reg) :target base) + (offset :scs (unsigned-reg) :target base) (data :scs (,@data-scs) :target result :to (:eval 1))) (:arg-types system-area-pointer positive-fixnum ,data-type) @@ -315,12 +298,6 @@ (:result-types ,data-type) (:generator 7 (move base offset) - ;; - ;; We shift right because the offset has fixnum lowtag. Effectively - ;; the index has already been multiplied by 4. - ,@(let ((adj (- 2 shift))) - (unless (zerop adj) - `((inst sr base ,adj)))) (inst cas base base object) (let ((offset 0)) ,set-form) @@ -337,6 +314,15 @@ (define-system-set 32bit-system-set 2 %set-sap-ref-32 (signed-reg unsigned-reg) (:or signed-num unsigned-num)) +(define-system-set signed-8bit-system-set 0 %set-signed-sap-ref-8 + (signed-reg unsigned-reg) (:or signed-num unsigned-num)) + +(define-system-set signed-16bit-system-set 1 %set-signed-sap-ref-16 + (signed-reg unsigned-reg) (:or signed-num unsigned-num)) + +(define-system-set signed-32bit-system-set 2 %set-signed-sap-ref-32 + (signed-reg unsigned-reg) (:or signed-num unsigned-num)) + ;;; Ugly, because there are only 2 free sap-regs. We stash the data value in ;;; NARGS to free up a sap-reg for BASE. ;;; @@ -344,7 +330,7 @@ (:policy :fast-safe) (:translate %set-sap-ref-sap) (:args (object :scs (sap-reg)) - (offset :scs (any-reg) :target base) + (offset :scs (unsigned-reg) :target base) (data :scs (sap-reg sap-stack))) (:arg-types system-area-pointer positive-fixnum system-area-pointer) (:temporary (:scs (sap-reg) :from (:eval 0) :to (:eval 1)) base) @@ -364,6 +350,45 @@ (inst st save base) (move result save))) +(define-vop (sap-system-set-c) + (:policy :fast-safe) + (:translate %set-sap-ref-sap) + (:args (object :scs (sap-reg)) + (data :scs (sap-reg) :target result)) + (:arg-types system-area-pointer + (:constant (unsigned-byte 16)) + system-area-pointer) + (:results (result :scs (sap-reg))) + (:result-types system-area-pointer) + (:generator 4 + (inst st data object offset) + (move result data))) + +;;; fake the presence of sap-ref-single and sap-ref-double. + +(def-source-transform sap-ref-single (sap offset) + `(make-single-float (signed-sap-ref-32 ,sap ,offset))) + +(def-source-transform %set-sap-ref-single (sap offset value) + (once-only ((sap sap) (offset offset) (value value)) + `(progn + (setf (signed-sap-ref-32 ,sap ,offset) ,value) + ,value))) + +(def-source-transform sap-ref-double (sap offset) + (once-only ((sap sap) (offset offset)) + `(make-double-float (signed-sap-ref-32 ,sap ,offset) + (sap-ref-32 sap (+ ,offset word-bytes))))) + +(def-source-transform %set-sap-ref-double (sap offset value) + (once-only ((sap sap) (offset offset) (value value)) + `(progn + (setf (signed-sap-ref-32 ,sap ,offset) + (double-float-high-bits ,value)) + (setf (sap-ref-32 ,sap (+ ,offset word-bytes)) + (double-float-low-bits ,value)) + ,value))) + ;;;; Noise to convert normal lisp data objects into SAPs. @@ -376,27 +401,3 @@ (:generator 2 (inst cal sap vector (- (* vm:vector-data-offset vm:word-bytes) vm:other-pointer-type)))) - - - -;;;; ### Noise to allow old forms to continue to work until they are gone. - -(macrolet ((frob (prim func) - `(def-primitive-translator ,prim (&rest args) - (warn "Someone used %primitive ~S -- should be ~S." - ',prim ',func) - `(,',func ,@args)))) - (frob 32bit-system-ref sap-ref-32) - (frob unsigned-32bit-system-ref sap-ref-32) - (frob 16bit-system-ref sap-ref-16) - (frob 8bit-system-ref sap-ref-8)) - -(macrolet ((frob (prim func) - `(def-primitive-translator ,prim (&rest args) - (warn "Someone used %primitive ~S -- should be ~S." - ',prim (list 'setf ',func)) - `(setf ,',func ,@args)))) - (frob 32bit-system-set sap-ref-32) - (frob signed-32bit-system-set sap-ref-32) - (frob 16bit-system-set sap-ref-16) - (frob 8bit-system-set sap-ref-8))