src/compiler/ppc/vm.lisp

   1 ;;;
   2 (in-package "SB!VM")
   3
   4 \f
   5 ;;;; Define the registers
   6
   7 (eval-when (:compile-toplevel :load-toplevel :execute)
   8   (defvar *register-names* (make-array 32 :initial-element nil)))
   9
  10 (macrolet ((defreg (name offset)
  11                (let ((offset-sym (symbolicate name "-OFFSET")))
  12                  `(eval-when (:compile-toplevel :load-toplevel :execute)
  13                    (def!constant ,offset-sym ,offset)
  14                    (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
  15
  16            (defregset (name &rest regs)
  17                `(eval-when (:compile-toplevel :load-toplevel :execute)
  18                  (defparameter ,name
  19                    (list ,@(mapcar #'(lambda (name)
  20                                        (symbolicate name "-OFFSET")) regs))))))
  21
  22   (defreg zero 0)
  23   (defreg nsp 1)
  24   (defreg rtoc 2)                         ; May be "NULL" someday.
  25   (defreg nl0 3)
  26   (defreg nl1 4)
  27   (defreg nl2 5)
  28   (defreg nl3 6)
  29   (defreg nl4 7)
  30   (defreg nl5 8)
  31   (defreg nl6 9)
  32   (defreg fdefn 10)                     ; was nl7
  33   (defreg nargs 11)
  34   (defreg nfp 12)
  35   (defreg cfunc 13)
  36   (defreg bsp 14)
  37   (defreg cfp 15)
  38   (defreg csp 16)
  39   (defreg alloc 17)
  40   (defreg null 18)
  41   (defreg code 19)
  42   (defreg cname 20)
  43   (defreg lexenv 21)
  44   (defreg ocfp 22)
  45   (defreg lra 23)
  46   (defreg a0 24)
  47   (defreg a1 25)
  48   (defreg a2 26)
  49   (defreg a3 27)
  50   (defreg l0 28)
  51   (defreg l1 29)
  52   (defreg l2 30)
  53   (defreg lip 31)
  54
  55   (defregset non-descriptor-regs
  56       nl0 nl1 nl2 nl3 nl4 nl5 nl6 #+nil nl7 cfunc nargs nfp)
  57
  58   (defregset descriptor-regs
  59       fdefn a0 a1 a2 a3  ocfp lra cname lexenv l0 l1 l2 )
  60
  61
  62  (defregset *register-arg-offsets*  a0 a1 a2 a3)
  63  (defparameter register-arg-names '(a0 a1 a2 a3)))
  64
  65
  66 \f
  67 ;;;; SB and SC definition:
  68
  69 (define-storage-base registers :finite :size 32)
  70 (define-storage-base float-registers :finite :size 32)
  71 (define-storage-base control-stack :unbounded :size 8)
  72 (define-storage-base non-descriptor-stack :unbounded :size 0)
  73 (define-storage-base constant :non-packed)
  74 (define-storage-base immediate-constant :non-packed)
  75
  76 ;;;
  77 ;;; Handy macro so we don't have to keep changing all the numbers whenever
  78 ;;; we insert a new storage class.
  79 ;;;
  80 (defmacro define-storage-classes (&rest classes)
  81   (do ((forms (list 'progn)
  82               (let* ((class (car classes))
  83                      (sc-name (car class))
  84                      (constant-name (intern (concatenate 'simple-string
  85                                                          (string sc-name)
  86                                                          "-SC-NUMBER"))))
  87                 (list* `(define-storage-class ,sc-name ,index
  88                           ,@(cdr class))
  89                        `(def!constant ,constant-name ,index)
  90                        forms)))
  91        (index 0 (1+ index))
  92        (classes classes (cdr classes)))
  93       ((null classes)
  94        (nreverse forms))))
  95
  96 ;; XXX this is most likely wrong.  Check with Eric Marsden next time you
  97 ;; see him
  98 (def!constant sb!vm::kludge-nondeterministic-catch-block-size 7)
  99
 100 (define-storage-classes
 101
 102   ;; Non-immediate contstants in the constant pool
 103   (constant constant)
 104
 105   ;; ZERO and NULL are in registers.
 106   (zero immediate-constant)
 107   (null immediate-constant)
 108
 109   ;; Anything else that can be an immediate.
 110   (immediate immediate-constant)
 111
 112
 113   ;; **** The stacks.
 114
 115   ;; The control stack.  (Scanned by GC)
 116   (control-stack control-stack)
 117
 118   ;; The non-descriptor stacks.
 119   (signed-stack non-descriptor-stack) ; (signed-byte 32)
 120   (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
 121   (base-char-stack non-descriptor-stack) ; non-descriptor characters.
 122   (sap-stack non-descriptor-stack) ; System area pointers.
 123   (single-stack non-descriptor-stack) ; single-floats
 124   (double-stack non-descriptor-stack
 125                 :element-size 2 :alignment 2) ; double floats.
 126   (complex-single-stack non-descriptor-stack :element-size 2)
 127   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
 128
 129
 130   ;; **** Things that can go in the integer registers.
 131
 132   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
 133   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
 134   (any-reg
 135    registers
 136    :locations #.(append non-descriptor-regs descriptor-regs)
 137    :constant-scs (zero immediate)
 138    :save-p t
 139    :alternate-scs (control-stack))
 140
 141   ;; Pointer descriptor objects.  Must be seen by GC.
 142   (descriptor-reg registers
 143    :locations #.descriptor-regs
 144    :constant-scs (constant null immediate)
 145    :save-p t
 146    :alternate-scs (control-stack))
 147
 148   ;; Non-Descriptor characters
 149   (base-char-reg registers
 150    :locations #.non-descriptor-regs
 151    :constant-scs (immediate)
 152    :save-p t
 153    :alternate-scs (base-char-stack))
 154
 155   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
 156   (sap-reg registers
 157    :locations #.non-descriptor-regs
 158    :constant-scs (immediate)
 159    :save-p t
 160    :alternate-scs (sap-stack))
 161
 162   ;; Non-Descriptor (signed or unsigned) numbers.
 163   (signed-reg registers
 164    :locations #.non-descriptor-regs
 165    :constant-scs (zero immediate)
 166    :save-p t
 167    :alternate-scs (signed-stack))
 168   (unsigned-reg registers
 169    :locations #.non-descriptor-regs
 170    :constant-scs (zero immediate)
 171    :save-p t
 172    :alternate-scs (unsigned-stack))
 173
 174   ;; Random objects that must not be seen by GC.  Used only as temporaries.
 175   (non-descriptor-reg registers
 176    :locations #.non-descriptor-regs)
 177
 178   ;; Pointers to the interior of objects.  Used only as a temporary.
 179   (interior-reg registers
 180    :locations (#.lip-offset))
 181
 182
 183   ;; **** Things that can go in the floating point registers.
 184
 185   ;; Non-Descriptor single-floats.
 186   (single-reg float-registers
 187    :locations #.(loop for i from 0 to 31 collect i)
 188    ;; ### Note: We really should have every location listed, but then we
 189    ;; would have to make load-tns work with element-sizes other than 1.
 190    :constant-scs ()
 191    :save-p t
 192    :alternate-scs (single-stack))
 193
 194   ;; Non-Descriptor double-floats.
 195   (double-reg float-registers
 196    :locations #.(loop for i from 0 to 31 collect i)
 197    ;; ### Note: load-tns don't work with an element-size other than 1.
 198    ;; :element-size 2 :alignment 2
 199    :constant-scs ()
 200    :save-p t
 201    :alternate-scs (double-stack))
 202
 203   (complex-single-reg float-registers
 204    :locations #.(loop for i from 0 to 30 by 2 collect i)
 205    :element-size 2
 206    :constant-scs ()
 207    :save-p t
 208    :alternate-scs (complex-single-stack))
 209
 210   (complex-double-reg float-registers
 211    :locations #.(loop for i from 0 to 30 by 2 collect i)
 212    :element-size 2
 213    :constant-scs ()
 214    :save-p t
 215    :alternate-scs (complex-double-stack))
 216
 217   ;; A catch or unwind block.
 218   (catch-block control-stack
 219                :element-size sb!vm::kludge-nondeterministic-catch-block-size))
 220
 221
 222 \f
 223 ;;;; Make some random tns for important registers.
 224
 225 (macrolet ((defregtn (name sc)
 226                (let ((offset-sym (symbolicate name "-OFFSET"))
 227                      (tn-sym (symbolicate name "-TN")))
 228                  `(defparameter ,tn-sym
 229                    (make-random-tn :kind :normal
 230                     :sc (sc-or-lose ',sc)
 231                     :offset ,offset-sym)))))
 232
 233   (defregtn zero any-reg)
 234   (defregtn lip interior-reg)
 235   (defregtn null descriptor-reg)
 236   (defregtn code descriptor-reg)
 237   (defregtn alloc any-reg)
 238
 239   (defregtn nargs any-reg)
 240   (defregtn bsp any-reg)
 241   (defregtn csp any-reg)
 242   (defregtn cfp any-reg)
 243   (defregtn ocfp any-reg)
 244   (defregtn nsp any-reg))
 245
 246
 247 \f
 248 ;;; Immediate-Constant-SC  --  Interface
 249 ;;;
 250 ;;; If value can be represented as an immediate constant, then return the
 251 ;;; appropriate SC number, otherwise return NIL.
 252 ;;;
 253 (!def-vm-support-routine immediate-constant-sc (value)
 254   (typecase value
 255     ((integer 0 0)
 256      (sc-number-or-lose 'zero))
 257     (null
 258      (sc-number-or-lose 'null))
 259     ((or fixnum system-area-pointer character)
 260      (sc-number-or-lose 'immediate))
 261     (symbol
 262      (if (static-symbol-p value)
 263          (sc-number-or-lose 'immediate)
 264          nil))))
 265
 266 \f
 267 ;;;; Function Call Parameters
 268
 269 ;;; The SC numbers for register and stack arguments/return values.
 270 ;;;
 271 (def!constant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
 272 (def!constant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
 273 (def!constant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
 274
 275 (eval-when (:compile-toplevel :load-toplevel :execute)
 276
 277 ;;; Offsets of special stack frame locations
 278 (def!constant ocfp-save-offset 0)
 279 (def!constant lra-save-offset 1)
 280 (def!constant nfp-save-offset 2)
 281
 282 ;;; The number of arguments/return values passed in registers.
 283 ;;;
 284 (def!constant register-arg-count 4)
 285
 286 ;;; Names to use for the argument registers.
 287 ;;;
 288
 289
 290 ); Eval-When (:compile-toplevel :load-toplevel :execute)
 291
 292
 293 ;;; A list of TN's describing the register arguments.
 294 ;;;
 295 (defparameter *register-arg-tns*
 296   (mapcar #'(lambda (n)
 297               (make-random-tn :kind :normal
 298                               :sc (sc-or-lose 'descriptor-reg)
 299                               :offset n))
 300           *register-arg-offsets*))
 301
 302 (export 'single-value-return-byte-offset)
 303
 304 ;;; SINGLE-VALUE-RETURN-BYTE-OFFSET
 305 ;;;
 306 ;;; This is used by the debugger.
 307 ;;;
 308 (def!constant single-value-return-byte-offset 8)
 309
 310 \f
 311 ;;; LOCATION-PRINT-NAME  --  Interface
 312 ;;;
 313 ;;;    This function is called by debug output routines that want a pretty name
 314 ;;; for a TN's location.  It returns a thing that can be printed with PRINC.
 315 ;;;
 316 (!def-vm-support-routine location-print-name (tn)
 317   (declare (type tn tn))
 318   (let ((sb (sb-name (sc-sb (tn-sc tn))))
 319         (offset (tn-offset tn)))
 320     (ecase sb
 321       (registers (or (svref *register-names* offset)
 322                      (format nil "R~D" offset)))
 323       (float-registers (format nil "F~D" offset))
 324       (control-stack (format nil "CS~D" offset))
 325       (non-descriptor-stack (format nil "NS~D" offset))
 326       (constant (format nil "Const~D" offset))
 327       (immediate-constant "Immed"))))