(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)
(inst addi alloc-tn alloc-tn ,alloc-size)
(inst add alloc-tn alloc-tn ,alloc-size))))
#!+gencgc
- (let ((fix-addr (gensym))
- (inline-alloc (gensym)))
- `(let ((,fix-addr (gen-label))
- (,inline-alloc (gen-label)))
- ;; Make temp-tn be the size
- (cond ((numberp ,size)
- (inst lr ,temp-tn ,size))
- (t
- (move ,temp-tn ,size)))
+ `(progn
+ ;; Make temp-tn be the size
+ (cond ((numberp ,size)
+ (inst lr ,temp-tn ,size))
+ (t
+ (move ,temp-tn ,size)))
+ #!-sb-thread
+ (inst lr ,flag-tn (make-fixup "boxed_region" :foreign))
+ #!-sb-thread
+ (inst lwz ,result-tn ,flag-tn 0)
+ #!+sb-thread
+ (inst lwz ,result-tn thread-base-tn (* thread-alloc-region-slot
+ n-word-bytes))
+
+ ;; we can optimize this to only use one fixup here, once we get
+ ;; it working
+ ;; (inst lr ,flag-tn (make-fixup "boxed_region" :foreign 4))
+ ;; (inst lwz ,flag-tn ,flag-tn 0)
+ #!-sb-thread
+ (inst lwz ,flag-tn ,flag-tn 4)
+ #!+sb-thread
+ (inst lwz ,flag-tn thread-base-tn (* (1+ thread-alloc-region-slot)
+ n-word-bytes))
+
+ (without-scheduling ()
+ ;; CAUTION: The C code depends on the exact order of
+ ;; instructions here. In particular, immediately before the
+ ;; TW instruction must be an ADD or ADDI instruction, so it
+ ;; can figure out the size of the desired allocation and
+ ;; storing the new base pointer back to the allocation region
+ ;; must take two instructions (one on threaded targets).
+
+ ;; Now make result-tn point at the end of the object, to
+ ;; figure out if we overflowed the current region.
+ (inst add ,result-tn ,result-tn ,temp-tn)
+ ;; result-tn points to the new end of the region. Did we go past
+ ;; the actual end of the region? If so, we need a full alloc.
+ ;; The C code depends on this exact form of instruction. If
+ ;; either changes, you have to change the other appropriately!
+ (inst tw :lge ,result-tn ,flag-tn)
+
+ ;; The C code depends on this instruction sequence taking up
+ ;; #!-sb-thread three #!+sb-thread one machine instruction.
+ ;; The lr of a fixup counts as two instructions.
+ #!-sb-thread
(inst lr ,flag-tn (make-fixup "boxed_region" :foreign))
- (inst lwz ,result-tn ,flag-tn 0)
-
- ;; we can optimize this to only use one fixup here, once we get
- ;; it working
- ;; (inst lr ,flag-tn (make-fixup "boxed_region" :foreign 4))
- ;; (inst lwz ,flag-tn ,flag-tn 0)
- (inst lwz ,flag-tn ,flag-tn 4)
-
- (without-scheduling ()
- ;; CAUTION: The C code depends on the exact order of
- ;; instructions here. In particular, three instructions before
- ;; the TW instruction must be an ADD or ADDI instruction, so it
- ;; can figure out the size of the desired allocation.
- ;; Now make result-tn point at the end of the object, to
- ;; figure out if we overflowed the current region.
- (inst add ,result-tn ,result-tn ,temp-tn)
- ;; result-tn points to the new end of the region. Did we go past
- ;; the actual end of the region? If so, we need a full alloc.
- ;; The C code depends on this exact form of instruction. If
- ;; either changes, you have to change the other appropriately!
- (inst cmpw ,result-tn ,flag-tn)
-
- (inst bng ,inline-alloc)
- (inst tw :lge ,result-tn ,flag-tn))
- (inst b ,fix-addr)
-
- (emit-label ,inline-alloc)
- (inst lr ,flag-tn (make-fixup "boxed_region" :foreign))
+ #!-sb-thread
(inst stw ,result-tn ,flag-tn 0)
+ #!+sb-thread
+ (inst stw ,result-tn thread-base-tn (* thread-alloc-region-slot
+ n-word-bytes)))
+
+ ;; Should the allocation trap above have fired, the runtime
+ ;; arranges for execution to resume here, just after where we
+ ;; would have updated the free pointer in the alloc region.
- (emit-label ,fix-addr)
- ;; At this point, result-tn points at the end of the object.
- ;; Adjust to point to the beginning.
- (inst sub ,result-tn ,result-tn ,temp-tn)
- ;; Set the lowtag appropriately
- (inst ori ,result-tn ,result-tn ,lowtag))))
+ ;; At this point, result-tn points at the end of the object.
+ ;; Adjust to point to the beginning.
+ (inst sub ,result-tn ,result-tn ,temp-tn)
+ ;; Set the lowtag appropriately
+ (inst ori ,result-tn ,result-tn ,lowtag)))
(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size
- &key (lowtag other-pointer-lowtag))
+ &key (lowtag other-pointer-lowtag)
+ stack-allocate-p)
&body body)
"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
(once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn)
(type-code type-code) (size size) (lowtag lowtag))
`(pseudo-atomic (,flag-tn)
- (allocation ,result-tn (pad-data-block ,size) ,lowtag
- :temp-tn ,temp-tn
- :flag-tn ,flag-tn)
+ (if ,stack-allocate-p
+ (progn
+ (align-csp ,temp-tn)
+ (inst ori ,result-tn csp-tn ,lowtag)
+ (inst addi csp-tn csp-tn (pad-data-block ,size)))
+ (allocation ,result-tn (pad-data-block ,size) ,lowtag
+ :temp-tn ,temp-tn
+ :flag-tn ,flag-tn))
(when ,type-code
(inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
(storew ,temp-tn ,result-tn 0 ,lowtag))
;;; trap if ALLOC-TN's negative (handling the deferred interrupt) and
;;; using FLAG-TN - minus the large constant - to correct ALLOC-TN.
(defmacro pseudo-atomic ((flag-tn) &body forms)
+ #!+sb-safepoint-strictly
+ `(progn ,flag-tn ,@forms (emit-safepoint))
+ #!-sb-safepoint-strictly
`(progn
(without-scheduling ()
;; Extra debugging stuff:
#+debug
(progn
- (inst andi. ,flag-tn alloc-tn 7)
+ (inst andi. ,flag-tn alloc-tn lowtag-mask)
(inst twi :ne ,flag-tn 0))
- (inst ori alloc-tn alloc-tn 4))
+ (inst ori alloc-tn alloc-tn pseudo-atomic-flag))
,@forms
+ (inst sync)
(without-scheduling ()
- (inst li ,flag-tn -5)
- (inst and alloc-tn alloc-tn ,flag-tn)
+ (inst subi alloc-tn alloc-tn pseudo-atomic-flag)
;; Now test to see if the pseudo-atomic interrupted bit is set.
- (inst andi. ,flag-tn alloc-tn 1)
+ (inst andi. ,flag-tn alloc-tn pseudo-atomic-interrupted-flag)
(inst twi :ne ,flag-tn 0))
#+debug
(progn
- (inst andi. ,flag-tn alloc-tn 7)
- (inst twi :ne ,flag-tn 0))))
+ (inst andi. ,flag-tn alloc-tn lowtag-mask)
+ (inst twi :ne ,flag-tn 0))
+ #!+sb-safepoint
+ (emit-safepoint)))
+
+#!+sb-safepoint
+(defun emit-safepoint ()
+ (inst lwz zero-tn null-tn (- (+ 4096 4 other-pointer-lowtag))))
(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
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*)))
+ (declare (truly-dynamic-extent *pinned-objects*))
+ ,@body))
projects / sbcl.git / blobdiff