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)
  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 #!-sb-thread l2 #!+sb-thread thread 30)
  78   (defreg lip 31)
  79
  80   (defregset non-descriptor-regs
  81       nl0 nl1 nl2 nl3 nl4 nl5 nl6 cfunc nargs nfp)
  82
  83   (defregset descriptor-regs
  84       fdefn a0 a1 a2 a3  ocfp lra cname lexenv l0 l1 #!-sb-thread 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 (define-storage-classes
 122
 123   ;; Non-immediate contstants in the constant pool
 124   (constant constant)
 125
 126   ;; ZERO and NULL are in registers.
 127   (zero immediate-constant)
 128   (null immediate-constant)
 129
 130   ;; Anything else that can be an immediate.
 131   (immediate immediate-constant)
 132
 133
 134   ;; **** The stacks.
 135
 136   ;; The control stack.  (Scanned by GC)
 137   (control-stack control-stack)
 138
 139   ;; We put ANY-REG and DESCRIPTOR-REG early so that their SC-NUMBER
 140   ;; is small and therefore the error trap information is smaller.
 141   ;; Moving them up here from their previous place down below saves
 142   ;; ~250K in core file size.  --njf, 2006-01-27
 143
 144   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
 145   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
 146   (any-reg
 147    registers
 148    :locations #.(append non-descriptor-regs descriptor-regs)
 149    :constant-scs (zero immediate)
 150    :save-p t
 151    :alternate-scs (control-stack))
 152
 153   ;; Pointer descriptor objects.  Must be seen by GC.
 154   (descriptor-reg registers
 155    :locations #.descriptor-regs
 156    :constant-scs (constant null immediate)
 157    :save-p t
 158    :alternate-scs (control-stack))
 159
 160   ;; The non-descriptor stacks.
 161   (signed-stack non-descriptor-stack) ; (signed-byte 32)
 162   (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
 163   (character-stack non-descriptor-stack) ; non-descriptor characters.
 164   (sap-stack non-descriptor-stack) ; System area pointers.
 165   (single-stack non-descriptor-stack) ; single-floats
 166   (double-stack non-descriptor-stack
 167                 :element-size 2 :alignment 2) ; double floats.
 168   (complex-single-stack non-descriptor-stack :element-size 2)
 169   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
 170
 171
 172   ;; **** Things that can go in the integer registers.
 173
 174   ;; Non-Descriptor characters
 175   (character-reg registers
 176    :locations #.non-descriptor-regs
 177    :constant-scs (immediate)
 178    :save-p t
 179    :alternate-scs (character-stack))
 180
 181   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
 182   (sap-reg registers
 183    :locations #.non-descriptor-regs
 184    :constant-scs (immediate)
 185    :save-p t
 186    :alternate-scs (sap-stack))
 187
 188   ;; Non-Descriptor (signed or unsigned) numbers.
 189   (signed-reg registers
 190    :locations #.non-descriptor-regs
 191    :constant-scs (zero immediate)
 192    :save-p t
 193    :alternate-scs (signed-stack))
 194   (unsigned-reg registers
 195    :locations #.non-descriptor-regs
 196    :constant-scs (zero immediate)
 197    :save-p t
 198    :alternate-scs (unsigned-stack))
 199
 200   ;; Random objects that must not be seen by GC.  Used only as temporaries.
 201   (non-descriptor-reg registers
 202    :locations #.non-descriptor-regs)
 203
 204   ;; Pointers to the interior of objects.  Used only as a temporary.
 205   (interior-reg registers
 206    :locations (#.lip-offset))
 207
 208
 209   ;; **** Things that can go in the floating point registers.
 210
 211   ;; Non-Descriptor single-floats.
 212   (single-reg float-registers
 213    :locations #.(loop for i from 0 to 31 collect i)
 214    ;; ### Note: We really should have every location listed, but then we
 215    ;; would have to make load-tns work with element-sizes other than 1.
 216    :constant-scs ()
 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 0 to 31 collect i)
 223    ;; ### Note: load-tns don't work with an element-size other than 1.
 224    ;; :element-size 2 :alignment 2
 225    :constant-scs ()
 226    :save-p t
 227    :alternate-scs (double-stack))
 228
 229   (complex-single-reg float-registers
 230    :locations #.(loop for i from 0 to 30 by 2 collect i)
 231    :element-size 2
 232    :constant-scs ()
 233    :save-p t
 234    :alternate-scs (complex-single-stack))
 235
 236   (complex-double-reg float-registers
 237    :locations #.(loop for i from 0 to 30 by 2 collect i)
 238    :element-size 2
 239    :constant-scs ()
 240    :save-p t
 241    :alternate-scs (complex-double-stack))
 242
 243   (catch-block control-stack :element-size catch-block-size)
 244   (unwind-block control-stack :element-size unwind-block-size))
 245 \f
 246 ;;;; Make some random tns for important registers.
 247
 248 (macrolet ((defregtn (name sc)
 249                (let ((offset-sym (symbolicate name "-OFFSET"))
 250                      (tn-sym (symbolicate name "-TN")))
 251                  `(defparameter ,tn-sym
 252                    (make-random-tn :kind :normal
 253                     :sc (sc-or-lose ',sc)
 254                     :offset ,offset-sym)))))
 255
 256   (defregtn zero any-reg)
 257   (defregtn lip interior-reg)
 258   (defregtn null descriptor-reg)
 259   (defregtn code descriptor-reg)
 260   (defregtn alloc any-reg)
 261   (defregtn lra descriptor-reg)
 262   (defregtn lexenv descriptor-reg)
 263
 264   (defregtn nargs any-reg)
 265   (defregtn bsp any-reg)
 266   (defregtn csp any-reg)
 267   (defregtn cfp any-reg)
 268   (defregtn ocfp any-reg)
 269   (defregtn nsp any-reg))
 270 \f
 271 ;;; If VALUE can be represented as an immediate constant, then return the
 272 ;;; appropriate SC number, otherwise return NIL.
 273 (defun immediate-constant-sc (value)
 274   (typecase value
 275     ((integer 0 0)
 276      (sc-number-or-lose 'zero))
 277     (null
 278      (sc-number-or-lose 'null))
 279     ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
 280          character)
 281      (sc-number-or-lose 'immediate))
 282     (symbol
 283      (if (static-symbol-p value)
 284          (sc-number-or-lose 'immediate)
 285          nil))))
 286
 287 (defun boxed-immediate-sc-p (sc)
 288   (or (eql sc (sc-number-or-lose 'zero))
 289       (eql sc (sc-number-or-lose 'null))
 290       (eql sc (sc-number-or-lose 'immediate))))
 291
 292 ;;; A predicate to see if a character can be used as an inline
 293 ;;; constant (the immediate field in the instruction used is sixteen
 294 ;;; bits wide, which is not the same as any defined subtype of
 295 ;;; CHARACTER).
 296 (defun inlinable-character-constant-p (char)
 297   (and (characterp char)
 298        (< (char-code char) #x10000)))
 299 \f
 300 ;;;; function call parameters
 301
 302 ;;; the SC numbers for register and stack arguments/return values
 303 (def!constant immediate-arg-scn (sc-number-or-lose 'any-reg))
 304 (def!constant control-stack-arg-scn (sc-number-or-lose 'control-stack))
 305
 306 (eval-when (:compile-toplevel :load-toplevel :execute)
 307
 308 ;;; offsets of special stack frame locations
 309 (def!constant ocfp-save-offset 0)
 310 (def!constant lra-save-offset 1)
 311 (def!constant nfp-save-offset 2)
 312
 313 ;;; the number of arguments/return values passed in registers
 314 (def!constant register-arg-count 4)
 315
 316 ;;; names to use for the argument registers
 317
 318
 319 ) ; EVAL-WHEN
 320
 321
 322 ;;; A list of TN's describing the register arguments.
 323 ;;;
 324 (defparameter *register-arg-tns*
 325   (mapcar #'(lambda (n)
 326               (make-random-tn :kind :normal
 327                               :sc (sc-or-lose 'descriptor-reg)
 328                               :offset n))
 329           *register-arg-offsets*))
 330
 331 #!+sb-thread
 332 (defparameter thread-base-tn
 333   (make-random-tn :kind :normal :sc (sc-or-lose 'unsigned-reg)
 334                   :offset thread-offset))
 335
 336 (export 'single-value-return-byte-offset)
 337
 338 ;;; This is used by the debugger.
 339 (def!constant single-value-return-byte-offset 8)
 340 \f
 341 ;;; This function is called by debug output routines that want a pretty name
 342 ;;; for a TN's location.  It returns a thing that can be printed with PRINC.
 343 (defun location-print-name (tn)
 344   (declare (type tn tn))
 345   (let ((sb (sb-name (sc-sb (tn-sc tn))))
 346         (offset (tn-offset tn)))
 347     (ecase sb
 348       (registers (or (svref *register-names* offset)
 349                      (format nil "R~D" offset)))
 350       (float-registers (format nil "F~D" offset))
 351       (control-stack (format nil "CS~D" offset))
 352       (non-descriptor-stack (format nil "NS~D" offset))
 353       (constant (format nil "Const~D" offset))
 354       (immediate-constant "Immed"))))
 355
 356 (defun combination-implementation-style (node)
 357   (declare (type sb!c::combination node))
 358   (flet ((valid-funtype (args result)
 359            (sb!c::valid-fun-use node
 360                                 (sb!c::specifier-type
 361                                  `(function ,args ,result)))))
 362     (case (sb!c::combination-fun-source-name node)
 363       (logtest
 364        (cond
 365          ((or (valid-funtype '(fixnum fixnum) '*)
 366               (valid-funtype '((signed-byte 32) (signed-byte 32)) '*)
 367               (valid-funtype '((unsigned-byte 32) (unsigned-byte 32)) '*))
 368           (values :maybe nil))
 369          (t (values :default nil))))
 370       (logbitp
 371        (cond
 372          ((or (valid-funtype '((constant-arg (integer 0 29)) fixnum) '*)
 373               (valid-funtype '((constant-arg (integer 0 31)) (signed-byte 32)) '*)
 374               (valid-funtype '((constant-arg (integer 0 31)) (unsigned-byte 32)) '*))
 375           (values :transform '(lambda (index integer)
 376                                (%logbitp integer index))))
 377          (t (values :default nil))))
 378       ;; FIXME: can handle MIN and MAX here
 379       (%ldb
 380        (flet ((validp (type width)
 381                 (and (valid-funtype `((constant-arg (integer 1 29))
 382                                       (constant-arg (mod ,width))
 383                                       ,type)
 384                                     'fixnum)
 385                      (destructuring-bind (size posn integer)
 386                          (sb!c::basic-combination-args node)
 387                        (declare (ignore integer))
 388                        (<= (+ (sb!c::lvar-value size)
 389                               (sb!c::lvar-value posn))
 390                            width)))))
 391          (if (or (validp 'fixnum 29)
 392                  (validp '(signed-byte 32) 32)
 393                  (validp '(unsigned-byte 32) 32))
 394              (values :transform '(lambda (size posn integer)
 395                                   (%%ldb integer size posn)))
 396              (values :default nil))))
 397       (t (values :default nil)))))
 398
 399 (defun primitive-type-indirect-cell-type (ptype)
 400   (declare (ignore ptype))
 401   nil)