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 \f
 136 ;;;; Storage allocation:
 137
 138 ;;;; Allocation macro
 139 ;;;;
 140 ;;;; This macro does the appropriate stuff to allocate space.
 141 ;;;;
 142 ;;;; The allocated space is stored in RESULT-TN with the lowtag LOWTAG
 143 ;;;; applied.  The amount of space to be allocated is SIZE bytes (which
 144 ;;;; must be a multiple of the lisp object size).
 145 (defmacro allocation (result-tn size lowtag &key stack-p temp-tn)
 146   #!+gencgc
 147   ;; A temp register is needed to do inline allocation.  TEMP-TN, in
 148   ;; this case, can be any register, since it holds a double-word
 149   ;; aligned address (essentially a fixnum).
 150   (assert temp-tn)
 151   ;; We assume we're in a pseudo-atomic so the pseudo-atomic bit is
 152   ;; set.
 153   `(cond
 154      (,stack-p
 155       ;; Stack allocation
 156       ;;
 157       ;; The control stack grows up, so round up CSP to a
 158       ;; multiple of 8 (lispobj size).  Use that as the
 159       ;; allocation pointer.  Then add SIZE bytes to the
 160       ;; allocation and set CSP to that, so we have the desired
 161       ;; space.
 162
 163       ;; Make sure the temp-tn is a non-descriptor register!
 164       (assert (and ,temp-tn (sc-is ,temp-tn non-descriptor-reg)))
 165
 166       ;; temp-tn is csp-tn rounded up to a multiple of 8 (lispobj size)
 167       (align-csp ,temp-tn)
 168       ;; For the benefit of future historians, this is how CMUCL does the
 169       ;; align-csp (I think their version is branch free only because
 170       ;; they simply don't worry about zeroing the pad word):
 171       #+nil (inst add ,temp-tn csp-tn sb!vm:lowtag-mask)
 172       #+nil (inst andn ,temp-tn sb!vm:lowtag-mask)
 173
 174       ;; Set the result to temp-tn, with appropriate lowtag
 175       (inst or ,result-tn csp-tn ,lowtag)
 176
 177       ;; Allocate the desired space on the stack.
 178       ;;
 179       ;; FIXME: Can't allocate on stack if SIZE is too large.
 180       ;; Need to rearrange this code.
 181       (inst add csp-tn ,size))
 182
 183      #!-gencgc
 184      ;; Normal allocation to the heap -- cheneygc version.
 185      ;;
 186      ;; On cheneygc, the alloc-tn currently has the pseudo-atomic bit.
 187      ;; If the lowtag also has a 1 bit in the same position, we're all set.
 188      ;;
 189      ;; See comment in PSEUDO-ATOMIC-FLAG.
 190      ((logbitp (1- n-lowtag-bits) ,lowtag)
 191       (inst or ,result-tn alloc-tn ,lowtag)
 192       (inst add alloc-tn ,size))
 193      ;;
 194      ;; Otherwise, we need to zap out the lowtag from alloc-tn, and then
 195      ;; or in the lowtag.
 196      #!-gencgc
 197      (t
 198       (inst andn ,result-tn alloc-tn lowtag-mask)
 199       (inst or ,result-tn ,lowtag)
 200       (inst add alloc-tn ,size))
 201
 202      ;; Normal allocation to the heap -- gencgc version.
 203      ;;
 204      ;; No need to worry about lowtag bits matching up here, since
 205      ;; alloc-tn is just a "pseudo-atomic-bit-tn" now and we don't read
 206      ;; it.
 207      #!+gencgc
 208      (t
 209       (inst li ,temp-tn (make-fixup "boxed_region" :foreign))
 210       (loadw ,result-tn ,temp-tn 0)     ;boxed_region.free_pointer
 211       (loadw ,temp-tn ,temp-tn 1)       ;boxed_region.end_addr
 212
 213       (without-scheduling ()
 214         (let ((done (gen-label))
 215               (full-alloc (gen-label)))
 216           ;; See if we can do an inline allocation.  The updated
 217           ;; free pointer should not point past the end of the
 218           ;; current region.  If it does, a full alloc needs to be
 219           ;; done.
 220           (inst add ,result-tn ,size)
 221
 222           ;; result-tn points to the new end of region.  Did we go
 223           ;; past the actual end of the region?  If so, we need a
 224           ;; full alloc.
 225           (inst cmp ,result-tn ,temp-tn)
 226           (if (member :sparc-v9 *backend-subfeatures*)
 227               (inst b :gtu full-alloc :pn)
 228               (inst b :gtu full-alloc))
 229           (inst nop)
 230           ;; Inline allocation worked, so update the free pointer
 231           ;; and go.  Should really do a swap instruction here to
 232           ;; swap memory with a register.
 233
 234           ;; Kludge: We ought to have two distinct FLAG-TN and TEMP-TN
 235           ;; here, to avoid the SUB and the TEMP-TN reload which is
 236           ;; causing it.  PPC gets it right.
 237           (inst li ,temp-tn (make-fixup "boxed_region" :foreign))
 238           (storew ,result-tn ,temp-tn 0)
 239
 240           (inst b done)
 241           (inst sub ,result-tn ,size)
 242
 243           (emit-label full-alloc)
 244           ;; Full alloc via trap to the C allocator.  Tell the
 245           ;; allocator what the result-tn and size are, using the
 246           ;; OR instruction.  Then trap to the allocator.
 247           (inst or zero-tn ,result-tn ,size)
 248           ;; DFL: Not certain why we use two kinds of traps: T for p/a
 249           ;; and UNIMP for all other traps.  But the C code in the runtime
 250           ;; for the UNIMP case is a lot nicer, so I'm hooking into that.
 251           ;; (inst t :t allocation-trap)
 252           (inst unimp allocation-trap)
 253
 254           (emit-label done)
 255           ;; Set lowtag appropriately
 256           (inst or ,result-tn ,lowtag))))))
 257
 258 (defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
 259                                  &body body)
 260   "Do stuff to allocate an other-pointer object of fixed Size with a single
 261   word header having the specified Type-Code.  The result is placed in
 262   Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
 263   by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
 264   initializes the object."
 265   (unless body
 266     (bug "empty &body in WITH-FIXED-ALLOCATION"))
 267   (once-only ((result-tn result-tn) (temp-tn temp-tn)
 268               (type-code type-code) (size size))
 269     `(pseudo-atomic ()
 270        (allocation ,result-tn (pad-data-block ,size) other-pointer-lowtag
 271                    :temp-tn ,temp-tn)
 272        (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
 273        (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
 274        ,@body)))
 275
 276 (defun align-csp (temp)
 277   (let ((aligned (gen-label)))
 278     ;; FIXME: why use a TEMP?  Why not just ZERO-TN?
 279     (inst andcc temp csp-tn lowtag-mask)
 280     (if (member :sparc-v9 *backend-subfeatures*)
 281         (inst b :eq aligned :pt)
 282         (inst b :eq aligned))
 283     (storew zero-tn csp-tn 0) ; sneaky use of delay slot
 284     (inst add csp-tn csp-tn n-word-bytes)
 285     (emit-label aligned)))
 286 \f
 287 ;;;; Error Code
 288 (eval-when (:compile-toplevel :load-toplevel :execute)
 289   (defun emit-error-break (vop kind code values)
 290     (let ((vector (gensym)))
 291       `((let ((vop ,vop))
 292           (when vop
 293             (note-this-location vop :internal-error)))
 294         (inst unimp ,kind)
 295         (with-adjustable-vector (,vector)
 296           (write-var-integer (error-number-or-lose ',code) ,vector)
 297           ,@(mapcar #'(lambda (tn)
 298                         `(let ((tn ,tn))
 299                            (write-var-integer (make-sc-offset (sc-number
 300                                                                (tn-sc tn))
 301                                                               (tn-offset tn))
 302                                               ,vector)))
 303                     values)
 304           (inst byte (length ,vector))
 305           (dotimes (i (length ,vector))
 306             (inst byte (aref ,vector i))))
 307         (emit-alignment word-shift)))))
 308
 309 (defmacro error-call (vop error-code &rest values)
 310   "Cause an error.  ERROR-CODE is the error to cause."
 311   (cons 'progn
 312         (emit-error-break vop error-trap error-code values)))
 313
 314
 315 (defmacro cerror-call (vop label error-code &rest values)
 316   "Cause a continuable error.  If the error is continued, execution resumes at
 317   LABEL."
 318   `(progn
 319      (inst b ,label)
 320      ,@(emit-error-break vop cerror-trap error-code values)))
 321
 322 (defmacro generate-error-code (vop error-code &rest values)
 323   "Generate-Error-Code Error-code Value*
 324   Emit code for an error with the specified Error-Code and context Values."
 325   `(assemble (*elsewhere*)
 326      (let ((start-lab (gen-label)))
 327        (emit-label start-lab)
 328        (error-call ,vop ,error-code ,@values)
 329        start-lab)))
 330
 331 (defmacro generate-cerror-code (vop error-code &rest values)
 332   "Generate-CError-Code Error-code Value*
 333   Emit code for a continuable error with the specified Error-Code and
 334   context Values.  If the error is continued, execution resumes after
 335   the GENERATE-CERROR-CODE form."
 336   (with-unique-names (continue error)
 337     `(let ((,continue (gen-label)))
 338        (emit-label ,continue)
 339        (assemble (*elsewhere*)
 340          (let ((,error (gen-label)))
 341            (emit-label ,error)
 342            (cerror-call ,vop ,continue ,error-code ,@values)
 343            ,error)))))
 344 \f
 345 ;;; a handy macro for making sequences look atomic
 346 (defmacro pseudo-atomic ((&optional) &rest forms)
 347   (let ()
 348     `(progn
 349        ;; Set the pseudo-atomic flag.
 350        (without-scheduling ()
 351          (inst or alloc-tn 4))
 352        ,@forms
 353        ;; Reset the pseudo-atomic flag.
 354        (without-scheduling ()
 355         ;; Remove the pseudo-atomic flag.
 356         (inst andn alloc-tn 4)
 357         ;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1).
 358         (inst andcc zero-tn alloc-tn 3)
 359         ;; The C code needs to process this correctly and fixup alloc-tn.
 360         (inst t :ne pseudo-atomic-trap)))))
 361
 362
 363 (def!macro with-pinned-objects ((&rest objects) &body body)
 364   "Arrange with the garbage collector that the pages occupied by
 365 OBJECTS will not be moved in memory for the duration of BODY.
 366 Useful for e.g. foreign calls where another thread may trigger
 367 garbage collection.  This is currently implemented by disabling GC"
 368   #!-gencgc
 369   (declare (ignore objects))            ;should we eval these for side-effect?
 370   #!-gencgc
 371   `(without-gcing
 372     ,@body)
 373   #!+gencgc
 374   `(let ((*pinned-objects* (list* ,@objects *pinned-objects*)))
 375      (declare (truly-dynamic-extent *pinned-objects*))
 376      ,@body))