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