X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Falpha%2Fvm.lisp;h=ab416a3600d2d3df6de9a76cd463d5e76e6bcaf3;hb=f1ffbf976aaa50b7b22f126b97e34afe06a91210;hp=3dd28ab959170826c53e44aa80b184da303b968c;hpb=e0814eee6f6dea52db010b45a330100f2fe65832;p=sbcl.git diff --git a/src/compiler/alpha/vm.lisp b/src/compiler/alpha/vm.lisp index 3dd28ab..ab416a3 100644 --- a/src/compiler/alpha/vm.lisp +++ b/src/compiler/alpha/vm.lisp @@ -19,17 +19,17 @@ (macrolet ((defreg (name offset) (let ((offset-sym (symbolicate name "-OFFSET"))) `(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant ,offset-sym ,offset) + (def!constant ,offset-sym ,offset) (setf (svref *register-names* ,offset-sym) - ,(symbol-name name))))) + ,(symbol-name name))))) (defregset (name &rest regs) `(eval-when (:compile-toplevel :load-toplevel :execute) (defparameter ,name (list ,@(mapcar (lambda (name) - (symbolicate name "-OFFSET")) + (symbolicate name "-OFFSET")) regs)))))) ;; c.f. src/runtime/alpha-lispregs.h - + ;; Ra (defreg lip 0) ;; Caller saved 0-7 @@ -73,13 +73,13 @@ (defreg nsp 30) ;; Wired zero (defreg zero 31) - + (defregset non-descriptor-regs nl0 nl1 nl2 nl3 nl4 nl5 nfp cfunc) - + (defregset descriptor-regs fdefn lexenv nargs ocfp lra a0 a1 a2 a3 a4 a5 l0 l1 l2) - + (defregset *register-arg-offsets* a0 a1 a2 a3 a4 a5) (defparameter register-arg-names '(a0 a1 a2 a3 a4 a5))) @@ -93,40 +93,35 @@ ;;; a handy macro so we don't have to keep changing all the numbers ;;; whenever we insert a new storage class. -;;; -;;; FIXME: This macro is not needed in the runtime target. -(defmacro define-storage-classes (&rest classes) +(defmacro !define-storage-classes (&rest classes) (do ((forms (list 'progn) - (let* ((class (car classes)) - (sc-name (car class)) - (constant-name (intern (concatenate 'simple-string - (string sc-name) - "-SC-NUMBER")))) - (list* `(define-storage-class ,sc-name ,index - ,@(cdr class)) - `(defconstant ,constant-name ,index) - ;; (The CMU CL version of this macro did - ;; `(EXPORT ',CONSTANT-NAME) - ;; here, but in SBCL we try to have package - ;; structure described statically in one - ;; master source file, instead of building it - ;; dynamically by letting all the system code - ;; modify it as the system boots.) - forms))) + (let* ((class (car classes)) + (sc-name (car class)) + (constant-name (intern (concatenate 'simple-string + (string sc-name) + "-SC-NUMBER")))) + (list* `(define-storage-class ,sc-name ,index + ,@(cdr class)) + `(def!constant ,constant-name ,index) + ;; (The CMU CL version of this macro did + ;; `(EXPORT ',CONSTANT-NAME) + ;; here, but in SBCL we try to have package + ;; structure described statically in one + ;; master source file, instead of building it + ;; dynamically by letting all the system code + ;; modify it as the system boots.) + forms))) (index 0 (1+ index)) (classes classes (cdr classes))) ((null classes) (nreverse forms)))) -;;; see comment in ../x86/vm.lisp. The value of 7 was taken from -;;; vm:catch-block-size in a cmucl that I happened to have around -;;; and seems to be working so far -dan -(defconstant sb!vm::kludge-nondeterministic-catch-block-size 7) +(def!constant kludge-nondeterministic-catch-block-size 7) -(define-storage-classes +(!define-storage-classes - ;; Non-immediate contstants in the constant pool + ;; non-immediate constants in the constant pool (constant constant) ;; ZERO and NULL are in registers. @@ -146,15 +141,15 @@ ;; The non-descriptor stacks. (signed-stack non-descriptor-stack - :element-size 2 :alignment 2) ; (signed-byte 64) + :element-size 2 :alignment 2) ; (signed-byte 64) (unsigned-stack non-descriptor-stack - :element-size 2 :alignment 2) ; (unsigned-byte 64) - (base-char-stack non-descriptor-stack) ; non-descriptor characters. + :element-size 2 :alignment 2) ; (unsigned-byte 64) + (character-stack non-descriptor-stack) ; non-descriptor characters. (sap-stack non-descriptor-stack - :element-size 2 :alignment 2) ; System area pointers. + :element-size 2 :alignment 2) ; System area pointers. (single-stack non-descriptor-stack) ; single-floats (double-stack non-descriptor-stack - :element-size 2 :alignment 2) ; double floats. + :element-size 2 :alignment 2) ; double floats. (complex-single-stack non-descriptor-stack :element-size 2) (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2) @@ -179,11 +174,11 @@ :alternate-scs (control-stack)) ;; Non-Descriptor characters - (base-char-reg registers + (character-reg registers :locations #.non-descriptor-regs :constant-scs (immediate) :save-p t - :alternate-scs (base-char-stack)) + :alternate-scs (character-stack)) ;; Non-Descriptor SAP's (arbitrary pointers into address space) (sap-reg registers @@ -245,7 +240,7 @@ ;; A catch or unwind block. (catch-block control-stack - :element-size sb!vm::kludge-nondeterministic-catch-block-size)) + :element-size kludge-nondeterministic-catch-block-size)) ;;; Make some random tns for important registers. (macrolet ((defregtn (name sc) @@ -253,8 +248,8 @@ (tn-sym (symbolicate name "-TN"))) `(defparameter ,tn-sym (make-random-tn :kind :normal - :sc (sc-or-lose ',sc) - :offset ,offset-sym))))) + :sc (sc-or-lose ',sc) + :offset ,offset-sym))))) ;; These, we access by foo-TN only @@ -276,12 +271,12 @@ ;; and some floating point values.. (defparameter fp-single-zero-tn (make-random-tn :kind :normal - :sc (sc-or-lose 'single-reg) - :offset 31)) + :sc (sc-or-lose 'single-reg) + :offset 31)) (defparameter fp-double-zero-tn (make-random-tn :kind :normal - :sc (sc-or-lose 'double-reg) - :offset 31)) + :sc (sc-or-lose 'double-reg) + :offset 31)) ;;; If value can be represented as an immediate constant, then return ;;; the appropriate SC number, otherwise return NIL. @@ -291,37 +286,38 @@ (sc-number-or-lose 'zero)) (null (sc-number-or-lose 'null )) - ((or fixnum system-area-pointer character) + ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum) + system-area-pointer character) (sc-number-or-lose 'immediate )) (symbol (if (static-symbol-p value) - (sc-number-or-lose 'immediate ) - nil)) + (sc-number-or-lose 'immediate ) + nil)) (single-float (if (eql value 0f0) - (sc-number-or-lose 'fp-single-zero ) - nil)) + (sc-number-or-lose 'fp-single-zero ) + nil)) (double-float (if (eql value 0d0) - (sc-number-or-lose 'fp-double-zero ) - nil)))) + (sc-number-or-lose 'fp-double-zero ) + nil)))) ;;;; function call parameters ;;; the SC numbers for register and stack arguments/return values -(defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg)) -(defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg)) -(defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack)) +(def!constant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg)) +(def!constant immediate-arg-scn (meta-sc-number-or-lose 'any-reg)) +(def!constant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack)) (eval-when (:compile-toplevel :load-toplevel :execute) ;;; offsets of special stack frame locations -(defconstant ocfp-save-offset 0) -(defconstant lra-save-offset 1) -(defconstant nfp-save-offset 2) +(def!constant ocfp-save-offset 0) +(def!constant lra-save-offset 1) +(def!constant nfp-save-offset 2) ;;; the number of arguments/return values passed in registers -(defconstant register-arg-count 6) +(def!constant register-arg-count 6) ;;; (Names to use for the argument registers would go here, but there ;;; are none.) @@ -331,13 +327,13 @@ ;;; a list of TN's describing the register arguments (defparameter *register-arg-tns* (mapcar (lambda (n) - (make-random-tn :kind :normal - :sc (sc-or-lose 'descriptor-reg) - :offset n)) - *register-arg-offsets*)) + (make-random-tn :kind :normal + :sc (sc-or-lose 'descriptor-reg) + :offset n)) + *register-arg-offsets*)) ;;; This is used by the debugger. -(defconstant single-value-return-byte-offset 4) +(def!constant single-value-return-byte-offset 4) ;;; This function is called by debug output routines that want a ;;; pretty name for a TN's location. It returns a thing that can be @@ -345,12 +341,14 @@ (!def-vm-support-routine location-print-name (tn) ; (declare (type tn tn)) (let ((sb (sb-name (sc-sb (tn-sc tn)))) - (offset (tn-offset tn))) + (offset (tn-offset tn))) (ecase sb (registers (or (svref *register-names* offset) - (format nil "R~D" offset))) + (format nil "R~D" offset))) (float-registers (format nil "F~D" offset)) (control-stack (format nil "CS~D" offset)) (non-descriptor-stack (format nil "NS~D" offset)) (constant (format nil "Const~D" offset)) (immediate-constant "Immed")))) + +