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 ;;; Load-Stack-TN, Store-Stack-TN  --  Interface
 106 ;;;
 107 ;;;    Move a stack TN to a register and vice-versa.
 108 (defmacro load-stack-tn (reg stack)
 109   `(let ((reg ,reg)
 110          (stack ,stack))
 111      (let ((offset (tn-offset stack)))
 112        (sc-case stack
 113          ((control-stack)
 114           (loadw reg cfp-tn offset))))))
 115
 116 (defmacro store-stack-tn (stack reg)
 117   `(let ((stack ,stack)
 118          (reg ,reg))
 119      (let ((offset (tn-offset stack)))
 120        (sc-case stack
 121          ((control-stack)
 122           (storew reg cfp-tn offset))))))
 123
 124 (defmacro maybe-load-stack-tn (reg reg-or-stack)
 125   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
 126   (once-only ((n-reg reg)
 127               (n-stack reg-or-stack))
 128     `(sc-case ,n-reg
 129        ((any-reg descriptor-reg)
 130         (sc-case ,n-stack
 131           ((any-reg descriptor-reg)
 132            (move ,n-reg ,n-stack))
 133           ((control-stack)
 134            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
 135
 136 \f
 137 ;;;; Storage allocation:
 138 (defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
 139                                  &body body)
 140   "Do stuff to allocate an other-pointer object of fixed Size with a single
 141   word header having the specified Type-Code.  The result is placed in
 142   Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
 143   by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
 144   initializes the object."
 145   (once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn)
 146               (type-code type-code) (size size))
 147     `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
 148        (inst ori ,result-tn alloc-tn other-pointer-lowtag)
 149        (inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
 150        (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
 151        ,@body)))
 152
 153 \f
 154 ;;;; Error Code
 155 (eval-when (:compile-toplevel :load-toplevel :execute)
 156   (defun emit-error-break (vop kind code values)
 157     (let ((vector (gensym)))
 158       `((let ((vop ,vop))
 159           (when vop
 160             (note-this-location vop :internal-error)))
 161         (inst unimp ,kind)
 162         (with-adjustable-vector (,vector)
 163           (write-var-integer (error-number-or-lose ',code) ,vector)
 164           ,@(mapcar #'(lambda (tn)
 165                         `(let ((tn ,tn))
 166                            (write-var-integer (make-sc-offset (sc-number
 167                                                                (tn-sc tn))
 168                                                               (tn-offset tn))
 169                                               ,vector)))
 170                     values)
 171           (inst byte (length ,vector))
 172           (dotimes (i (length ,vector))
 173             (inst byte (aref ,vector i))))
 174         (align word-shift)))))
 175
 176 (defmacro error-call (vop error-code &rest values)
 177   "Cause an error.  ERROR-CODE is the error to cause."
 178   (cons 'progn
 179         (emit-error-break vop error-trap error-code values)))
 180
 181
 182 (defmacro cerror-call (vop label error-code &rest values)
 183   "Cause a continuable error.  If the error is continued, execution resumes at
 184   LABEL."
 185   `(progn
 186      ,@(emit-error-break vop cerror-trap error-code values)
 187      (inst b ,label)))
 188
 189 (defmacro generate-error-code (vop error-code &rest values)
 190   "Generate-Error-Code Error-code Value*
 191   Emit code for an error with the specified Error-Code and context Values."
 192   `(assemble (*elsewhere*)
 193      (let ((start-lab (gen-label)))
 194        (emit-label start-lab)
 195        (error-call ,vop ,error-code ,@values)
 196        start-lab)))
 197
 198 (defmacro generate-cerror-code (vop error-code &rest values)
 199   "Generate-CError-Code Error-code Value*
 200   Emit code for a continuable error with the specified Error-Code and
 201   context Values.  If the error is continued, execution resumes after
 202   the GENERATE-CERROR-CODE form."
 203   (let ((continue (gensym "CONTINUE-LABEL-"))
 204         (error (gensym "ERROR-LABEL-")))
 205     `(let ((,continue (gen-label)))
 206        (emit-label ,continue)
 207        (assemble (*elsewhere*)
 208          (let ((,error (gen-label)))
 209            (emit-label ,error)
 210            (cerror-call ,vop ,continue ,error-code ,@values)
 211            ,error)))))
 212
 213
 214 \f
 215 ;;; PSEUDO-ATOMIC -- Handy macro for making sequences look atomic.
 216 ;;;
 217 ;;; flag-tn must be wired to NL3. If a deferred interrupt happens
 218 ;;; while we have the low bits of alloc-tn set, we add a "large"
 219 ;;; constant to flag-tn.  On exit, we add flag-tn to alloc-tn
 220 ;;; which (a) aligns alloc-tn again and (b) makes alloc-tn go
 221 ;;; negative.  We then trap if alloc-tn's negative (handling the
 222 ;;; deferred interrupt) and using flag-tn - minus the large constant -
 223 ;;; to correct alloc-tn.
 224 (defmacro pseudo-atomic ((flag-tn &key (extra 0)) &rest forms)
 225   (let ((n-extra (gensym)))
 226     `(let ((,n-extra ,extra))
 227        (without-scheduling ()
 228         ;; Extra debugging stuff:
 229         #+debug
 230         (progn
 231           (inst andi. ,flag-tn alloc-tn 7)
 232           (inst twi :ne ,flag-tn 0))
 233         (inst lr ,flag-tn (- ,n-extra 4))
 234         (inst addi alloc-tn alloc-tn 4))
 235       ,@forms
 236       (without-scheduling ()
 237        (inst add alloc-tn alloc-tn ,flag-tn)
 238        (inst twi :lt alloc-tn 0))
 239       #+debug
 240       (progn
 241         (inst andi. ,flag-tn alloc-tn 7)
 242         (inst twi :ne ,flag-tn 0)))))
 243
 244
 245