X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fvm.lisp;h=39924ff8dec9b5442c8defe7a77eee765f8fd24f;hb=3b98d369be67b42cbd823af9c6df55ac9601bfa9;hp=92f537da989593148e375ef0c28c0bb7654af41b;hpb=ec2616d216958a608581802c47496c0194478dc8;p=sbcl.git diff --git a/src/compiler/x86/vm.lisp b/src/compiler/x86/vm.lisp index 92f537d..39924ff 100644 --- a/src/compiler/x86/vm.lisp +++ b/src/compiler/x86/vm.lisp @@ -24,24 +24,24 @@ (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 :load-toplevel :execute) + (let ((offset-sym (symbolicate name "-OFFSET")) + (names-vector (symbolicate "*" size "-REGISTER-NAMES*"))) + `(progn + (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 - (defconstant ,offset-sym ,offset)) - (setf (svref ,names-vector ,offset-sym) - ,(symbol-name name))))) - ;; 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 :load-toplevel :execute) - (defparameter ,name - (list ,@(mapcar (lambda (name) - (symbolicate name "-OFFSET")) - regs)))))) + (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 related *FOO-REGISTER-NAMES* variable. + (defregset (name &rest regs) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter ,name + (list ,@(mapcar (lambda (name) + (symbolicate name "-OFFSET")) + regs)))))) ;; byte registers ;; @@ -94,7 +94,7 @@ ;; 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 (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *register-arg-names* '(edx edi esi))) @@ -118,7 +118,7 @@ ;;; the new way: (define-storage-base float-registers :finite :size 8) -(define-storage-base stack :unbounded :size 8) +(define-storage-base stack :unbounded :size 4 :size-increment 1) (define-storage-base constant :non-packed) (define-storage-base immediate-constant :non-packed) (define-storage-base noise :unbounded :size 2) @@ -132,12 +132,12 @@ (collect ((forms)) (let ((index 0)) (dolist (class classes) - (let* ((sc-name (car class)) - (constant-name (symbolicate sc-name "-SC-NUMBER"))) - (forms `(define-storage-class ,sc-name ,index - ,@(cdr class))) - (forms `(defconstant ,constant-name ,index)) - (incf index)))) + (let* ((sc-name (car class)) + (constant-name (symbolicate sc-name "-SC-NUMBER"))) + (forms `(define-storage-class ,sc-name ,index + ,@(cdr class))) + (forms `(def!constant ,constant-name ,index)) + (incf index)))) `(progn ,@(forms)))) @@ -160,7 +160,8 @@ ;;; (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) - (defconstant kludge-nondeterministic-catch-block-size 6)) + (def!constant kludge-nondeterministic-catch-block-size + #!-win32 5 #!+win32 7)) (!define-storage-classes @@ -169,29 +170,30 @@ ;; some FP constants can be generated in the i387 silicon (fp-constant immediate-constant) - + (fp-single-immediate immediate-constant) + (fp-double-immediate immediate-constant) (immediate immediate-constant) ;; ;; the stacks ;; - + ;; the control stack - (control-stack stack) ; may be pointers, scanned by GC + (control-stack stack) ; may be pointers, scanned by GC ;; the non-descriptor stacks - (signed-stack stack) ; (signed-byte 32) - (unsigned-stack stack) ; (unsigned-byte 32) - (base-char-stack stack) ; non-descriptor characters. - (sap-stack stack) ; System area pointers. - (single-stack stack) ; single-floats - (double-stack stack :element-size 2) ; double-floats. + (signed-stack stack) ; (signed-byte 32) + (unsigned-stack stack) ; (unsigned-byte 32) + (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. #!+long-float - (long-stack stack :element-size 3) ; long-floats. - (complex-single-stack stack :element-size 2) ; complex-single-floats - (complex-double-stack stack :element-size 4) ; complex-double-floats + (long-stack stack :element-size 3) ; long-floats. + (complex-single-stack stack :element-size 2) ; complex-single-floats + (complex-double-stack stack :element-size 4) ; complex-double-floats #!+long-float - (complex-long-stack stack :element-size 6) ; complex-long-floats + (complex-long-stack stack :element-size 6) ; complex-long-floats ;; ;; magic SCs @@ -211,122 +213,128 @@ ;; 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* - :element-size 2 -; :reserve-locations (#.eax-offset) - :constant-scs (immediate) - :save-p t - :alternate-scs (control-stack)) + :locations #.*dword-regs* + :element-size 2 +; :reserve-locations (#.eax-offset) + :constant-scs (immediate) + :save-p t + :alternate-scs (control-stack)) ;; pointer descriptor objects -- must be seen by GC (descriptor-reg registers - :locations #.*dword-regs* - :element-size 2 -; :reserve-locations (#.eax-offset) - :constant-scs (constant immediate) - :save-p t - :alternate-scs (control-stack)) + :locations #.*dword-regs* + :element-size 2 +; :reserve-locations (#.eax-offset) + :constant-scs (constant immediate) + :save-p t + :alternate-scs (control-stack)) ;; non-descriptor characters - (base-char-reg registers - :locations #.*byte-regs* - :reserve-locations (#.ah-offset #.al-offset) - :constant-scs (immediate) - :save-p t - :alternate-scs (base-char-stack)) + (character-reg registers + :locations #!-sb-unicode #.*byte-regs* + #!+sb-unicode #.*dword-regs* + #!+sb-unicode #!+sb-unicode + :element-size 2 + #!-sb-unicode #!-sb-unicode + :reserve-locations (#.ah-offset #.al-offset) + :constant-scs (immediate) + :save-p t + :alternate-scs (character-stack)) ;; non-descriptor SAPs (arbitrary pointers into address space) (sap-reg registers - :locations #.*dword-regs* - :element-size 2 -; :reserve-locations (#.eax-offset) - :constant-scs (immediate) - :save-p t - :alternate-scs (sap-stack)) + :locations #.*dword-regs* + :element-size 2 +; :reserve-locations (#.eax-offset) + :constant-scs (immediate) + :save-p t + :alternate-scs (sap-stack)) ;; non-descriptor (signed or unsigned) numbers (signed-reg registers - :locations #.*dword-regs* - :element-size 2 -; :reserve-locations (#.eax-offset) - :constant-scs (immediate) - :save-p t - :alternate-scs (signed-stack)) + :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* - :element-size 2 -; :reserve-locations (#.eax-offset) - :constant-scs (immediate) - :save-p t - :alternate-scs (unsigned-stack)) + :locations #.*dword-regs* + :element-size 2 +; :reserve-locations (#.eax-offset) + :constant-scs (immediate) + :save-p t + :alternate-scs (unsigned-stack)) ;; miscellaneous objects that must not be seen by GC. Used only as ;; temporaries. (word-reg registers - :locations #.*word-regs* - :element-size 2 -; :reserve-locations (#.ax-offset) - ) + :locations #.*word-regs* + :element-size 2 +; :reserve-locations (#.ax-offset) + ) (byte-reg registers - :locations #.*byte-regs* -; :reserve-locations (#.al-offset #.ah-offset) - ) + :locations #.*byte-regs* +; :reserve-locations (#.al-offset #.ah-offset) + ) ;; that can go in the floating point registers ;; non-descriptor SINGLE-FLOATs (single-reg float-registers - :locations (0 1 2 3 4 5 6 7) - :constant-scs (fp-constant) - :save-p t - :alternate-scs (single-stack)) + :locations (0 1 2 3 4 5 6 7) + :constant-scs (fp-constant fp-single-immediate) + :save-p t + :alternate-scs (single-stack)) ;; non-descriptor DOUBLE-FLOATs (double-reg float-registers - :locations (0 1 2 3 4 5 6 7) - :constant-scs (fp-constant) - :save-p t - :alternate-scs (double-stack)) + :locations (0 1 2 3 4 5 6 7) + :constant-scs (fp-constant fp-double-immediate) + :save-p t + :alternate-scs (double-stack)) ;; non-descriptor LONG-FLOATs #!+long-float (long-reg float-registers - :locations (0 1 2 3 4 5 6 7) - :constant-scs (fp-constant) - :save-p t - :alternate-scs (long-stack)) + :locations (0 1 2 3 4 5 6 7) + :constant-scs (fp-constant) + :save-p t + :alternate-scs (long-stack)) (complex-single-reg float-registers - :locations (0 2 4 6) - :element-size 2 - :constant-scs () - :save-p t - :alternate-scs (complex-single-stack)) + :locations (0 2 4 6) + :element-size 2 + :constant-scs () + :save-p t + :alternate-scs (complex-single-stack)) (complex-double-reg float-registers - :locations (0 2 4 6) - :element-size 2 - :constant-scs () - :save-p t - :alternate-scs (complex-double-stack)) + :locations (0 2 4 6) + :element-size 2 + :constant-scs () + :save-p t + :alternate-scs (complex-double-stack)) #!+long-float (complex-long-reg float-registers - :locations (0 2 4 6) - :element-size 2 - :constant-scs () - :save-p t - :alternate-scs (complex-long-stack)) + :locations (0 2 4 6) + :element-size 2 + :constant-scs () + :save-p t + :alternate-scs (complex-long-stack)) ;; a catch or unwind block (catch-block stack :element-size kludge-nondeterministic-catch-block-size)) (eval-when (:compile-toplevel :load-toplevel :execute) -(defparameter *byte-sc-names* '(base-char-reg byte-reg base-char-stack)) +(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... ;;; @@ -338,19 +346,19 @@ ;;;; miscellaneous TNs for the various registers (macrolet ((def-misc-reg-tns (sc-name &rest reg-names) - (collect ((forms)) - (dolist (reg-name reg-names) - (let ((tn-name (symbolicate reg-name "-TN")) - (offset-name (symbolicate reg-name "-OFFSET"))) - ;; 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) - :offset - ,offset-name))))) - `(progn ,@(forms))))) + (collect ((forms)) + (dolist (reg-name reg-names) + (let ((tn-name (symbolicate reg-name "-TN")) + (offset-name (symbolicate reg-name "-OFFSET"))) + ;; 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) + :offset + ,offset-name))))) + `(progn ,@(forms))))) (def-misc-reg-tns unsigned-reg eax ebx ecx edx ebp esp edi esi) (def-misc-reg-tns word-reg ax bx cx dx bp sp di si) @@ -360,94 +368,154 @@ ;;; TNs for registers used to pass arguments (defparameter *register-arg-tns* (mapcar (lambda (register-arg-name) - (symbol-value (symbolicate register-arg-name "-TN"))) - *register-arg-names*)) + (symbol-value (symbolicate register-arg-name "-TN"))) + *register-arg-names*)) ;;; FIXME: doesn't seem to be used in SBCL #| ;;; added by pw (defparameter fp-constant-tn (make-random-tn :kind :normal - :sc (sc-or-lose 'fp-constant) - :offset 31)) ; Offset doesn't get used. + :sc (sc-or-lose 'fp-constant) + :offset 31)) ; Offset doesn't get used. |# ;;; 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) +(defun 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) + character) (sc-number-or-lose 'immediate)) (symbol (when (static-symbol-p value) (sc-number-or-lose 'immediate))) (single-float - (when (or (eql value 0f0) (eql value 1f0)) - (sc-number-or-lose 'fp-constant))) + (case value + ((0f0 1f0) (sc-number-or-lose 'fp-constant)) + (t (sc-number-or-lose 'fp-single-immediate)))) (double-float - (when (or (eql value 0d0) (eql value 1d0)) - (sc-number-or-lose 'fp-constant))) + (case value + ((0d0 1d0) (sc-number-or-lose 'fp-constant)) + (t (sc-number-or-lose 'fp-double-immediate)))) #!+long-float (long-float - (when (or (eql value 0l0) (eql value 1l0) - (eql value pi) - (eql value (log 10l0 2l0)) - (eql value (log 2.718281828459045235360287471352662L0 2l0)) - (eql value (log 2l0 10l0)) - (eql value (log 2l0 2.718281828459045235360287471352662L0))) - (sc-number-or-lose 'fp-constant))))) + (when (or (eql value 0l0) (eql value 1l0) + (eql value pi) + (eql value (log 10l0 2l0)) + (eql value (log 2.718281828459045235360287471352662L0 2l0)) + (eql value (log 2l0 10l0)) + (eql value (log 2l0 2.718281828459045235360287471352662L0))) + (sc-number-or-lose 'fp-constant))))) + +(defun boxed-immediate-sc-p (sc) + (eql sc (sc-number-or-lose 'immediate))) + +;; For an immediate TN, return its value encoded for use as a literal. +;; For any other TN, return the TN. Only works for FIXNUMs, +;; STATIC-SYMBOLs, and CHARACTERS (FLOATs and SAPs are handled +;; elsewhere). +(defun encode-value-if-immediate (tn) + (if (sc-is tn immediate) + (let ((val (tn-value tn))) + (etypecase val + (integer (fixnumize val)) + (symbol (+ nil-value (static-symbol-offset val))) + (character (logior (ash (char-code val) n-widetag-bits) + character-widetag)))) + tn)) ;;;; 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) +;;; Offsets of special stack frame locations relative to EBP. +;;; +;;; Consider the standard prologue PUSH EBP; MOV EBP, ESP: the return +;;; address is at EBP+4, the old control stack frame pointer is at +;;; EBP, the magic 3rd slot is at EBP-4. Then come the locals from +;;; EBP-8 on. +(def!constant return-pc-save-offset 0) +(def!constant ocfp-save-offset 1) +;;; Let SP be the stack pointer before CALLing, and FP is the frame +;;; pointer after the standard prologue. SP + +;;; FRAME-WORD-OFFSET(SP->FP-OFFSET + I) = FP + FRAME-WORD-OFFSET(I). +(def!constant sp->fp-offset 2) + +(declaim (inline frame-word-offset)) +(defun frame-word-offset (index) + (- (1- index))) + +(declaim (inline frame-byte-offset)) +(defun frame-byte-offset (index) + (* (frame-word-offset index) n-word-bytes)) ;;; 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 - ; related to signal context stuff +(def!constant cfp-offset ebp-offset) ; pfw - needed by stuff in /code + ; related to signal context stuff ;;; 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) +(defun location-print-name (tn) (declare (type tn tn)) (let* ((sc (tn-sc tn)) - (sb (sb-name (sc-sb sc))) - (offset (tn-offset tn))) + (sb (sb-name (sc-sb sc))) + (offset (tn-offset tn))) (ecase sb (registers (let* ((sc-name (sc-name sc)) - (name-vec (cond ((member sc-name *byte-sc-names*) - *byte-register-names*) - ((member sc-name *word-sc-names*) - *word-register-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)))) + (name-vec (cond ((member sc-name *byte-sc-names*) + *byte-register-names*) + ((member sc-name *word-sc-names*) + *word-register-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)))) (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)) - ;; On the X86 we don't do anything. - name) + +(defun combination-implementation-style (node) + (declare (type sb!c::combination node)) + (flet ((valid-funtype (args result) + (sb!c::valid-fun-use node + (sb!c::specifier-type + `(function ,args ,result))))) + (case (sb!c::combination-fun-source-name node) + (logtest + (cond + ((valid-funtype '(fixnum fixnum) '*) + (values :maybe nil)) + ((valid-funtype '((signed-byte 32) (signed-byte 32)) '*) + (values :maybe nil)) + ((valid-funtype '((unsigned-byte 32) (unsigned-byte 32)) '*) + (values :maybe nil)) + (t (values :default nil)))) + (logbitp + (cond + ((and (valid-funtype '((integer 0 29) fixnum) '*) + (sb!c::constant-lvar-p (first (sb!c::basic-combination-args node)))) + (values :transform '(lambda (index integer) + (%logbitp integer index)))) + ((valid-funtype '((integer 0 31) (signed-byte 32)) '*) + (values :transform '(lambda (index integer) + (%logbitp integer index)))) + ((valid-funtype '((integer 0 31) (unsigned-byte 32)) '*) + (values :transform '(lambda (index integer) + (%logbitp integer index)))) + (t (values :default nil)))) + (t (values :default nil)))))