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