src/compiler/alpha/vm.lisp

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