src/compiler/mips/vm.lisp

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