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     ((frob (op inst shift)
  25        `(defmacro ,op (object base &optional (offset 0) (lowtag 0))
  26           `(inst ,',inst ,object ,base (- (ash ,offset ,,shift) ,lowtag)))))
  27   (frob loadw lwz word-shift)
  28   (frob 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 sb!vm:function-code-offset sb!vm:function-pointer-type)
  80     (inst addi ,lip ,function (- (* n-word-bytes sb!vm:simple-fun-code-offset) sb!vm: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   (once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn)
 143               (type-code type-code) (size size))
 144     `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
 145        (inst ori ,result-tn alloc-tn other-pointer-lowtag)
 146        (inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
 147        (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
 148        ,@body)))
 149
 150 \f
 151 ;;;; Error Code
 152 (eval-when (:compile-toplevel :load-toplevel :execute)
 153   (defun emit-error-break (vop kind code values)
 154     (let ((vector (gensym)))
 155       `((let ((vop ,vop))
 156           (when vop
 157             (note-this-location vop :internal-error)))
 158         (inst unimp ,kind)
 159         (with-adjustable-vector (,vector)
 160           (write-var-integer (error-number-or-lose ',code) ,vector)
 161           ,@(mapcar #'(lambda (tn)
 162                         `(let ((tn ,tn))
 163                            (write-var-integer (make-sc-offset (sc-number
 164                                                                (tn-sc tn))
 165                                                               (tn-offset tn))
 166                                               ,vector)))
 167                     values)
 168           (inst byte (length ,vector))
 169           (dotimes (i (length ,vector))
 170             (inst byte (aref ,vector i))))
 171         (align word-shift)))))
 172
 173 (defmacro error-call (vop error-code &rest values)
 174   "Cause an error.  ERROR-CODE is the error to cause."
 175   (cons 'progn
 176         (emit-error-break vop error-trap error-code values)))
 177
 178
 179 (defmacro cerror-call (vop label error-code &rest values)
 180   "Cause a continuable error.  If the error is continued, execution resumes at
 181   LABEL."
 182   `(progn
 183      ,@(emit-error-break vop cerror-trap error-code values)
 184      (inst b ,label)))
 185
 186 (defmacro generate-error-code (vop error-code &rest values)
 187   "Generate-Error-Code Error-code Value*
 188   Emit code for an error with the specified Error-Code and context Values."
 189   `(assemble (*elsewhere*)
 190      (let ((start-lab (gen-label)))
 191        (emit-label start-lab)
 192        (error-call ,vop ,error-code ,@values)
 193        start-lab)))
 194
 195 (defmacro generate-cerror-code (vop error-code &rest values)
 196   "Generate-CError-Code Error-code Value*
 197   Emit code for a continuable error with the specified Error-Code and
 198   context Values.  If the error is continued, execution resumes after
 199   the GENERATE-CERROR-CODE form."
 200   (let ((continue (gensym "CONTINUE-LABEL-"))
 201         (error (gensym "ERROR-LABEL-")))
 202     `(let ((,continue (gen-label)))
 203        (emit-label ,continue)
 204        (assemble (*elsewhere*)
 205          (let ((,error (gen-label)))
 206            (emit-label ,error)
 207            (cerror-call ,vop ,continue ,error-code ,@values)
 208            ,error)))))
 209
 210
 211 \f
 212 ;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
 213 ;;;
 214 ;;; flag-tn must be wired to NL3. If a deferred interrupt happens
 215 ;;; while we have the low bits of alloc-tn set, we add a "large"
 216 ;;; constant to flag-tn.  On exit, we add flag-tn to alloc-tn
 217 ;;; which (a) aligns alloc-tn again and (b) makes alloc-tn go
 218 ;;; negative.  We then trap if alloc-tn's negative (handling the
 219 ;;; deferred interrupt) and using flag-tn - minus the large constant -
 220 ;;; to correct alloc-tn.
 221 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
 222   (let ((n-extra (gensym)))
 223     `(let ((,n-extra ,extra))
 224        (without-scheduling ()
 225         ;; Extra debugging stuff:
 226         #+debug
 227         (progn
 228           (inst andi. ,flag-tn alloc-tn 7)
 229           (inst twi :ne ,flag-tn 0))
 230         (inst lr ,flag-tn (- ,n-extra 4))
 231         (inst addi alloc-tn alloc-tn 4))
 232       ,@forms
 233       (without-scheduling ()
 234        (inst add alloc-tn alloc-tn ,flag-tn)
 235        (inst twi :lt alloc-tn 0))
 236       #+debug
 237       (progn
 238         (inst andi. ,flag-tn alloc-tn 7)
 239         (inst twi :ne ,flag-tn 0)))))
 240
 241
 242