src/compiler/ppc/vm.lisp

   1 ;;;; miscellaneous VM definition noise for the PPC
   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 \f
  15 ;;;; Define the registers
  16
  17 (eval-when (:compile-toplevel :load-toplevel :execute)
  18   (defvar *register-names* (make-array 32 :initial-element nil)))
  19
  20 (macrolet ((defreg (name offset)
  21                (let ((offset-sym (symbolicate name "-OFFSET")))
  22                  `(eval-when (:compile-toplevel :load-toplevel :execute)
  23                    (def!constant ,offset-sym ,offset)
  24                    (setf (svref *register-names* ,offset-sym) ,(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")) regs))))))
  31
  32   (defreg zero 0)
  33   (defreg nsp 1)
  34   (defreg rtoc 2)                         ; May be "NULL" someday.
  35   (defreg nl0 3)
  36   (defreg nl1 4)
  37   (defreg nl2 5)
  38   (defreg nl3 6)
  39   (defreg nl4 7)
  40   (defreg nl5 8)
  41   (defreg nl6 9)
  42   (defreg fdefn 10)                     ; was nl7
  43   (defreg nargs 11)
  44   ;; FIXME: some kind of comment here would be nice.
  45   ;;
  46   ;; FIXME II: this also reveals the need to autogenerate lispregs.h
  47   #!+darwin  (defreg cfunc 12)
  48   #!-darwin  (defreg nfp 12)
  49   #!+darwin  (defreg nfp 13)
  50   #!-darwin  (defreg cfunc 13)
  51   (defreg bsp 14)
  52   (defreg cfp 15)
  53   (defreg csp 16)
  54   (defreg alloc 17)
  55   (defreg null 18)
  56   (defreg code 19)
  57   (defreg cname 20)
  58   (defreg lexenv 21)
  59   (defreg ocfp 22)
  60   (defreg lra 23)
  61   (defreg a0 24)
  62   (defreg a1 25)
  63   (defreg a2 26)
  64   (defreg a3 27)
  65   (defreg l0 28)
  66   (defreg l1 29)
  67   (defreg l2 30)
  68   (defreg lip 31)
  69
  70   (defregset non-descriptor-regs
  71       nl0 nl1 nl2 nl3 nl4 nl5 nl6 #+nil nl7 cfunc nargs nfp)
  72
  73   (defregset descriptor-regs
  74       fdefn a0 a1 a2 a3  ocfp lra cname lexenv l0 l1 l2 )
  75
  76
  77  (defregset *register-arg-offsets*  a0 a1 a2 a3)
  78  (defparameter register-arg-names '(a0 a1 a2 a3)))
  79
  80
  81 \f
  82 ;;;; SB and SC definition:
  83
  84 (define-storage-base registers :finite :size 32)
  85 (define-storage-base float-registers :finite :size 32)
  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 ;;;
  92 ;;; Handy macro so we don't have to keep changing all the numbers whenever
  93 ;;; we insert a new storage class.
  94 ;;;
  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                        `(def!constant ,constant-name ,index)
 105                        forms)))
 106        (index 0 (1+ index))
 107        (classes classes (cdr classes)))
 108       ((null classes)
 109        (nreverse forms))))
 110
 111 (def!constant kludge-nondeterministic-catch-block-size 7)
 112
 113 (define-storage-classes
 114
 115   ;; Non-immediate contstants in the constant pool
 116   (constant constant)
 117
 118   ;; ZERO and NULL are in registers.
 119   (zero immediate-constant)
 120   (null immediate-constant)
 121
 122   ;; Anything else that can be an immediate.
 123   (immediate immediate-constant)
 124
 125
 126   ;; **** The stacks.
 127
 128   ;; The control stack.  (Scanned by GC)
 129   (control-stack control-stack)
 130
 131   ;; The non-descriptor stacks.
 132   (signed-stack non-descriptor-stack) ; (signed-byte 32)
 133   (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
 134   (base-char-stack non-descriptor-stack) ; non-descriptor characters.
 135   (sap-stack non-descriptor-stack) ; System area pointers.
 136   (single-stack non-descriptor-stack) ; single-floats
 137   (double-stack non-descriptor-stack
 138                 :element-size 2 :alignment 2) ; double floats.
 139   (complex-single-stack non-descriptor-stack :element-size 2)
 140   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
 141
 142
 143   ;; **** Things that can go in the integer registers.
 144
 145   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
 146   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
 147   (any-reg
 148    registers
 149    :locations #.(append non-descriptor-regs descriptor-regs)
 150    :constant-scs (zero immediate)
 151    :save-p t
 152    :alternate-scs (control-stack))
 153
 154   ;; Pointer descriptor objects.  Must be seen by GC.
 155   (descriptor-reg registers
 156    :locations #.descriptor-regs
 157    :constant-scs (constant null immediate)
 158    :save-p t
 159    :alternate-scs (control-stack))
 160
 161   ;; Non-Descriptor characters
 162   (base-char-reg registers
 163    :locations #.non-descriptor-regs
 164    :constant-scs (immediate)
 165    :save-p t
 166    :alternate-scs (base-char-stack))
 167
 168   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
 169   (sap-reg registers
 170    :locations #.non-descriptor-regs
 171    :constant-scs (immediate)
 172    :save-p t
 173    :alternate-scs (sap-stack))
 174
 175   ;; Non-Descriptor (signed or unsigned) numbers.
 176   (signed-reg registers
 177    :locations #.non-descriptor-regs
 178    :constant-scs (zero immediate)
 179    :save-p t
 180    :alternate-scs (signed-stack))
 181   (unsigned-reg registers
 182    :locations #.non-descriptor-regs
 183    :constant-scs (zero immediate)
 184    :save-p t
 185    :alternate-scs (unsigned-stack))
 186
 187   ;; Random objects that must not be seen by GC.  Used only as temporaries.
 188   (non-descriptor-reg registers
 189    :locations #.non-descriptor-regs)
 190
 191   ;; Pointers to the interior of objects.  Used only as a temporary.
 192   (interior-reg registers
 193    :locations (#.lip-offset))
 194
 195
 196   ;; **** Things that can go in the floating point registers.
 197
 198   ;; Non-Descriptor single-floats.
 199   (single-reg float-registers
 200    :locations #.(loop for i from 0 to 31 collect i)
 201    ;; ### Note: We really should have every location listed, but then we
 202    ;; would have to make load-tns work with element-sizes other than 1.
 203    :constant-scs ()
 204    :save-p t
 205    :alternate-scs (single-stack))
 206
 207   ;; Non-Descriptor double-floats.
 208   (double-reg float-registers
 209    :locations #.(loop for i from 0 to 31 collect i)
 210    ;; ### Note: load-tns don't work with an element-size other than 1.
 211    ;; :element-size 2 :alignment 2
 212    :constant-scs ()
 213    :save-p t
 214    :alternate-scs (double-stack))
 215
 216   (complex-single-reg float-registers
 217    :locations #.(loop for i from 0 to 30 by 2 collect i)
 218    :element-size 2
 219    :constant-scs ()
 220    :save-p t
 221    :alternate-scs (complex-single-stack))
 222
 223   (complex-double-reg float-registers
 224    :locations #.(loop for i from 0 to 30 by 2 collect i)
 225    :element-size 2
 226    :constant-scs ()
 227    :save-p t
 228    :alternate-scs (complex-double-stack))
 229
 230   ;; A catch or unwind block.
 231   (catch-block control-stack
 232                :element-size kludge-nondeterministic-catch-block-size))
 233 \f
 234 ;;;; Make some random tns for important registers.
 235
 236 (macrolet ((defregtn (name sc)
 237                (let ((offset-sym (symbolicate name "-OFFSET"))
 238                      (tn-sym (symbolicate name "-TN")))
 239                  `(defparameter ,tn-sym
 240                    (make-random-tn :kind :normal
 241                     :sc (sc-or-lose ',sc)
 242                     :offset ,offset-sym)))))
 243
 244   (defregtn zero any-reg)
 245   (defregtn lip interior-reg)
 246   (defregtn null descriptor-reg)
 247   (defregtn code descriptor-reg)
 248   (defregtn alloc any-reg)
 249
 250   (defregtn nargs any-reg)
 251   (defregtn bsp any-reg)
 252   (defregtn csp any-reg)
 253   (defregtn cfp any-reg)
 254   (defregtn ocfp any-reg)
 255   (defregtn nsp any-reg))
 256 \f
 257 ;;; If VALUE can be represented as an immediate constant, then return the
 258 ;;; appropriate SC number, otherwise return NIL.
 259 (!def-vm-support-routine immediate-constant-sc (value)
 260   (typecase value
 261     ((integer 0 0)
 262      (sc-number-or-lose 'zero))
 263     (null
 264      (sc-number-or-lose 'null))
 265     ((or fixnum system-area-pointer character)
 266      (sc-number-or-lose 'immediate))
 267     (symbol
 268      (if (static-symbol-p value)
 269          (sc-number-or-lose 'immediate)
 270          nil))))
 271 \f
 272 ;;;; function call parameters
 273
 274 ;;; the SC numbers for register and stack arguments/return values
 275 (def!constant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
 276 (def!constant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
 277 (def!constant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
 278
 279 (eval-when (:compile-toplevel :load-toplevel :execute)
 280
 281 ;;; offsets of special stack frame locations
 282 (def!constant ocfp-save-offset 0)
 283 (def!constant lra-save-offset 1)
 284 (def!constant nfp-save-offset 2)
 285
 286 ;;; the number of arguments/return values passed in registers
 287 (def!constant register-arg-count 4)
 288
 289 ;;; names to use for the argument registers
 290
 291
 292 ) ; EVAL-WHEN
 293
 294
 295 ;;; A list of TN's describing the register arguments.
 296 ;;;
 297 (defparameter *register-arg-tns*
 298   (mapcar #'(lambda (n)
 299               (make-random-tn :kind :normal
 300                               :sc (sc-or-lose 'descriptor-reg)
 301                               :offset n))
 302           *register-arg-offsets*))
 303
 304 (export 'single-value-return-byte-offset)
 305
 306 ;;; This is used by the debugger.
 307 (def!constant single-value-return-byte-offset 8)
 308 \f
 309 ;;; This function is called by debug output routines that want a pretty name
 310 ;;; for a TN's location.  It returns a thing that can be printed with PRINC.
 311 (!def-vm-support-routine location-print-name (tn)
 312   (declare (type tn tn))
 313   (let ((sb (sb-name (sc-sb (tn-sc tn))))
 314         (offset (tn-offset tn)))
 315     (ecase sb
 316       (registers (or (svref *register-names* offset)
 317                      (format nil "R~D" offset)))
 318       (float-registers (format nil "F~D" offset))
 319       (control-stack (format nil "CS~D" offset))
 320       (non-descriptor-stack (format nil "NS~D" offset))
 321       (constant (format nil "Const~D" offset))
 322       (immediate-constant "Immed"))))
 323 \f
 324 ;;; The loader uses this to convert alien names to the form they
 325 ;;; occur in the symbol table.  This is ELF, so do nothing.
 326
 327 (defun extern-alien-name (name)
 328   (declare (type simple-base-string name))
 329   ;; Darwin is non-ELF, and needs a _ prefix
 330   #!+darwin (concatenate 'string "_" name)
 331   ;; The other (ELF) ports currently don't need any prefix
 332   #!-darwin name)