(ash ,',offset word-shift)
(- other-pointer-lowtag))))))))
(frob value)
- (frob function))
+ (frob function)
+
+ ;; FIXME: These are only good for static-symbols, so why not
+ ;; statically-allocate the static-symbol TLS slot indices at
+ ;; cross-compile time so we can just use a fixed offset within the
+ ;; TLS block instead of mucking about with the extra memory access
+ ;; (and temp register, for stores)?
+ #!+sb-thread
+ (defmacro load-tl-symbol-value (reg symbol)
+ `(progn
+ (inst lwz ,reg null-tn
+ (+ (static-symbol-offset ',symbol)
+ (ash symbol-tls-index-slot word-shift)
+ (- other-pointer-lowtag)))
+ (inst lwzx ,reg thread-base-tn ,reg)))
+ #!-sb-thread
+ (defmacro load-tl-symbol-value (reg symbol)
+ `(load-symbol-value ,reg ,symbol))
+
+ #!+sb-thread
+ (defmacro store-tl-symbol-value (reg symbol temp)
+ `(progn
+ (inst lwz ,temp null-tn
+ (+ (static-symbol-offset ',symbol)
+ (ash symbol-tls-index-slot word-shift)
+ (- other-pointer-lowtag)))
+ (inst stwx ,reg thread-base-tn ,temp)))
+ #!-sb-thread
+ (defmacro store-tl-symbol-value (reg symbol temp)
+ (declare (ignore temp))
+ `(store-symbol-value ,reg ,symbol)))
(defmacro load-type (target source &optional (offset 0))
"Loads the type bits of a pointer into target independent of
;; (loadw ,lip ,function function-code-offset function-pointer-type)
(inst addi ,lip ,function (- (* n-word-bytes simple-fun-code-offset) fun-pointer-lowtag))
(inst mtctr ,lip)
- (move code-tn ,function)
(inst bctr)))
-(defmacro lisp-return (return-pc lip &key (offset 0) (frob-code t))
+(defmacro lisp-return (return-pc lip &key (offset 0))
"Return to RETURN-PC."
`(progn
(inst addi ,lip ,return-pc (- (* (1+ ,offset) n-word-bytes) other-pointer-lowtag))
(inst mtlr ,lip)
- ,@(if frob-code
- `((move code-tn ,return-pc)))
(inst blr)))
(defmacro emit-return-pc (label)
"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)))
\f
;;;; Error Code
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun emit-error-break (vop kind code values)
- (let ((vector (gensym)))
- `((let ((vop ,vop))
- (when vop
- (note-this-location vop :internal-error)))
- (inst unimp ,kind)
- (with-adjustable-vector (,vector)
- (write-var-integer (error-number-or-lose ',code) ,vector)
- ,@(mapcar #'(lambda (tn)
- `(let ((tn ,tn))
- (write-var-integer (make-sc-offset (sc-number
- (tn-sc tn))
- (tn-offset tn))
- ,vector)))
- values)
- (inst byte (length ,vector))
- (dotimes (i (length ,vector))
- (inst byte (aref ,vector i))))
- (align word-shift)))))
-
-(defmacro error-call (vop error-code &rest values)
+(defun emit-error-break (vop kind code values)
+ (assemble ()
+ (when vop
+ (note-this-location vop :internal-error))
+ (inst unimp kind)
+ (with-adjustable-vector (vector)
+ (write-var-integer code vector)
+ (dolist (tn values)
+ (write-var-integer (make-sc-offset (sc-number (tn-sc tn))
+ (or (tn-offset tn) 0))
+ vector))
+ (inst byte (length vector))
+ (dotimes (i (length vector))
+ (inst byte (aref vector i)))
+ (emit-alignment word-shift))))
+
+(defun 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)))
+ (emit-error-break vop error-trap (error-number-or-lose error-code) values))
-
-(defmacro cerror-call (vop label error-code &rest values)
- "Cause a continuable error. If the error is continued, execution resumes at
- LABEL."
- `(progn
- ,@(emit-error-break vop cerror-trap error-code values)
- (inst b ,label)))
-
-(defmacro generate-error-code (vop error-code &rest values)
+(defun 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*)
- (let ((start-lab (gen-label)))
- (emit-label start-lab)
- (error-call ,vop ,error-code ,@values)
- start-lab)))
-
-(defmacro generate-cerror-code (vop error-code &rest values)
- "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
- the GENERATE-CERROR-CODE form."
- (with-unique-names (continue error)
- `(let ((,continue (gen-label)))
- (emit-label ,continue)
- (assemble (*elsewhere*)
- (let ((,error (gen-label)))
- (emit-label ,error)
- (cerror-call ,vop ,continue ,error-code ,@values)
- ,error)))))
+ (assemble (*elsewhere*)
+ (let ((start-lab (gen-label)))
+ (emit-label start-lab)
+ (emit-error-break vop error-trap (error-number-or-lose error-code) values)
+ start-lab)))
\f
;;;; PSEUDO-ATOMIC
OBJECTS will not be moved in memory for the duration of BODY.
Useful for e.g. foreign calls where another thread may trigger
garbage collection. This is currently implemented by disabling GC"
+ #!-gencgc
(declare (ignore objects)) ; should we eval these for side-effect?
+ #!-gencgc
`(without-gcing
- ,@body))
+ ,@body)
+ #!+gencgc
+ `(let ((*pinned-objects* (list* ,@objects *pinned-objects*)))
+ ,@body))
projects / sbcl.git / blobdiff