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 (defmacro load-type (target source &optional (offset 0))
  61   "Loads the type bits of a pointer into target independent of
  62   byte-ordering issues."
  63   (once-only ((n-target target)
  64               (n-source source)
  65               (n-offset offset))
  66     (ecase *backend-byte-order*
  67       (:little-endian
  68        `(inst lbz ,n-target ,n-source ,n-offset))
  69       (:big-endian
  70        `(inst lbz ,n-target ,n-source (+ ,n-offset 3))))))
  71
  72 ;;; Macros to handle the fact that we cannot use the machine native call and
  73 ;;; return instructions.
  74
  75 (defmacro lisp-jump (function lip)
  76   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
  77   `(progn
  78     ;; something is deeply bogus.  look at this
  79     ;; (loadw ,lip ,function function-code-offset function-pointer-type)
  80     (inst addi ,lip ,function (- (* n-word-bytes simple-fun-code-offset) fun-pointer-lowtag))
  81     (inst mtctr ,lip)
  82     (move code-tn ,function)
  83     (inst bctr)))
  84
  85 (defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
  86   "Return to RETURN-PC."
  87   `(progn
  88      (inst addi ,lip ,return-pc (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
  89      (inst mtlr ,lip)
  90      ,@(if frob-code
  91          `((move code-tn ,return-pc)))
  92      (inst blr)))
  93
  94 (defmacro emit-return-pc (label)
  95   "Emit a return-pc header word.  LABEL is the label to use for this return-pc."
  96   `(progn
  97      (align n-lowtag-bits)
  98      (emit-label ,label)
  99      (inst lra-header-word)))
 100
 101
 102 \f
 103 ;;;; Stack TN's
 104
 105 ;;; Move a stack TN to a register and vice-versa.
 106 (defmacro load-stack-tn (reg stack)
 107   `(let ((reg ,reg)
 108          (stack ,stack))
 109      (let ((offset (tn-offset stack)))
 110        (sc-case stack
 111          ((control-stack)
 112           (loadw reg cfp-tn offset))))))
 113 (defmacro store-stack-tn (stack reg)
 114   `(let ((stack ,stack)
 115          (reg ,reg))
 116      (let ((offset (tn-offset stack)))
 117        (sc-case stack
 118          ((control-stack)
 119           (storew reg cfp-tn offset))))))
 120
 121 (defmacro maybe-load-stack-tn (reg reg-or-stack)
 122   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
 123   (once-only ((n-reg reg)
 124               (n-stack reg-or-stack))
 125     `(sc-case ,n-reg
 126        ((any-reg descriptor-reg)
 127         (sc-case ,n-stack
 128           ((any-reg descriptor-reg)
 129            (move ,n-reg ,n-stack))
 130           ((control-stack)
 131            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
 132
 133 \f
 134 ;;;; Storage allocation:
 135 (defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
 136                                  &body body)
 137   "Do stuff to allocate an other-pointer object of fixed Size with a single
 138   word header having the specified Type-Code.  The result is placed in
 139   Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
 140   by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
 141   initializes the object."
 142   (unless body
 143     (bug "empty &body in WITH-FIXED-ALLOCATION"))
 144   (once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn)
 145               (type-code type-code) (size size))
 146     `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
 147        (inst ori ,result-tn alloc-tn other-pointer-lowtag)
 148        (inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
 149        (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
 150        ,@body)))
 151
 152 (defun align-csp (temp)
 153   ;; is used for stack allocation of dynamic-extent objects
 154   (let ((aligned (gen-label)))
 155     (inst andi. temp csp-tn lowtag-mask)
 156     (inst beq aligned)
 157     (inst addi csp-tn csp-tn n-word-bytes)
 158     (storew zero-tn csp-tn -1)
 159     (emit-label aligned)))
 160
 161 \f
 162 ;;;; Error Code
 163 (eval-when (:compile-toplevel :load-toplevel :execute)
 164   (defun emit-error-break (vop kind code values)
 165     (let ((vector (gensym)))
 166       `((let ((vop ,vop))
 167           (when vop
 168             (note-this-location vop :internal-error)))
 169         (inst unimp ,kind)
 170         (with-adjustable-vector (,vector)
 171           (write-var-integer (error-number-or-lose ',code) ,vector)
 172           ,@(mapcar #'(lambda (tn)
 173                         `(let ((tn ,tn))
 174                            (write-var-integer (make-sc-offset (sc-number
 175                                                                (tn-sc tn))
 176                                                               (tn-offset tn))
 177                                               ,vector)))
 178                     values)
 179           (inst byte (length ,vector))
 180           (dotimes (i (length ,vector))
 181             (inst byte (aref ,vector i))))
 182         (align word-shift)))))
 183
 184 (defmacro error-call (vop error-code &rest values)
 185   "Cause an error.  ERROR-CODE is the error to cause."
 186   (cons 'progn
 187         (emit-error-break vop error-trap error-code values)))
 188
 189
 190 (defmacro cerror-call (vop label error-code &rest values)
 191   "Cause a continuable error.  If the error is continued, execution resumes at
 192   LABEL."
 193   `(progn
 194      ,@(emit-error-break vop cerror-trap error-code values)
 195      (inst b ,label)))
 196
 197 (defmacro generate-error-code (vop error-code &rest values)
 198   "Generate-Error-Code Error-code Value*
 199   Emit code for an error with the specified Error-Code and context Values."
 200   `(assemble (*elsewhere*)
 201      (let ((start-lab (gen-label)))
 202        (emit-label start-lab)
 203        (error-call ,vop ,error-code ,@values)
 204        start-lab)))
 205
 206 (defmacro generate-cerror-code (vop error-code &rest values)
 207   "Generate-CError-Code Error-code Value*
 208   Emit code for a continuable error with the specified Error-Code and
 209   context Values.  If the error is continued, execution resumes after
 210   the GENERATE-CERROR-CODE form."
 211   (with-unique-names (continue error)
 212     `(let ((,continue (gen-label)))
 213        (emit-label ,continue)
 214        (assemble (*elsewhere*)
 215          (let ((,error (gen-label)))
 216            (emit-label ,error)
 217            (cerror-call ,vop ,continue ,error-code ,@values)
 218            ,error)))))
 219 \f
 220 ;;;; PSEUDO-ATOMIC
 221
 222 ;;; handy macro for making sequences look atomic
 223 ;;;
 224 ;;; FLAG-TN must be wired to NL3. If a deferred interrupt happens
 225 ;;; while we have the low bits of ALLOC-TN set, we add a "large"
 226 ;;; constant to FLAG-TN. On exit, we add FLAG-TN to ALLOC-TN which (a)
 227 ;;; aligns ALLOC-TN again and (b) makes ALLOC-TN go negative. We then
 228 ;;; trap if ALLOC-TN's negative (handling the deferred interrupt) and
 229 ;;; using FLAG-TN - minus the large constant - to correct ALLOC-TN.
 230 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &body forms)
 231   (let ((n-extra (gensym)))
 232     `(let ((,n-extra ,extra))
 233        (without-scheduling ()
 234         ;; Extra debugging stuff:
 235         #+debug
 236         (progn
 237           (inst andi. ,flag-tn alloc-tn 7)
 238           (inst twi :ne ,flag-tn 0))
 239         (inst lr ,flag-tn (- ,n-extra 4))
 240         (inst addi alloc-tn alloc-tn 4))
 241       ,@forms
 242       (without-scheduling ()
 243        (inst add alloc-tn alloc-tn ,flag-tn)
 244        (inst twi :lt alloc-tn 0))
 245       #+debug
 246       (progn
 247         (inst andi. ,flag-tn alloc-tn 7)
 248         (inst twi :ne ,flag-tn 0)))))
 249
 250
 251
 252
 253 (defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
 254   "Arrange with the garbage collector that the pages occupied by
 255 OBJECTS will not be moved in memory for the duration of BODY.
 256 Useful for e.g. foreign calls where another thread may trigger
 257 garbage collection.  This is currently implemented by disabling GC"
 258   (declare (ignore objects))            ;should we eval these for side-effect?
 259   `(without-gcing
 260     ,@body))