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.
akovalenko · Sep 24, 2003 · 4578e13 · 4578e13
1 parent 89823a0
commit 4578e13
Show file tree

Hide file tree

Showing 8 changed files with 75 additions and 51 deletions.
diff --git a/src/assembly/ppc/arith.lisp b/src/assembly/ppc/arith.lisp
@@ -152,18 +152,17 @@
   (inst bns GO-HOME)
 
   CONS-BIGNUM
-  ;; Allocate a BIGNUM for the result.
-  (pseudo-atomic (pa-flag :extra (pad-data-block (1+ bignum-digits-offset)))
+  ;; Allocate a BIGNUM for the result. Note that we always allocate
+  ;; two words, even if only one is needed. This is so we can use the
+  ;; standard allocation macros.
+  (with-fixed-allocation (res pa-flag temp bignum-widetag (pad-data-block (+ bignum-digits-offset 2)))
     (let ((one-word (gen-label)))
-      (inst ori res alloc-tn other-pointer-lowtag)
       ;; We start out assuming that we need one word.  Is that correct?
       (inst srawi temp lo 31)
       (inst xor. temp temp hi)
       (inst li temp (logior (ash 1 n-widetag-bits) bignum-widetag))
       (inst beq one-word)
       ;; Nope, we need two, so allocate the additional space.
-      (inst addi alloc-tn 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)

diff --git a/src/assembly/ppc/array.lisp b/src/assembly/ppc/array.lisp
@@ -27,10 +27,9 @@
 			  (:temp pa-flag non-descriptor-reg nl3-offset)
 			  (:temp vector descriptor-reg a3-offset))
   (pseudo-atomic (pa-flag)
-    (inst ori vector alloc-tn sb!vm:other-pointer-lowtag)
     (inst addi ndescr words (* (1+ sb!vm:vector-data-offset) sb!vm:n-word-bytes))
     (inst clrrwi ndescr ndescr n-lowtag-bits)
-    (inst add alloc-tn alloc-tn ndescr)
+    (allocation vector ndescr sb!vm:other-pointer-lowtag)
     (inst srwi ndescr type sb!vm:word-shift)
     (storew ndescr vector 0 sb!vm:other-pointer-lowtag)
     (storew length vector sb!vm:vector-length-slot sb!vm:other-pointer-lowtag))

diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp
@@ -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))))
diff --git a/src/compiler/ppc/array.lisp b/src/compiler/ppc/array.lisp
@@ -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)))
 
 

diff --git a/src/compiler/ppc/call.lisp b/src/compiler/ppc/call.lisp
@@ -1122,11 +1122,9 @@ default-value-8
     (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.

diff --git a/src/compiler/ppc/macros.lisp b/src/compiler/ppc/macros.lisp
@@ -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 @@ garbage collection.  This is currently implemented by disabling GC"
   (declare (ignore objects))		;should we eval these for side-effect?
   `(without-gcing
     ,@body))
+
+
diff --git a/src/compiler/ppc/move.lisp b/src/compiler/ppc/move.lisp
@@ -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))))
 ;;;

diff --git a/version.lisp-expr b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.3.90"
+"0.8.3.90.ppc_gencgc_branch.1"