src/compiler/alpha/vm.lisp

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