Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/compiler/ppc alloc.lisp,1.2,1.2.6.1 array.lisp,1.4,1.4.6.1 call.lisp,1.3,1.3.6.1 macros.lisp,1.6,1.6.4.1 move.lisp,1.1,1.1.32.1
|
From: Patrik N. <kin...@us...> - 2003-09-24 20:04:38
|
Update of /cvsroot/sbcl/sbcl/src/compiler/ppc
In directory sc8-pr-cvs1:/tmp/cvs-serv9650/src/compiler/ppc
Modified Files:
Tag: ppc_gencgc_branch
alloc.lisp array.lisp call.lisp macros.lisp move.lisp
Log Message:
0.8.3.90.ppc_gencgc_branch.1:
* Replaced all allocation in vops/assembly with a single
allocation macro. Both nice for somewhat cleaning up code,
and making it far easier to change how allocation is done.
Index: alloc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/alloc.lisp,v
retrieving revision 1.2
retrieving revision 1.2.6.1
diff -u -d -r1.2 -r1.2.6.1
--- alloc.lisp 29 Jul 2003 13:01:56 -0000 1.2
+++ alloc.lisp 24 Sep 2003 20:03:12 -0000 1.2.6.1
@@ -35,9 +35,8 @@
temp)))))
(let* ((cons-cells (if star (1- num) num))
(alloc (* (pad-data-block cons-size) cons-cells)))
- (pseudo-atomic (pa-flag :extra alloc)
- (inst clrrwi res alloc-tn n-lowtag-bits)
- (inst ori res res list-pointer-lowtag)
+ (pseudo-atomic (pa-flag)
+ (allocation res alloc list-pointer-lowtag)
(move ptr res)
(dotimes (i (1- cons-cells))
(storew (maybe-load (tn-ref-tn things)) ptr
@@ -69,6 +68,7 @@
(unboxed-arg :scs (any-reg)))
(:results (result :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) ndescr)
+ (:temporary (:scs (non-descriptor-reg)) size)
(:temporary (:scs (any-reg) :from (:argument 0)) boxed)
(:temporary (:scs (non-descriptor-reg) :from (:argument 1)) unboxed)
(:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
@@ -82,9 +82,8 @@
;; 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.
- (inst ori result alloc-tn other-pointer-lowtag)
- (inst add alloc-tn alloc-tn boxed)
- (inst add alloc-tn alloc-tn unboxed)
+ (inst add size boxed unboxed)
+ (allocation result size other-pointer-lowtag)
(inst slwi ndescr boxed (- n-widetag-bits word-shift))
(inst ori ndescr ndescr code-header-widetag)
(storew ndescr result 0 other-pointer-lowtag)
@@ -115,9 +114,9 @@
(:results (result :scs (descriptor-reg)))
(:generator 10
(let ((size (+ length closure-info-offset)))
- (pseudo-atomic (pa-flag :extra (pad-data-block size))
- (inst clrrwi. result alloc-tn n-lowtag-bits)
- (inst ori result result fun-pointer-lowtag)
+ (pseudo-atomic (pa-flag)
+ (allocation result (pad-data-block size)
+ fun-pointer-lowtag)
(inst lr temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
(storew temp result 0 fun-pointer-lowtag)))
;(inst lis temp (ash 18 10))
@@ -154,12 +153,8 @@
(:temporary (:scs (non-descriptor-reg)) temp)
(:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
(:generator 4
- (pseudo-atomic (pa-flag :extra (pad-data-block words))
- (cond ((logbitp 2 lowtag)
- (inst ori result alloc-tn lowtag))
- (t
- (inst clrrwi result alloc-tn n-lowtag-bits)
- (inst ori result result lowtag)))
+ (pseudo-atomic (pa-flag)
+ (allocation result (pad-data-block words) lowtag)
(when type
(inst lr temp (logior (ash (1- words) n-widetag-bits) type))
(storew temp result 0 lowtag)))))
@@ -178,10 +173,5 @@
(inst addi header header (+ (ash -2 n-widetag-bits) type))
(inst clrrwi bytes bytes n-lowtag-bits)
(pseudo-atomic (pa-flag)
- (cond ((logbitp 2 lowtag)
- (inst ori result alloc-tn lowtag))
- (t
- (inst clrrwi result alloc-tn n-lowtag-bits)
- (inst ori result result lowtag)))
- (storew header result 0 lowtag)
- (inst add alloc-tn alloc-tn bytes))))
+ (allocation result bytes lowtag)
+ (storew header result 0 lowtag))))
Index: array.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/array.lisp,v
retrieving revision 1.4
retrieving revision 1.4.6.1
diff -u -d -r1.4 -r1.4.6.1
--- array.lisp 5 Aug 2003 14:11:40 -0000 1.4
+++ array.lisp 24 Sep 2003 20:03:12 -0000 1.4.6.1
@@ -26,15 +26,14 @@
(:results (result :scs (descriptor-reg)))
(:generator 0
(pseudo-atomic (pa-flag)
- (inst ori header alloc-tn other-pointer-lowtag)
- (inst addi ndescr rank (* (1+ array-dimensions-offset) sb!vm:n-word-bytes))
+ (inst addi ndescr rank (* (1+ array-dimensions-offset) n-word-bytes))
(inst clrrwi ndescr ndescr n-lowtag-bits)
- (inst add alloc-tn alloc-tn ndescr)
- (inst addi ndescr rank (fixnumize (1- sb!vm:array-dimensions-offset)))
- (inst slwi ndescr ndescr sb!vm:n-widetag-bits)
+ (allocation header ndescr other-pointer-lowtag)
+ (inst addi ndescr rank (fixnumize (1- array-dimensions-offset)))
+ (inst slwi ndescr ndescr n-widetag-bits)
(inst or ndescr ndescr type)
(inst srwi ndescr ndescr 2)
- (storew ndescr header 0 sb!vm:other-pointer-lowtag))
+ (storew ndescr header 0 other-pointer-lowtag))
(move result header)))
Index: call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/call.lisp,v
retrieving revision 1.3
retrieving revision 1.3.6.1
diff -u -d -r1.3 -r1.3.6.1
--- call.lisp 29 Jul 2003 13:01:56 -0000 1.3
+++ call.lisp 24 Sep 2003 20:03:12 -0000 1.3.6.1
@@ -1122,11 +1122,9 @@
(pseudo-atomic (pa-flag)
(assemble ()
;; Allocate a cons (2 words) for each item.
- (inst clrrwi result alloc-tn n-lowtag-bits)
- (inst ori result result list-pointer-lowtag)
- (move dst result)
(inst slwi temp count 1)
- (inst add alloc-tn alloc-tn temp)
+ (allocation result temp list-pointer-lowtag)
+ (move dst result)
(inst b enter)
;; Compute the next cons and store it in the current one.
Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/macros.lisp,v
retrieving revision 1.6
retrieving revision 1.6.4.1
diff -u -d -r1.6 -r1.6.4.1
--- macros.lisp 2 Sep 2003 00:08:15 -0000 1.6
+++ macros.lisp 24 Sep 2003 20:03:12 -0000 1.6.4.1
@@ -132,6 +132,45 @@
;;;; 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).
+;;
+;; If STACK-P is given, then allocation occurs on the control stack
+;; (for dynamic-extent). In this case, you MUST also specify NODE, so
+;; that the appropriate compiler policy can be used, and TEMP-TN,
+;; which is needed for work-space. TEMP-TN MUST be a non-descriptor
+;; reg.
+;;
+;; If generational GC is enabled, you MUST supply a value for TEMP-TN
+;; because 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).
+(defmacro allocation (result-tn size lowtag &key stack-p node temp-tn)
+ ;; We assume we're in a pseudo-atomic so the pseudo-atomic bit is
+ ;; set. If the lowtag also has a 1 bit in the same position, we're all
+ ;; set. Otherwise, we need to zap out the lowtag from alloc-tn, and
+ ;; then or in the lowtag.
+ ;; Normal allocation to the heap.
+ `(let ((size ,size))
+ (if (logbitp (1- n-lowtag-bits) ,lowtag)
+ (progn
+ (inst ori ,result-tn alloc-tn ,lowtag)
+ (if (numberp size)
+ (inst addi alloc-tn alloc-tn size)
+ (inst add alloc-tn alloc-tn size)))
+ (progn
+ (inst clrrwi ,result-tn alloc-tn n-lowtag-bits)
+ (inst ori ,result-tn ,result-tn ,lowtag)
+ (if (numberp size)
+ (inst addi alloc-tn alloc-tn size)
+ (inst add alloc-tn alloc-tn size))))))
+
(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size)
&body body)
"Do stuff to allocate an other-pointer object of fixed Size with a single
@@ -141,10 +180,11 @@
initializes the object."
(once-only ((result-tn result-tn) (temp-tn temp-tn) (flag-tn flag-tn)
(type-code type-code) (size size))
- `(pseudo-atomic (,flag-tn :extra (pad-data-block ,size))
- (inst ori ,result-tn alloc-tn other-pointer-lowtag)
- (inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
- (storew ,temp-tn ,result-tn 0 other-pointer-lowtag)
+ `(pseudo-atomic (,flag-tn)
+ (allocation ,result-tn (pad-data-block ,size) other-pointer-lowtag)
+ (when ,type-code
+ (inst lr ,temp-tn (logior (ash (1- ,size) n-widetag-bits) ,type-code))
+ (storew ,temp-tn ,result-tn 0 other-pointer-lowtag))
,@body)))
@@ -247,3 +287,5 @@
(declare (ignore objects)) ;should we eval these for side-effect?
`(without-gcing
,@body))
+
+
Index: move.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/move.lisp,v
retrieving revision 1.1
retrieving revision 1.1.32.1
diff -u -d -r1.1 -r1.1.32.1
--- move.lisp 18 Mar 2002 17:56:12 -0000 1.1
+++ move.lisp 24 Sep 2003 20:03:13 -0000 1.1.32.1
@@ -235,22 +235,19 @@
(move x arg)
(let ((done (gen-label))
(one-word (gen-label))
- (initial-alloc (pad-data-block (1+ bignum-digits-offset))))
+ ;; We always allocate 2 words even if we only need one it. (The
+ ;; copying GC will take care of freeing the unused extra word.)
+ (initial-alloc (+ bignum-digits-offset 2)))
(inst srawi. temp x 29)
(inst slwi y x 2)
(inst beq done)
- (pseudo-atomic (pa-flag :extra initial-alloc)
+ (with-fixed-allocation (y pa-flag temp bignum-widetag initial-alloc)
(inst cmpwi x 0)
- (inst ori y alloc-tn other-pointer-lowtag)
(inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
(inst bge one-word)
- (inst addi alloc-tn alloc-tn
- (- (pad-data-block (+ bignum-digits-offset 2))
- (pad-data-block (+ bignum-digits-offset 1))))
(inst li temp (logior (ash 2 n-widetag-bits) bignum-widetag))
(emit-label one-word)
- (storew temp y 0 other-pointer-lowtag)
(storew x y bignum-digits-offset other-pointer-lowtag))
(emit-label done))))
;;;
|