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                    (defconstant ,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-bases
  89 (define-storage-base registers :finite :size 32)
  90 (define-storage-base float-registers :finite :size 64)
  91 (define-storage-base control-stack :unbounded :size 8)
  92 (define-storage-base non-descriptor-stack :unbounded :size 0)
  93 (define-storage-base constant :non-packed)
  94 (define-storage-base immediate-constant :non-packed)
  95 )
  96
  97 (!define-storage-classes
  98
  99   ;; Non-immediate constants in the constant pool
 100   (constant constant)
 101
 102   ;; ZERO and NULL are in registers.
 103   (zero immediate-constant)
 104   (null immediate-constant)
 105   (fp-single-zero immediate-constant)
 106   (fp-double-zero immediate-constant)
 107
 108   ;; Anything else that can be an immediate.
 109   (immediate immediate-constant)
 110
 111
 112   ;; **** The stacks.
 113
 114   ;; The control stack.  (Scanned by GC)
 115   (control-stack control-stack)
 116
 117   ;; We put ANY-REG and DESCRIPTOR-REG early so that their SC-NUMBER
 118   ;; is small and therefore the error trap information is smaller.
 119   ;; Moving them up here from their previous place down below saves
 120   ;; ~250K in core file size.  --njf, 2006-01-27
 121
 122   ;; Immediate descriptor objects.  Don't have to be seen by GC, but nothing
 123   ;; bad will happen if they are.  (fixnums, characters, header values, etc).
 124   (any-reg
 125    registers
 126    :locations #.(append non-descriptor-regs descriptor-regs)
 127    :reserve-locations #.(append reserve-non-descriptor-regs
 128                                 reserve-descriptor-regs)
 129    :constant-scs (constant zero immediate)
 130    :save-p t
 131    :alternate-scs (control-stack))
 132
 133   ;; Pointer descriptor objects.  Must be seen by GC.
 134   (descriptor-reg registers
 135    :locations #.descriptor-regs
 136    :reserve-locations #.reserve-descriptor-regs
 137    :constant-scs (constant null immediate)
 138    :save-p t
 139    :alternate-scs (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   ;; **** Things that can go in the integer registers.
 153
 154   ;; Non-Descriptor characters
 155   (character-reg registers
 156    :locations #.non-descriptor-regs
 157    :reserve-locations #.reserve-non-descriptor-regs
 158    :constant-scs (immediate)
 159    :save-p t
 160    :alternate-scs (character-stack))
 161
 162   ;; Non-Descriptor SAP's (arbitrary pointers into address space)
 163   (sap-reg registers
 164    :locations #.non-descriptor-regs
 165    :reserve-locations #.reserve-non-descriptor-regs
 166    :constant-scs (immediate)
 167    :save-p t
 168    :alternate-scs (sap-stack))
 169
 170   ;; Non-Descriptor (signed or unsigned) numbers.
 171   (signed-reg registers
 172    :locations #.non-descriptor-regs
 173    :reserve-locations #.reserve-non-descriptor-regs
 174    :constant-scs (zero immediate)
 175    :save-p t
 176    :alternate-scs (signed-stack))
 177   (unsigned-reg registers
 178    :locations #.non-descriptor-regs
 179    :reserve-locations #.reserve-non-descriptor-regs
 180    :constant-scs (zero immediate)
 181    :save-p t
 182    :alternate-scs (unsigned-stack))
 183
 184   ;; Random objects that must not be seen by GC.  Used only as temporaries.
 185   (non-descriptor-reg registers
 186    :locations #.non-descriptor-regs)
 187
 188   ;; Pointers to the interior of objects.  Used only as an temporary.
 189   (interior-reg registers
 190    :locations (#.lip-offset))
 191
 192
 193   ;; **** Things that can go in the floating point registers.
 194
 195   ;; Non-Descriptor single-floats.
 196   (single-reg float-registers
 197    :locations #.(loop for i from 4 to 31 collect i)
 198    :constant-scs (fp-single-zero)
 199    :save-p t
 200    :alternate-scs (single-stack))
 201
 202   ;; Non-Descriptor double-floats.
 203   (double-reg float-registers
 204    :locations #.(loop for i from 4 to 31 collect i)
 205    :constant-scs (fp-double-zero)
 206    :save-p t
 207    :alternate-scs (double-stack))
 208
 209   (complex-single-reg float-registers
 210    :locations #.(loop for i from 4 to 30 by 2 collect i)
 211    :element-size 2
 212    :constant-scs ()
 213    :save-p t
 214    :alternate-scs (complex-single-stack))
 215
 216   (complex-double-reg float-registers
 217    :locations #.(loop for i from 4 to 30 by 2 collect i)
 218    :element-size 2
 219    :constant-scs ()
 220    :save-p t
 221    :alternate-scs (complex-double-stack))
 222
 223   (catch-block control-stack :element-size catch-block-size)
 224   (unwind-block control-stack :element-size unwind-block-size)
 225
 226   ;; floating point numbers temporarily stuck in integer registers for c-call
 227   (single-int-carg-reg registers
 228                        :locations (26 25 24 23)
 229                        :alternate-scs ()
 230                        :constant-scs ())
 231   (double-int-carg-reg registers
 232                        :locations (25 23)
 233                        :constant-scs ()
 234                        :alternate-scs ()
 235 ;                       :alignment 2          ;is this needed?
 236 ;                       :element-size 2
 237                        ))
 238
 239 \f
 240 ;;;; Make some random tns for important registers.
 241
 242 ;;; how can we address reg L0 through L0-offset when it is not
 243 ;;; defined here ? do all registers have an -offset and this is
 244 ;;; redundant work ?
 245 ;;;
 246 ;;; FIXME-lav: move this into arch-generic-helpers
 247 (macrolet ((defregtn (name sc)
 248                (let ((offset-sym (symbolicate name "-OFFSET"))
 249                      (tn-sym (symbolicate name "-TN")))
 250                  `(defparameter ,tn-sym
 251                    (make-random-tn :kind :normal
 252                     :sc (sc-or-lose ',sc)
 253                     :offset ,offset-sym)))))
 254
 255   ;; These, we access by foo-TN only
 256
 257   (defregtn zero any-reg)
 258   (defregtn nargs any-reg)
 259   ;; FIXME-lav: 20080820: not a fix, but fdefn and lexenv is used in assembly-rtns
 260   (defregtn fdefn descriptor-reg) ; FIXME-lav, not used
 261   (defregtn lexenv descriptor-reg) ; FIXME-lav, not used
 262
 263   (defregtn nfp descriptor-reg) ; why not descriptor-reg ?
 264   (defregtn ocfp any-reg) ; why not descriptor-reg ?
 265
 266   (defregtn null descriptor-reg)
 267
 268   (defregtn bsp any-reg)
 269   (defregtn cfp any-reg)
 270   (defregtn csp any-reg)
 271   (defregtn alloc any-reg)
 272   (defregtn nsp any-reg)
 273
 274   (defregtn code descriptor-reg)
 275   (defregtn lip interior-reg))
 276
 277 ;; And some floating point values.
 278 (defparameter fp-single-zero-tn
 279   (make-random-tn :kind :normal
 280                   :sc (sc-or-lose 'single-reg)
 281                   :offset 0))
 282 (defparameter fp-double-zero-tn
 283   (make-random-tn :kind :normal
 284                   :sc (sc-or-lose 'double-reg)
 285                   :offset 0))
 286
 287 \f
 288 ;;; If VALUE can be represented as an immediate constant, then return
 289 ;;; the appropriate SC number, otherwise return NIL.
 290 (defun immediate-constant-sc (value)
 291   (typecase value
 292     ((integer 0 0)
 293      (sc-number-or-lose 'zero))
 294     (null
 295      (sc-number-or-lose 'null))
 296     ((or (integer #.sb!xc:most-negative-fixnum #.sb!xc:most-positive-fixnum)
 297          #-sb-xc-host system-area-pointer ; no object can be a SAP in the host
 298          character)
 299      (sc-number-or-lose 'immediate))
 300     (symbol
 301      (if (static-symbol-p value)
 302          (sc-number-or-lose 'immediate)
 303          nil))
 304     (single-float
 305      (if (eql value 0f0)
 306          (sc-number-or-lose 'fp-single-zero)
 307          nil))
 308     (double-float
 309      (if (eql value 0d0)
 310          (sc-number-or-lose 'fp-double-zero)
 311          nil))))
 312
 313 (defun boxed-immediate-sc-p (sc)
 314   (or (eql sc (sc-number-or-lose 'zero))
 315       (eql sc (sc-number-or-lose 'null))
 316       (eql sc (sc-number-or-lose 'immediate))))
 317 \f
 318 ;;;; Function Call Parameters
 319
 320 ;;; The SC numbers for register and stack arguments/return values.
 321 ;;;
 322 (defconstant immediate-arg-scn (sc-number-or-lose 'any-reg))
 323 (defconstant control-stack-arg-scn (sc-number-or-lose 'control-stack))
 324
 325 (eval-when (:compile-toplevel :load-toplevel :execute)
 326
 327 ;;; Offsets of special stack frame locations
 328 (defconstant ocfp-save-offset 0)
 329 (defconstant lra-save-offset 1)
 330 (defconstant nfp-save-offset 2)
 331
 332 ;;; The number of arguments/return values passed in registers.
 333 ;;;
 334 (defconstant register-arg-count 6)
 335
 336 ;;; Names to use for the argument registers.
 337 ;;;
 338 (defconstant-eqx register-arg-names '(a0 a1 a2 a3 a4 a5) #'equal)
 339
 340 ) ; EVAL-WHEN
 341
 342
 343 ;;; A list of TN's describing the register arguments.
 344 ;;;
 345 (defparameter *register-arg-tns*
 346   (mapcar (lambda (n)
 347             (make-random-tn :kind :normal
 348                             :sc (sc-or-lose 'descriptor-reg)
 349                             :offset n))
 350           *register-arg-offsets*))
 351
 352 ;;; This is used by the debugger.
 353 (defconstant single-value-return-byte-offset 4)
 354 \f
 355 ;;; This function is called by debug output routines that want a pretty name
 356 ;;; for a TN's location.  It returns a thing that can be printed with PRINC.
 357 (defun location-print-name (tn)
 358   (declare (type tn tn))
 359   (let ((sb (sb-name (sc-sb (tn-sc tn))))
 360         (offset (tn-offset tn)))
 361     (ecase sb
 362       (registers (or (svref *register-names* offset)
 363                      (format nil "R~D" offset)))
 364       (float-registers (format nil "F~D" offset))
 365       (control-stack (format nil "CS~D" offset))
 366       (non-descriptor-stack (format nil "NS~D" offset))
 367       (constant (format nil "Const~D" offset))
 368       (immediate-constant "Immed"))))
 369
 370 (defun combination-implementation-style (node)
 371   (declare (type sb!c::combination node) (ignore node))
 372   (values :default nil))
 373
 374 (defun primitive-type-indirect-cell-type (ptype)
 375   (declare (ignore ptype))
 376   nil)