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