X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fx86-64%2Fvm.lisp;h=44a68b1b177c3d7dc7112a0c962f5094fc253ac7;hb=69d60b456b07a0256f08df0d02484f361ce5737c;hp=25c736db3ab434c37b76b6b2a87fe94200e3fd45;hpb=4ebdc81b1a9c6dbed6e98b112afc8dd32b17a2dd;p=sbcl.git diff --git a/src/compiler/x86-64/vm.lisp b/src/compiler/x86-64/vm.lisp index 25c736d..44a68b1 100644 --- a/src/compiler/x86-64/vm.lisp +++ b/src/compiler/x86-64/vm.lisp @@ -18,11 +18,11 @@ ;;;; register specs (eval-when (:compile-toplevel :load-toplevel :execute) - (defvar *byte-register-names* (make-array 8 :initial-element nil)) + (defvar *byte-register-names* (make-array 32 :initial-element nil)) (defvar *word-register-names* (make-array 16 :initial-element nil)) (defvar *dword-register-names* (make-array 16 :initial-element nil)) (defvar *qword-register-names* (make-array 32 :initial-element nil)) - (defvar *float-register-names* (make-array 8 :initial-element nil))) + (defvar *float-register-names* (make-array 16 :initial-element nil))) (macrolet ((defreg (name offset size) (let ((offset-sym (symbolicate name "-OFFSET")) @@ -49,15 +49,29 @@ ;; 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) - (defreg ch 3 :byte) - (defreg dl 4 :byte) - (defreg dh 5 :byte) - (defreg bl 6 :byte) - (defreg bh 7 :byte) - (defregset *byte-regs* al ah cl ch dl dh bl bh) + ;; + ;; High-byte are registers disabled on AMD64, since they can't be + ;; encoded for an op that has a REX-prefix and we don't want to + ;; add special cases into the code generation. The overlap doesn't + ;; therefore exist anymore, but the numbering hasn't been changed + ;; to reflect this. + (defreg al 0 :byte) + (defreg cl 2 :byte) + (defreg dl 4 :byte) + (defreg bl 6 :byte) + (defreg sil 12 :byte) + (defreg dil 14 :byte) + (defreg r8b 16 :byte) + (defreg r9b 18 :byte) + (defreg r10b 20 :byte) + (defreg r11b 22 :byte) + (defreg r12b 24 :byte) + (defreg r13b 26 :byte) + (defreg r14b 28 :byte) + (defreg r15b 30 :byte) + (defregset *byte-regs* + al cl dl bl sil dil r8b r9b r10b + r11b #+nil r12b #+nil r13b r14b r15b) ;; word registers (defreg ax 0 :word) @@ -102,15 +116,24 @@ r8 r9 r10 r11 #+nil r12 #+nil r13 r14 r15) ;; floating point registers - (defreg fr0 0 :float) - (defreg fr1 1 :float) - (defreg fr2 2 :float) - (defreg fr3 3 :float) - (defreg fr4 4 :float) - (defreg fr5 5 :float) - (defreg fr6 6 :float) - (defreg fr7 7 :float) - (defregset *float-regs* fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7) + (defreg float0 0 :float) + (defreg float1 1 :float) + (defreg float2 2 :float) + (defreg float3 3 :float) + (defreg float4 4 :float) + (defreg float5 5 :float) + (defreg float6 6 :float) + (defreg float7 7 :float) + (defreg float8 8 :float) + (defreg float9 9 :float) + (defreg float10 10 :float) + (defreg float11 11 :float) + (defreg float12 12 :float) + (defreg float13 13 :float) + (defreg float14 14 :float) + (defreg float15 15 :float) + (defregset *float-regs* float0 float1 float2 float3 float4 float5 float6 float7 + float8 float9 float10 float11 float12 float13 float14 float15) ;; registers used to pass arguments ;; @@ -119,7 +142,8 @@ ;; names and offsets for registers used to pass arguments (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *register-arg-names* '(rdx rdi rsi))) - (defregset *register-arg-offsets* rdx rdi rsi)) + (defregset *register-arg-offsets* rdx rdi rsi) + (defregset *c-call-register-arg-offsets* rdi rsi rdx rcx r8 r9)) ;;;; SB definitions @@ -131,9 +155,7 @@ ;;; words in a dword register. (define-storage-base registers :finite :size 32) -;;; I suspect we should do fp with SSE instead of the old x86 stuff, -;;; but for the time being - -(define-storage-base float-registers :finite :size 8) +(define-storage-base float-registers :finite :size 16) (define-storage-base stack :unbounded :size 8) (define-storage-base constant :non-packed) @@ -184,8 +206,8 @@ ;; non-immediate constants in the constant pool (constant constant) - ;; some FP constants can be generated in the i387 silicon - (fp-constant immediate-constant) + (fp-single-zero immediate-constant) + (fp-double-zero immediate-constant) (immediate immediate-constant) @@ -200,12 +222,12 @@ ;; XXX alpha backend has :element-size 2 :alignment 2 in these entries (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. + (double-stack stack) (complex-single-stack stack :element-size 2) ; complex-single-floats - (complex-double-stack stack :element-size 4) ; complex-double-floats + (complex-double-stack stack :element-size 2) ; complex-double-floats ;; @@ -242,12 +264,14 @@ :alternate-scs (control-stack)) ;; non-descriptor characters - (base-char-reg registers - :locations #.*byte-regs* - :reserve-locations (#.ah-offset #.al-offset) + (character-reg registers + :locations #!-sb-unicode #.*byte-regs* + #!+sb-unicode #.*qword-regs* + #!-sb-unicode #!-sb-unicode + :reserve-locations (#.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 @@ -290,27 +314,27 @@ ;; non-descriptor SINGLE-FLOATs (single-reg float-registers - :locations (0 1 2 3 4 5 6 7) - :constant-scs (fp-constant) + :locations #.(loop for i from 0 below 15 collect i) + :constant-scs (fp-single-zero) :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) + :locations #.(loop for i from 0 below 15 collect i) + :constant-scs (fp-double-zero) :save-p t :alternate-scs (double-stack)) (complex-single-reg float-registers - :locations (0 2 4 6) + :locations #.(loop for i from 0 to 14 by 2 collect i) :element-size 2 :constant-scs () :save-p t :alternate-scs (complex-single-stack)) (complex-double-reg float-registers - :locations (0 2 4 6) + :locations #.(loop for i from 0 to 14 by 2 collect i) :element-size 2 :constant-scs () :save-p t @@ -320,12 +344,14 @@ (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* '(dword-reg)) (defparameter *qword-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... ;;; @@ -355,8 +381,11 @@ r8 r9 r10 r11 r12 r13 r14 r15) (def-misc-reg-tns dword-reg eax ebx ecx edx ebp esp edi esi) (def-misc-reg-tns word-reg ax bx cx dx bp sp di si) - (def-misc-reg-tns byte-reg al ah bl bh cl ch dl dh) - (def-misc-reg-tns single-reg fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7)) + (def-misc-reg-tns byte-reg al cl dl bl sil dil r8b r9b r10b + r11b r14b r15b) + (def-misc-reg-tns single-reg + float0 float1 float2 float3 float4 float5 float6 float7 + float8 float9 float10 float11 float12 float13 float14 float15)) ;;; TNs for registers used to pass arguments (defparameter *register-arg-tns* @@ -364,15 +393,17 @@ (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 + +(defparameter fp-single-zero-tn (make-random-tn :kind :normal - :sc (sc-or-lose 'fp-constant) - :offset 31)) ; Offset doesn't get used. -|# - + :sc (sc-or-lose 'single-reg) + :offset 15)) + +(defparameter fp-double-zero-tn + (make-random-tn :kind :normal + :sc (sc-or-lose 'double-reg) + :offset 15)) + ;;; 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) @@ -384,20 +415,14 @@ (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))) + (if (eql value 0f0) + (sc-number-or-lose 'fp-single-zero ) + nil)) (double-float - (when (or (eql value 0d0) (eql value 1d0)) - (sc-number-or-lose 'fp-constant))) - #!+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))))) + (if (eql value 0d0) + (sc-number-or-lose 'fp-double-zero ) + nil)))) + ;;;; miscellaneous function call parameters @@ -406,19 +431,10 @@ (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 -(def!constant lra-save-offset return-pc-save-offset) - -#+nil -(def!constant cfp-offset ebp-offset) ; pfw - needed by stuff in /code - ; related to signal context stuff +(def!constant lra-save-offset return-pc-save-offset) ; ? ;;; This is used by the debugger. -(def!constant single-value-return-byte-offset 2) +(def!constant single-value-return-byte-offset 3) ;;; 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. @@ -443,24 +459,22 @@ (svref name-vec offset)) ;; FIXME: Shouldn't this be an ERROR? (format nil "" offset sc-name)))) - (float-registers (format nil "FR~D" offset)) + (float-registers (format nil "FLOAT~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-base-string name)) - ;; OpenBSD is non-ELF, and needs a _ prefix - #!+openbsd (concatenate 'string "_" name) - ;; The other (ELF) ports currently don't need any prefix - #!-openbsd name) - (defun dwords-for-quad (value) (let* ((lo (logand value (1- (ash 1 32)))) - (hi (ash (- value lo) -32))) + (hi (ash value -32))) (values lo hi))) + +(defun words-for-dword (value) + (let* ((lo (logand value (1- (ash 1 16)))) + (hi (ash value -16))) + (values lo hi))) + +(def!constant cfp-offset rbp-offset) ; pfw - needed by stuff in /code +