;;; Instruction-like macros.
(defmacro move (dst src &optional (always-emit-code-p nil))
+ #!+sb-doc
"Move SRC into DST (unless they are location= and ALWAYS-EMIT-CODE-P
- is nil)."
+is nil)."
(once-only ((n-dst dst)
(n-src src))
`(if (location= ,n-dst ,n-src)
(- other-pointer-lowtag))))
(defmacro load-type (target source &optional (offset 0))
+ #!+sb-doc
"Loads the type bits of a pointer into target independent of
- byte-ordering issues."
+byte-ordering issues."
(once-only ((n-target target)
(n-source source)
(n-offset offset))
(:little-endian
`(inst lbu ,n-target ,n-source ,n-offset))
(:big-endian
- `(inst lbu ,n-target ,n-source (+ ,n-offset 3))))))
+ `(inst lbu ,n-target ,n-source (+ ,n-offset (1- n-word-bytes)))))))
;;; Macros to handle the fact that we cannot use the machine native call and
;;; return instructions.
(defmacro lisp-jump (function lip)
+ #!+sb-doc
"Jump to the lisp function FUNCTION. LIP is an interior-reg temporary."
`(progn
(inst addu ,lip ,function (- (ash simple-fun-code-offset word-shift)
(move code-tn ,function t)))
(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
+ #!+sb-doc
"Return to RETURN-PC. LIP is an interior-reg temporary."
`(progn
(inst addu ,lip ,return-pc
(defmacro emit-return-pc (label)
+ #!+sb-doc
"Emit a return-pc header word. LABEL is the label to use for this return-pc."
`(progn
- (align n-lowtag-bits)
+ (emit-alignment n-lowtag-bits)
(emit-label ,label)
(inst lra-header-word)))
(storew reg cfp-tn offset))))))
(defmacro maybe-load-stack-tn (reg reg-or-stack)
+ #!+sb-doc
"Move the TN Reg-Or-Stack into Reg if it isn't already there."
(once-only ((n-reg reg)
(n-stack reg-or-stack))
\f
;;;; Storage allocation:
-(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
+(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code
+ size dynamic-extent-p
+ &key (lowtag other-pointer-lowtag))
&body body)
+ #!+sb-doc
"Do stuff to allocate an other-pointer object of fixed Size with a single
- word header having the specified Type-Code. The result is placed in
- Result-TN, Flag-Tn must be wired to NL4-OFFSET, and Temp-TN is a non-
- descriptor temp (which may be randomly used by the body.) The body is
- placed inside the PSEUDO-ATOMIC, and presumably initializes the object."
+word header having the specified Type-Code. The result is placed in
+Result-TN, Flag-Tn must be wired to NL4-OFFSET, and Temp-TN is a non-
+descriptor temp (which may be randomly used by the body.) The body is
+placed inside the PSEUDO-ATOMIC, and presumably initializes the object."
(unless body
(bug "empty &body in WITH-FIXED-ALLOCATION"))
- (once-only ((result-tn result-tn) (temp-tn temp-tn) (size size))
- `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
- (inst or ,result-tn alloc-tn other-pointer-lowtag)
- (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
- (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
- ,@body)))
+ (once-only ((result-tn result-tn) (flag-tn flag-tn) (temp-tn temp-tn)
+ (type-code type-code) (size size)
+ (dynamic-extent-p dynamic-extent-p)
+ (lowtag lowtag))
+ `(if ,dynamic-extent-p
+ (pseudo-atomic (,flag-tn)
+ (align-csp ,temp-tn)
+ (inst or ,result-tn csp-tn ,lowtag)
+ (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
+ (inst addu csp-tn (pad-data-block ,size))
+ (storew ,temp-tn ,result-tn 0 ,lowtag)
+ ,@body)
+ (pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
+ ;; The pseudo-atomic bit in alloc-tn is set. If the lowtag also
+ ;; has a 1 bit in the same position, we're all set. Otherwise,
+ ;; we need to subtract the pseudo-atomic bit.
+ (inst or ,result-tn alloc-tn ,lowtag)
+ (unless (logbitp 0 ,lowtag) (inst sub ,result-tn 1))
+ (inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
+ (storew ,temp-tn ,result-tn 0 ,lowtag)
+ ,@body))))
(defun align-csp (temp)
;; is used for stack allocation of dynamic-extent objects
(:signed
(inst slt temp x y)))
(if not-p
- (inst beq temp zero-tn target)
- (inst bne temp zero-tn target)))
+ (inst beq temp target)
+ (inst bne temp target)))
(:gt
(ecase flavor
(:unsigned
(:signed
(inst slt temp y x)))
(if not-p
- (inst beq temp zero-tn target)
- (inst bne temp zero-tn target))))
+ (inst beq temp target)
+ (inst bne temp target))))
(inst nop))
\f
;;;; Error Code
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun emit-error-break (vop kind code values)
(let ((vector (gensym)))
`((let ((vop ,vop))
(inst byte (length ,vector))
(dotimes (i (length ,vector))
(inst byte (aref ,vector i))))
- (align word-shift)))))
+ (emit-alignment word-shift)))))
(defmacro error-call (vop error-code &rest values)
+ #!+sb-doc
"Cause an error. ERROR-CODE is the error to cause."
(cons 'progn
(emit-error-break vop error-trap error-code values)))
(defmacro cerror-call (vop label error-code &rest values)
+ #!+sb-doc
"Cause a continuable error. If the error is continued, execution resumes at
LABEL."
`(progn
,@(emit-error-break vop cerror-trap error-code values))))
(defmacro generate-error-code (vop error-code &rest values)
+ #!+sb-doc
"Generate-Error-Code Error-code Value*
Emit code for an error with the specified Error-Code and context Values."
`(assemble (*elsewhere*)
start-lab)))
(defmacro generate-cerror-code (vop error-code &rest values)
+ #!+sb-doc
"Generate-CError-Code Error-code Value*
Emit code for a continuable error with the specified Error-Code and
context Values. If the error is continued, execution resumes after
(:results (value :scs ,scs))
(:result-types ,el-type)
(:generator 5
- (inst add lip object index)
- (inst lw value lip (- (* ,offset n-word-bytes) ,lowtag))
- (inst nop)))
+ (inst addu lip object index)
+ (loadw value lip ,offset ,lowtag)))
(define-vop (,(symbolicate name "-C"))
,@(when translate
`((:translate ,translate)))
(:results (value :scs ,scs))
(:result-types ,el-type)
(:generator 4
- (inst lw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
- (inst nop)))))
+ (loadw value object (+ ,offset index) ,lowtag)))))
(defmacro define-full-setter (name type offset lowtag scs el-type
&optional translate)
(:results (result :scs ,scs))
(:result-types ,el-type)
(:generator 2
- (inst add lip object index)
- (inst sw value lip (- (* ,offset n-word-bytes) ,lowtag))
+ (inst addu lip object index)
+ (storew value lip ,offset ,lowtag)
(move result value)))
(define-vop (,(symbolicate name "-C"))
,@(when translate
(:results (result :scs ,scs))
(:result-types ,el-type)
(:generator 1
- (inst sw value object (- (* (+ ,offset index) n-word-bytes) ,lowtag))
+ (storew value object (+ ,offset index) ,lowtag)
(move result value)))))
(move result value))))))
-(defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
+(def!macro with-pinned-objects ((&rest objects) &body body)
"Arrange with the garbage collector that the pages occupied by
OBJECTS will not be moved in memory for the duration of BODY.
Useful for e.g. foreign calls where another thread may trigger
projects / sbcl.git / blobdiff