src/compiler/hppa/vm.lisp

   1 ;;;; miscellaneous VM definition noise for HPPA
   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 ;;;; Define the registers
  16
  17 (eval-when (:compile-toplevel :load-toplevel :execute)
  18   (defvar *register-names* (make-array 32 :initial-element nil)))
  19
  20 ;;; FIXME: These want to turn into macrolets.
  21 (macrolet ((defreg (name offset)
  22                (let ((offset-sym (symbolicate name "-OFFSET")))
  23                  `(eval-when (:compile-toplevel :load-toplevel :execute)
  24                    (def!constant ,offset-sym ,offset)
  25                    (setf (svref *register-names* ,offset-sym) ,(symbol-name name)))))
  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
  31   ;; Wired-zero
  32   (defreg zero 0)
  33   ;; This gets trashed by the C call convention.
  34   (defreg nfp 1)
  35   (defreg cfunc 2)
  36   ;; These are the callee saves, so these registers are stay live over
  37   ;; call-out.
  38   (defreg csp 3)
  39   (defreg cfp 4)
  40   (defreg bsp 5)
  41   (defreg null 6)
  42   (defreg alloc 7)
  43   (defreg code 8)
  44   (defreg fdefn 9)
  45   (defreg lexenv 10)
  46   (defreg nargs 11)
  47   (defreg ocfp 12)
  48   (defreg lra 13)
  49   (defreg a0 14)
  50   (defreg a1 15)
  51   (defreg a2 16)
  52   (defreg a3 17)
  53   (defreg a4 18)
  54   ;; This is where the caller-saves registers start, but we don't
  55   ;; really care because we need to clear the above after call-out to
  56   ;; make sure no pointers into oldspace are kept around.
  57   (defreg a5 19)
  58   (defreg l0 20)
  59   (defreg l1 21)
  60   (defreg l2 22)
  61   ;; These are the 4 C argument registers.
  62   (defreg nl3 23)
  63   (defreg nl2 24)
  64   (defreg nl1 25)
  65   (defreg nl0 26)
  66   ;; The global Data Pointer.  We just leave it alone, because we
  67   ;; don't need it.
  68   (defreg dp 27)
  69   ;; These two are use for C return values.
  70   (defreg nl4 28)
  71   (defreg nl5 29)
  72   (defreg nsp 30)
  73   (defreg lip 31)
  74
  75   (defregset non-descriptor-regs
  76       nl0 nl1 nl2 nl3 nl4 nl5 nfp cfunc)
  77
  78   (defregset descriptor-regs
  79       fdefn lexenv nargs ocfp lra a0 a1 a2 a3 a4 a5 l0 l1 l2)
  80
  81   (defregset *register-arg-offsets*
  82       a0 a1 a2 a3 a4 a5))
  83
  84
  85 (define-storage-base registers :finite :size 32)
  86 (define-storage-base float-registers :finite :size 64)
  87 (define-storage-base control-stack :unbounded :size 8)
  88 (define-storage-base non-descriptor-stack :unbounded :size 0)
  89 (define-storage-base constant :non-packed)
  90 (define-storage-base immediate-constant :non-packed)
  91
  92 ;;;
  93 ;;; Handy macro so we don't have to keep changing all the numbers whenever
  94 ;;; we insert a new storage class.
  95 ;;;
  96 (defmacro !define-storage-classes (&rest classes)
  97   (do ((forms (list 'progn)
  98               (let* ((class (car classes))
  99                      (sc-name (car class))
 100                      (constant-name (intern (concatenate 'simple-string
 101                                                          (string sc-name)
 102                                                          "-SC-NUMBER"))))
 103                 (list* `(define-storage-class ,sc-name ,index
 104                           ,@(cdr class))
 105                        `(defconstant ,constant-name ,index)
 106                        `(export ',constant-name)
 107                        forms)))
 108        (index 0 (1+ index))
 109        (classes classes (cdr classes)))
 110       ((null classes)
 111        (nreverse forms))))
 112
 113 (def!constant kludge-nondeterministic-catch-block-size 7)
 114
 115 (!define-storage-classes
 116
 117   ;; Non-immediate contstants in the constant pool
 118   (constant constant)
 119
 120   ;; ZERO and NULL are in registers.
 121   (zero immediate-constant)
 122   (null immediate-constant)
 123   (fp-single-zero immediate-constant)
 124   (fp-double-zero immediate-constant)
 125
 126   ;; Anything else that can be an immediate.
 127   (immediate immediate-constant)
 128
 129
 130   ;; **** The stacks.
 131
 132   ;; The control stack.  (Scanned by GC)
 133   (control-stack control-stack)
 134
 135   ;; We put ANY-REG and DESCRIPTOR-REG early so that their SC-NUMBER
 136   ;; is small and therefore the error trap information is smaller.
 137   ;; Moving them up here from their previous place down below saves
 138   ;; ~250K in core file size.  --njf, 2006-01-27
 139
 140   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
 141   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
 142   (any-reg
 143    registers
 144    :locations #.(append non-descriptor-regs descriptor-regs)
 145    :constant-scs (zero immediate)
 146    :save-p t
 147    :alternate-scs (control-stack))
 148
 149   ;; Pointer descriptor objects.  Must be seen by GC.
 150   (descriptor-reg registers
 151    :locations #.descriptor-regs
 152    :constant-scs (constant null immediate)
 153    :save-p t
 154    :alternate-scs (control-stack))
 155
 156   ;; The non-descriptor stacks.
 157   (signed-stack non-descriptor-stack) ; (signed-byte 32)
 158   (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
 159   (character-stack non-descriptor-stack) ; non-descriptor characters.
 160   (sap-stack non-descriptor-stack) ; System area pointers.
 161   (single-stack non-descriptor-stack) ; single-floats
 162   (double-stack non-descriptor-stack
 163                 :element-size 2 :alignment 2) ; double floats.
 164   (complex-single-stack non-descriptor-stack :element-size 2)
 165   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
 166
 167
 168   ;; **** Things that can go in the integer registers.
 169
 170   ;; Non-Descriptor characters
 171   (character-reg registers
 172    :locations #.non-descriptor-regs
 173    :constant-scs (immediate)
 174    :save-p t
 175    :alternate-scs (character-stack))
 176
 177   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
 178   (sap-reg registers
 179    :locations #.non-descriptor-regs
 180    :constant-scs (immediate)
 181    :save-p t
 182    :alternate-scs (sap-stack))
 183
 184   ;; Non-Descriptor (signed or unsigned) numbers.
 185   (signed-reg registers
 186    :locations #.non-descriptor-regs
 187    :constant-scs (zero immediate)
 188    :save-p t
 189    :alternate-scs (signed-stack))
 190   (unsigned-reg registers
 191    :locations #.non-descriptor-regs
 192    :constant-scs (zero immediate)
 193    :save-p t
 194    :alternate-scs (unsigned-stack))
 195
 196   ;; Random objects that must not be seen by GC.  Used only as temporaries.
 197   (non-descriptor-reg registers
 198    :locations #.non-descriptor-regs)
 199
 200   ;; Pointers to the interior of objects.  Used only as an temporary.
 201   (interior-reg registers
 202    :locations (#.lip-offset))
 203
 204
 205   ;; **** Things that can go in the floating point registers.
 206
 207   ;; Non-Descriptor single-floats.
 208   (single-reg float-registers
 209    :locations #.(loop for i from 4 to 31 collect i)
 210    :constant-scs (fp-single-zero)
 211    :save-p t
 212    :alternate-scs (single-stack))
 213
 214   ;; Non-Descriptor double-floats.
 215   (double-reg float-registers
 216    :locations #.(loop for i from 4 to 31 collect i)
 217    :constant-scs (fp-double-zero)
 218    :save-p t
 219    :alternate-scs (double-stack))
 220
 221   (complex-single-reg float-registers
 222    :locations #.(loop for i from 4 to 30 by 2 collect i)
 223    :element-size 2
 224    :constant-scs ()
 225    :save-p t
 226    :alternate-scs (complex-single-stack))
 227
 228   (complex-double-reg float-registers
 229    :locations #.(loop for i from 4 to 30 by 2 collect i)
 230    :element-size 2
 231    :constant-scs ()
 232    :save-p t
 233    :alternate-scs (complex-double-stack))
 234
 235   ;; A catch or unwind block.
 236   (catch-block control-stack :element-size kludge-nondeterministic-catch-block-size))
 237
 238 \f
 239 ;;;; Make some random tns for important registers.
 240
 241 (macrolet ((defregtn (name sc)
 242                (let ((offset-sym (symbolicate name "-OFFSET"))
 243                      (tn-sym (symbolicate name "-TN")))
 244                  `(defparameter ,tn-sym
 245                    (make-random-tn :kind :normal
 246                     :sc (sc-or-lose ',sc)
 247                     :offset ,offset-sym)))))
 248
 249   ;; These, we access by foo-TN only
 250
 251   (defregtn zero any-reg)
 252   (defregtn null descriptor-reg)
 253   (defregtn code descriptor-reg)
 254   (defregtn alloc any-reg)
 255   (defregtn bsp any-reg)
 256   (defregtn csp any-reg)
 257   (defregtn cfp any-reg)
 258   (defregtn nsp any-reg)
 259
 260   ;; These alias regular locations, so we have to make sure we don't bypass
 261   ;; the register allocator when using them.
 262   (defregtn nargs any-reg)
 263   (defregtn ocfp any-reg)
 264   (defregtn lip interior-reg))
 265
 266 ;; And some floating point values.
 267 (defparameter fp-single-zero-tn
 268   (make-random-tn :kind :normal
 269                   :sc (sc-or-lose 'single-reg)
 270                   :offset 0))
 271 (defparameter fp-double-zero-tn
 272   (make-random-tn :kind :normal
 273                   :sc (sc-or-lose 'double-reg)
 274                   :offset 0))
 275
 276 \f
 277 ;;; If VALUE can be represented as an immediate constant, then return
 278 ;;; the 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     ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
 286          character)
 287      (sc-number-or-lose 'immediate))
 288     (symbol
 289      (if (static-symbol-p value)
 290          (sc-number-or-lose 'immediate)
 291          nil))
 292     (single-float
 293      (if (zerop value)
 294          (sc-number-or-lose 'fp-single-zero)
 295          nil))
 296     (double-float
 297      (if (zerop value)
 298          (sc-number-or-lose 'fp-double-zero)
 299          nil))))
 300
 301 \f
 302 ;;;; Function Call Parameters
 303
 304 ;;; The SC numbers for register and stack arguments/return values.
 305 ;;;
 306 (defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
 307 (defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
 308 (defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
 309
 310 (eval-when (:compile-toplevel :load-toplevel :execute)
 311
 312 ;;; Offsets of special stack frame locations
 313 (defconstant ocfp-save-offset 0)
 314 (defconstant lra-save-offset 1)
 315 (defconstant nfp-save-offset 2)
 316
 317 ;;; The number of arguments/return values passed in registers.
 318 ;;;
 319 (defconstant register-arg-count 6)
 320
 321 ;;; Names to use for the argument registers.
 322 ;;;
 323 (defconstant-eqx register-arg-names '(a0 a1 a2 a3 a4 a5) #'equal)
 324
 325 ) ; EVAL-WHEN
 326
 327
 328 ;;; A list of TN's describing the register arguments.
 329 ;;;
 330 (defparameter register-arg-tns
 331   (mapcar #'(lambda (n)
 332               (make-random-tn :kind :normal
 333                               :sc (sc-or-lose 'descriptor-reg)
 334                               :offset n))
 335           *register-arg-offsets*))
 336
 337 ;;; This is used by the debugger.
 338 (defconstant single-value-return-byte-offset 4)
 339 \f
 340 ;;; This function is called by debug output routines that want a pretty name
 341 ;;; for a TN's location.  It returns a thing that can be printed with PRINC.
 342 (!def-vm-support-routine location-print-name (tn)
 343   (declare (type tn tn))
 344   (let ((sb (sb-name (sc-sb (tn-sc tn))))
 345         (offset (tn-offset tn)))
 346     (ecase sb
 347       (registers (or (svref *register-names* offset)
 348                      (format nil "R~D" offset)))
 349       (float-registers (format nil "F~D" offset))
 350       (control-stack (format nil "CS~D" offset))
 351       (non-descriptor-stack (format nil "NS~D" offset))
 352       (constant (format nil "Const~D" offset))
 353       (immediate-constant "Immed"))))
 354
 355 (!def-vm-support-routine combination-implementation-style (node)
 356   (declare (type sb!c::combination node) (ignore node))
 357   (values :default nil))