X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Falpha%2Fvm.lisp;h=7cd45fcec91dc8f17205178f9b743f25104c6022;hb=079ef9dad558ca07cb8178ef428bf738112174fa;hp=6d5bcf75dc6ce13b1f883943e821b14fe1ede39e;hpb=63fcb94b875a97e468d9add229e220ecceec2352;p=sbcl.git diff --git a/src/compiler/alpha/vm.lisp b/src/compiler/alpha/vm.lisp index 6d5bcf7..7cd45fc 100644 --- a/src/compiler/alpha/vm.lisp +++ b/src/compiler/alpha/vm.lisp @@ -19,13 +19,14 @@ (macrolet ((defreg (name offset) (let ((offset-sym (symbolicate name "-OFFSET"))) `(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant ,offset-sym ,offset) - (setf (svref *register-names* ,offset-sym) ,(symbol-name name))))) + (def!constant ,offset-sym ,offset) + (setf (svref *register-names* ,offset-sym) + ,(symbol-name name))))) (defregset (name &rest regs) `(eval-when (:compile-toplevel :load-toplevel :execute) (defparameter ,name - (list ,@(mapcar #'(lambda (name) - (symbolicate name "-OFFSET")) + (list ,@(mapcar (lambda (name) + (symbolicate name "-OFFSET")) regs)))))) ;; c.f. src/runtime/alpha-lispregs.h @@ -92,10 +93,8 @@ ;;; 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)) @@ -104,7 +103,7 @@ "-SC-NUMBER")))) (list* `(define-storage-class ,sc-name ,index ,@(cdr class)) - `(defconstant ,constant-name ,index) + `(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 @@ -118,14 +117,11 @@ ((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. @@ -148,7 +144,7 @@ :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. + (character-stack non-descriptor-stack) ; non-descriptor characters. (sap-stack non-descriptor-stack :element-size 2 :alignment 2) ; System area pointers. (single-stack non-descriptor-stack) ; single-floats @@ -178,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 @@ -244,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) @@ -308,19 +304,19 @@ ;;;; 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.) @@ -329,14 +325,14 @@ ;;; 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)) + (mapcar (lambda (n) + (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 @@ -353,3 +349,15 @@ (non-descriptor-stack (format nil "NS~D" offset)) (constant (format nil "Const~D" offset)) (immediate-constant "Immed")))) + +;;; The loader uses this to convert alien names to the form they +;;; occure in the symbol table (for example, prepending an +;;; underscore). +(defun extern-alien-name (name) + (declare (type string name)) + ;; ELF ports currently don't need any prefix + (typecase name + (simple-base-string name) + (base-string (coerce name 'simple-base-string)) + (t (handler-case (coerce name 'simple-base-string) + (type-error () (error "invalid external alien name: ~S" name))))))