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 (!define-storage-classes
  95
  96   ;; non-immediate constants in the constant pool
  97   (constant constant)
  98
  99   ;; ZERO and NULL are in registers.
 100   (zero immediate-constant)
 101   (null immediate-constant)
 102   (fp-single-zero immediate-constant)
 103   (fp-double-zero immediate-constant)
 104
 105   ;; Anything else that can be an immediate.
 106   (immediate immediate-constant)
 107
 108
 109   ;; **** The stacks.
 110
 111   ;; The control stack.  (Scanned by GC)
 112   (control-stack control-stack)
 113
 114   ;; We put ANY-REG and DESCRIPTOR-REG early so that their SC-NUMBER
 115   ;; is small and therefore the error trap information is smaller.
 116   ;; Moving them up here from their previous place down below saves
 117   ;; ~250K in core file size.  --njf, 2006-01-27
 118
 119   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
 120   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
 121   (any-reg
 122    registers
 123    :locations #.(append non-descriptor-regs descriptor-regs)
 124    :constant-scs (zero immediate)
 125    :save-p t
 126    :alternate-scs (control-stack))
 127
 128   ;; Pointer descriptor objects.  Must be seen by GC.
 129   (descriptor-reg registers
 130    :locations #.descriptor-regs
 131    :constant-scs (constant null immediate)
 132    :save-p t
 133    :alternate-scs (control-stack))
 134
 135   ;; The non-descriptor stacks.
 136   (signed-stack non-descriptor-stack
 137                 :element-size 2 :alignment 2) ; (signed-byte 64)
 138   (unsigned-stack non-descriptor-stack
 139                   :element-size 2 :alignment 2) ; (unsigned-byte 64)
 140   (character-stack non-descriptor-stack) ; non-descriptor characters.
 141   (sap-stack non-descriptor-stack
 142              :element-size 2 :alignment 2) ; System area pointers.
 143   (single-stack non-descriptor-stack) ; single-floats
 144   (double-stack non-descriptor-stack
 145                 :element-size 2 :alignment 2) ; double floats.
 146   (complex-single-stack non-descriptor-stack :element-size 2)
 147   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
 148
 149
 150   ;; **** Things that can go in the integer registers.
 151
 152   ;; Non-Descriptor characters
 153   (character-reg registers
 154                  :locations #.non-descriptor-regs
 155    :constant-scs (immediate)
 156    :save-p t
 157    :alternate-scs (character-stack))
 158
 159   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
 160   (sap-reg registers
 161    :locations #.non-descriptor-regs
 162    :constant-scs (immediate)
 163    :save-p t
 164    :alternate-scs (sap-stack))
 165
 166   ;; Non-Descriptor (signed or unsigned) numbers.
 167   (signed-reg registers
 168    :locations #.non-descriptor-regs
 169    :constant-scs (zero immediate)
 170    :save-p t
 171    :alternate-scs (signed-stack))
 172   (unsigned-reg registers
 173    :locations #.non-descriptor-regs
 174    :constant-scs (zero immediate)
 175    :save-p t
 176    :alternate-scs (unsigned-stack))
 177
 178   ;; Random objects that must not be seen by GC.  Used only as temporaries.
 179   (non-descriptor-reg registers
 180    :locations #.non-descriptor-regs)
 181
 182   ;; Pointers to the interior of objects.  Used only as an temporary.
 183   (interior-reg registers
 184    :locations (#.lip-offset))
 185
 186
 187   ;; **** Things that can go in the floating point registers.
 188
 189   ;; Non-Descriptor single-floats.
 190   (single-reg float-registers
 191    :locations #.(loop for i from 4 to 30 collect i)
 192    :constant-scs (fp-single-zero)
 193    :save-p t
 194    :alternate-scs (single-stack))
 195
 196   ;; Non-Descriptor double-floats.
 197   (double-reg float-registers
 198    :locations #.(loop for i from 4 to 30 collect i)
 199    :constant-scs (fp-double-zero)
 200    :save-p t
 201    :alternate-scs (double-stack))
 202
 203   (complex-single-reg float-registers
 204    :locations #.(loop for i from 4 to 28 by 2 collect i)
 205    :element-size 2
 206    :constant-scs ()
 207    :save-p t
 208    :alternate-scs (complex-single-stack))
 209
 210   (complex-double-reg float-registers
 211    :locations #.(loop for i from 4 to 28 by 2 collect i)
 212    :element-size 2
 213    :constant-scs ()
 214    :save-p t
 215    :alternate-scs (complex-double-stack))
 216
 217   (catch-block control-stack :element-size catch-block-size)
 218   (unwind-block control-stack :element-size unwind-block-size))
 219 \f
 220 ;;; Make some random tns for important registers.
 221 (macrolet ((defregtn (name sc)
 222              (let ((offset-sym (symbolicate name "-OFFSET"))
 223                    (tn-sym (symbolicate name "-TN")))
 224                `(defparameter ,tn-sym
 225                   (make-random-tn :kind :normal
 226                        :sc (sc-or-lose ',sc)
 227                        :offset ,offset-sym)))))
 228
 229   ;; These, we access by foo-TN only
 230
 231   (defregtn zero any-reg)
 232   (defregtn null descriptor-reg)
 233   (defregtn code descriptor-reg)
 234   (defregtn alloc any-reg)
 235   (defregtn bsp any-reg)
 236   (defregtn csp any-reg)
 237   (defregtn cfp any-reg)
 238   (defregtn nsp any-reg)
 239
 240   ;; These alias regular locations, so we have to make sure we don't bypass
 241   ;; the register allocator when using them.
 242   (defregtn nargs any-reg)
 243   (defregtn ocfp any-reg)
 244   (defregtn lip interior-reg))
 245
 246 ;; and some floating point values..
 247 (defparameter fp-single-zero-tn
 248   (make-random-tn :kind :normal
 249                   :sc (sc-or-lose 'single-reg)
 250                   :offset 31))
 251 (defparameter fp-double-zero-tn
 252   (make-random-tn :kind :normal
 253                   :sc (sc-or-lose 'double-reg)
 254                   :offset 31))
 255 \f
 256 ;;; If value can be represented as an immediate constant, then return
 257 ;;; the appropriate SC number, otherwise return NIL.
 258 (defun immediate-constant-sc (value)
 259   (typecase value
 260     ((integer 0 0)
 261      (sc-number-or-lose 'zero))
 262     (null
 263      (sc-number-or-lose 'null ))
 264     ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
 265          character)
 266      (sc-number-or-lose 'immediate ))
 267     (symbol
 268      (if (static-symbol-p value)
 269          (sc-number-or-lose 'immediate )
 270          nil))
 271     (single-float
 272      (if (eql value 0f0)
 273          (sc-number-or-lose 'fp-single-zero )
 274          nil))
 275     (double-float
 276      (if (eql value 0d0)
 277          (sc-number-or-lose 'fp-double-zero )
 278          nil))))
 279
 280 (defun boxed-immediate-sc-p (sc)
 281   (or (eql sc (sc-number-or-lose 'zero))
 282       (eql sc (sc-number-or-lose 'null))
 283       (eql sc (sc-number-or-lose 'immediate))))
 284
 285 ;;; A predicate to see if a character can be used as an inline
 286 ;;; constant (the immediate field in the instruction used is eight
 287 ;;; bits wide, which is not the same as any defined subtype of
 288 ;;; CHARACTER, as BASE-CHAR is seven bits wide).
 289 (defun inlinable-character-constant-p (char)
 290   (and (characterp char)
 291        (< (char-code char) #x100)))
 292 \f
 293 ;;;; function call parameters
 294
 295 ;;; the SC numbers for register and stack arguments/return values
 296 (defconstant immediate-arg-scn (sc-number-or-lose 'any-reg))
 297 (defconstant control-stack-arg-scn (sc-number-or-lose 'control-stack))
 298
 299 (eval-when  (:compile-toplevel :load-toplevel :execute)
 300
 301 ;;; offsets of special stack frame locations
 302 (defconstant ocfp-save-offset 0)
 303 (defconstant lra-save-offset 1)
 304 (defconstant nfp-save-offset 2)
 305
 306 ;;; the number of arguments/return values passed in registers
 307 (defconstant register-arg-count 6)
 308
 309 ;;; (Names to use for the argument registers would go here, but there
 310 ;;; are none.)
 311
 312 ); EVAL-WHEN
 313
 314 ;;; a list of TN's describing the register arguments
 315 (defparameter *register-arg-tns*
 316   (mapcar (lambda (n)
 317             (make-random-tn :kind :normal
 318                             :sc (sc-or-lose 'descriptor-reg)
 319                             :offset n))
 320           *register-arg-offsets*))
 321
 322 ;;; This is used by the debugger.
 323 (defconstant single-value-return-byte-offset 4)
 324 \f
 325 ;;; This function is called by debug output routines that want a
 326 ;;; pretty name for a TN's location. It returns a thing that can be
 327 ;;; printed with PRINC.
 328 (defun location-print-name (tn)
 329 ;  (declare (type tn tn))
 330   (let ((sb (sb-name (sc-sb (tn-sc tn))))
 331         (offset (tn-offset tn)))
 332     (ecase sb
 333       (registers (or (svref *register-names* offset)
 334                      (format nil "R~D" offset)))
 335       (float-registers (format nil "F~D" offset))
 336       (control-stack (format nil "CS~D" offset))
 337       (non-descriptor-stack (format nil "NS~D" offset))
 338       (constant (format nil "Const~D" offset))
 339       (immediate-constant "Immed"))))
 340
 341 (defun combination-implementation-style (node)
 342   (declare (type sb!c::combination node) (ignore node))
 343   (values :default nil))
 344
 345 (defun primitive-type-indirect-cell-type (ptype)
 346   (declare (ignore ptype))
 347   nil)