X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Falpha%2Fvm.lisp;h=6c312841fb76a0c096cddbebe138b7f6f5c4c07b;hb=c81c32ef8a737b0cc61d3c0c6a137cab39baac73;hp=1f6827be368c997ba030ca603bc2c148e1841792;hpb=dfa55a883f94470267b626dae77ce7e7dfac3df6;p=sbcl.git diff --git a/src/compiler/alpha/vm.lisp b/src/compiler/alpha/vm.lisp index 1f6827b..6c31284 100644 --- a/src/compiler/alpha/vm.lisp +++ b/src/compiler/alpha/vm.lisp @@ -1,4 +1,4 @@ -;;;; miscellaneous VM definition noise for the x86 +;;;; miscellaneous VM definition noise for the Alpha ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -10,10 +10,8 @@ ;;;; files for more information. (in-package "SB!VM") - - -;;;; Define the registers +;;;; defining the registers (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *register-names* (make-array 32 :initial-element nil))) @@ -21,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,12 +91,10 @@ (define-storage-base constant :non-packed) (define-storage-base immediate-constant :non-packed) -;;; -;;; 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. +;;; a handy macro so we don't have to keep changing all the numbers +;;; whenever we insert a new storage class. -(defmacro define-storage-classes (&rest classes) +(defmacro !define-storage-classes (&rest classes) (do ((forms (list 'progn) (let* ((class (car classes)) (sc-name (car class)) @@ -106,8 +103,14 @@ "-SC-NUMBER")))) (list* `(define-storage-class ,sc-name ,index ,@(cdr class)) - `(defconstant ,constant-name ,index) - `(export ',constant-name) + `(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))) @@ -117,12 +120,11 @@ ;;; 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 sb!vm::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. @@ -242,10 +244,8 @@ ;; A catch or unwind block. (catch-block control-stack :element-size sb!vm::kludge-nondeterministic-catch-block-size)) - -;;;; Make some random tns for important registers. - +;;; Make some random tns for important registers. (macrolet ((defregtn (name sc) (let ((offset-sym (symbolicate name "-OFFSET")) (tn-sym (symbolicate name "-TN"))) @@ -271,7 +271,7 @@ (defregtn ocfp any-reg) (defregtn lip interior-reg)) -;; And some floating point values. +;; and some floating point values.. (defparameter fp-single-zero-tn (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg) @@ -280,13 +280,9 @@ (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) :offset 31)) - -;;; Immediate-Constant-SC -- Interface -;;; -;;; If value can be represented as an immediate constant, then return the -;;; appropriate SC number, otherwise return NIL. -;;; +;;; If value can be represented as an immediate constant, then return +;;; the appropriate SC number, otherwise return NIL. (!def-vm-support-routine immediate-constant-sc (value) (typecase value ((integer 0 0) @@ -308,54 +304,42 @@ (sc-number-or-lose 'fp-double-zero ) nil)))) -;;;; Function Call Parameters +;;;; 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)) +;;; the SC numbers for register and stack arguments/return values +(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) - -;;; The number of arguments/return values passed in registers. -;;; -(defconstant register-arg-count 6) - -;;; Names to use for the argument registers. -;;; +;;; offsets of special stack frame locations +(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 +(def!constant register-arg-count 6) -); Eval-When (Compile Load Eval) +;;; (Names to use for the argument registers would go here, but there +;;; are none.) +); EVAL-WHEN -;;; A list of TN's describing the register arguments. -;;; +;;; 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*)) -;;; SINGLE-VALUE-RETURN-BYTE-OFFSET -;;; ;;; This is used by the debugger. -;;; -(export 'single-value-return-byte-offset) -(defconstant single-value-return-byte-offset 4) - +(def!constant single-value-return-byte-offset 4) -;;; LOCATION-PRINT-NAME -- Interface -;;; -;;; 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 printed with PRINC. -;;; +;;; 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 +;;; printed with PRINC. (!def-vm-support-routine location-print-name (tn) ; (declare (type tn tn)) (let ((sb (sb-name (sc-sb (tn-sc tn)))) @@ -368,3 +352,11 @@ (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 simple-base-string name)) + ;; On the Alpha we don't do anything. + name)