Permalink
Browse files

SPARC gencgc

Based on Raymond Toy's work.
  • Loading branch information...
lichtblau committed Sep 28, 2012
1 parent 3e77276 commit 1d06300e09f767a38bbe6d5b38232ca334ab1913
View
@@ -850,6 +850,7 @@ PRM Pierre Mai
PVE Peter Van Eynde
PW Paul Werkowski
RAM Robert MacLachlan
+RLT Raymond Toy
TCR Tobias Rittweiler
THS Thiemo Seufer
VJA Vincent Arkesteijn
View
@@ -622,7 +622,17 @@ elif [ "$sbcl_arch" = "sparc" ]; then
# 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
@@ -2588,6 +2588,7 @@ structure representations"
"%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"
@@ -2679,8 +2680,8 @@ structure representations"
"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"
@@ -171,31 +171,12 @@
(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)
@@ -23,17 +23,34 @@
(: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))
View
@@ -153,7 +153,7 @@
":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")
@@ -18,6 +18,7 @@
(: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)
@@ -41,14 +42,10 @@
(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
@@ -81,6 +78,7 @@
(: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)))
@@ -89,15 +87,16 @@
(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)
@@ -127,15 +126,10 @@
(: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)))))
@@ -173,12 +167,8 @@
(: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)))))
@@ -191,18 +181,12 @@
(: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))))
@@ -20,14 +20,14 @@
(: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)
@@ -23,5 +23,18 @@
(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*)
@@ -1136,8 +1136,7 @@ default-value-8
(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.
@@ -1147,15 +1146,13 @@ default-value-8
;; 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)
Oops, something went wrong.

0 comments on commit 1d06300

Please sign in to comment.