src/compiler/sparc/vm.lisp

   1 ;;;; miscellaneous VM definition noise for the Sparc
   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 ;;;; Define 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
  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/sparc-lispregs.h
  33
  34   ;; Globals.  These are difficult to extract from a sigcontext.
  35   (defreg zero 0)                               ; %g0
  36   (defreg alloc 1)                              ; %g1
  37   (defreg null 2)                               ; %g2
  38   (defreg csp 3)                                ; %g3
  39   (defreg cfp 4)                                ; %g4
  40   (defreg bsp 5)                                ; %g5
  41   ;; %g6 and %g7 are supposed to be reserved for the system.
  42
  43   ;; Outs.  These get clobbered when we call into C.
  44   (defreg nl0 8)                                ; %o0
  45   (defreg nl1 9)                                ; %o1
  46   (defreg nl2 10)                               ; %o2
  47   (defreg nl3 11)                               ; %o3
  48   (defreg nl4 12)                               ; %o4
  49   (defreg nl5 13)                               ; %o5
  50   (defreg nsp 14)                               ; %o6
  51   (defreg nargs 15)                             ; %o7
  52
  53   ;; Locals.  These are preserved when we call into C.
  54   (defreg a0 16)                                ; %l0
  55   (defreg a1 17)                                ; %l1
  56   (defreg a2 18)                                ; %l2
  57   (defreg a3 19)                                ; %l3
  58   (defreg a4 20)                                ; %l4
  59   (defreg a5 21)                                ; %l5
  60   (defreg ocfp 22)                              ; %l6
  61   (defreg lra 23)                               ; %l7
  62
  63   ;; Ins.  These are preserved just like locals.
  64   (defreg cname 24)                             ; %i0
  65   (defreg lexenv 25)                            ; %i1
  66   (defreg l0 26)                                ; %i2
  67   (defreg nfp 27)                               ; %i3
  68   (defreg cfunc 28)                             ; %i4
  69   (defreg code 29)                              ; %i5
  70   ;; we can't touch reg 30 if we ever want to return
  71   (defreg lip 31)                               ; %i7
  72
  73   (defregset non-descriptor-regs
  74       nl0 nl1 nl2 nl3 nl4 nl5 cfunc nargs nfp)
  75
  76   (defregset descriptor-regs
  77       a0 a1 a2 a3 a4 a5 ocfp lra cname lexenv l0)
  78
  79   (defregset *register-arg-offsets*
  80       a0 a1 a2 a3 a4 a5))
  81 \f
  82 ;;;; SB and SC definition:
  83
  84 (define-storage-base registers :finite :size 32)
  85 (define-storage-base float-registers :finite :size 64)
  86 (define-storage-base control-stack :unbounded :size 8)
  87 (define-storage-base non-descriptor-stack :unbounded :size 0)
  88 (define-storage-base constant :non-packed)
  89 (define-storage-base immediate-constant :non-packed)
  90
  91 ;;; Handy macro so we don't have to keep changing all the numbers whenever
  92 ;;; we insert a new storage class.
  93 ;;;
  94 ;;; FIXME: This macro is not needed in the runtime target.
  95 (defmacro define-storage-classes (&rest classes)
  96   (do ((forms (list 'progn)
  97               (let* ((class (car classes))
  98                      (sc-name (car class))
  99                      (constant-name (intern (concatenate 'simple-string
 100                                                          (string sc-name)
 101                                                          "-SC-NUMBER"))))
 102                 (list* `(define-storage-class ,sc-name ,index
 103                           ,@(cdr class))
 104                        `(defconstant ,constant-name ,index)
 105                        ;; (The CMU CL version of this macro did
 106                        ;;   `(EXPORT ',CONSTANT-NAME)
 107                        ;; here, but in SBCL we try to have package
 108                        ;; structure described statically in one
 109                        ;; master source file, instead of building it
 110                        ;; dynamically by letting all the system code
 111                        ;; modify it as the system boots.)
 112                        forms)))
 113        (index 0 (1+ index))
 114        (classes classes (cdr classes)))
 115       ((null classes)
 116        (nreverse forms))))
 117
 118 ;;; see comment in ../x86/vm.lisp.  The value of 7 was taken from
 119 ;;; vm:catch-block-size in a cmucl that I happened to have around
 120 ;;; and seems to be working so far    -dan
 121 ;;;
 122 ;;; arbitrarily taken for alpha, too. - Christophe
 123 (defconstant sb!vm::kludge-nondeterministic-catch-block-size 7)
 124
 125 (define-storage-classes
 126
 127   ;; Non-immediate contstants in the constant pool
 128   (constant constant)
 129
 130   ;; ZERO and NULL are in registers.
 131   (zero immediate-constant)
 132   (null 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) ; (signed-byte 32)
 145   (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
 146   (base-char-stack non-descriptor-stack) ; non-descriptor characters.
 147   (sap-stack non-descriptor-stack) ; System area pointers.
 148   (single-stack non-descriptor-stack) ; single-floats
 149   (double-stack non-descriptor-stack
 150                 :element-size 2 :alignment 2) ; double floats.
 151   #!+long-float
 152   (long-stack non-descriptor-stack :element-size 4 :alignment 4) ; long floats.
 153   ;; complex-single-floats
 154   (complex-single-stack non-descriptor-stack :element-size 2)
 155   ;; complex-double-floats.
 156   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
 157   #!+long-float
 158   ;; complex-long-floats.
 159   (complex-long-stack non-descriptor-stack :element-size 8 :alignment 4)
 160
 161
 162   ;; **** Things that can go in the integer registers.
 163
 164   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
 165   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
 166   (any-reg
 167    registers
 168    :locations #.(append non-descriptor-regs descriptor-regs)
 169    :constant-scs (zero immediate)
 170    :save-p t
 171    :alternate-scs (control-stack))
 172
 173   ;; Pointer descriptor objects.  Must be seen by GC.
 174   (descriptor-reg registers
 175    :locations #.descriptor-regs
 176    :constant-scs (constant null immediate)
 177    :save-p t
 178    :alternate-scs (control-stack))
 179
 180   ;; Non-Descriptor characters
 181   (base-char-reg registers
 182    :locations #.non-descriptor-regs
 183    :constant-scs (immediate)
 184    :save-p t
 185    :alternate-scs (base-char-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 0 to 31 collect i)
 220    :reserve-locations (28 29 30 31)
 221    :constant-scs ()
 222    :save-p t
 223    :alternate-scs (single-stack))
 224
 225   ;; Non-Descriptor double-floats.
 226   (double-reg float-registers
 227    :locations #.(loop for i from 0 to #!-sparc-64 31 #!+sparc-64 63
 228                       by 2 collect i)
 229    :element-size 2 :alignment 2
 230    :reserve-locations (28 30)
 231    :constant-scs ()
 232    :save-p t
 233    :alternate-scs (double-stack))
 234
 235   ;; Non-Descriptor double-floats.
 236   #!+long-float
 237   (long-reg float-registers
 238    :locations #.(loop for i from 0 to #!-sparc-64 31 #!+sparc-64 63
 239                       by 4 collect i)
 240    :element-size 4 :alignment 4
 241    :reserve-locations (28)
 242    :constant-scs ()
 243    :save-p t
 244    :alternate-scs (long-stack))
 245
 246   (complex-single-reg float-registers
 247    :locations #.(loop for i from 0 to 31 by 2 collect i)
 248    :element-size 2 :alignment 2
 249    :reserve-locations (28 30)
 250    :constant-scs ()
 251    :save-p t
 252    :alternate-scs (complex-single-stack))
 253
 254   (complex-double-reg float-registers
 255    :locations #.(loop for i from 0 to #!-sparc-64 31 #!+sparc-64 63
 256                       by 4 collect i)
 257    :element-size 4 :alignment 4
 258    :reserve-locations (28)
 259    :constant-scs ()
 260    :save-p t
 261    :alternate-scs (complex-double-stack))
 262
 263   #!+long-float
 264   (complex-long-reg float-registers
 265    :locations #.(loop for i from 0 to #!-sparc-64 31 #!+sparc-64 63
 266                       by 8 collect i)
 267    :element-size 8 :alignment 8
 268    :constant-scs ()
 269    :save-p t
 270    :alternate-scs (complex-long-stack))
 271
 272
 273   ;; A catch or unwind block.
 274   (catch-block control-stack :element-size sb!vm::kludge-nondeterministic-catch-block-size))
 275
 276
 277 \f
 278 ;;;; Make some random tns for important registers.
 279
 280 (macrolet ((defregtn (name sc)
 281                (let ((offset-sym (symbolicate name "-OFFSET"))
 282                      (tn-sym (symbolicate name "-TN")))
 283                  `(defparameter ,tn-sym
 284                    (make-random-tn :kind :normal
 285                     :sc (sc-or-lose ',sc)
 286                     :offset ,offset-sym)))))
 287   (defregtn zero any-reg)
 288   (defregtn null descriptor-reg)
 289   (defregtn code descriptor-reg)
 290   (defregtn alloc any-reg)
 291
 292   (defregtn nargs any-reg)
 293   (defregtn bsp any-reg)
 294   (defregtn csp any-reg)
 295   (defregtn cfp any-reg)
 296   (defregtn ocfp any-reg)
 297   (defregtn nsp any-reg))
 298
 299
 300 \f
 301 ;;; If value can be represented as an immediate constant, then return the
 302 ;;; appropriate SC number, otherwise return NIL.
 303 (!def-vm-support-routine immediate-constant-sc (value)
 304   (typecase value
 305     ((integer 0 0)
 306      (sc-number-or-lose 'zero))
 307     (null
 308      (sc-number-or-lose 'null))
 309     ((or fixnum system-area-pointer character)
 310      (sc-number-or-lose 'immediate))
 311     (symbol
 312      (if (static-symbol-p value)
 313          (sc-number-or-lose 'immediate)
 314          nil))))
 315
 316 \f
 317 ;;;; function call parameters
 318
 319 ;;; the SC numbers for register and stack arguments/return values.
 320 (defconstant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
 321 (defconstant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
 322 (defconstant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
 323
 324 (eval-when (:compile-toplevel :load-toplevel :execute)
 325
 326   ;; offsets of special stack frame locations
 327   (defconstant ocfp-save-offset 0)
 328   (defconstant lra-save-offset 1)
 329   (defconstant nfp-save-offset 2)
 330
 331   ;; the number of arguments/return values passed in registers.
 332   ;;
 333   (defconstant register-arg-count 6)
 334
 335   ;; names to use for the argument registers.
 336   ;;
 337   (defparameter register-arg-names '(a0 a1 a2 a3 a4 a5))
 338 ); eval-when (:compile-toplevel :load-toplevel :execute)
 339
 340
 341 ;;; a list of TN's describing the register arguments.
 342 (defparameter *register-arg-tns*
 343   (mapcar (lambda (n)
 344             (make-random-tn :kind :normal
 345                               :sc (sc-or-lose 'descriptor-reg)
 346                               :offset n))
 347           *register-arg-offsets*))
 348
 349 ;;; This is used by the debugger.
 350 (defconstant single-value-return-byte-offset 8)
 351
 352 \f
 353 ;;; This function is called by debug output routines that want a
 354 ;;; pretty name for a TN's location. It returns a thing that can be
 355 ;;; printed with PRINC.
 356 (!def-vm-support-routine location-print-name (tn)
 357   (declare (type tn tn)) ; FIXME: commented out on alpha
 358   (let ((sb (sb-name (sc-sb (tn-sc tn))))
 359         (offset (tn-offset tn)))
 360     (ecase sb
 361       (registers (or (svref *register-names* offset)
 362                      (format nil "R~D" offset)))
 363       (float-registers (format nil "F~D" offset))
 364       (control-stack (format nil "CS~D" offset))
 365       (non-descriptor-stack (format nil "NS~D" offset))
 366       (constant (format nil "Const~D" offset))
 367       (immediate-constant "Immed"))))
 368
 369 \f
 370 ;;; The loader uses this to convert alien names to the form they
 371 ;;; occure in the symbol table (for example, prepending an
 372 ;;; underscore).  On the SPARC, we don't prepend an underscore.
 373 (defun extern-alien-name (name)
 374   (declare (type simple-base-string name))
 375   (concatenate 'string #+nil "_" name))