fix unthreaded non-x86oid builds

[sbcl.git] / src / compiler / x86-64 / vm.lisp

diff --git a/src/compiler/x86-64/vm.lisp b/src/compiler/x86-64/vm.lisp
index fd8b94b..a19f45c 100644 (file)
--- a/src/compiler/x86-64/vm.lisp
+++ b/src/compiler/x86-64/vm.lisp
@@ -19,30 +19,30 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defvar *byte-register-names* (make-array 32 :initial-element nil))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (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 *word-register-names* (make-array 32 :initial-element nil))
+  (defvar *dword-register-names* (make-array 32 :initial-element nil))

   (defvar *qword-register-names* (make-array 32 :initial-element nil))
   (defvar *float-register-names* (make-array 16 :initial-element nil)))
 
 (macrolet ((defreg (name offset size)
   (defvar *qword-register-names* (make-array 32 :initial-element nil))
   (defvar *float-register-names* (make-array 16 :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
                     ;; 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 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
   ;;
 
   ;; byte registers
   ;;

@@ -71,7 +71,7 @@
   (defreg r15b 30 :byte)
   (defregset *byte-regs*
       al cl dl bl sil dil r8b r9b r10b
   (defreg r15b 30 :byte)
   (defregset *byte-regs*
       al cl dl bl sil dil r8b r9b r10b

-      r11b #+nil r12b #+nil r13b r14b r15b)
+      #+nil r11b #+nil r12b r13b r14b r15b)

 
   ;; word registers
   (defreg ax 0 :word)
 
   ;; word registers
   (defreg ax 0 :word)

@@ -82,7 +82,16 @@
   (defreg bp 10 :word)
   (defreg si 12 :word)
   (defreg di 14 :word)
   (defreg bp 10 :word)
   (defreg si 12 :word)
   (defreg di 14 :word)

-  (defregset *word-regs* ax cx dx bx si di)
+  (defreg r8w  16 :word)
+  (defreg r9w  18 :word)
+  (defreg r10w 20 :word)
+  (defreg r11w 22 :word)
+  (defreg r12w 24 :word)
+  (defreg r13w 26 :word)
+  (defreg r14w 28 :word)
+  (defreg r15w 30 :word)
+  (defregset *word-regs* ax cx dx bx si di r8w r9w r10w
+             #+nil r11w #+nil r12w r13w r14w r15w)

 
   ;; double word registers
   (defreg eax 0 :dword)
 
   ;; double word registers
   (defreg eax 0 :dword)

@@ -93,7 +102,16 @@
   (defreg ebp 10 :dword)
   (defreg esi 12 :dword)
   (defreg edi 14 :dword)
   (defreg ebp 10 :dword)
   (defreg esi 12 :dword)
   (defreg edi 14 :dword)

-  (defregset *dword-regs* eax ecx edx ebx esi edi)
+  (defreg r8d  16 :dword)
+  (defreg r9d  18 :dword)
+  (defreg r10d 20 :dword)
+  (defreg r11d 22 :dword)
+  (defreg r12d 24 :dword)
+  (defreg r13d 26 :dword)
+  (defreg r14d 28 :dword)
+  (defreg r15d 30 :dword)
+  (defregset *dword-regs* eax ecx edx ebx esi edi r8d r9d r10d
+             #+nil r11d #+nil r12w r13d r14d r15d)

 
   ;; quadword registers
   (defreg rax 0 :qword)
 
   ;; quadword registers
   (defreg rax 0 :qword)

@@ -112,8 +130,17 @@
   (defreg r13 26 :qword)
   (defreg r14 28 :qword)
   (defreg r15 30 :qword)
   (defreg r13 26 :qword)
   (defreg r14 28 :qword)
   (defreg r15 30 :qword)

-  (defregset *qword-regs* rax rcx rdx rbx rsi rdi 
-            r8 r9 r10 r11 #+nil r12 #+nil r13 r14 r15)
+  ;; for no good reason at the time, r12 and r13 were missed from the
+  ;; list of qword registers.  However
+  ;; <jsnell> r13 is already used as temporary [#lisp irc 2005/01/30]
+  ;; and we're now going to use r12 for the struct thread*
+  ;;
+  ;; Except that now we use r11 instead of r13 as the temporary,
+  ;; since it's got a more compact encoding than r13, and experimentally
+  ;; the temporary gets used more than the other registers that are never
+  ;; wired. -- JES, 2005-11-02
+  (defregset *qword-regs* rax rcx rdx rbx rsi rdi
+             r8 r9 r10 #+nil r11 #+nil r12 r13  r14 r15)

 
   ;; floating point registers
   (defreg float0 0 :float)
 
   ;; floating point registers
   (defreg float0 0 :float)

@@ -133,7 +160,7 @@
   (defreg float14 14 :float)
   (defreg float15 15 :float)
   (defregset *float-regs* float0 float1 float2 float3 float4 float5 float6 float7
   (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)
+             float8 float9 float10 float11 float12 float13 float14 float15)

 
   ;; registers used to pass arguments
   ;;
 
   ;; registers used to pass arguments
   ;;

@@ -171,12 +198,12 @@
   (collect ((forms))
     (let ((index 0))
       (dolist (class classes)
   (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 `(def!constant ,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))))
 
     `(progn
        ,@(forms))))
 

@@ -199,7 +226,7 @@
 ;;; (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)
 ;;; (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))
+  (def!constant kludge-nondeterministic-catch-block-size 5))

 
 (!define-storage-classes
 
 
 (!define-storage-classes
 

@@ -208,26 +235,33 @@
 
   (fp-single-zero immediate-constant)
   (fp-double-zero immediate-constant)
 
   (fp-single-zero immediate-constant)
   (fp-double-zero immediate-constant)

+  (fp-complex-single-zero immediate-constant)
+  (fp-complex-double-zero immediate-constant)
+
+  (fp-single-immediate immediate-constant)
+  (fp-double-immediate immediate-constant)
+  (fp-complex-single-immediate immediate-constant)
+  (fp-complex-double-immediate immediate-constant)

 
   (immediate immediate-constant)
 
   ;;
   ;; the stacks
   ;;
 
   (immediate immediate-constant)
 
   ;;
   ;; the stacks
   ;;

-  
+

   ;; the control stack
   ;; 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
   ;; XXX alpha backend has :element-size 2 :alignment 2 in these entries
 
   ;; the non-descriptor stacks
   ;; XXX alpha backend has :element-size 2 :alignment 2 in these entries

-  (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
+  (signed-stack stack)                  ; (signed-byte 64)
+  (unsigned-stack stack)                ; (unsigned-byte 64)
+  (character-stack stack)               ; non-descriptor characters.
+  (sap-stack stack)                     ; System area pointers.
+  (single-stack stack)                  ; single-floats

   (double-stack stack)
   (double-stack stack)

-  (complex-single-stack stack :element-size 2) ; complex-single-floats
-  (complex-double-stack stack :element-size 2) ; complex-double-floats
+  (complex-single-stack stack)  ; complex-single-floats
+  (complex-double-stack stack :element-size 2)  ; complex-double-floats

 
 
   ;;
 
 
   ;;

@@ -248,109 +282,109 @@
   ;; 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
   ;; 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 #.*qword-regs*
-          :element-size 2 ; I think this is for the al/ah overlap thing
-          :constant-scs (immediate)
-          :save-p t
-          :alternate-scs (control-stack))
+           :locations #.*qword-regs*
+           :element-size 2 ; I think this is for the al/ah overlap thing
+           :constant-scs (immediate)
+           :save-p t
+           :alternate-scs (control-stack))

 
   ;; pointer descriptor objects -- must be seen by GC
   (descriptor-reg registers
 
   ;; pointer descriptor objects -- must be seen by GC
   (descriptor-reg registers

-                 :locations #.*qword-regs*
-                 :element-size 2
-;                :reserve-locations (#.eax-offset)
-                 :constant-scs (constant immediate)
-                 :save-p t
-                 :alternate-scs (control-stack))
+                  :locations #.*qword-regs*
+                  :element-size 2
+;                 :reserve-locations (#.eax-offset)
+                  :constant-scs (constant immediate)
+                  :save-p t
+                  :alternate-scs (control-stack))

 
   ;; non-descriptor characters
   (character-reg registers
 
   ;; non-descriptor characters
   (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 (character-stack))
+                 :locations #!-sb-unicode #.*byte-regs*
+                            #!+sb-unicode #.*qword-regs*
+                 #!+sb-unicode #!+sb-unicode
+                 :element-size 2
+                 #!-sb-unicode #!-sb-unicode
+                 :reserve-locations (#.al-offset)
+                 :constant-scs (immediate)
+                 :save-p t
+                 :alternate-scs (character-stack))

 
   ;; non-descriptor SAPs (arbitrary pointers into address space)
   (sap-reg registers
 
   ;; non-descriptor SAPs (arbitrary pointers into address space)
   (sap-reg registers

-          :locations #.*qword-regs*
-          :element-size 2
-;         :reserve-locations (#.eax-offset)
-          :constant-scs (immediate)
-          :save-p t
-          :alternate-scs (sap-stack))
+           :locations #.*qword-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
 
   ;; non-descriptor (signed or unsigned) numbers
   (signed-reg registers

-             :locations #.*qword-regs*
-             :element-size 2
-             :constant-scs (immediate)
-             :save-p t
-             :alternate-scs (signed-stack))
+              :locations #.*qword-regs*
+              :element-size 2
+              :constant-scs (immediate)
+              :save-p t
+              :alternate-scs (signed-stack))

   (unsigned-reg registers
   (unsigned-reg registers

-               :locations #.*qword-regs*
-               :element-size 2
-               :constant-scs (immediate)
-               :save-p t
-               :alternate-scs (unsigned-stack))
+                :locations #.*qword-regs*
+                :element-size 2
+                :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
 
   ;; miscellaneous objects that must not be seen by GC. Used only as
   ;; temporaries.
   (word-reg registers

-           :locations #.*word-regs*
-           :element-size 2
-           )
+            :locations #.*word-regs*
+            :element-size 2
+            )

   (dword-reg registers
   (dword-reg registers

-           :locations #.*dword-regs*
-           :element-size 2
-           )
+            :locations #.*dword-regs*
+            :element-size 2
+            )

   (byte-reg registers
   (byte-reg registers

-           :locations #.*byte-regs*
-           )
+            :locations #.*byte-regs*
+            )

 
   ;; that can go in the floating point registers
 
   ;; non-descriptor SINGLE-FLOATs
   (single-reg float-registers
 
   ;; that can go in the floating point registers
 
   ;; non-descriptor SINGLE-FLOATs
   (single-reg float-registers

-             :locations #.(loop for i from 0 below 15 collect i)
-             :constant-scs (fp-single-zero)
-             :save-p t
-             :alternate-scs (single-stack))
+              :locations #.*float-regs*
+              :constant-scs (fp-single-zero fp-single-immediate)
+              :save-p t
+              :alternate-scs (single-stack))

 
   ;; non-descriptor DOUBLE-FLOATs
   (double-reg float-registers
 
   ;; non-descriptor DOUBLE-FLOATs
   (double-reg float-registers

-             :locations #.(loop for i from 0 below 15 collect i)
-             :constant-scs (fp-double-zero)
-             :save-p t
-             :alternate-scs (double-stack))
+              :locations #.*float-regs*
+              :constant-scs (fp-double-zero fp-double-immediate)
+              :save-p t
+              :alternate-scs (double-stack))

 
   (complex-single-reg float-registers
 
   (complex-single-reg float-registers

-                     :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))
+                      :locations #.*float-regs*
+                      :constant-scs (fp-complex-single-zero fp-complex-single-immediate)
+                      :save-p t
+                      :alternate-scs (complex-single-stack))

 
   (complex-double-reg float-registers
 
   (complex-double-reg float-registers

-                     :locations #.(loop for i from 0 to 14 by 2 collect i)
-                     :element-size 2
-                     :constant-scs ()
-                     :save-p t
-                     :alternate-scs (complex-double-stack))
+                      :locations #.*float-regs*
+                      :constant-scs (fp-complex-double-zero fp-complex-double-immediate)
+                      :save-p t
+                      :alternate-scs (complex-double-stack))

 
   ;; a catch or unwind block
   (catch-block stack :element-size kludge-nondeterministic-catch-block-size))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 
   ;; 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* 
+(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))
   '(#!-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* 
+(defparameter *qword-sc-names*

   '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack
   '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack

-    signed-stack unsigned-stack sap-stack single-stack 
+    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...
     #!+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...

@@ -358,78 +392,117 @@
 ;;; These are used to (at least) determine operand size.
 (defparameter *float-sc-names* '(single-reg))
 (defparameter *double-sc-names* '(double-reg double-stack))
 ;;; These are used to (at least) determine operand size.
 (defparameter *float-sc-names* '(single-reg))
 (defparameter *double-sc-names* '(double-reg double-stack))

+(defparameter *complex-sc-names* '(complex-single-reg complex-single-stack
+                                   complex-double-reg complex-double-stack))

 ) ; EVAL-WHEN
 \f
 ;;;; miscellaneous TNs for the various registers
 
 (macrolet ((def-misc-reg-tns (sc-name &rest reg-names)
 ) ; EVAL-WHEN
 \f
 ;;;; 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 rax rbx rcx rdx rbp rsp rdi rsi
 
   (def-misc-reg-tns unsigned-reg rax rbx rcx rdx rbp rsp rdi rsi

-                   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)
+                    r8 r9 r10 r11 r12 r13 r14 r15)
+  (def-misc-reg-tns dword-reg eax ebx ecx edx ebp esp edi esi
+                    r8d r9d r10d r11d r12d r13d r14d r15d)
+  (def-misc-reg-tns word-reg ax bx cx dx bp sp di si
+                    r8w r9w r10w r11w r12w r13w r14w r15w)

   (def-misc-reg-tns byte-reg al cl dl bl sil dil r8b r9b r10b
   (def-misc-reg-tns byte-reg al cl dl bl sil dil r8b r9b r10b

-                   r11b r14b r15b)
-  (def-misc-reg-tns single-reg 
+                    r11b r12b r13b r14b r15b)
+  (def-misc-reg-tns single-reg

       float0 float1 float2 float3 float4 float5 float6 float7
       float8 float9 float10 float11 float12 float13 float14 float15))
 
       float0 float1 float2 float3 float4 float5 float6 float7
       float8 float9 float10 float11 float12 float13 float14 float15))
 

+(defun reg-in-size (tn size)
+  (make-random-tn :kind :normal
+                  :sc (sc-or-lose
+                       (ecase size
+                         (:byte 'byte-reg)
+                         (:word 'word-reg)
+                         (:dword 'dword-reg)
+                         (:qword 'unsigned-reg)))
+                  :offset (tn-offset tn)))
+
+;; A register that's never used by the code generator, and can therefore
+;; be used as an assembly temporary in cases where a VOP :TEMPORARY can't
+;; be used.
+(defparameter temp-reg-tn r11-tn)
+

 ;;; TNs for registers used to pass arguments
 (defparameter *register-arg-tns*
   (mapcar (lambda (register-arg-name)
 ;;; 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*))
-
-
-(defparameter fp-single-zero-tn
-  (make-random-tn :kind :normal
-                 :sc (sc-or-lose 'single-reg)
-                 :offset 15))
+            (symbol-value (symbolicate register-arg-name "-TN")))
+          *register-arg-names*))

 
 

-(defparameter fp-double-zero-tn
-  (make-random-tn :kind :normal
-                 :sc (sc-or-lose 'double-reg)
-                 :offset 15))
+(defparameter thread-base-tn
+  (make-random-tn :kind :normal :sc (sc-or-lose 'unsigned-reg )
+                  :offset r12-offset))

 
 ;;; 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 (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
 
 ;;; 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 (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)

-        #-sb-xc-host system-area-pointer character)
+         character)

      (sc-number-or-lose 'immediate))
     (symbol
      (when (static-symbol-p value)
        (sc-number-or-lose 'immediate)))
     (single-float
      (sc-number-or-lose 'immediate))
     (symbol
      (when (static-symbol-p value)
        (sc-number-or-lose 'immediate)))
     (single-float

-     (if (eql value 0f0)
-        (sc-number-or-lose 'fp-single-zero )
-        nil))
+       (sc-number-or-lose
+        (if (eql value 0f0) 'fp-single-zero 'fp-single-immediate)))

     (double-float
     (double-float

-     (if (eql value 0d0)
-        (sc-number-or-lose 'fp-double-zero )
-        nil))))
-
+       (sc-number-or-lose
+        (if (eql value 0d0) 'fp-double-zero 'fp-double-immediate)))
+    ((complex single-float)
+       (sc-number-or-lose
+        (if (eql value #c(0f0 0f0))
+            'fp-complex-single-zero
+            'fp-complex-single-immediate)))
+    ((complex double-float)
+       (sc-number-or-lose
+        (if (eql value #c(0d0 0d0))
+            'fp-complex-double-zero
+            'fp-complex-double-immediate)))))
+
+(!def-vm-support-routine boxed-immediate-sc-p (sc)
+  (eql sc (sc-number-or-lose 'immediate)))

 \f
 ;;;; miscellaneous function call parameters
 
 \f
 ;;;; miscellaneous function call parameters
 

-;;; offsets of special stack frame locations
-(def!constant ocfp-save-offset 0)
-(def!constant return-pc-save-offset 1)
+;;; Offsets of special stack frame locations relative to RBP.
+;;;
+;;; Consider the standard prologue PUSH RBP; MOV RBP, RSP: the return
+;;; address is at RBP+8, the old control stack frame pointer is at
+;;; RBP, the magic 3rd slot is at RBP-8. Then come the locals from
+;;; RBP-16 on.
+(def!constant return-pc-save-offset 0)
+(def!constant ocfp-save-offset 1)

 (def!constant code-save-offset 2)
 (def!constant code-save-offset 2)

+;;; 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))

 
 (def!constant lra-save-offset return-pc-save-offset) ; ?
 
 
 (def!constant lra-save-offset return-pc-save-offset) ; ?
 

@@ -441,24 +514,24 @@
 (!def-vm-support-routine location-print-name (tn)
   (declare (type tn tn))
   (let* ((sc (tn-sc tn))
 (!def-vm-support-routine 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))
     (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*)
-                             ((member sc-name *qword-sc-names*)
-                              *qword-register-names*))))
-        (or (and name-vec
-                 (< -1 offset (length name-vec))
-                 (svref name-vec offset))
-            ;; FIXME: Shouldn't this be an ERROR?
-            (format nil "<unknown reg: off=~W, sc=~A>" 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*)
+                              ((member sc-name *qword-sc-names*)
+                               *qword-register-names*))))
+         (or (and name-vec
+                  (< -1 offset (length name-vec))
+                  (svref name-vec offset))
+             ;; FIXME: Shouldn't this be an ERROR?
+             (format nil "<unknown reg: off=~W, sc=~A>" offset sc-name))))

       (float-registers (format nil "FLOAT~D" offset))
       (stack (format nil "S~D" offset))
       (constant (format nil "Const~D" offset))
       (float-registers (format nil "FLOAT~D" offset))
       (stack (format nil "S~D" offset))
       (constant (format nil "Const~D" offset))

@@ -466,30 +539,18 @@
       (noise (symbol-name (sc-name sc))))))
 ;;; FIXME: Could this, and everything that uses it, be made #!+SB-SHOW?
 
       (noise (symbol-name (sc-name sc))))))
 ;;; FIXME: Could this, and everything that uses it, be made #!+SB-SHOW?
 

-\f
-;;; The loader uses this to convert alien names to the form they need in
-;;; the symbol table (for example, prepending an underscore).
-\f
-;;; 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 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))))))
-

 (defun dwords-for-quad (value)
   (let* ((lo (logand value (1- (ash 1 32))))
 (defun dwords-for-quad (value)
   (let* ((lo (logand value (1- (ash 1 32))))

-        (hi (ash value -32)))
+         (hi (ash value -32)))

     (values lo hi)))
 
 (defun words-for-dword (value)
   (let* ((lo (logand value (1- (ash 1 16))))
     (values lo hi)))
 
 (defun words-for-dword (value)
   (let* ((lo (logand value (1- (ash 1 16))))

-        (hi (ash value -16)))
+         (hi (ash value -16)))

     (values lo hi)))
 
 (def!constant cfp-offset rbp-offset) ; pfw - needed by stuff in /code
 
     (values lo hi)))
 
 (def!constant cfp-offset rbp-offset) ; pfw - needed by stuff in /code
 

+(!def-vm-support-routine combination-implementation-style (node)
+  (declare (type sb!c::combination node) (ignore node))
+  (values :default nil))