Based on Raymond Toy's work.
PVE Peter Van Eynde
PW Paul Werkowski
RAM Robert MacLachlan
+RLT Raymond Toy
TCR Tobias Rittweiler
THS Thiemo Seufer
VJA Vincent Arkesteijn
# FUNCDEF macro for assembler. No harm in running this on sparc-linux
# as well.
sh tools-for-build/sparc-funcdef.sh > src/runtime/sparc-funcdef.h
- printf ' :cheneygc' >> $ltf
+ if [ "$sbcl_os" = "sunos" ]; then
+ printf ' :gencgc' >> $ltf
+ else
+ echo '***'
+ echo '*** You are running SPARC on non-SunOS. Since GENCGC is'
+ echo '*** untested on this combination, make-config.sh is falling'
+ echo '*** back to CHENEYGC. Please consider adjusting parms.lisp'
+ echo '*** to build with GENCGC instead.'
+ echo '***'
+ printf ' :cheneygc' >> $ltf
+ fi
if [ "$sbcl_os" = "sunos" ] || [ "$sbcl_os" = "linux" ]; then
printf ' :linkage-table' >> $ltf
fi
"%COMPILER-BARRIER" "%DATA-DEPENDENCY-BARRIER"
"%MEMORY-BARRIER" "%READ-BARRIER" "%WRITE-BARRIER"
"AFTER-BREAKPOINT-TRAP"
+ #!+(and gencgc sparc) "ALLOCATION-TRAP"
"ANY-REG-SC-NUMBER" "ARRAY-DATA-SLOT" "ARRAY-DIMENSIONS-OFFSET"
"ARRAY-DISPLACED-P-SLOT" "ARRAY-DISPLACEMENT-SLOT"
"ARRAY-DISPLACED-FROM-SLOT"
"GENCGC-CARD-BYTES"
"GENCGC-ALLOC-GRANULARITY"
"GENCGC-RELEASE-GRANULARITY"
- #!+ppc "PSEUDO-ATOMIC-INTERRUPTED-FLAG"
- #!+ppc "PSEUDO-ATOMIC-FLAG"
+ #!+(or ppc sparc) "PSEUDO-ATOMIC-INTERRUPTED-FLAG"
+ #!+(or ppc sparc) "PSEUDO-ATOMIC-FLAG"
#!+sb-safepoint "GLOBAL-SAFEPOINT-TRAP"
"GENESIS" "HALT-TRAP" "IGNORE-ME-SC-NUMBER"
"IMMEDIATE-CHARACTER-SC-NUMBER" "IMMEDIATE-SAP-SC-NUMBER"
(inst srl lo n-fixnum-tag-bits)
(inst or lo temp)
(inst sra hi n-fixnum-tag-bits)
- ;; Allocate a BIGNUM for the result.
- #+nil
- (pseudo-atomic (:extra (pad-data-block (1+ bignum-digits-offset)))
- (let ((one-word (gen-label)))
- (inst or res alloc-tn other-pointer-lowtag)
- ;; We start out assuming that we need one word. Is that correct?
- (inst sra temp lo 31)
- (inst xorcc temp hi)
- (inst b :eq one-word)
- (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
- ;; Nope, we need two, so allocate the addition space.
- (inst add alloc-tn (- (pad-data-block (+ 2 bignum-digits-offset))
- (pad-data-block (1+ bignum-digits-offset))))
- (inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
- (storew hi res (1+ bignum-digits-offset) other-pointer-lowtag)
- (emit-label one-word)
- (storew temp res 0 other-pointer-lowtag)
- (storew lo res bignum-digits-offset other-pointer-lowtag)))
;; Always allocate 2 words for the bignum result, even if we only
;; need one. The copying GC will take care of the extra word if it
;; isn't needed.
(with-fixed-allocation
(res temp bignum-widetag (+ 2 bignum-digits-offset))
(let ((one-word (gen-label)))
- (inst or res alloc-tn other-pointer-lowtag)
;; We start out assuming that we need one word. Is that correct?
(inst sra temp lo 31)
(inst xorcc temp hi)
(:res result descriptor-reg a0-offset)
(:temp ndescr non-descriptor-reg nl0-offset)
+ (:temp gc-temp non-descriptor-reg nl1-offset)
(:temp vector descriptor-reg a3-offset))
(pseudo-atomic ()
- (inst or vector alloc-tn other-pointer-lowtag)
;; boxed words == unboxed bytes
(inst add ndescr words (* (1+ vector-data-offset) n-word-bytes))
(inst andn ndescr 7)
- (inst add alloc-tn ndescr)
+ (allocation vector ndescr other-pointer-lowtag :temp-tn gc-temp)
(inst srl ndescr type word-shift)
(storew ndescr vector 0 other-pointer-lowtag)
(storew length vector vector-length-slot other-pointer-lowtag))
;; This makes sure the zero byte at the end of a string is paged in so
;; the kernel doesn't bitch if we pass it the string.
+ ;;
+ ;; RLT comments in CMUCL about changing the following line to
+ ;; store at -1 instead of 0:
+ ;; This used to write to the word after the last allocated word. I
+ ;; (RLT) made it write to the last allocated word, which is where
+ ;; the zero-byte of the string is. Look at the deftransform for
+ ;; make-array in array-tran.lisp. For strings we always allocate
+ ;; enough space to hold the zero-byte.
+ ;; Which is most certainly motivated by the fact that this store (if
+ ;; performed on gencgc) overwrites the first word of the following
+ ;; page -- destroying the first object of an unrelated allocation region!
+ ;;
+ ;; But the CMUCL fix breaks :ELEMENT-TYPE NIL strings, so we'd need a
+ ;; branch to figure out whether to do it. Until and unless someone
+ ;; demonstrates that gencgc actually gives us uncommitted memory, I'm
+ ;; just not doing it at all: -- DFL
+ #!-gencgc
(storew zero-tn alloc-tn 0)
(move result vector))
":GENCGC and :CHENEYGC are incompatible")
("(and cheneygc (not (or alpha hppa mips ppc sparc)))"
":CHENEYGC not supported on selected architecture")
- ("(and gencgc (not (or ppc x86 x86-64)))"
+ ("(and gencgc (not (or sparc ppc x86 x86-64)))"
":GENCGC not supported on selected architecture")
("(not (or gencgc cheneygc))"
"One of :GENCGC or :CHENEYGC must be enabled")
(:temporary (:scs (descriptor-reg)) temp)
(:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
res)
+ (:temporary (:scs (non-descriptor-reg)) alloc-temp)
(:info num)
(:results (result :scs (descriptor-reg)))
(:variant-vars star)
(let* ((dx-p (node-stack-allocate-p node))
(cons-cells (if star (1- num) num))
(alloc (* (pad-data-block cons-size) cons-cells)))
- (pseudo-atomic (:extra (if dx-p 0 alloc))
- (let ((allocation-area-tn (if dx-p csp-tn alloc-tn)))
- (when dx-p
- (align-csp res))
- (inst andn res allocation-area-tn lowtag-mask)
- (inst or res list-pointer-lowtag)
- (when dx-p
- (inst add csp-tn csp-tn alloc)))
+ (pseudo-atomic ()
+ (allocation res alloc list-pointer-lowtag
+ :stack-p dx-p
+ :temp-tn alloc-temp)
(move ptr res)
(dotimes (i (1- cons-cells))
(storew (maybe-load (tn-ref-tn things)) ptr
(:results (result :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
(:temporary (:scs (any-reg) :from (:argument 0)) boxed)
+ (:temporary (:scs (non-descriptor-reg)) size)
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
(:generator 100
(inst add boxed boxed-arg (fixnumize (1+ code-trace-table-offset-slot)))
(inst add unboxed lowtag-mask)
(inst and unboxed (lognot lowtag-mask))
(pseudo-atomic ()
- ;; CMUCL Comment:
- ;; Note: we don't have to subtract off the 4 that was added by
- ;; pseudo-atomic, because oring in other-pointer-lowtag just adds
- ;; it right back.
;;
;; This looks like another dreadful type pun. CSR - 2002-02-06
- (inst or result alloc-tn other-pointer-lowtag)
- (inst add alloc-tn boxed)
- (inst add alloc-tn unboxed)
+ ;;
+ ;; Not any more, or not in that sense at least, because the
+ ;; "p/a bit is also the highest lowtag bit" assumption is now hidden
+ ;; in the allocation macro. DFL - 2012-10-01
+ ;;
+ ;; Figure out how much space we really need and allocate it.
+ (inst add size boxed unboxed)
+ (allocation result size other-pointer-lowtag :temp-tn ndescr)
(inst sll ndescr boxed (- n-widetag-bits word-shift))
(inst or ndescr code-header-widetag)
(storew ndescr result 0 other-pointer-lowtag)
(:generator 10
(let* ((size (+ length closure-info-offset))
(alloc-size (pad-data-block size)))
- (pseudo-atomic (:extra (if stack-allocate-p 0 alloc-size))
- (cond (stack-allocate-p
- (align-csp temp)
- (inst andn result csp-tn lowtag-mask)
- (inst or result fun-pointer-lowtag)
- (inst add csp-tn alloc-size))
- (t
- (inst andn result alloc-tn lowtag-mask)
- (inst or result fun-pointer-lowtag)))
+ (pseudo-atomic ()
+ (allocation result alloc-size fun-pointer-lowtag
+ :stack-p stack-allocate-p
+ :temp-tn temp)
(inst li temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
(storew temp result 0 fun-pointer-lowtag)
(storew function result closure-fun-slot fun-pointer-lowtag)))))
(:results (result :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 4
- (pseudo-atomic (:extra (pad-data-block words))
- (cond ((logbitp (1- n-lowtag-bits) lowtag)
- (inst or result alloc-tn lowtag))
- (t
- (inst andn result alloc-tn lowtag-mask)
- (inst or result lowtag)))
+ (pseudo-atomic ()
+ (allocation result (pad-data-block words) lowtag :temp-tn temp)
(when type
(inst li temp (logior (ash (1- words) n-widetag-bits) type))
(storew temp result 0 lowtag)))))
(:results (result :scs (descriptor-reg)))
(:temporary (:scs (any-reg)) bytes)
(:temporary (:scs (non-descriptor-reg)) header)
+ (:temporary (:scs (non-descriptor-reg)) temp)
(:generator 6
(inst add bytes extra (* (1+ words) n-word-bytes))
(inst sll header bytes (- n-widetag-bits 2))
(inst add header header (+ (ash -2 n-widetag-bits) type))
(inst and bytes (lognot lowtag-mask))
(pseudo-atomic ()
- ;; Need to be careful if the lowtag and the pseudo-atomic flag
- ;; are not compatible.
- (cond ((logbitp (1- n-lowtag-bits) lowtag)
- (inst or result alloc-tn lowtag))
- (t
- (inst andn result alloc-tn lowtag-mask)
- (inst or result lowtag)))
- (storew header result 0 lowtag)
- (inst add alloc-tn alloc-tn bytes))))
+ (allocation result bytes lowtag :temp-tn temp)
+ (storew header result 0 lowtag))))
(:arg-types tagged-num tagged-num)
(:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
(:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:temporary (:scs (non-descriptor-reg)) gencgc-temp)
(:results (result :scs (descriptor-reg)))
(:generator 0
(pseudo-atomic ()
- (inst or header alloc-tn other-pointer-lowtag)
(inst add ndescr rank (+ (* (1+ array-dimensions-offset) n-word-bytes)
lowtag-mask))
(inst andn ndescr lowtag-mask)
- (inst add alloc-tn ndescr)
+ (allocation header ndescr other-pointer-lowtag :temp-tn gencgc-temp)
(inst add ndescr rank (fixnumize (1- array-dimensions-offset)))
(inst sll ndescr ndescr n-widetag-bits)
(inst or ndescr ndescr type)
(setf *backend-byte-order* :big-endian)
-(setf *backend-page-bytes* 8192)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf *backend-page-bytes* 8192))
+;;; The size in bytes of GENCGC cards, i.e. the granularity at which
+;;; writes to old generations are logged. With mprotect-based write
+;;; barriers, this must be a multiple of the OS page size.
+(def!constant gencgc-card-bytes *backend-page-bytes*)
+;;; The minimum size of new allocation regions. While it doesn't
+;;; currently make a lot of sense to have a card size lower than
+;;; the alloc granularity, it will, once we are smarter about finding
+;;; the start of objects.
+(def!constant gencgc-alloc-granularity 0)
+;;; The minimum size at which we release address ranges to the OS.
+;;; This must be a multiple of the OS page size.
+(def!constant gencgc-release-granularity *backend-page-bytes*)
(let* ((enter (gen-label))
(loop (gen-label))
(done (gen-label))
- (dx-p (node-stack-allocate-p node))
- (alloc-area-tn (if dx-p csp-tn alloc-tn)))
+ (dx-p (node-stack-allocate-p node)))
(move context context-arg)
(move count count-arg)
;; Check to see if there are any arguments.
;; We need to do this atomically.
(pseudo-atomic ()
- (when dx-p
- (align-csp temp))
;; Allocate a cons (2 words) for each item.
- (inst andn result alloc-area-tn lowtag-mask)
- (inst or result list-pointer-lowtag)
- (move dst result)
(inst sll temp count 1)
+ (allocation result temp list-pointer-lowtag
+ :stack-p dx-p
+ :temp-tn dst)
(inst b enter)
- (inst add alloc-area-tn temp)
+ (move dst result)
;; Compute the next cons and store it in the current one.
(emit-label loop)
(loadw ,n-reg cfp-tn (tn-offset ,n-stack))))))))
\f
+\f
;;;; Storage allocation:
+
+;;;; Allocation macro
+;;;;
+;;;; This macro does the appropriate stuff to allocate space.
+;;;;
+;;;; The allocated space is stored in RESULT-TN with the lowtag LOWTAG
+;;;; applied. The amount of space to be allocated is SIZE bytes (which
+;;;; must be a multiple of the lisp object size).
+(defmacro allocation (result-tn size lowtag &key stack-p temp-tn)
+ #!+gencgc
+ ;; A temp register is needed to do inline allocation. TEMP-TN, in
+ ;; this case, can be any register, since it holds a double-word
+ ;; aligned address (essentially a fixnum).
+ (assert temp-tn)
+ ;; We assume we're in a pseudo-atomic so the pseudo-atomic bit is
+ ;; set.
+ `(cond
+ (,stack-p
+ ;; Stack allocation
+ ;;
+ ;; The control stack grows up, so round up CSP to a
+ ;; multiple of 8 (lispobj size). Use that as the
+ ;; allocation pointer. Then add SIZE bytes to the
+ ;; allocation and set CSP to that, so we have the desired
+ ;; space.
+
+ ;; Make sure the temp-tn is a non-descriptor register!
+ (assert (and ,temp-tn (sc-is ,temp-tn non-descriptor-reg)))
+
+ ;; temp-tn is csp-tn rounded up to a multiple of 8 (lispobj size)
+ (align-csp ,temp-tn)
+ ;; For the benefit of future historians, this is how CMUCL does the
+ ;; align-csp (I think their version is branch free only because
+ ;; they simply don't worry about zeroing the pad word):
+ #+nil (inst add ,temp-tn csp-tn sb!vm:lowtag-mask)
+ #+nil (inst andn ,temp-tn sb!vm:lowtag-mask)
+
+ ;; Set the result to temp-tn, with appropriate lowtag
+ (inst or ,result-tn csp-tn ,lowtag)
+
+ ;; Allocate the desired space on the stack.
+ ;;
+ ;; FIXME: Can't allocate on stack if SIZE is too large.
+ ;; Need to rearrange this code.
+ (inst add csp-tn ,size))
+
+ #!-gencgc
+ ;; Normal allocation to the heap -- cheneygc version.
+ ;;
+ ;; On cheneygc, the alloc-tn currently has the pseudo-atomic bit.
+ ;; If the lowtag also has a 1 bit in the same position, we're all set.
+ ;;
+ ;; See comment in PSEUDO-ATOMIC-FLAG.
+ ((logbitp (1- n-lowtag-bits) ,lowtag)
+ (inst or ,result-tn alloc-tn ,lowtag)
+ (inst add alloc-tn ,size))
+ ;;
+ ;; Otherwise, we need to zap out the lowtag from alloc-tn, and then
+ ;; or in the lowtag.
+ #!-gencgc
+ (t
+ (inst andn ,result-tn alloc-tn lowtag-mask)
+ (inst or ,result-tn ,lowtag)
+ (inst add alloc-tn ,size))
+
+ ;; Normal allocation to the heap -- gencgc version.
+ ;;
+ ;; No need to worry about lowtag bits matching up here, since
+ ;; alloc-tn is just a "pseudo-atomic-bit-tn" now and we don't read
+ ;; it.
+ #!+gencgc
+ (t
+ (inst li ,temp-tn (make-fixup "boxed_region" :foreign))
+ (loadw ,result-tn ,temp-tn 0) ;boxed_region.free_pointer
+ (loadw ,temp-tn ,temp-tn 1) ;boxed_region.end_addr
+
+ (without-scheduling ()
+ (let ((done (gen-label))
+ (full-alloc (gen-label)))
+ ;; See if we can do an inline allocation. The updated
+ ;; free pointer should not point past the end of the
+ ;; current region. If it does, a full alloc needs to be
+ ;; done.
+ (inst add ,result-tn ,size)
+
+ ;; result-tn points to the new end of region. Did we go
+ ;; past the actual end of the region? If so, we need a
+ ;; full alloc.
+ (inst cmp ,result-tn ,temp-tn)
+ (if (member :sparc-v9 *backend-subfeatures*)
+ (inst b :gtu full-alloc :pn)
+ (inst b :gtu full-alloc))
+ (inst nop)
+ ;; Inline allocation worked, so update the free pointer
+ ;; and go. Should really do a swap instruction here to
+ ;; swap memory with a register.
+
+ ;; Kludge: We ought to have two distinct FLAG-TN and TEMP-TN
+ ;; here, to avoid the SUB and the TEMP-TN reload which is
+ ;; causing it. PPC gets it right.
+ (inst li ,temp-tn (make-fixup "boxed_region" :foreign))
+ (storew ,result-tn ,temp-tn 0)
+
+ (inst b done)
+ (inst sub ,result-tn ,size)
+
+ (emit-label full-alloc)
+ ;; Full alloc via trap to the C allocator. Tell the
+ ;; allocator what the result-tn and size are, using the
+ ;; OR instruction. Then trap to the allocator.
+ (inst or zero-tn ,result-tn ,size)
+ ;; DFL: Not certain why we use two kinds of traps: T for p/a
+ ;; and UNIMP for all other traps. But the C code in the runtime
+ ;; for the UNIMP case is a lot nicer, so I'm hooking into that.
+ ;; (inst t :t allocation-trap)
+ (inst unimp allocation-trap)
+
+ (emit-label done)
+ ;; Set lowtag appropriately
+ (inst or ,result-tn ,lowtag))))))
+
(defmacro with-fixed-allocation ((result-tn temp-tn type-code size)
&body body)
"Do stuff to allocate an other-pointer object of fixed Size with a single
(bug "empty &body in WITH-FIXED-ALLOCATION"))
(once-only ((result-tn result-tn) (temp-tn temp-tn)
(type-code type-code) (size size))
- `(pseudo-atomic (:extra (pad-data-block ,size))
- (inst or ,result-tn alloc-tn other-pointer-lowtag)
+ `(pseudo-atomic ()
+ (allocation ,result-tn (pad-data-block ,size) other-pointer-lowtag
+ :temp-tn ,temp-tn)
(inst li ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
(storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
,@body)))
,error)))))
\f
;;; a handy macro for making sequences look atomic
-(defmacro pseudo-atomic ((&key (extra 0)) &rest forms)
- (let ((n-extra (gensym)))
- `(let ((,n-extra ,extra))
+(defmacro pseudo-atomic ((&optional) &rest forms)
+ (let ()
+ `(progn
;; Set the pseudo-atomic flag.
(without-scheduling ()
- (inst add alloc-tn 4))
+ (inst or alloc-tn 4))
,@forms
;; Reset the pseudo-atomic flag.
(without-scheduling ()
- #+nil (inst taddcctv alloc-tn (- ,n-extra 4))
;; Remove the pseudo-atomic flag.
- (inst add alloc-tn (- ,n-extra 4))
+ (inst andn alloc-tn 4)
;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1).
(inst andcc zero-tn alloc-tn 3)
;; The C code needs to process this correctly and fixup alloc-tn.
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))
;;; number of bits per byte where a byte is the smallest addressable object
(def!constant n-byte-bits 8)
+;;; flags for the generational garbage collector
+(def!constant pseudo-atomic-interrupted-flag 1)
+(def!constant pseudo-atomic-flag
+ ;; Must be (ash 1 (1- sb-vm:n-lowtag-bits)) for cheneygc ALLOCATION.
+ 4)
+
(def!constant float-sign-shift 31)
(def!constant single-float-bias 126)
(def!constant dynamic-1-space-start #x40000000)
(def!constant dynamic-1-space-end #x48000000))
-#!+sunos ; might as well start by trying the same numbers
+#!+(and sunos cheneygc) ; might as well start by trying the same numbers
(progn
(def!constant linkage-table-space-start #x0f800000)
(def!constant linkage-table-space-end #x10000000)
(def!constant dynamic-1-space-start #x40000000)
(def!constant dynamic-1-space-end #x48000000))
+#!+(and sunos gencgc) ; sensibly small read-only and static spaces
+(progn
+ (def!constant linkage-table-space-start #x0f800000)
+ (def!constant linkage-table-space-end #x10000000)
+
+ (def!constant read-only-space-start #x11000000)
+ (def!constant read-only-space-end #x110ff000)
+
+ (def!constant static-space-start #x11100000)
+ (def!constant static-space-end #x111ff000)
+
+ (def!constant dynamic-space-start #x30000000)
+ (def!constant dynamic-space-end (!configure-dynamic-space-end)))
+
#!+netbsd ; Need a gap at 0x4000000 for shared libraries
(progn
(def!constant linkage-table-space-start #x0f800000)
fun-end-breakpoint-trap
after-breakpoint-trap
single-step-around-trap
- single-step-before-trap)
+ single-step-before-trap
+ #!+gencgc allocation-trap)
(defenum (:start 24)
object-not-list-trap
(append
*common-static-symbols*
*c-callable-static-symbols*
- '()))
+ '(#!+gencgc *restart-lisp-function*)))
(defparameter *static-funs*
'(length
OS_LIBS += -lz
endif
-GC_SRC = cheneygc.c
+ifdef LISP_FEATURE_GENCGC
+ GC_SRC = gencgc.c
+else
+ GC_SRC = cheneygc.c
+endif
# Nothing to do for after-grovel-headers.
.PHONY: after-grovel-headers
OS_LIBS += -lz
endif
-GC_SRC = cheneygc.c
+ifdef LISP_FEATURE_GENCGC
+ GC_SRC = gencgc.c
+else
+ GC_SRC = cheneygc.c
+endif
# Nothing to do for after-grovel-headers.
.PHONY: after-grovel-headers
CC = gcc
CFLAGS += -DSVR4 -D_REENTRANT
-ASFLAGS = -g -Wall -DSVR4
+ASFLAGS = -g -Wall -DSVR4 -Wa,-xarch=v8plus
LINKFLAGS += -v
NM = nm -t x -p
OS_LIBS += -lz
endif
-GC_SRC = cheneygc.c
+ifdef LISP_FEATURE_GENCGC
+ GC_SRC = gencgc.c
+else
+ GC_SRC = cheneygc.c
+endif
# Nothing to do for after-grovel-headers.
.PHONY: after-grovel-headers
/* FIXME: It would be good to document these too! */
extern void arch_skip_instruction(os_context_t*);
+extern void arch_handle_allocation_trap(os_context_t*);
extern boolean arch_pseudo_atomic_atomic(os_context_t*);
extern void arch_set_pseudo_atomic_interrupted(os_context_t*);
extern void arch_clear_pseudo_atomic_interrupted(os_context_t*);
#elif defined(LISP_FEATURE_PPC)
#define FPU_STATE_SIZE 32
long long fpu_state[FPU_STATE_SIZE];
+#elif defined(LISP_FEATURE_SPARC)
+ /*
+ * 32 (single-precision) FP registers, and the FP state register.
+ * But Sparc V9 has 32 double-precision registers (equivalent to 64
+ * single-precision, but can't be accessed), so we leave enough room
+ * for that.
+ */
+#define FPU_STATE_SIZE (((32 + 32 + 1) + 1)/2)
+ long long fpu_state[FPU_STATE_SIZE];
#endif
/* This code uses the FP instructions which may be set up for Lisp
thread_register_gc_trigger();
#else
set_pseudo_atomic_interrupted(thread);
-#ifdef LISP_FEATURE_PPC
+#ifdef GENCGC_IS_PRECISE
/* PPC calls alloc() from a trap or from pa_alloc(),
* look up the most context if it's from a trap. */
{
sigset_t *sigset = os_context_sigmask_addr(context);
/* On PPC pseudo_atomic_interrupted is cleared when coming out of
* handle_allocation_trap. */
-#if defined(LISP_FEATURE_GENCGC) && !defined(LISP_FEATURE_PPC)
+#if defined(LISP_FEATURE_GENCGC) && !defined(GENCGC_IS_PRECISE)
int interrupts_enabled = (SymbolValue(INTERRUPTS_ENABLED,thread) != NIL);
int gc_inhibit = (SymbolValue(GC_INHIBIT,thread) != NIL);
int gc_pending = (SymbolValue(GC_PENDING,thread) == T);
arch_skip_instruction(context);
break;
#endif
+#if defined(LISP_FEATURE_SPARC) && defined(LISP_FEATURE_GENCGC)
+ case trap_Allocation:
+ arch_handle_allocation_trap(context);
+ arch_skip_instruction(context);
+ break;
+#endif
case trap_Halt:
fake_foreign_function_call(context);
lose("%%PRIMITIVE HALT called; the party is over.\n");
* and with no pending handler. Both deferrable interrupt handlers
* and gc are careful not to clobber each other's pending_mask. */
boolean gc_blocked_deferrables;
-#ifdef LISP_FEATURE_PPC
+#ifdef GENCGC_IS_PRECISE
/* On PPC when consing wants to turn to alloc(), it does so via a
* trap. When alloc() wants to save the sigmask it consults
* allocation_trap_context. It does not look up the most recent
# define THREADS_USING_GCSIGNAL 1
#endif
+/* Now that SPARC has precise GENCGC, several places that used to be
+ * #ifdef PCC need adjustment. Clearly, "PPC or SPARC" is as unhelpful
+ * a test as its reverse, "x86 or x86-64". However, the feature
+ * commonly used to differentiate between those two worlds is
+ * C_STACK_IS_CONTROL_STACK, and clearly (or at least in my humble
+ * opinion), at some point we'd like to have precise GC on x86 while
+ * still sharing the C stack, so stack usage ought not imply GC
+ * conservativeness. So let's have a helper feature that makes the code
+ * a bit more future-proof, even if it is itself currently defined in
+ * the naive way: */
+#if defined(LISP_FEATURE_GENCGC) && !defined(LISP_FEATURE_C_STACK_IS_CONTROL_STACK)
+# define GENCGC_IS_PRECISE 1
+#endif
+
#endif /* _SBCL_RUNTIME_H_ */
arch_skip_instruction(context);
}
+#ifdef LISP_FEATURE_GENCGC
+void
+arch_handle_allocation_trap(os_context_t *context)
+{
+ unsigned int* pc;
+ unsigned int or_inst;
+ int rs1;
+ int size;
+ int immed;
+ int context_index;
+ boolean were_in_lisp;
+ char* memory;
+
+ pc = (unsigned int*) *os_context_pc_addr(context);
+ or_inst = pc[-1];
+
+ /*
+ * The instruction before this trap instruction had better be an OR
+ * instruction!
+ */
+ if (!(((or_inst >> 30) == 2) && (((or_inst >> 19) & 0x1f) == 2)))
+ lose(stderr, "Whoa!!! Got an allocation trap not preceeded by an OR inst: 0x%08x!\n",
+ or_inst);
+
+ /*
+ * An OR instruction. RS1 is the register we want to allocate to.
+ * RS2 (or an immediate) is the size.
+ */
+ rs1 = (or_inst >> 14) & 0x1f;
+ immed = (or_inst >> 13) & 1;
+
+ if (immed == 1)
+ size = or_inst & 0x1fff;
+ else {
+ size = or_inst & 0x1f;
+ size = *os_context_register_addr(context, size);
+ }
+
+ if (foreign_function_call_active)
+ lose(stderr, "Whoa! allocation trap and we weren't in lisp!\n");
+ fake_foreign_function_call(context);
+
+ /*
+ * Allocate some memory, store the memory address in rs1.
+ */
+ {
+ struct interrupt_data *data =
+ arch_os_get_current_thread()->interrupt_data;
+ data->allocation_trap_context = context;
+ memory = alloc(size);
+ data->allocation_trap_context = 0;
+ }
+ *os_context_register_addr(context, rs1) = memory;
+
+ undo_fake_foreign_function_call(context);
+}
+#endif
+
static void sigill_handler(int signal, siginfo_t *siginfo,
os_context_t *context)
{
retl ! return from leaf routine
nop
+ .global do_pending_interrupt
+ FUNCDEF(do_pending_interrupt)
+do_pending_interrupt:
+ unimp trap_PendingInterrupt
+ retl
+ nop
+
+/*
+ * Save the FPU state. %o0 contains a pointer to where we can
+ * store our state.
+ */
+
+/*
+ * Note we only save the 16 double-float registers (which saves
+ * the 32 single-float values too, I think). If we're compiling for
+ * a sparc v9, the Lisp code can actually use all 32 double-float
+ * registers. For later.
+ */
+ .global fpu_save
+ FUNCDEF(fpu_save)
+fpu_save:
+ std %f0, [%o0 + 4*0]
+ std %f2, [%o0 + 4*2]
+ std %f4, [%o0 + 4*4]
+ std %f6, [%o0 + 4*6]
+ std %f8, [%o0 + 4*8]
+ std %f10, [%o0 + 4*10]
+ std %f12, [%o0 + 4*12]
+ std %f14, [%o0 + 4*14]
+ std %f16, [%o0 + 4*16]
+ std %f18, [%o0 + 4*18]
+ std %f20, [%o0 + 4*20]
+ std %f22, [%o0 + 4*22]
+ std %f24, [%o0 + 4*24]
+ std %f26, [%o0 + 4*26]
+ std %f28, [%o0 + 4*28]
+ std %f30, [%o0 + 4*30]
+#ifdef FEATURE_SPARC_V9
+ std %f32, [%o0 + 4*32]
+ std %f34, [%o0 + 4*34]
+ std %f36, [%o0 + 4*36]
+ std %f38, [%o0 + 4*38]
+ std %f40, [%o0 + 4*40]
+ std %f42, [%o0 + 4*42]
+ std %f44, [%o0 + 4*44]
+ std %f46, [%o0 + 4*46]
+ std %f48, [%o0 + 4*48]
+ std %f50, [%o0 + 4*50]
+ std %f52, [%o0 + 4*52]
+ std %f54, [%o0 + 4*54]
+ std %f56, [%o0 + 4*56]
+ std %f58, [%o0 + 4*58]
+ std %f60, [%o0 + 4*60]
+ std %f62, [%o0 + 4*62]
+ st %fsr, [%o0 + 4*64]
+#else
+ st %fsr, [%o0 + 4*32]
+#endif
+ retl
+ nop
+
+ .global fpu_restore
+ FUNCDEF(fpu_restore)
+fpu_restore:
+ ldd [%o0 + 4*0], %f0
+ ldd [%o0 + 4*2], %f2
+ ldd [%o0 + 4*4], %f4
+ ldd [%o0 + 4*6], %f6
+ ldd [%o0 + 4*8], %f8
+ ldd [%o0 + 4*10], %f10
+ ldd [%o0 + 4*12], %f12
+ ldd [%o0 + 4*14], %f14
+ ldd [%o0 + 4*16], %f16
+ ldd [%o0 + 4*18], %f18
+ ldd [%o0 + 4*20], %f20
+ ldd [%o0 + 4*22], %f22
+ ldd [%o0 + 4*24], %f24
+ ldd [%o0 + 4*26], %f26
+ ldd [%o0 + 4*28], %f28
+ ldd [%o0 + 4*30], %f30
+#ifdef FEATURE_SPARC_V9
+ ldd [%o0 + 4*32], %f32
+ ldd [%o0 + 4*34], %f34
+ ldd [%o0 + 4*36], %f36
+ ldd [%o0 + 4*38], %f38
+ ldd [%o0 + 4*40], %f40
+ ldd [%o0 + 4*42], %f42
+ ldd [%o0 + 4*44], %f44
+ ldd [%o0 + 4*46], %f46
+ ldd [%o0 + 4*48], %f48
+ ldd [%o0 + 4*50], %f50
+ ldd [%o0 + 4*52], %f52
+ ldd [%o0 + 4*54], %f54
+ ldd [%o0 + 4*56], %f56
+ ldd [%o0 + 4*58], %f58
+ ldd [%o0 + 4*60], %f60
+ ldd [%o0 + 4*62], %f62
+ ld [%o0 + 4*64], %fsr
+#else
+ ld [%o0 + 4*32], %fsr
+#endif
+ retl
+ nop
+
.global save_context
FUNCDEF(save_context)
save_context:
ta ST_FLUSH_WINDOWS ! flush register windows
retl ! return from leaf routine
- nop
+ nop
}
th->interrupt_data->pending_handler = 0;
th->interrupt_data->gc_blocked_deferrables = 0;
-#ifdef LISP_FEATURE_PPC
+#ifdef GENCGC_IS_PRECISE
th->interrupt_data->allocation_trap_context = 0;
#endif
th->no_tls_value_marker=initial_function;
;; This fails on threaded PPC because the hash-table implementation
;; uses recursive system locks, which cons (see below for test
;; (:no-consing :lock), which also fails on threaded PPC).
+;;
+;; -- That may have been the situation in 2010 when the above comment
+;; was written, but AFAICT now, hash tables use WITH-PINNED-OBJECTS,
+;; which conses on PPC and SPARC when GENCGC is enabled. So neither is
+;; this actually about threading, nor about PPC. Yet since we are
+;; failing most of this file on SPARC anyway (for some tests even on
+;; cheneygc), I won't bother to mark this particular test as failing.
+;; It would be nice if someone could go through this file and figure it
+;; all out... --DFL
(with-test (:name (:no-consing :hash-tables) :fails-on '(and :ppc :sb-thread))
(assert-no-consing (test-hash-table)))
projects / sbcl.git / commitdiff