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                   (def!constant ,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                        `(def!constant ,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 (def!constant kludge-nondeterministic-catch-block-size 6)
 121
 122 (!define-storage-classes
 123
 124   ;; non-immediate constants in the constant pool
 125   (constant constant)
 126
 127   ;; ZERO and NULL are in registers.
 128   (zero immediate-constant)
 129   (null immediate-constant)
 130   (fp-single-zero immediate-constant)
 131   (fp-double-zero immediate-constant)
 132
 133   ;; Anything else that can be an immediate.
 134   (immediate immediate-constant)
 135
 136
 137   ;; **** The stacks.
 138
 139   ;; The control stack.  (Scanned by GC)
 140   (control-stack control-stack)
 141
 142   ;; We put ANY-REG and DESCRIPTOR-REG early so that their SC-NUMBER
 143   ;; is small and therefore the error trap information is smaller.
 144   ;; Moving them up here from their previous place down below saves
 145   ;; ~250K in core file size.  --njf, 2006-01-27
 146
 147   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
 148   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
 149   (any-reg
 150    registers
 151    :locations #.(append non-descriptor-regs descriptor-regs)
 152    :constant-scs (zero immediate)
 153    :save-p t
 154    :alternate-scs (control-stack))
 155
 156   ;; Pointer descriptor objects.  Must be seen by GC.
 157   (descriptor-reg registers
 158    :locations #.descriptor-regs
 159    :constant-scs (constant null immediate)
 160    :save-p t
 161    :alternate-scs (control-stack))
 162
 163   ;; The non-descriptor stacks.
 164   (signed-stack non-descriptor-stack
 165                 :element-size 2 :alignment 2) ; (signed-byte 64)
 166   (unsigned-stack non-descriptor-stack
 167                   :element-size 2 :alignment 2) ; (unsigned-byte 64)
 168   (character-stack non-descriptor-stack) ; non-descriptor characters.
 169   (sap-stack non-descriptor-stack
 170              :element-size 2 :alignment 2) ; System area pointers.
 171   (single-stack non-descriptor-stack) ; single-floats
 172   (double-stack non-descriptor-stack
 173                 :element-size 2 :alignment 2) ; double floats.
 174   (complex-single-stack non-descriptor-stack :element-size 2)
 175   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
 176
 177
 178   ;; **** Things that can go in the integer registers.
 179
 180   ;; Non-Descriptor characters
 181   (character-reg registers
 182                  :locations #.non-descriptor-regs
 183    :constant-scs (immediate)
 184    :save-p t
 185    :alternate-scs (character-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 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 (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
 294          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 (def!constant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
 313 (def!constant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
 314 (def!constant 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 (def!constant ocfp-save-offset 0)
 320 (def!constant lra-save-offset 1)
 321 (def!constant nfp-save-offset 2)
 322
 323 ;;; the number of arguments/return values passed in registers
 324 (def!constant 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 (def!constant 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"))))
 357
 358 (!def-vm-support-routine combination-implementation-style (node)
 359   (declare (type sb!c::combination node) (ignore node))
 360   (values :default nil))
 361
 362 (defun primitive-type-indirect-cell-type (ptype)
 363   (declare (ignore ptype))
 364   nil)