src/compiler/hppa/vm.lisp

   1 (in-package "SB!VM")
   2
   3 \f
   4 ;;;; Define the registers
   5
   6 (eval-when (:compile-toplevel :load-toplevel :execute)
   7   (defvar *register-names* (make-array 32 :initial-element nil)))
   8
   9 ;;; FIXME: These want to turn into macrolets.
  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            (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
  20   ;; Wired-zero
  21   (defreg zero 0)
  22   ;; This gets trashed by the C call convention.
  23   (defreg nfp 1)
  24   (defreg cfunc 2)
  25   ;; These are the callee saves, so these registers are stay live over
  26   ;; call-out.
  27   (defreg csp 3)
  28   (defreg cfp 4)
  29   (defreg bsp 5)
  30   (defreg null 6)
  31   (defreg alloc 7)
  32   (defreg code 8)
  33   (defreg fdefn 9)
  34   (defreg lexenv 10)
  35   (defreg nargs 11)
  36   (defreg ocfp 12)
  37   (defreg lra 13)
  38   (defreg a0 14)
  39   (defreg a1 15)
  40   (defreg a2 16)
  41   (defreg a3 17)
  42   (defreg a4 18)
  43   ;; This is where the caller-saves registers start, but we don't
  44   ;; really care because we need to clear the above after call-out to
  45   ;; make sure no pointers into oldspace are kept around.
  46   (defreg a5 19)
  47   (defreg l0 20)
  48   (defreg l1 21)
  49   (defreg l2 22)
  50   ;; These are the 4 C argument registers.
  51   (defreg nl3 23)
  52   (defreg nl2 24)
  53   (defreg nl1 25)
  54   (defreg nl0 26)
  55   ;; The global Data Pointer.  We just leave it alone, because we
  56   ;; don't need it.
  57   (defreg dp 27)
  58   ;; These two are use for C return values.
  59   (defreg nl4 28)
  60   (defreg nl5 29)
  61   (defreg nsp 30)
  62   (defreg lip 31)
  63
  64   (defregset non-descriptor-regs
  65       nl0 nl1 nl2 nl3 nl4 nl5 nfp cfunc)
  66
  67   (defregset descriptor-regs
  68       fdefn lexenv nargs ocfp lra a0 a1 a2 a3 a4 a5 l0 l1 l2)
  69
  70   (defregset *register-arg-offsets*
  71       a0 a1 a2 a3 a4 a5))
  72
  73
  74 (define-storage-base registers :finite :size 32)
  75 (define-storage-base float-registers :finite :size 64)
  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                        `(defconstant ,constant-name ,index)
  95                        `(export ',constant-name)
  96                        forms)))
  97        (index 0 (1+ index))
  98        (classes classes (cdr classes)))
  99       ((null classes)
 100        (nreverse forms))))
 101
 102 (def!constant sb!vm::kludge-nondeterministic-catch-block-size 7)
 103
 104 (!define-storage-classes
 105
 106   ;; Non-immediate contstants in the constant pool
 107   (constant constant)
 108
 109   ;; ZERO and NULL are in registers.
 110   (zero immediate-constant)
 111   (null immediate-constant)
 112   (fp-single-zero immediate-constant)
 113   (fp-double-zero immediate-constant)
 114
 115   ;; Anything else that can be an immediate.
 116   (immediate immediate-constant)
 117
 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   (base-char-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
 131                 :element-size 2 :alignment 2) ; double floats.
 132   (complex-single-stack non-descriptor-stack :element-size 2)
 133   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
 134
 135
 136   ;; **** Things that can go in the integer registers.
 137
 138   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
 139   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
 140   (any-reg
 141    registers
 142    :locations #.(append non-descriptor-regs descriptor-regs)
 143    :constant-scs (zero immediate)
 144    :save-p t
 145    :alternate-scs (control-stack))
 146
 147   ;; Pointer descriptor objects.  Must be seen by GC.
 148   (descriptor-reg registers
 149    :locations #.descriptor-regs
 150    :constant-scs (constant null immediate)
 151    :save-p t
 152    :alternate-scs (control-stack))
 153
 154   ;; Non-Descriptor characters
 155   (base-char-reg registers
 156    :locations #.non-descriptor-regs
 157    :constant-scs (immediate)
 158    :save-p t
 159    :alternate-scs (base-char-stack))
 160
 161   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
 162   (sap-reg registers
 163    :locations #.non-descriptor-regs
 164    :constant-scs (immediate)
 165    :save-p t
 166    :alternate-scs (sap-stack))
 167
 168   ;; Non-Descriptor (signed or unsigned) numbers.
 169   (signed-reg registers
 170    :locations #.non-descriptor-regs
 171    :constant-scs (zero immediate)
 172    :save-p t
 173    :alternate-scs (signed-stack))
 174   (unsigned-reg registers
 175    :locations #.non-descriptor-regs
 176    :constant-scs (zero immediate)
 177    :save-p t
 178    :alternate-scs (unsigned-stack))
 179
 180   ;; Random objects that must not be seen by GC.  Used only as temporaries.
 181   (non-descriptor-reg registers
 182    :locations #.non-descriptor-regs)
 183
 184   ;; Pointers to the interior of objects.  Used only as an temporary.
 185   (interior-reg registers
 186    :locations (#.lip-offset))
 187
 188
 189   ;; **** Things that can go in the floating point registers.
 190
 191   ;; Non-Descriptor single-floats.
 192   (single-reg float-registers
 193    :locations #.(loop for i from 4 to 31 collect i)
 194    :constant-scs (fp-single-zero)
 195    :save-p t
 196    :alternate-scs (single-stack))
 197
 198   ;; Non-Descriptor double-floats.
 199   (double-reg float-registers
 200    :locations #.(loop for i from 4 to 31 collect i)
 201    :constant-scs (fp-double-zero)
 202    :save-p t
 203    :alternate-scs (double-stack))
 204
 205   (complex-single-reg float-registers
 206    :locations #.(loop for i from 4 to 30 by 2 collect i)
 207    :element-size 2
 208    :constant-scs ()
 209    :save-p t
 210    :alternate-scs (complex-single-stack))
 211
 212   (complex-double-reg float-registers
 213    :locations #.(loop for i from 4 to 30 by 2 collect i)
 214    :element-size 2
 215    :constant-scs ()
 216    :save-p t
 217    :alternate-scs (complex-double-stack))
 218
 219   ;; A catch or unwind block.
 220   (catch-block control-stack :element-size sb!vm::kludge-nondeterministic-catch-block-size))
 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   ;; These, we access by foo-TN only
 234
 235   (defregtn zero any-reg)
 236   (defregtn null descriptor-reg)
 237   (defregtn code descriptor-reg)
 238   (defregtn alloc any-reg)
 239   (defregtn bsp any-reg)
 240   (defregtn csp any-reg)
 241   (defregtn cfp any-reg)
 242   (defregtn nsp any-reg)
 243
 244   ;; These alias regular locations, so we have to make sure we don't bypass
 245   ;; the register allocator when using them.
 246   (defregtn nargs any-reg)
 247   (defregtn ocfp any-reg)
 248   (defregtn lip interior-reg))
 249
 250 ;; And some floating point values.
 251 (defparameter fp-single-zero-tn
 252   (make-random-tn :kind :normal
 253                   :sc (sc-or-lose 'single-reg)
 254                   :offset 0))
 255 (defparameter fp-double-zero-tn
 256   (make-random-tn :kind :normal
 257                   :sc (sc-or-lose 'double-reg)
 258                   :offset 0))
 259
 260 \f
 261 ;;; If VALUE can be represented as an immediate constant, then return
 262 ;;; the appropriate SC number, otherwise return NIL.
 263 (!def-vm-support-routine immediate-constant-sc (value)
 264   (typecase value
 265     ((integer 0 0)
 266      (sc-number-or-lose 'zero))
 267     (null
 268      (sc-number-or-lose 'null))
 269     ((or fixnum system-area-pointer character)
 270      (sc-number-or-lose 'immediate))
 271     (symbol
 272      (if (static-symbol-p value)
 273          (sc-number-or-lose 'immediate)
 274          nil))
 275     (single-float
 276      (if (zerop value)
 277          (sc-number-or-lose 'fp-single-zero)
 278          nil))
 279     (double-float
 280      (if (zerop value)
 281          (sc-number-or-lose 'fp-double-zero)
 282          nil))))
 283
 284 \f
 285 ;;;; Function Call Parameters
 286
 287 ;;; The SC numbers for register and stack arguments/return values.
 288 ;;;
 289 (defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
 290 (defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
 291 (defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
 292
 293 (eval-when (:compile-toplevel :load-toplevel :execute)
 294
 295 ;;; Offsets of special stack frame locations
 296 (defconstant ocfp-save-offset 0)
 297 (defconstant lra-save-offset 1)
 298 (defconstant nfp-save-offset 2)
 299
 300 ;;; The number of arguments/return values passed in registers.
 301 ;;;
 302 (defconstant register-arg-count 6)
 303
 304 ;;; Names to use for the argument registers.
 305 ;;;
 306 (defconstant-eqx register-arg-names '(a0 a1 a2 a3 a4 a5) #'equal)
 307
 308 ) ; EVAL-WHEN
 309
 310
 311 ;;; A list of TN's describing the register arguments.
 312 ;;;
 313 (defparameter register-arg-tns
 314   (mapcar #'(lambda (n)
 315               (make-random-tn :kind :normal
 316                               :sc (sc-or-lose 'descriptor-reg)
 317                               :offset n))
 318           *register-arg-offsets*))
 319
 320 ;;; This is used by the debugger.
 321 (defconstant single-value-return-byte-offset 4)
 322 \f
 323 ;;; This function is called by debug output routines that want a pretty name
 324 ;;; for a TN's location.  It returns a thing that can be printed with PRINC.
 325 (!def-vm-support-routine location-print-name (tn)
 326   (declare (type tn tn))
 327   (let ((sb (sb-name (sc-sb (tn-sc tn))))
 328         (offset (tn-offset tn)))
 329     (ecase sb
 330       (registers (or (svref *register-names* offset)
 331                      (format nil "R~D" offset)))
 332       (float-registers (format nil "F~D" offset))
 333       (control-stack (format nil "CS~D" offset))
 334       (non-descriptor-stack (format nil "NS~D" offset))
 335       (constant (format nil "Const~D" offset))
 336       (immediate-constant "Immed"))))
 337
 338 ;;; The loader uses this to convert alien names to the form they
 339 ;;; occure in the symbol table (for example, prepending an
 340 ;;; underscore).  On the HPPA we just leave it alone.
 341 (defun extern-alien-name (name)
 342   (declare (type simple-base-string name))
 343   name)