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