double->single float conversion isn't a no-op on x87 anymore

[sbcl.git] / src / compiler / ppc / vm.lisp

diff --git a/src/compiler/ppc/vm.lisp b/src/compiler/ppc/vm.lisp
index 7b482c4..720f8b3 100644 (file)
--- a/src/compiler/ppc/vm.lisp
+++ b/src/compiler/ppc/vm.lisp
@@ -1,6 +1,26 @@
-;;;
+;;;; miscellaneous VM definition noise for the PPC
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+

 (in-package "SB!VM")
 
 (in-package "SB!VM")
 

+;;; NUMBER-STACK-DISPLACEMENT
+;;;
+;;; The number of bytes reserved above the number stack pointer.  These
+;;; slots are required by architecture, mostly (?) to make C backtrace
+;;; work. This must be a power of 2 - see BYTES-REQUIRED-FOR-NUMBER-STACK.
+;;;
+(def!constant number-stack-displacement
+  (* #!-darwin 2
+     #!+darwin 8
+     n-word-bytes))

 \f
 ;;;; Define the registers
 
 \f
 ;;;; Define the registers
 

@@ -10,9 +30,9 @@
 (macrolet ((defreg (name offset)
                (let ((offset-sym (symbolicate name "-OFFSET")))
                  `(eval-when (:compile-toplevel :load-toplevel :execute)
 (macrolet ((defreg (name offset)
                (let ((offset-sym (symbolicate name "-OFFSET")))
                  `(eval-when (:compile-toplevel :load-toplevel :execute)

-                   (defconstant ,offset-sym ,offset)
+                   (def!constant ,offset-sym ,offset)

                    (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
                    (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))

-           
+

            (defregset (name &rest regs)
                `(eval-when (:compile-toplevel :load-toplevel :execute)
                  (defparameter ,name
            (defregset (name &rest regs)
                `(eval-when (:compile-toplevel :load-toplevel :execute)
                  (defparameter ,name

@@ -29,10 +49,15 @@
   (defreg nl4 7)
   (defreg nl5 8)
   (defreg nl6 9)
   (defreg nl4 7)
   (defreg nl5 8)
   (defreg nl6 9)

-  (defreg fdefn 10)                    ; was nl7
+  (defreg fdefn 10)                     ; was nl7

   (defreg nargs 11)
   (defreg nargs 11)

-  (defreg nfp 12)
-  (defreg cfunc 13)
+  ;; FIXME: some kind of comment here would be nice.
+  ;;
+  ;; FIXME II: this also reveals the need to autogenerate lispregs.h
+  #!+darwin  (defreg cfunc 12)
+  #!-darwin  (defreg nfp 12)
+  #!+darwin  (defreg nfp 13)
+  #!-darwin  (defreg cfunc 13)

   (defreg bsp 14)
   (defreg cfp 15)
   (defreg csp 16)
   (defreg bsp 14)
   (defreg cfp 15)
   (defreg csp 16)

@@ -49,16 +74,16 @@
   (defreg a3 27)
   (defreg l0 28)
   (defreg l1 29)
   (defreg a3 27)
   (defreg l0 28)
   (defreg l1 29)

-  (defreg l2 30)
+  (defreg #!-sb-thread l2 #!+sb-thread thread 30)

   (defreg lip 31)
 
   (defregset non-descriptor-regs
       nl0 nl1 nl2 nl3 nl4 nl5 nl6 #+nil nl7 cfunc nargs nfp)
   (defreg lip 31)
 
   (defregset non-descriptor-regs
       nl0 nl1 nl2 nl3 nl4 nl5 nl6 #+nil nl7 cfunc nargs nfp)

-  
+

   (defregset descriptor-regs
   (defregset descriptor-regs

-      fdefn a0 a1 a2 a3  ocfp lra cname lexenv l0 l1 l2 )
+      fdefn a0 a1 a2 a3  ocfp lra cname lexenv l0 l1 #!-sb-thread l2 )
+

 
 

-  

  (defregset *register-arg-offsets*  a0 a1 a2 a3)
  (defparameter register-arg-names '(a0 a1 a2 a3)))
 
  (defregset *register-arg-offsets*  a0 a1 a2 a3)
  (defparameter register-arg-names '(a0 a1 a2 a3)))
 

@@ -76,26 +101,24 @@
 ;;;
 ;;; Handy macro so we don't have to keep changing all the numbers whenever
 ;;; we insert a new storage class.
 ;;;
 ;;; 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)
   (do ((forms (list 'progn)
 (defmacro define-storage-classes (&rest classes)
   (do ((forms (list 'progn)

-             (let* ((class (car classes))
-                    (sc-name (car class))
-                    (constant-name (intern (concatenate 'simple-string
-                                                        (string sc-name)
-                                                        "-SC-NUMBER"))))
-               (list* `(define-storage-class ,sc-name ,index
-                         ,@(cdr class))
-                      `(defconstant ,constant-name ,index)
-                      forms)))
+              (let* ((class (car classes))
+                     (sc-name (car class))
+                     (constant-name (intern (concatenate 'simple-string
+                                                         (string sc-name)
+                                                         "-SC-NUMBER"))))
+                (list* `(define-storage-class ,sc-name ,index
+                          ,@(cdr class))
+                       `(def!constant ,constant-name ,index)
+                       forms)))

        (index 0 (1+ index))
        (classes classes (cdr classes)))
       ((null classes)
        (nreverse forms))))
 
        (index 0 (1+ index))
        (classes classes (cdr classes)))
       ((null classes)
        (nreverse forms))))
 

-;; XXX this is most likely wrong.  Check with Eric Marsden next time you
-;; see him
-(defconstant sb!vm::kludge-nondeterministic-catch-block-size 7)
+(def!constant kludge-nondeterministic-catch-block-size 6)

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

@@ -115,19 +138,10 @@
   ;; The control stack.  (Scanned by GC)
   (control-stack control-stack)
 
   ;; The control stack.  (Scanned by GC)
   (control-stack control-stack)
 

-  ;; The non-descriptor stacks.
-  (signed-stack non-descriptor-stack) ; (signed-byte 32)
-  (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
-  (base-char-stack non-descriptor-stack) ; non-descriptor characters.
-  (sap-stack non-descriptor-stack) ; System area pointers.
-  (single-stack non-descriptor-stack) ; single-floats
-  (double-stack non-descriptor-stack
-               :element-size 2 :alignment 2) ; double floats.
-  (complex-single-stack non-descriptor-stack :element-size 2)
-  (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
-
-
-  ;; **** Things that can go in the integer registers.
+  ;; We put ANY-REG and DESCRIPTOR-REG early so that their SC-NUMBER
+  ;; is small and therefore the error trap information is smaller.
+  ;; Moving them up here from their previous place down below saves
+  ;; ~250K in core file size.  --njf, 2006-01-27

 
   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
 
   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
   ;; bad will happen if they are.  (fixnums, characters, header values, etc).

@@ -145,12 +159,26 @@
    :save-p t
    :alternate-scs (control-stack))
 
    :save-p t
    :alternate-scs (control-stack))
 

+  ;; The non-descriptor stacks.
+  (signed-stack non-descriptor-stack) ; (signed-byte 32)
+  (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
+  (character-stack non-descriptor-stack) ; non-descriptor characters.
+  (sap-stack non-descriptor-stack) ; System area pointers.
+  (single-stack non-descriptor-stack) ; single-floats
+  (double-stack non-descriptor-stack
+                :element-size 2 :alignment 2) ; double floats.
+  (complex-single-stack non-descriptor-stack :element-size 2)
+  (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
+
+
+  ;; **** Things that can go in the integer registers.
+

   ;; Non-Descriptor characters
   ;; Non-Descriptor characters

-  (base-char-reg registers
+  (character-reg registers

    :locations #.non-descriptor-regs
    :constant-scs (immediate)
    :save-p t
    :locations #.non-descriptor-regs
    :constant-scs (immediate)
    :save-p t

-   :alternate-scs (base-char-stack))
+   :alternate-scs (character-stack))

 
   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
   (sap-reg registers
 
   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
   (sap-reg registers

@@ -216,9 +244,7 @@
 
   ;; A catch or unwind block.
   (catch-block control-stack
 
   ;; A catch or unwind block.
   (catch-block control-stack

-               :element-size sb!vm::kludge-nondeterministic-catch-block-size))
-
-
+               :element-size kludge-nondeterministic-catch-block-size))

 \f
 ;;;; Make some random tns for important registers.
 
 \f
 ;;;; Make some random tns for important registers.
 

@@ -235,93 +261,145 @@
   (defregtn null descriptor-reg)
   (defregtn code descriptor-reg)
   (defregtn alloc any-reg)
   (defregtn null descriptor-reg)
   (defregtn code descriptor-reg)
   (defregtn alloc any-reg)

-  
+  (defregtn lra descriptor-reg)
+  (defregtn lexenv descriptor-reg)
+

   (defregtn nargs any-reg)
   (defregtn bsp any-reg)
   (defregtn csp any-reg)
   (defregtn cfp any-reg)
   (defregtn ocfp any-reg)
   (defregtn nsp any-reg))
   (defregtn nargs any-reg)
   (defregtn bsp any-reg)
   (defregtn csp any-reg)
   (defregtn cfp any-reg)
   (defregtn ocfp any-reg)
   (defregtn nsp any-reg))

-
-

 \f
 \f

-;;; Immediate-Constant-SC  --  Interface
-;;;
-;;; If value can be represented as an immediate constant, then return the
+;;; If VALUE can be represented as an immediate constant, then return the

 ;;; appropriate SC number, otherwise return NIL.
 ;;; appropriate SC number, otherwise return NIL.

-;;;
-(!def-vm-support-routine immediate-constant-sc (value)
+(defun immediate-constant-sc (value)

   (typecase value
     ((integer 0 0)
      (sc-number-or-lose 'zero))
     (null
      (sc-number-or-lose 'null))
   (typecase value
     ((integer 0 0)
      (sc-number-or-lose 'zero))
     (null
      (sc-number-or-lose 'null))

-    ((or fixnum system-area-pointer character)
+    ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
+         character)

      (sc-number-or-lose 'immediate))
     (symbol
      (if (static-symbol-p value)
      (sc-number-or-lose 'immediate))
     (symbol
      (if (static-symbol-p value)

-        (sc-number-or-lose 'immediate)
-        nil))))
-
+         (sc-number-or-lose 'immediate)
+         nil))))
+
+(defun boxed-immediate-sc-p (sc)
+  (or (eql sc (sc-number-or-lose 'zero))
+      (eql sc (sc-number-or-lose 'null))
+      (eql sc (sc-number-or-lose 'immediate))))
+
+;;; A predicate to see if a character can be used as an inline
+;;; constant (the immediate field in the instruction used is sixteen
+;;; bits wide, which is not the same as any defined subtype of
+;;; CHARACTER).
+(defun inlinable-character-constant-p (char)
+  (and (characterp char)
+       (< (char-code char) #x10000)))

 \f
 \f

-;;;; 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)
 
 
 (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)
+;;; 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.
-;;;
-(defconstant register-arg-count 4)
+;;; the number of arguments/return values passed in registers
+(def!constant register-arg-count 4)

 
 

-;;; Names to use for the argument registers.
-;;; 
+;;; names to use for the argument registers

 
 
 
 

-); Eval-When (:compile-toplevel :load-toplevel :execute)
+) ; EVAL-WHEN

 
 
 ;;; A list of TN's describing the register arguments.
 ;;;
 (defparameter *register-arg-tns*
   (mapcar #'(lambda (n)
 
 
 ;;; 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))
-         *register-arg-offsets*))
+              (make-random-tn :kind :normal
+                              :sc (sc-or-lose 'descriptor-reg)
+                              :offset n))
+          *register-arg-offsets*))
+
+#!+sb-thread
+(defparameter thread-base-tn
+  (make-random-tn :kind :normal :sc (sc-or-lose 'unsigned-reg)
+                  :offset thread-offset))

 
 (export 'single-value-return-byte-offset)
 
 
 (export 'single-value-return-byte-offset)
 

-;;; SINGLE-VALUE-RETURN-BYTE-OFFSET
-;;;

 ;;; This is used by the debugger.
 ;;; This is used by the debugger.

-;;;
-(defconstant single-value-return-byte-offset 8)
-
+(def!constant single-value-return-byte-offset 8)

 \f
 \f

-;;; LOCATION-PRINT-NAME  --  Interface
-;;;
-;;;    This function is called by debug output routines that want a pretty name
+;;; 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.
 ;;; 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 ((sb (sb-name (sc-sb (tn-sc tn))))
   (declare (type tn tn))
   (let ((sb (sb-name (sc-sb (tn-sc tn))))

-       (offset (tn-offset tn)))
+        (offset (tn-offset tn)))

     (ecase sb
       (registers (or (svref *register-names* offset)
     (ecase sb
       (registers (or (svref *register-names* offset)

-                    (format nil "R~D" offset)))
+                     (format nil "R~D" offset)))

       (float-registers (format nil "F~D" offset))
       (control-stack (format nil "CS~D" offset))
       (non-descriptor-stack (format nil "NS~D" offset))
       (constant (format nil "Const~D" offset))
       (immediate-constant "Immed"))))
       (float-registers (format nil "F~D" offset))
       (control-stack (format nil "CS~D" offset))
       (non-descriptor-stack (format nil "NS~D" offset))
       (constant (format nil "Const~D" offset))
       (immediate-constant "Immed"))))

+
+(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
+         ((or (valid-funtype '(fixnum fixnum) '*)
+              (valid-funtype '((signed-byte 32) (signed-byte 32)) '*)
+              (valid-funtype '((unsigned-byte 32) (unsigned-byte 32)) '*))
+          (values :maybe nil))
+         (t (values :default nil))))
+      (logbitp
+       (cond
+         ((or (valid-funtype '((constant-arg (integer 0 29)) fixnum) '*)
+              (valid-funtype '((constant-arg (integer 0 31)) (signed-byte 32)) '*)
+              (valid-funtype '((constant-arg (integer 0 31)) (unsigned-byte 32)) '*))
+          (values :transform '(lambda (index integer)
+                               (%logbitp integer index))))
+         (t (values :default nil))))
+      ;; FIXME: can handle MIN and MAX here
+      (sb!kernel:%ldb
+       (flet ((validp (type width)
+                (and (valid-funtype `((constant-arg (integer 1 29))
+                                      (constant-arg (mod ,width))
+                                      ,type)
+                                    'fixnum)
+                     (destructuring-bind (size posn integer)
+                         (sb!c::basic-combination-args node)
+                       (declare (ignore integer))
+                       (<= (+ (sb!c::lvar-value size)
+                              (sb!c::lvar-value posn))
+                           width)))))
+         (if (or (validp 'fixnum 29)
+                 (validp '(signed-byte 32) 32)
+                 (validp '(unsigned-byte 32) 32))
+             (values :transform '(lambda (size posn integer)
+                                  (%%ldb integer size posn)))
+             (values :default nil))))
+      (t (values :default nil)))))
+
+(defun primitive-type-indirect-cell-type (ptype)
+  (declare (ignore ptype))
+  nil)