src/compiler/hppa/vm.lisp

   1 ;;;; miscellaneous VM definition noise for HPPA
   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 ;;;; 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            (defregset (name &rest regs)
  26                `(eval-when (:compile-toplevel :load-toplevel :execute)
  27                  (defparameter ,name
  28                    (list ,@(mapcar #'(lambda (name) (symbolicate name "-OFFSET")) regs))))))
  29   ;; Wired-zero
  30   (defreg zero 0)
  31   ;; This gets trashed by the C call convention.
  32   (defreg nfp 1) ;; and saved by lisp before calling C
  33   (defreg cfunc 2)
  34   ;; These are the callee saves, so these registers are stay live over
  35   ;; call-out.
  36   (defreg csp 3)
  37   (defreg cfp 4)
  38   (defreg bsp 5)
  39   (defreg null 6)
  40   (defreg alloc 7)
  41   (defreg code 8)
  42   (defreg fdefn 9)
  43   (defreg lexenv 10)
  44   (defreg nargs 11)
  45   (defreg ocfp 12)
  46   (defreg lra 13)
  47   (defreg a0 14)
  48   (defreg a1 15)
  49   (defreg a2 16)
  50   (defreg a3 17)
  51   (defreg a4 18)
  52   ;; This is where the caller-saves registers start, but we don't
  53   ;; really care because we need to clear the above after call-out to
  54   ;; make sure no pointers into oldspace are kept around.
  55   (defreg a5 19)
  56   (defreg l0 20)
  57   (defreg l1 21)
  58   (defreg l2 22)
  59   ;; These are the 4 C argument registers.
  60   (defreg nl3 23)
  61   (defreg nl2 24)
  62   (defreg nl1 25)
  63   (defreg nl0 26)
  64   ;; The global Data Pointer.  We just leave it alone, because we
  65   ;; don't need it.
  66   (defreg dp 27)
  67   ;; These two are use for C return values.
  68   (defreg nl4 28)
  69   (defreg nl5 29)
  70   (defreg nsp 30)
  71   (defreg lip 31)
  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 fdefn lexenv ocfp lra l0 l1 l2)
  78
  79   (defregset *register-arg-offsets*
  80     a0 a1 a2 a3 a4 a5)
  81
  82   (defregset reserve-descriptor-regs
  83              fdefn lexenv)
  84
  85   (defregset reserve-non-descriptor-regs
  86              cfunc))
  87
  88 (define-storage-base registers :finite :size 32)
  89 (define-storage-base float-registers :finite :size 64)
  90 (define-storage-base control-stack :unbounded :size 8)
  91 (define-storage-base non-descriptor-stack :unbounded :size 0)
  92 (define-storage-base constant :non-packed)
  93 (define-storage-base immediate-constant :non-packed)
  94
  95 ;;;
  96 ;;; Handy macro so we don't have to keep changing all the numbers whenever
  97 ;;; we insert a new storage class.
  98 ;;; FIX-lav: move this into arch-generic-helpers.lisp and rip out from arches
  99 (defmacro !define-storage-classes (&rest classes)
 100   (do ((forms (list 'progn)
 101               (let* ((class (car classes))
 102                      (sc-name (car class))
 103                      (constant-name (intern (concatenate 'simple-string
 104                                                          (string sc-name)
 105                                                          "-SC-NUMBER"))))
 106                 (list* `(define-storage-class ,sc-name ,index
 107                           ,@(cdr class))
 108                        `(def!constant ,constant-name ,index)
 109                        forms)))
 110        (index 0 (1+ index))
 111        (classes classes (cdr classes)))
 112       ((null classes)
 113        (nreverse forms))))
 114
 115 (def!constant kludge-nondeterministic-catch-block-size 7)
 116
 117 (!define-storage-classes
 118
 119   ;; Non-immediate constants in the constant pool
 120   (constant constant)
 121
 122   ;; ZERO and NULL are in registers.
 123   (zero immediate-constant)
 124   (null immediate-constant)
 125   (fp-single-zero immediate-constant)
 126   (fp-double-zero immediate-constant)
 127
 128   ;; Anything else that can be an immediate.
 129   (immediate immediate-constant)
 130
 131
 132   ;; **** The stacks.
 133
 134   ;; The control stack.  (Scanned by GC)
 135   (control-stack control-stack)
 136
 137   ;; We put ANY-REG and DESCRIPTOR-REG early so that their SC-NUMBER
 138   ;; is small and therefore the error trap information is smaller.
 139   ;; Moving them up here from their previous place down below saves
 140   ;; ~250K in core file size.  --njf, 2006-01-27
 141
 142   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
 143   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
 144   (any-reg
 145    registers
 146    :locations #.(append non-descriptor-regs descriptor-regs)
 147    :reserve-locations #.(append reserve-non-descriptor-regs
 148                                 reserve-descriptor-regs)
 149    :constant-scs (constant 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    :reserve-locations #.reserve-descriptor-regs
 157    :constant-scs (constant null immediate)
 158    :save-p t
 159    :alternate-scs (control-stack))
 160
 161   ;; The non-descriptor stacks.
 162   (signed-stack non-descriptor-stack) ; (signed-byte 32)
 163   (unsigned-stack non-descriptor-stack) ; (unsigned-byte 32)
 164   (character-stack non-descriptor-stack) ; non-descriptor characters.
 165   (sap-stack non-descriptor-stack) ; System area pointers.
 166   (single-stack non-descriptor-stack) ; single-floats
 167   (double-stack non-descriptor-stack
 168                 :element-size 2 :alignment 2) ; double floats.
 169   (complex-single-stack non-descriptor-stack :element-size 2)
 170   (complex-double-stack non-descriptor-stack :element-size 4 :alignment 2)
 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    :reserve-locations #.reserve-non-descriptor-regs
 178    :constant-scs (immediate)
 179    :save-p t
 180    :alternate-scs (character-stack))
 181
 182   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
 183   (sap-reg registers
 184    :locations #.non-descriptor-regs
 185    :reserve-locations #.reserve-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    :reserve-locations #.reserve-non-descriptor-regs
 194    :constant-scs (zero immediate)
 195    :save-p t
 196    :alternate-scs (signed-stack))
 197   (unsigned-reg registers
 198    :locations #.non-descriptor-regs
 199    :reserve-locations #.reserve-non-descriptor-regs
 200    :constant-scs (zero immediate)
 201    :save-p t
 202    :alternate-scs (unsigned-stack))
 203
 204   ;; Random objects that must not be seen by GC.  Used only as temporaries.
 205   (non-descriptor-reg registers
 206    :locations #.non-descriptor-regs)
 207
 208   ;; Pointers to the interior of objects.  Used only as an temporary.
 209   (interior-reg registers
 210    :locations (#.lip-offset))
 211
 212
 213   ;; **** Things that can go in the floating point registers.
 214
 215   ;; Non-Descriptor single-floats.
 216   (single-reg float-registers
 217    :locations #.(loop for i from 4 to 31 collect i)
 218    :constant-scs (fp-single-zero)
 219    :save-p t
 220    :alternate-scs (single-stack))
 221
 222   ;; Non-Descriptor double-floats.
 223   (double-reg float-registers
 224    :locations #.(loop for i from 4 to 31 collect i)
 225    :constant-scs (fp-double-zero)
 226    :save-p t
 227    :alternate-scs (double-stack))
 228
 229   (complex-single-reg float-registers
 230    :locations #.(loop for i from 4 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 4 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   ;; A catch or unwind block.
 244   (catch-block control-stack :element-size kludge-nondeterministic-catch-block-size)
 245
 246
 247   ;; floating point numbers temporarily stuck in integer registers for c-call
 248   (single-int-carg-reg registers
 249                        :locations (26 25 24 23)
 250                        :alternate-scs ()
 251                        :constant-scs ())
 252   (double-int-carg-reg registers
 253                        :locations (25 23)
 254                        :constant-scs ()
 255                        :alternate-scs ()
 256 ;                       :alignment 2          ;is this needed?
 257 ;                       :element-size 2
 258                        ))
 259
 260 \f
 261 ;;;; Make some random tns for important registers.
 262 ; how can we address reg L0 through L0-offset when it is not
 263 ; defined here ? do all registers have an -offset and this is
 264 ; redundant work ?
 265 ;FIX-lav: move this into arch-generic-helpers
 266 (macrolet ((defregtn (name sc)
 267                (let ((offset-sym (symbolicate name "-OFFSET"))
 268                      (tn-sym (symbolicate name "-TN")))
 269                  `(defparameter ,tn-sym
 270                    (make-random-tn :kind :normal
 271                     :sc (sc-or-lose ',sc)
 272                     :offset ,offset-sym)))))
 273
 274   ;; These, we access by foo-TN only
 275
 276   (defregtn zero any-reg)
 277   (defregtn nargs any-reg)
 278   ;FIX-lav: 20080820: not a fix, but fdefn and lexenv is used in assembly-rtns
 279   (defregtn fdefn descriptor-reg) ; FIX-lav, not used
 280   (defregtn lexenv descriptor-reg) ; FIX-lav, not used
 281
 282   (defregtn nfp descriptor-reg) ; why not descriptor-reg ?
 283   (defregtn ocfp any-reg) ; why not descriptor-reg ?
 284
 285   (defregtn null descriptor-reg)
 286
 287   (defregtn bsp any-reg)
 288   (defregtn cfp any-reg)
 289   (defregtn csp any-reg)
 290   (defregtn alloc any-reg)
 291   (defregtn nsp any-reg)
 292
 293   (defregtn code descriptor-reg)
 294   (defregtn lip interior-reg))
 295
 296 ;; And some floating point values.
 297 (defparameter fp-single-zero-tn
 298   (make-random-tn :kind :normal
 299                   :sc (sc-or-lose 'single-reg)
 300                   :offset 0))
 301 (defparameter fp-double-zero-tn
 302   (make-random-tn :kind :normal
 303                   :sc (sc-or-lose 'double-reg)
 304                   :offset 0))
 305
 306 \f
 307 ;;; If VALUE can be represented as an immediate constant, then return
 308 ;;; the appropriate SC number, otherwise return NIL.
 309 (!def-vm-support-routine immediate-constant-sc (value)
 310   (typecase value
 311     ((integer 0 0)
 312      (sc-number-or-lose 'zero))
 313     (null
 314      (sc-number-or-lose 'null))
 315     ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
 316          system-area-pointer character)
 317      (sc-number-or-lose 'immediate))
 318     (symbol
 319      (if (static-symbol-p value)
 320          (sc-number-or-lose 'immediate)
 321          nil))
 322     (single-float
 323      (if (zerop value)
 324          (sc-number-or-lose 'fp-single-zero)
 325          nil))
 326     (double-float
 327      (if (zerop value)
 328          (sc-number-or-lose 'fp-double-zero)
 329          nil))))
 330
 331 \f
 332 ;;;; Function Call Parameters
 333
 334 ;;; The SC numbers for register and stack arguments/return values.
 335 ;;;
 336 (def!constant register-arg-scn (meta-sc-number-or-lose 'descriptor-reg))
 337 (def!constant immediate-arg-scn (meta-sc-number-or-lose 'any-reg))
 338 (def!constant control-stack-arg-scn (meta-sc-number-or-lose 'control-stack))
 339
 340 (eval-when (:compile-toplevel :load-toplevel :execute)
 341
 342 ;;; Offsets of special stack frame locations
 343 (def!constant ocfp-save-offset 0)
 344 (def!constant lra-save-offset 1)
 345 (def!constant nfp-save-offset 2)
 346
 347 ;;; The number of arguments/return values passed in registers.
 348 ;;;
 349 (def!constant register-arg-count 6)
 350
 351 ;;; Names to use for the argument registers.
 352 ;;;
 353 (defconstant-eqx register-arg-names '(a0 a1 a2 a3 a4 a5) #'equal)
 354
 355 ) ; EVAL-WHEN
 356
 357
 358 ;;; A list of TN's describing the register arguments.
 359 ;;;
 360 (defparameter *register-arg-tns*
 361   (mapcar (lambda (n)
 362             (make-random-tn :kind :normal
 363                             :sc (sc-or-lose 'descriptor-reg)
 364                             :offset n))
 365           *register-arg-offsets*))
 366
 367 ;;; This is used by the debugger.
 368 (def!constant single-value-return-byte-offset 4)
 369 \f
 370 ;;; This function is called by debug output routines that want a pretty name
 371 ;;; for a TN's location.  It returns a thing that can be printed with PRINC.
 372 (!def-vm-support-routine location-print-name (tn)
 373   (declare (type tn tn))
 374   (let ((sb (sb-name (sc-sb (tn-sc tn))))
 375         (offset (tn-offset tn)))
 376     (ecase sb
 377       (registers (or (svref *register-names* offset)
 378                      (format nil "R~D" offset)))
 379       (float-registers (format nil "F~D" offset))
 380       (control-stack (format nil "CS~D" offset))
 381       (non-descriptor-stack (format nil "NS~D" offset))
 382       (constant (format nil "Const~D" offset))
 383       (immediate-constant "Immed"))))
 384
 385 (!def-vm-support-routine combination-implementation-style (node)
 386   (declare (type sb!c::combination node) (ignore node))
 387   (values :default nil))