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 7)
 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   ;; The non-descriptor stacks.
 143   (signed-stack non-descriptor-stack
 144                 :element-size 2 :alignment 2) ; (signed-byte 64)
 145   (unsigned-stack non-descriptor-stack
 146                   :element-size 2 :alignment 2) ; (unsigned-byte 64)
 147   (character-stack non-descriptor-stack) ; non-descriptor characters.
 148   (sap-stack non-descriptor-stack
 149              :element-size 2 :alignment 2) ; System area pointers.
 150   (single-stack non-descriptor-stack) ; single-floats
 151   (double-stack non-descriptor-stack
 152                 :element-size 2 :alignment 2) ; double floats.
 153   (complex-single-stack non-descriptor-stack :element-size 2)
 154   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
 155
 156
 157   ;; **** Things that can go in the integer registers.
 158
 159   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
 160   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
 161   (any-reg
 162    registers
 163    :locations #.(append non-descriptor-regs descriptor-regs)
 164 ;   :locations #.non-descriptor-regs
 165    :constant-scs (zero immediate)
 166    :save-p t
 167    :alternate-scs (control-stack))
 168
 169   ;; Pointer descriptor objects.  Must be seen by GC.
 170   (descriptor-reg registers
 171                   :locations #.descriptor-regs
 172                   :constant-scs (constant null immediate)
 173                   :save-p t
 174                   :alternate-scs (control-stack))
 175
 176   ;; Non-Descriptor characters
 177   (character-reg registers
 178                  :locations #.non-descriptor-regs
 179    :constant-scs (immediate)
 180    :save-p t
 181    :alternate-scs (character-stack))
 182
 183   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
 184   (sap-reg registers
 185    :locations #.non-descriptor-regs
 186    :constant-scs (immediate)
 187    :save-p t
 188    :alternate-scs (sap-stack))
 189
 190   ;; Non-Descriptor (signed or unsigned) numbers.
 191   (signed-reg registers
 192    :locations #.non-descriptor-regs
 193    :constant-scs (zero immediate)
 194    :save-p t
 195    :alternate-scs (signed-stack))
 196   (unsigned-reg registers
 197    :locations #.non-descriptor-regs
 198    :constant-scs (zero immediate)
 199    :save-p t
 200    :alternate-scs (unsigned-stack))
 201
 202   ;; Random objects that must not be seen by GC.  Used only as temporaries.
 203   (non-descriptor-reg registers
 204    :locations #.non-descriptor-regs)
 205
 206   ;; Pointers to the interior of objects.  Used only as an temporary.
 207   (interior-reg registers
 208    :locations (#.lip-offset))
 209
 210
 211   ;; **** Things that can go in the floating point registers.
 212
 213   ;; Non-Descriptor single-floats.
 214   (single-reg float-registers
 215    :locations #.(loop for i from 4 to 30 collect i)
 216    :constant-scs (fp-single-zero)
 217    :save-p t
 218    :alternate-scs (single-stack))
 219
 220   ;; Non-Descriptor double-floats.
 221   (double-reg float-registers
 222    :locations #.(loop for i from 4 to 30 collect i)
 223    :constant-scs (fp-double-zero)
 224    :save-p t
 225    :alternate-scs (double-stack))
 226
 227   (complex-single-reg float-registers
 228    :locations #.(loop for i from 4 to 28 by 2 collect i)
 229    :element-size 2
 230    :constant-scs ()
 231    :save-p t
 232    :alternate-scs (complex-single-stack))
 233
 234   (complex-double-reg float-registers
 235    :locations #.(loop for i from 4 to 28 by 2 collect i)
 236    :element-size 2
 237    :constant-scs ()
 238    :save-p t
 239    :alternate-scs (complex-double-stack))
 240
 241   ;; A catch or unwind block.
 242   (catch-block control-stack
 243                :element-size kludge-nondeterministic-catch-block-size))
 244 \f
 245 ;;; Make some random tns for important registers.
 246 (macrolet ((defregtn (name sc)
 247              (let ((offset-sym (symbolicate name "-OFFSET"))
 248                    (tn-sym (symbolicate name "-TN")))
 249                `(defparameter ,tn-sym
 250                   (make-random-tn :kind :normal
 251                        :sc (sc-or-lose ',sc)
 252                        :offset ,offset-sym)))))
 253
 254   ;; These, we access by foo-TN only
 255
 256   (defregtn zero any-reg)
 257   (defregtn null descriptor-reg)
 258   (defregtn code descriptor-reg)
 259   (defregtn alloc any-reg)
 260   (defregtn bsp any-reg)
 261   (defregtn csp any-reg)
 262   (defregtn cfp any-reg)
 263   (defregtn nsp any-reg)
 264
 265   ;; These alias regular locations, so we have to make sure we don't bypass
 266   ;; the register allocator when using them.
 267   (defregtn nargs any-reg)
 268   (defregtn ocfp any-reg)
 269   (defregtn lip interior-reg))
 270
 271 ;; and some floating point values..
 272 (defparameter fp-single-zero-tn
 273   (make-random-tn :kind :normal
 274                   :sc (sc-or-lose 'single-reg)
 275                   :offset 31))
 276 (defparameter fp-double-zero-tn
 277   (make-random-tn :kind :normal
 278                   :sc (sc-or-lose 'double-reg)
 279                   :offset 31))
 280 \f
 281 ;;; If value can be represented as an immediate constant, then return
 282 ;;; the appropriate SC number, otherwise return NIL.
 283 (!def-vm-support-routine immediate-constant-sc (value)
 284   (typecase value
 285     ((integer 0 0)
 286      (sc-number-or-lose 'zero))
 287     (null
 288      (sc-number-or-lose 'null ))
 289     ((or fixnum system-area-pointer character)
 290      (sc-number-or-lose 'immediate ))
 291     (symbol
 292      (if (static-symbol-p value)
 293          (sc-number-or-lose 'immediate )
 294          nil))
 295     (single-float
 296      (if (eql value 0f0)
 297          (sc-number-or-lose 'fp-single-zero )
 298          nil))
 299     (double-float
 300      (if (eql value 0d0)
 301          (sc-number-or-lose 'fp-double-zero )
 302          nil))))
 303 \f
 304 ;;;; function call parameters
 305
 306 ;;; the SC numbers for register and stack arguments/return values
 307 (def!constant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
 308 (def!constant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
 309 (def!constant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
 310
 311 (eval-when  (:compile-toplevel :load-toplevel :execute)
 312
 313 ;;; offsets of special stack frame locations
 314 (def!constant ocfp-save-offset 0)
 315 (def!constant lra-save-offset 1)
 316 (def!constant nfp-save-offset 2)
 317
 318 ;;; the number of arguments/return values passed in registers
 319 (def!constant register-arg-count 6)
 320
 321 ;;; (Names to use for the argument registers would go here, but there
 322 ;;; are none.)
 323
 324 ); EVAL-WHEN
 325
 326 ;;; a list of TN's describing the register arguments
 327 (defparameter *register-arg-tns*
 328   (mapcar (lambda (n)
 329             (make-random-tn :kind :normal
 330                             :sc (sc-or-lose 'descriptor-reg)
 331                             :offset n))
 332           *register-arg-offsets*))
 333
 334 ;;; This is used by the debugger.
 335 (def!constant single-value-return-byte-offset 4)
 336 \f
 337 ;;; This function is called by debug output routines that want a
 338 ;;; pretty name for a TN's location. It returns a thing that can be
 339 ;;; printed with PRINC.
 340 (!def-vm-support-routine location-print-name (tn)
 341 ;  (declare (type tn tn))
 342   (let ((sb (sb-name (sc-sb (tn-sc tn))))
 343         (offset (tn-offset tn)))
 344     (ecase sb
 345       (registers (or (svref *register-names* offset)
 346                      (format nil "R~D" offset)))
 347       (float-registers (format nil "F~D" offset))
 348       (control-stack (format nil "CS~D" offset))
 349       (non-descriptor-stack (format nil "NS~D" offset))
 350       (constant (format nil "Const~D" offset))
 351       (immediate-constant "Immed"))))
 352 \f
 353 ;;; The loader uses this to convert alien names to the form they
 354 ;;; occure in the symbol table (for example, prepending an
 355 ;;; underscore).
 356 (defun extern-alien-name (name)
 357   (declare (type string name))
 358   ;; ELF ports currently don't need any prefix
 359   (typecase name
 360     (simple-base-string name)
 361     (base-string (coerce name 'simple-base-string))
 362     (t (handler-case (coerce name 'simple-base-string)
 363          (type-error () (error "invalid external alien name: ~S" name))))))