X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fvm.lisp;h=377b196abcd70362540aa344f555327bc6c3f7a9;hb=bf27595fb567015495b7131707cc85af361567fe;hp=001f5e585dcbcbcb20c79dc2593f5191f4366550;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/compiler/x86/vm.lisp b/src/compiler/x86/vm.lisp index 001f5e5..377b196 100644 --- a/src/compiler/x86/vm.lisp +++ b/src/compiler/x86/vm.lisp @@ -13,37 +13,41 @@ ;;; the size of an INTEGER representation of a SYSTEM-AREA-POINTER, i.e. ;;; size of a native memory address -(deftype sap-int-type () '(unsigned-byte 32)) -;;; FIXME: This should just named be SAP-INT, not SAP-INT-TYPE. And -;;; grep for SAPINT in the code and replace it with SAP-INT as -;;; appropriate. +(deftype sap-int () '(unsigned-byte 32)) ;;;; register specs +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *byte-register-names* (make-array 8 :initial-element nil)) + (defvar *word-register-names* (make-array 16 :initial-element nil)) + (defvar *dword-register-names* (make-array 16 :initial-element nil)) + (defvar *float-register-names* (make-array 8 :initial-element nil))) + (macrolet ((defreg (name offset size) (let ((offset-sym (symbolicate name "-OFFSET")) (names-vector (symbolicate "*" size "-REGISTER-NAMES*"))) `(progn - (eval-when (:compile-toplevel :execute :load-toplevel) - (defconstant ,offset-sym ,offset)) + (eval-when (:compile-toplevel :load-toplevel :execute) + ;; EVAL-WHEN is necessary because stuff like #.EAX-OFFSET + ;; (in the same file) depends on compile-time evaluation + ;; of the DEFCONSTANT. -- AL 20010224 + (def!constant ,offset-sym ,offset)) (setf (svref ,names-vector ,offset-sym) ,(symbol-name name))))) - ;; FIXME: It looks to me as though DEFREGSET should also define the - ;; *FOO-REGISTER-NAMES* variable. + ;; FIXME: It looks to me as though DEFREGSET should also + ;; define the related *FOO-REGISTER-NAMES* variable. (defregset (name &rest regs) - `(eval-when (:compile-toplevel :execute :load-toplevel) - (defconstant ,name + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter ,name (list ,@(mapcar (lambda (name) (symbolicate name "-OFFSET")) regs)))))) ;; byte registers ;; - ;; Note: the encoding here is different then that used by the chip. We - ;; use this encoding so that the compiler thinks that AX (and EAX) overlap - ;; AL and AH instead of AL and CL. - (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *byte-register-names* (make-array 8 :initial-element nil))) + ;; Note: the encoding here is different than that used by the chip. + ;; We use this encoding so that the compiler thinks that AX (and + ;; EAX) overlap AL and AH instead of AL and CL. (defreg al 0 :byte) (defreg ah 1 :byte) (defreg cl 2 :byte) @@ -52,11 +56,9 @@ (defreg dh 5 :byte) (defreg bl 6 :byte) (defreg bh 7 :byte) - (defregset byte-regs al ah cl ch dl dh bl bh) + (defregset *byte-regs* al ah cl ch dl dh bl bh) ;; word registers - (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *word-register-names* (make-array 16 :initial-element nil))) (defreg ax 0 :word) (defreg cx 2 :word) (defreg dx 4 :word) @@ -65,11 +67,9 @@ (defreg bp 10 :word) (defreg si 12 :word) (defreg di 14 :word) - (defregset word-regs ax cx dx bx si di) + (defregset *word-regs* ax cx dx bx si di) ;; double word registers - (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *dword-register-names* (make-array 16 :initial-element nil))) (defreg eax 0 :dword) (defreg ecx 2 :dword) (defreg edx 4 :dword) @@ -78,11 +78,9 @@ (defreg ebp 10 :dword) (defreg esi 12 :dword) (defreg edi 14 :dword) - (defregset dword-regs eax ecx edx ebx esi edi) + (defregset *dword-regs* eax ecx edx ebx esi edi) ;; floating point registers - (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *float-register-names* (make-array 8 :initial-element nil))) (defreg fr0 0 :float) (defreg fr1 1 :float) (defreg fr2 2 :float) @@ -91,15 +89,16 @@ (defreg fr5 5 :float) (defreg fr6 6 :float) (defreg fr7 7 :float) - (defregset float-regs fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7) + (defregset *float-regs* fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7) ;; registers used to pass arguments ;; ;; the number of arguments/return values passed in registers - (defconstant register-arg-count 3) + (def!constant register-arg-count 3) ;; names and offsets for registers used to pass arguments - (defconstant register-arg-names '(edx edi esi)) - (defregset register-arg-offsets edx edi esi)) + (eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *register-arg-names* '(edx edi esi))) + (defregset *register-arg-offsets* edx edi esi)) ;;;; SB definitions @@ -129,8 +128,7 @@ ;;; 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) (collect ((forms)) (let ((index 0)) (dolist (class classes) @@ -138,35 +136,35 @@ (constant-name (symbolicate sc-name "-SC-NUMBER"))) (forms `(define-storage-class ,sc-name ,index ,@(cdr class))) - (forms `(defconstant ,constant-name ,index)) - (forms `(let ((sb!int::*rogue-export* "DEFINE-STORAGE-CLASSES")) - (export ',constant-name))) + (forms `(def!constant ,constant-name ,index)) (incf index)))) `(progn ,@(forms)))) -;;; The DEFINE-STORAGE-CLASS call for CATCH-BLOCK refers to the size of -;;; CATCH-BLOCK. The size of CATCH-BLOCK isn't calculated until later in -;;; the build process, and the calculation is entangled with code which has -;;; lots of predependencies, including dependencies on the prior call of -;;; DEFINE-STORAGE-CLASS. The proper way to unscramble this would be to -;;; untangle the code, so that the code which calculates the size of -;;; CATCH-BLOCK can be separated from the other lots-of-dependencies code, so -;;; that the code which calculates the size of CATCH-BLOCK can be executed -;;; early, so that this value is known properly at this point in compilation. -;;; However, that would be a lot of editing of code that I (WHN 19990131) can't -;;; test until the project is complete. So instead, I set the correct value by -;;; hand here (a sort of nondeterministic guess of the right answer:-) and add -;;; an assertion later, after the value is calculated, that the original guess -;;; was correct. +;;; The DEFINE-STORAGE-CLASS call for CATCH-BLOCK refers to the size +;;; of CATCH-BLOCK. The size of CATCH-BLOCK isn't calculated until +;;; later in the build process, and the calculation is entangled with +;;; code which has lots of predependencies, including dependencies on +;;; the prior call of DEFINE-STORAGE-CLASS. The proper way to +;;; unscramble this would be to untangle the code, so that the code +;;; which calculates the size of CATCH-BLOCK can be separated from the +;;; other lots-of-dependencies code, so that the code which calculates +;;; the size of CATCH-BLOCK can be executed early, so that this value +;;; is known properly at this point in compilation. However, that +;;; would be a lot of editing of code that I (WHN 19990131) can't test +;;; until the project is complete. So instead, I set the correct value +;;; by hand here (a sort of nondeterministic guess of the right +;;; answer:-) and add an assertion later, after the value is +;;; calculated, that the original guess was correct. ;;; -;;; (What a KLUDGE! Anyone who wants to come in and clean up this mess has my -;;; gratitude.) (FIXME: Maybe this should be me..) -(defconstant sb!vm::kludge-nondeterministic-catch-block-size 6) +;;; (What a KLUDGE! Anyone who wants to come in and clean up this mess +;;; has my gratitude.) (FIXME: Maybe this should be me..) +(eval-when (:compile-toplevel :load-toplevel :execute) + (def!constant kludge-nondeterministic-catch-block-size 6)) -(define-storage-classes +(!define-storage-classes - ;; non-immediate contstants in the constant pool + ;; non-immediate constants in the constant pool (constant constant) ;; some FP constants can be generated in the i387 silicon @@ -184,7 +182,7 @@ ;; the non-descriptor stacks (signed-stack stack) ; (signed-byte 32) (unsigned-stack stack) ; (unsigned-byte 32) - (base-char-stack stack) ; non-descriptor characters. + (character-stack stack) ; non-descriptor characters. (sap-stack stack) ; System area pointers. (single-stack stack) ; single-floats (double-stack stack :element-size 2) ; double-floats. @@ -213,7 +211,7 @@ ;; immediate descriptor objects. Don't have to be seen by GC, but nothing ;; bad will happen if they are. (fixnums, characters, header values, etc). (any-reg registers - :locations #.dword-regs + :locations #.*dword-regs* :element-size 2 ; :reserve-locations (#.eax-offset) :constant-scs (immediate) @@ -222,7 +220,7 @@ ;; pointer descriptor objects -- must be seen by GC (descriptor-reg registers - :locations #.dword-regs + :locations #.*dword-regs* :element-size 2 ; :reserve-locations (#.eax-offset) :constant-scs (constant immediate) @@ -230,16 +228,18 @@ :alternate-scs (control-stack)) ;; non-descriptor characters - (base-char-reg registers - :locations #.byte-regs + (character-reg registers + :locations #!-sb-unicode #.*byte-regs* + #!+sb-unicode #.*dword-regs* + #!-sb-unicode #!-sb-unicode :reserve-locations (#.ah-offset #.al-offset) :constant-scs (immediate) :save-p t - :alternate-scs (base-char-stack)) + :alternate-scs (character-stack)) ;; non-descriptor SAPs (arbitrary pointers into address space) (sap-reg registers - :locations #.dword-regs + :locations #.*dword-regs* :element-size 2 ; :reserve-locations (#.eax-offset) :constant-scs (immediate) @@ -248,14 +248,14 @@ ;; non-descriptor (signed or unsigned) numbers (signed-reg registers - :locations #.dword-regs + :locations #.*dword-regs* :element-size 2 ; :reserve-locations (#.eax-offset) :constant-scs (immediate) :save-p t :alternate-scs (signed-stack)) (unsigned-reg registers - :locations #.dword-regs + :locations #.*dword-regs* :element-size 2 ; :reserve-locations (#.eax-offset) :constant-scs (immediate) @@ -265,12 +265,12 @@ ;; miscellaneous objects that must not be seen by GC. Used only as ;; temporaries. (word-reg registers - :locations #.word-regs + :locations #.*word-regs* :element-size 2 ; :reserve-locations (#.ax-offset) ) (byte-reg registers - :locations #.byte-regs + :locations #.*byte-regs* ; :reserve-locations (#.al-offset #.ah-offset) ) @@ -321,24 +321,22 @@ :alternate-scs (complex-long-stack)) ;; a catch or unwind block - (catch-block stack - :element-size sb!vm::kludge-nondeterministic-catch-block-size)) + (catch-block stack :element-size kludge-nondeterministic-catch-block-size)) (eval-when (:compile-toplevel :load-toplevel :execute) - -(defconstant byte-sc-names '(base-char-reg byte-reg base-char-stack)) -(defconstant word-sc-names '(word-reg)) -(defconstant dword-sc-names +(defparameter *byte-sc-names* + '(#!-sb-unicode character-reg byte-reg #!-sb-unicode character-stack)) +(defparameter *word-sc-names* '(word-reg)) +(defparameter *dword-sc-names* '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack - signed-stack unsigned-stack sap-stack single-stack constant)) - + signed-stack unsigned-stack sap-stack single-stack + #!+sb-unicode character-reg #!+sb-unicode character-stack constant)) ;;; added by jrd. I guess the right thing to do is to treat floats ;;; as a separate size... ;;; ;;; These are used to (at least) determine operand size. -(defconstant float-sc-names '(single-reg)) -(defconstant double-sc-names '(double-reg double-stack)) - +(defparameter *float-sc-names* '(single-reg)) +(defparameter *double-sc-names* '(double-reg double-stack)) ) ; EVAL-WHEN ;;;; miscellaneous TNs for the various registers @@ -348,8 +346,9 @@ (dolist (reg-name reg-names) (let ((tn-name (symbolicate reg-name "-TN")) (offset-name (symbolicate reg-name "-OFFSET"))) - ;; FIXME: Couldn't shouldn't this be DEFCONSTANT - ;; instead of DEFPARAMETER? + ;; FIXME: It'd be good to have the special + ;; variables here be named with the *FOO* + ;; convention. (forms `(defparameter ,tn-name (make-random-tn :kind :normal :sc (sc-or-lose ',sc-name) @@ -366,7 +365,7 @@ (defparameter *register-arg-tns* (mapcar (lambda (register-arg-name) (symbol-value (symbolicate register-arg-name "-TN"))) - register-arg-names)) + *register-arg-names*)) ;;; FIXME: doesn't seem to be used in SBCL #| @@ -377,13 +376,12 @@ :offset 31)) ; Offset doesn't get used. |# -;;; IMMEDIATE-CONSTANT-SC -;;; -;;; 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) +;;; 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 - ((or fixnum #-sb-xc-host system-area-pointer character) + ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum) + #-sb-xc-host system-area-pointer character) (sc-number-or-lose 'immediate)) (symbol (when (static-symbol-p value) @@ -407,28 +405,26 @@ ;;;; miscellaneous function call parameters ;;; offsets of special stack frame locations -(defconstant ocfp-save-offset 0) -(defconstant return-pc-save-offset 1) -(defconstant code-save-offset 2) +(def!constant ocfp-save-offset 0) +(def!constant return-pc-save-offset 1) +(def!constant code-save-offset 2) ;;; FIXME: This is a bad comment (changed since when?) and there are others ;;; like it in this file. It'd be nice to clarify them. Failing that deleting ;;; them or flagging them with KLUDGE might be better than nothing. ;;; ;;; names of these things seem to have changed. these aliases by jrd -(defconstant lra-save-offset return-pc-save-offset) +(def!constant lra-save-offset return-pc-save-offset) -(defconstant cfp-offset ebp-offset) ; pfw - needed by stuff in /code +(def!constant cfp-offset ebp-offset) ; pfw - needed by stuff in /code ; related to signal context stuff -;;; SINGLE-VALUE-RETURN-BYTE-OFFSET -;;; ;;; This is used by the debugger. -(defconstant single-value-return-byte-offset 2) +(def!constant single-value-return-byte-offset 2) ;;; 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) +(!def-vm-support-routine location-print-name (tn) (declare (type tn tn)) (let* ((sc (tn-sc tn)) (sb (sb-name (sc-sb sc))) @@ -436,26 +432,32 @@ (ecase sb (registers (let* ((sc-name (sc-name sc)) - (name-vec (cond ((member sc-name byte-sc-names) + (name-vec (cond ((member sc-name *byte-sc-names*) *byte-register-names*) - ((member sc-name word-sc-names) + ((member sc-name *word-sc-names*) *word-register-names*) - ((member sc-name dword-sc-names) + ((member sc-name *dword-sc-names*) *dword-register-names*)))) (or (and name-vec (< -1 offset (length name-vec)) (svref name-vec offset)) ;; FIXME: Shouldn't this be an ERROR? - (format nil "" offset sc-name)))) + (format nil "" offset sc-name)))) (float-registers (format nil "FR~D" offset)) (stack (format nil "S~D" offset)) (constant (format nil "Const~D" offset)) (immediate-constant "Immed") (noise (symbol-name (sc-name sc)))))) ;;; FIXME: Could this, and everything that uses it, be made #!+SB-SHOW? + ;;; The loader uses this to convert alien names to the form they need in ;;; the symbol table (for example, prepending an underscore). (defun extern-alien-name (name) - (declare (type simple-string 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))))))