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 (defmacro !define-storage-classes (&rest classes)
  98   (do ((forms (list 'progn)
  99               (let* ((class (car classes))
 100                      (sc-name (car class))
 101                      (constant-name (intern (concatenate 'simple-string
 102                                                          (string sc-name)
 103                                                          "-SC-NUMBER"))))
 104                 (list* `(define-storage-class ,sc-name ,index
 105                           ,@(cdr class))
 106                        `(defconstant ,constant-name ,index)
 107                        ;; (The CMU CL version of this macro did
 108                        ;;   `(EXPORT ',CONSTANT-NAME)
 109                        ;; here, but in SBCL we try to have package
 110                        ;; structure described statically in one
 111                        ;; master source file, instead of building it
 112                        ;; dynamically by letting all the system code
 113                        ;; modify it as the system boots.)
 114                        forms)))
 115        (index 0 (1+ index))
 116        (classes classes (cdr classes)))
 117       ((null classes)
 118        (nreverse forms))))
 119
 120 ;;; see comment in ../x86/vm.lisp.  The value of 7 was taken from
 121 ;;; vm:catch-block-size in a cmucl that I happened to have around
 122 ;;; and seems to be working so far    -dan
 123 (defconstant sb!vm::kludge-nondeterministic-catch-block-size 7)
 124
 125 (!define-storage-classes
 126
 127   ;; non-immediate constants in the constant pool
 128   (constant constant)
 129
 130   ;; ZERO and NULL are in registers.
 131   (zero immediate-constant)
 132   (null immediate-constant)
 133   (fp-single-zero immediate-constant)
 134   (fp-double-zero immediate-constant)
 135
 136   ;; Anything else that can be an immediate.
 137   (immediate immediate-constant)
 138
 139
 140   ;; **** The stacks.
 141
 142   ;; The control stack.  (Scanned by GC)
 143   (control-stack control-stack)
 144
 145   ;; The non-descriptor stacks.
 146   (signed-stack non-descriptor-stack
 147                 :element-size 2 :alignment 2) ; (signed-byte 64)
 148   (unsigned-stack non-descriptor-stack
 149                   :element-size 2 :alignment 2) ; (unsigned-byte 64)
 150   (base-char-stack non-descriptor-stack) ; non-descriptor characters.
 151   (sap-stack non-descriptor-stack
 152              :element-size 2 :alignment 2) ; System area pointers.
 153   (single-stack non-descriptor-stack) ; single-floats
 154   (double-stack non-descriptor-stack
 155                 :element-size 2 :alignment 2) ; double floats.
 156   (complex-single-stack non-descriptor-stack :element-size 2)
 157   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
 158
 159
 160   ;; **** Things that can go in the integer registers.
 161
 162   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
 163   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
 164   (any-reg
 165    registers
 166    :locations #.(append non-descriptor-regs descriptor-regs)
 167 ;   :locations #.non-descriptor-regs
 168    :constant-scs (zero immediate)
 169    :save-p t
 170    :alternate-scs (control-stack))
 171
 172   ;; Pointer descriptor objects.  Must be seen by GC.
 173   (descriptor-reg registers
 174                   :locations #.descriptor-regs
 175                   :constant-scs (constant null immediate)
 176                   :save-p t
 177                   :alternate-scs (control-stack))
 178
 179   ;; Non-Descriptor characters
 180   (base-char-reg registers
 181                  :locations #.non-descriptor-regs
 182    :constant-scs (immediate)
 183    :save-p t
 184    :alternate-scs (base-char-stack))
 185
 186   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
 187   (sap-reg registers
 188    :locations #.non-descriptor-regs
 189    :constant-scs (immediate)
 190    :save-p t
 191    :alternate-scs (sap-stack))
 192
 193   ;; Non-Descriptor (signed or unsigned) numbers.
 194   (signed-reg registers
 195    :locations #.non-descriptor-regs
 196    :constant-scs (zero immediate)
 197    :save-p t
 198    :alternate-scs (signed-stack))
 199   (unsigned-reg registers
 200    :locations #.non-descriptor-regs
 201    :constant-scs (zero immediate)
 202    :save-p t
 203    :alternate-scs (unsigned-stack))
 204
 205   ;; Random objects that must not be seen by GC.  Used only as temporaries.
 206   (non-descriptor-reg registers
 207    :locations #.non-descriptor-regs)
 208
 209   ;; Pointers to the interior of objects.  Used only as an temporary.
 210   (interior-reg registers
 211    :locations (#.lip-offset))
 212
 213
 214   ;; **** Things that can go in the floating point registers.
 215
 216   ;; Non-Descriptor single-floats.
 217   (single-reg float-registers
 218    :locations #.(loop for i from 4 to 30 collect i)
 219    :constant-scs (fp-single-zero)
 220    :save-p t
 221    :alternate-scs (single-stack))
 222
 223   ;; Non-Descriptor double-floats.
 224   (double-reg float-registers
 225    :locations #.(loop for i from 4 to 30 collect i)
 226    :constant-scs (fp-double-zero)
 227    :save-p t
 228    :alternate-scs (double-stack))
 229
 230   (complex-single-reg float-registers
 231    :locations #.(loop for i from 4 to 28 by 2 collect i)
 232    :element-size 2
 233    :constant-scs ()
 234    :save-p t
 235    :alternate-scs (complex-single-stack))
 236
 237   (complex-double-reg float-registers
 238    :locations #.(loop for i from 4 to 28 by 2 collect i)
 239    :element-size 2
 240    :constant-scs ()
 241    :save-p t
 242    :alternate-scs (complex-double-stack))
 243
 244   ;; A catch or unwind block.
 245   (catch-block control-stack
 246                :element-size sb!vm::kludge-nondeterministic-catch-block-size))
 247 \f
 248 ;;; Make some random tns for important registers.
 249 (macrolet ((defregtn (name sc)
 250              (let ((offset-sym (symbolicate name "-OFFSET"))
 251                    (tn-sym (symbolicate name "-TN")))
 252                `(defparameter ,tn-sym
 253                   (make-random-tn :kind :normal
 254                        :sc (sc-or-lose ',sc)
 255                        :offset ,offset-sym)))))
 256
 257   ;; These, we access by foo-TN only
 258
 259   (defregtn zero any-reg)
 260   (defregtn null descriptor-reg)
 261   (defregtn code descriptor-reg)
 262   (defregtn alloc any-reg)
 263   (defregtn bsp any-reg)
 264   (defregtn csp any-reg)
 265   (defregtn cfp any-reg)
 266   (defregtn nsp any-reg)
 267
 268   ;; These alias regular locations, so we have to make sure we don't bypass
 269   ;; the register allocator when using them.
 270   (defregtn nargs any-reg)
 271   (defregtn ocfp any-reg)
 272   (defregtn lip interior-reg))
 273
 274 ;; and some floating point values..
 275 (defparameter fp-single-zero-tn
 276   (make-random-tn :kind :normal
 277                   :sc (sc-or-lose 'single-reg)
 278                   :offset 31))
 279 (defparameter fp-double-zero-tn
 280   (make-random-tn :kind :normal
 281                   :sc (sc-or-lose 'double-reg)
 282                   :offset 31))
 283 \f
 284 ;;; If value can be represented as an immediate constant, then return
 285 ;;; the appropriate SC number, otherwise return NIL.
 286 (!def-vm-support-routine immediate-constant-sc (value)
 287   (typecase value
 288     ((integer 0 0)
 289      (sc-number-or-lose 'zero))
 290     (null
 291      (sc-number-or-lose 'null ))
 292     ((or fixnum system-area-pointer character)
 293      (sc-number-or-lose 'immediate ))
 294     (symbol
 295      (if (static-symbol-p value)
 296          (sc-number-or-lose 'immediate )
 297          nil))
 298     (single-float
 299      (if (eql value 0f0)
 300          (sc-number-or-lose 'fp-single-zero )
 301          nil))
 302     (double-float
 303      (if (eql value 0d0)
 304          (sc-number-or-lose 'fp-double-zero )
 305          nil))))
 306 \f
 307 ;;;; function call parameters
 308
 309 ;;; the SC numbers for register and stack arguments/return values
 310 (defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
 311 (defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
 312 (defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
 313
 314 (eval-when  (:compile-toplevel :load-toplevel :execute)
 315
 316 ;;; offsets of special stack frame locations
 317 (defconstant ocfp-save-offset 0)
 318 (defconstant lra-save-offset 1)
 319 (defconstant nfp-save-offset 2)
 320
 321 ;;; the number of arguments/return values passed in registers
 322 (defconstant register-arg-count 6)
 323
 324 ;;; (Names to use for the argument registers would go here, but there
 325 ;;; are none.)
 326
 327 ); EVAL-WHEN
 328
 329 ;;; a list of TN's describing the register arguments
 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
 341 ;;; pretty name for a TN's location. It returns a thing that can be
 342 ;;; printed with PRINC.
 343 (!def-vm-support-routine location-print-name (tn)
 344 ;  (declare (type tn tn))
 345   (let ((sb (sb-name (sc-sb (tn-sc tn))))
 346         (offset (tn-offset tn)))
 347     (ecase sb
 348       (registers (or (svref *register-names* offset)
 349                      (format nil "R~D" offset)))
 350       (float-registers (format nil "F~D" offset))
 351       (control-stack (format nil "CS~D" offset))
 352       (non-descriptor-stack (format nil "NS~D" offset))
 353       (constant (format nil "Const~D" offset))
 354       (immediate-constant "Immed"))))