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