src/compiler/ppc/macros.lisp

   1 ;;;; a bunch of handy macros 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 \f
  14 ;;; Instruction-like macros.
  15
  16 (defmacro move (dst src)
  17   "Move SRC into DST unless they are location=."
  18   (once-only ((n-dst dst)
  19               (n-src src))
  20     `(unless (location= ,n-dst ,n-src)
  21        (inst mr ,n-dst ,n-src))))
  22
  23 (macrolet
  24     ((def (op inst shift)
  25        `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
  26           `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
  27   (def loadw lwz word-shift)
  28   (def storew stw word-shift))
  29
  30 (defmacro load-symbol (reg symbol)
  31   `(inst addi ,reg null-tn (static-symbol-offset ,symbol)))
  32
  33 (macrolet
  34     ((frob (slot)
  35        (let ((loader (intern (concatenate 'simple-string
  36                                           "LOAD-SYMBOL-"
  37                                           (string slot))))
  38              (storer (intern (concatenate 'simple-string
  39                                           "STORE-SYMBOL-"
  40                                           (string slot))))
  41              (offset (intern (concatenate 'simple-string
  42                                           "SYMBOL-"
  43                                           (string slot)
  44                                           "-SLOT")
  45                              (find-package "SB!VM"))))
  46          `(progn
  47             (defmacro ,loader (reg symbol)
  48               `(inst lwz ,reg null-tn
  49                      (+ (static-symbol-offset ',symbol)
  50                         (ash ,',offset word-shift)
  51                         (- other-pointer-lowtag))))
  52             (defmacro ,storer (reg symbol)
  53               `(inst stw ,reg null-tn
  54                      (+ (static-symbol-offset ',symbol)
  55                         (ash ,',offset word-shift)
  56                         (- other-pointer-lowtag))))))))
  57   (frob value)
  58   (frob function)
  59
  60   ;; FIXME: These are only good for static-symbols, so why not
  61   ;; statically-allocate the static-symbol TLS slot indices at
  62   ;; cross-compile time so we can just use a fixed offset within the
  63   ;; TLS block instead of mucking about with the extra memory access
  64   ;; (and temp register, for stores)?
  65   #!+sb-thread
  66   (defmacro load-tl-symbol-value (reg symbol)
  67     `(progn
  68        (inst lwz ,reg null-tn
  69              (+ (static-symbol-offset ',symbol)
  70                 (ash symbol-tls-index-slot word-shift)
  71                 (- other-pointer-lowtag)))
  72        (inst lwzx ,reg thread-base-tn ,reg)))
  73   #!-sb-thread
  74   (defmacro load-tl-symbol-value (reg symbol)
  75     `(load-symbol-value ,reg ,symbol))
  76
  77   #!+sb-thread
  78   (defmacro store-tl-symbol-value (reg symbol temp)
  79     `(progn
  80        (inst lwz ,temp null-tn
  81              (+ (static-symbol-offset ',symbol)
  82                 (ash symbol-tls-index-slot word-shift)
  83                 (- other-pointer-lowtag)))
  84        (inst stwx ,reg thread-base-tn ,temp)))
  85   #!-sb-thread
  86   (defmacro store-tl-symbol-value (reg symbol temp)
  87     (declare (ignore temp))
  88     `(store-symbol-value ,reg ,symbol)))
  89
  90 (defmacro load-type (target source &optional (offset 0))
  91   "Loads the type bits of a pointer into target independent of
  92   byte-ordering issues."
  93   (once-only ((n-target target)
  94               (n-source source)
  95               (n-offset offset))
  96     (ecase *backend-byte-order*
  97       (:little-endian
  98        `(inst lbz ,n-target ,n-source ,n-offset))
  99       (:big-endian
 100        `(inst lbz ,n-target ,n-source (+ ,n-offset (1- n-word-bytes)))))))
 101
 102 ;;; Macros to handle the fact that we cannot use the machine native call and
 103 ;;; return instructions.
 104
 105 (defmacro lisp-jump (function lip)
 106   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
 107   `(progn
 108     ;; something is deeply bogus.  look at this
 109     ;; (loadw ,lip ,function function-code-offset function-pointer-type)
 110     (inst addi ,lip ,function (- (* n-word-bytes simple-fun-code-offset) fun-pointer-lowtag))
 111     (inst mtctr ,lip)
 112     (inst bctr)))
 113
 114 (defmacro lisp-return (return-pc lip &key (offset 0))
 115   "Return to RETURN-PC."
 116   `(progn
 117      (inst addi ,lip ,return-pc (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
 118      (inst mtlr ,lip)
 119      (inst blr)))
 120
 121 (defmacro emit-return-pc (label)
 122   "Emit a return-pc header word.  LABEL is the label to use for this return-pc."
 123   `(progn
 124      (emit-alignment n-lowtag-bits)
 125      (emit-label ,label)
 126      (inst lra-header-word)))
 127
 128
 129 \f
 130 ;;;; Stack TN's
 131
 132 ;;; Move a stack TN to a register and vice-versa.
 133 (defmacro load-stack-tn (reg stack)
 134   `(let ((reg ,reg)
 135          (stack ,stack))
 136      (let ((offset (tn-offset stack)))
 137        (sc-case stack
 138          ((control-stack)
 139           (loadw reg cfp-tn offset))))))
 140 (defmacro store-stack-tn (stack reg)
 141   `(let ((stack ,stack)
 142          (reg ,reg))
 143      (let ((offset (tn-offset stack)))
 144        (sc-case stack
 145          ((control-stack)
 146           (storew reg cfp-tn offset))))))
 147
 148 (defmacro maybe-load-stack-tn (reg reg-or-stack)
 149   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
 150   (once-only ((n-reg reg)
 151               (n-stack reg-or-stack))
 152     `(sc-case ,n-reg
 153        ((any-reg descriptor-reg)
 154         (sc-case ,n-stack
 155           ((any-reg descriptor-reg)
 156            (move ,n-reg ,n-stack))
 157           ((control-stack)
 158            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
 159
 160 \f
 161 ;;;; Storage allocation:
 162
 163 ;;; This is the main mechanism for allocating memory in the lisp heap.
 164 ;;;
 165 ;;; The allocated space is stored in RESULT-TN with the lowtag LOWTAG
 166 ;;; applied.  The amount of space to be allocated is SIZE bytes (which
 167 ;;; must be a multiple of the lisp object size).
 168 ;;;
 169 ;;; On other platforms (Non-PPC), if STACK-P is given, then allocation
 170 ;;; occurs on the control stack (for dynamic-extent).  In this case,
 171 ;;; you MUST also specify NODE, so that the appropriate compiler
 172 ;;; policy can be used, and TEMP-TN, which is needed for work-space.
 173 ;;; TEMP-TN MUST be a non-descriptor reg. FIXME: This is not yet
 174 ;;; implemented on PPC. We should implement this and replace the
 175 ;;; inline stack-based allocation that presently occurs in the
 176 ;;; VOPs. The stack-p argument is ignored on PPC.
 177 ;;;
 178 ;;; If generational GC is enabled, you MUST supply a value for TEMP-TN
 179 ;;; because a temp register is needed to do inline allocation.
 180 ;;; TEMP-TN, in this case, can be any register, since it holds a
 181 ;;; double-word aligned address (essentially a fixnum).
 182 (defmacro allocation (result-tn size lowtag &key stack-p node temp-tn flag-tn)
 183   ;; We assume we're in a pseudo-atomic so the pseudo-atomic bit is
 184   ;; set.  If the lowtag also has a 1 bit in the same position, we're all
 185   ;; set.  Otherwise, we need to zap out the lowtag from alloc-tn, and
 186   ;; then or in the lowtag.
 187   ;; Normal allocation to the heap.
 188   (declare (ignore stack-p node)
 189            #!-gencgc
 190            (ignore temp-tn flag-tn))
 191     #!-gencgc
 192     (let ((alloc-size (gensym)))
 193       `(let ((,alloc-size ,size))
 194          (if (logbitp (1- n-lowtag-bits) ,lowtag)
 195              (progn
 196                (inst ori ,result-tn alloc-tn ,lowtag))
 197              (progn
 198                (inst clrrwi ,result-tn alloc-tn n-lowtag-bits)
 199                (inst ori ,result-tn ,result-tn ,lowtag)))
 200          (if (numberp ,alloc-size)
 201              (inst addi alloc-tn alloc-tn ,alloc-size)
 202              (inst add alloc-tn alloc-tn ,alloc-size))))
 203     #!+gencgc
 204     (let ((fix-addr (gensym))
 205           (inline-alloc (gensym)))
 206       `(let ((,fix-addr (gen-label))
 207              (,inline-alloc (gen-label)))
 208          ;; Make temp-tn be the size
 209          (cond ((numberp ,size)
 210                 (inst lr ,temp-tn ,size))
 211                (t
 212                 (move ,temp-tn ,size)))
 213
 214          #!-sb-thread
 215          (inst lr ,flag-tn (make-fixup "boxed_region" :foreign))
 216          #!-sb-thread
 217          (inst lwz ,result-tn ,flag-tn 0)
 218          #!+sb-thread
 219          (inst lwz ,result-tn thread-base-tn (* thread-alloc-region-slot
 220                                                 n-word-bytes))
 221
 222          ;; we can optimize this to only use one fixup here, once we get
 223          ;; it working
 224          ;; (inst lr ,flag-tn (make-fixup "boxed_region" :foreign 4))
 225          ;; (inst lwz ,flag-tn ,flag-tn 0)
 226          #!-sb-thread
 227          (inst lwz ,flag-tn ,flag-tn 4)
 228          #!+sb-thread
 229          (inst lwz ,flag-tn thread-base-tn (* (1+ thread-alloc-region-slot)
 230                                               n-word-bytes))
 231
 232          (without-scheduling ()
 233            ;; CAUTION: The C code depends on the exact order of
 234            ;; instructions here.  In particular, three instructions before
 235            ;; the TW instruction must be an ADD or ADDI instruction, so it
 236            ;; can figure out the size of the desired allocation.
 237            ;; Now make result-tn point at the end of the object, to
 238            ;; figure out if we overflowed the current region.
 239            (inst add ,result-tn ,result-tn ,temp-tn)
 240            ;; result-tn points to the new end of the region.  Did we go past
 241            ;; the actual end of the region?  If so, we need a full alloc.
 242            ;; The C code depends on this exact form of instruction.  If
 243            ;; either changes, you have to change the other appropriately!
 244            (inst cmpw ,result-tn ,flag-tn)
 245
 246            (inst bng ,inline-alloc)
 247            (inst tw :lge ,result-tn ,flag-tn))
 248          (inst b ,fix-addr)
 249
 250          (emit-label ,inline-alloc)
 251          #!-sb-thread
 252          (inst lr ,flag-tn (make-fixup "boxed_region" :foreign))
 253          #!-sb-thread
 254          (inst stw ,result-tn ,flag-tn 0)
 255          #!+sb-thread
 256          (inst stw ,result-tn thread-base-tn (* thread-alloc-region-slot
 257                                                 n-word-bytes))
 258
 259          (emit-label ,fix-addr)
 260          ;; At this point, result-tn points at the end of the object.
 261          ;; Adjust to point to the beginning.
 262          (inst sub ,result-tn ,result-tn ,temp-tn)
 263          ;; Set the lowtag appropriately
 264          (inst ori ,result-tn ,result-tn ,lowtag))))
 265
 266 (defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size
 267                                             &key (lowtag other-pointer-lowtag))
 268                                  &body body)
 269   "Do stuff to allocate an other-pointer object of fixed Size with a single
 270   word header having the specified Type-Code.  The result is placed in
 271   Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
 272   by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
 273   initializes the object."
 274   (once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn)
 275               (type-code type-code) (size size) (lowtag lowtag))
 276     `(pseudo-atomic (,flag-tn)
 277        (allocation ,result-tn (pad-data-block ,size) ,lowtag
 278                    :temp-tn ,temp-tn
 279                    :flag-tn ,flag-tn)
 280        (when ,type-code
 281          (inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
 282          (storew ,temp-tn ,result-tn 0 ,lowtag))
 283        ,@body)))
 284
 285 (defun align-csp (temp)
 286   ;; is used for stack allocation of dynamic-extent objects
 287   (let ((aligned (gen-label)))
 288     (inst andi. temp csp-tn lowtag-mask)
 289     (inst beq aligned)
 290     (inst addi csp-tn csp-tn n-word-bytes)
 291     (storew zero-tn csp-tn -1)
 292     (emit-label aligned)))
 293
 294 \f
 295 ;;;; Error Code
 296 (defun emit-error-break (vop kind code values)
 297   (assemble ()
 298     (when vop
 299       (note-this-location vop :internal-error))
 300     (inst unimp kind)
 301     (with-adjustable-vector (vector)
 302       (write-var-integer code vector)
 303       (dolist (tn values)
 304         (write-var-integer (make-sc-offset (sc-number (tn-sc tn))
 305                                            (or (tn-offset tn) 0))
 306                            vector))
 307       (inst byte (length vector))
 308       (dotimes (i (length vector))
 309         (inst byte (aref vector i)))
 310       (emit-alignment word-shift))))
 311
 312 (defun error-call (vop error-code &rest values)
 313   #!+sb-doc
 314   "Cause an error.  ERROR-CODE is the error to cause."
 315   (emit-error-break vop error-trap (error-number-or-lose error-code) values))
 316
 317 (defun generate-error-code (vop error-code &rest values)
 318   #!+sb-doc
 319   "Generate-Error-Code Error-code Value*
 320   Emit code for an error with the specified Error-Code and context Values."
 321   (assemble (*elsewhere*)
 322     (let ((start-lab (gen-label)))
 323       (emit-label start-lab)
 324       (emit-error-break vop error-trap (error-number-or-lose error-code) values)
 325       start-lab)))
 326 \f
 327 ;;;; PSEUDO-ATOMIC
 328
 329 ;;; handy macro for making sequences look atomic
 330 ;;;
 331 ;;; FLAG-TN must be wired to NL3. If a deferred interrupt happens
 332 ;;; while we have the low bits of ALLOC-TN set, we add a "large"
 333 ;;; constant to FLAG-TN. On exit, we add FLAG-TN to ALLOC-TN which (a)
 334 ;;; aligns ALLOC-TN again and (b) makes ALLOC-TN go negative. We then
 335 ;;; trap if ALLOC-TN's negative (handling the deferred interrupt) and
 336 ;;; using FLAG-TN - minus the large constant - to correct ALLOC-TN.
 337 (defmacro pseudo-atomic ((flag-tn) &body forms)
 338   `(progn
 339      (without-scheduling ()
 340        ;; Extra debugging stuff:
 341        #+debug
 342        (progn
 343          (inst andi. ,flag-tn alloc-tn 7)
 344          (inst twi :ne ,flag-tn 0))
 345        (inst ori alloc-tn alloc-tn 4))
 346      ,@forms
 347      (without-scheduling ()
 348        (inst li ,flag-tn -5)
 349        (inst and alloc-tn alloc-tn ,flag-tn)
 350        ;; Now test to see if the pseudo-atomic interrupted bit is set.
 351        (inst andi. ,flag-tn alloc-tn 1)
 352        (inst twi :ne ,flag-tn 0))
 353      #+debug
 354      (progn
 355        (inst andi. ,flag-tn alloc-tn 7)
 356        (inst twi :ne ,flag-tn 0))))
 357
 358 (def!macro with-pinned-objects ((&rest objects) &body body)
 359   "Arrange with the garbage collector that the pages occupied by
 360 OBJECTS will not be moved in memory for the duration of BODY.
 361 Useful for e.g. foreign calls where another thread may trigger
 362 garbage collection.  This is currently implemented by disabling GC"
 363   #!-gencgc
 364   (declare (ignore objects))            ; should we eval these for side-effect?
 365   #!-gencgc
 366   `(without-gcing
 367     ,@body)
 368   #!+gencgc
 369   `(let ((*pinned-objects* (list* ,@objects *pinned-objects*)))
 370      ,@body))