src/compiler/mips/vm.lisp

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