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     ((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 ld word-shift)
  28   (def 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 (1- n-word-bytes)))))))
  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      (emit-alignment 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 (defun align-csp (temp)
 154   (let ((aligned (gen-label)))
 155     ;; FIXME: why use a TEMP?  Why not just ZERO-TN?
 156     (inst andcc temp csp-tn lowtag-mask)
 157     (if (member :sparc-v9 *backend-subfeatures*)
 158         (inst b :eq aligned :pt)
 159         (inst b :eq aligned))
 160     (storew zero-tn csp-tn 0) ; sneaky use of delay slot
 161     (inst add csp-tn csp-tn n-word-bytes)
 162     (emit-label aligned)))
 163 \f
 164 ;;;; Error Code
 165 (eval-when (:compile-toplevel :load-toplevel :execute)
 166   (defun emit-error-break (vop kind code values)
 167     (let ((vector (gensym)))
 168       `((let ((vop ,vop))
 169           (when vop
 170             (note-this-location vop :internal-error)))
 171         (inst unimp ,kind)
 172         (with-adjustable-vector (,vector)
 173           (write-var-integer (error-number-or-lose ',code) ,vector)
 174           ,@(mapcar #'(lambda (tn)
 175                         `(let ((tn ,tn))
 176                            (write-var-integer (make-sc-offset (sc-number
 177                                                                (tn-sc tn))
 178                                                               (tn-offset tn))
 179                                               ,vector)))
 180                     values)
 181           (inst byte (length ,vector))
 182           (dotimes (i (length ,vector))
 183             (inst byte (aref ,vector i))))
 184         (emit-alignment word-shift)))))
 185
 186 (defmacro error-call (vop error-code &rest values)
 187   "Cause an error.  ERROR-CODE is the error to cause."
 188   (cons 'progn
 189         (emit-error-break vop error-trap error-code values)))
 190
 191
 192 (defmacro cerror-call (vop label error-code &rest values)
 193   "Cause a continuable error.  If the error is continued, execution resumes at
 194   LABEL."
 195   `(progn
 196      (inst b ,label)
 197      ,@(emit-error-break vop cerror-trap error-code values)))
 198
 199 (defmacro generate-error-code (vop error-code &rest values)
 200   "Generate-Error-Code Error-code Value*
 201   Emit code for an error with the specified Error-Code and context Values."
 202   `(assemble (*elsewhere*)
 203      (let ((start-lab (gen-label)))
 204        (emit-label start-lab)
 205        (error-call ,vop ,error-code ,@values)
 206        start-lab)))
 207
 208 (defmacro generate-cerror-code (vop error-code &rest values)
 209   "Generate-CError-Code Error-code Value*
 210   Emit code for a continuable error with the specified Error-Code and
 211   context Values.  If the error is continued, execution resumes after
 212   the GENERATE-CERROR-CODE form."
 213   (with-unique-names (continue error)
 214     `(let ((,continue (gen-label)))
 215        (emit-label ,continue)
 216        (assemble (*elsewhere*)
 217          (let ((,error (gen-label)))
 218            (emit-label ,error)
 219            (cerror-call ,vop ,continue ,error-code ,@values)
 220            ,error)))))
 221 \f
 222 ;;; a handy macro for making sequences look atomic
 223 (defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
 224   (let ((n-extra (gensym)))
 225     `(let ((,n-extra ,extra))
 226        ;; Set the pseudo-atomic flag.
 227        (without-scheduling ()
 228          (inst add alloc-tn 4))
 229        ,@forms
 230        ;; Reset the pseudo-atomic flag.
 231        (without-scheduling ()
 232          #+nil (inst taddcctv alloc-tn (- ,n-extra 4))
 233         ;; Remove the pseudo-atomic flag.
 234         (inst add alloc-tn (- ,n-extra 4))
 235         ;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1).
 236         (inst andcc zero-tn alloc-tn 3)
 237         ;; The C code needs to process this correctly and fixup alloc-tn.
 238         (inst t :ne pseudo-atomic-trap)))))
 239
 240
 241 (def!macro with-pinned-objects ((&rest objects) &body body)
 242   "Arrange with the garbage collector that the pages occupied by
 243 OBJECTS will not be moved in memory for the duration of BODY.
 244 Useful for e.g. foreign calls where another thread may trigger
 245 garbage collection.  This is currently implemented by disabling GC"
 246   (declare (ignore objects))            ;should we eval these for side-effect?
 247   `(without-gcing
 248     ,@body))