src/compiler/sparc/macros.lisp

   1 ;;;; various useful macros for generating Sparc code
   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 move ,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 ld word-shift)
  28   (frob storew st word-shift))
  29
  30 (defmacro load-symbol (reg symbol)
  31   `(inst add ,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 ld ,reg null-tn
  49                      (+ (static-symbol-offset ',symbol)
  50                         (ash ,',offset word-shift)
  51                         (- other-pointer-lowtag))))
  52             (defmacro ,storer (reg symbol)
  53               `(inst st ,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   #!+sb-doc
  62   "Loads the type bits of a pointer into target independent of
  63   byte-ordering issues."
  64   (once-only ((n-target target)
  65               (n-source source)
  66               (n-offset offset))
  67     ;; FIXME: although I don't understand entirely, I'm going to do
  68     ;; what whn does in x86/macros.lisp -- Christophe
  69     (ecase *backend-byte-order*
  70       (:little-endian
  71        `(inst ldub ,n-target ,n-source ,n-offset))
  72       (:big-endian
  73        `(inst ldub ,n-target ,n-source (+ ,n-offset 3))))))
  74
  75 ;;; Macros to handle the fact that we cannot use the machine native call and
  76 ;;; return instructions.
  77
  78 (defmacro lisp-jump (fun)
  79   "Jump to the lisp function FUNCTION.  LIP is an interior-reg temporary."
  80   `(progn
  81      (inst j ,fun
  82            (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag))
  83      (move code-tn ,fun)))
  84
  85 (defmacro lisp-return (return-pc &key (offset 0) (frob-code t))
  86   "Return to RETURN-PC."
  87   `(progn
  88      (inst j ,return-pc
  89            (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
  90      ,(if frob-code
  91           `(move code-tn ,return-pc)
  92           '(inst nop))))
  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
 114 (defmacro store-stack-tn (stack reg)
 115   `(let ((stack ,stack)
 116          (reg ,reg))
 117      (let ((offset (tn-offset stack)))
 118        (sc-case stack
 119          ((control-stack)
 120           (storew reg cfp-tn offset))))))
 121
 122 (defmacro maybe-load-stack-tn (reg reg-or-stack)
 123   "Move the TN Reg-Or-Stack into Reg if it isn't already there."
 124   (once-only ((n-reg reg)
 125               (n-stack reg-or-stack))
 126     `(sc-case ,n-reg
 127        ((any-reg descriptor-reg)
 128         (sc-case ,n-stack
 129           ((any-reg descriptor-reg)
 130            (move ,n-reg ,n-stack))
 131           ((control-stack)
 132            (loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
 133
 134 \f
 135 ;;;; Storage allocation:
 136 (defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
 137                                  &body body)
 138   "Do stuff to allocate an other-pointer object of fixed Size with a single
 139   word header having the specified Type-Code.  The result is placed in
 140   Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
 141   by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
 142   initializes the object."
 143   (unless body
 144     (bug "empty &body in WITH-FIXED-ALLOCATION"))
 145   (once-only ((result-tn result-tn) (temp-tn temp-tn)
 146               (type-code type-code) (size size))
 147     `(pseudo-atomic (:extra (pad-data-block ,size))
 148        (inst or ,result-tn alloc-tn other-pointer-lowtag)
 149        (inst li ,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      (inst b ,label)
 187      ,@(emit-error-break vop cerror-trap error-code values)))
 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   (with-unique-names (continue error)
 204     `(let ((,continue (gen-label)))
 205        (emit-label ,continue)
 206        (assemble (*elsewhere*)
 207          (let ((,error (gen-label)))
 208            (emit-label ,error)
 209            (cerror-call ,vop ,continue ,error-code ,@values)
 210            ,error)))))
 211 \f
 212 ;;; a handy macro for making sequences look atomic
 213 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
 214   (let ((n-extra (gensym)))
 215     `(let ((,n-extra ,extra))
 216        ;; Set the pseudo-atomic flag.
 217        (without-scheduling ()
 218          (inst add alloc-tn 4))
 219        ,@forms
 220        ;; Reset the pseudo-atomic flag.
 221        (without-scheduling ()
 222          #+nil (inst taddcctv alloc-tn (- ,n-extra 4))
 223         ;; Remove the pseudo-atomic flag.
 224         (inst add alloc-tn (- ,n-extra 4))
 225         ;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1).
 226         (inst andcc zero-tn alloc-tn 3)
 227         ;; The C code needs to process this correctly and fixup alloc-tn.
 228         (inst t :ne pseudo-atomic-trap)))))
 229
 230
 231 (defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
 232   "Arrange with the garbage collector that the pages occupied by
 233 OBJECTS will not be moved in memory for the duration of BODY.
 234 Useful for e.g. foreign calls where another thread may trigger
 235 garbage collection.  This is currently implemented by disabling GC"
 236   (declare (ignore objects))            ;should we eval these for side-effect?
 237   `(without-gcing
 238     ,@body))