From a90bef303e5a5be7f21bdf990d3cad7c78e51c16 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Sun, 8 Aug 2004 11:15:12 +0000
Subject: [PATCH] Define allocation macro to handle allocation.  Use it. 
 (Incomplete, but everything should still work.)

---
 assembly/ppc/array.lisp  |  5 ++---
 compiler/ppc/alloc.lisp  | 14 +++++++-------
 compiler/ppc/array.lisp  |  6 +++---
 compiler/ppc/macros.lisp | 35 ++++++++++++++++++++++++++++++++++-
 4 files changed, 46 insertions(+), 14 deletions(-)

diff --git a/assembly/ppc/array.lisp b/assembly/ppc/array.lisp
index cd6dac467..0887e0494 100644
--- a/assembly/ppc/array.lisp
+++ b/assembly/ppc/array.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/ppc/array.lisp,v 1.2 2003/08/03 11:27:51 gerd Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/ppc/array.lisp,v 1.3 2004/08/08 11:15:11 rtoy Exp $
 ;;;
 ;;;    This file contains the support routines for arrays and vectors.
 ;;;
@@ -31,10 +31,9 @@
 			  (:temp pa-flag non-descriptor-reg nl3-offset)
 			  (:temp vector descriptor-reg a3-offset))
   (pseudo-atomic (pa-flag)
-    (inst ori vector alloc-tn vm:other-pointer-type)
     (inst addi ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes))
     (inst clrrwi ndescr ndescr lowtag-bits)
-    (inst add alloc-tn alloc-tn ndescr)
+    (allocation vector ndescr other-pointer-type)
     (inst srwi ndescr type vm:word-shift)
     (storew ndescr vector 0 vm:other-pointer-type)
     (storew length vector vm:vector-length-slot vm:other-pointer-type))
diff --git a/compiler/ppc/alloc.lisp b/compiler/ppc/alloc.lisp
index e773f04b7..5dddf30c2 100644
--- a/compiler/ppc/alloc.lisp
+++ b/compiler/ppc/alloc.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/alloc.lisp,v 1.5 2004/07/25 18:15:52 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/alloc.lisp,v 1.6 2004/08/08 11:15:11 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -43,6 +43,7 @@
   (:temporary (:scs (descriptor-reg) :type list :to (:result 0) :target result)
 	      res)
   (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
+  (:temporary (:scs (non-descriptor-reg)) alloc-temp)
   (:info num dynamic-extent)
   (:results (result :scs (descriptor-reg)))
   (:variant-vars star)
@@ -64,9 +65,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 lowtag-bits)
-		 (inst ori res res list-pointer-type)
+	       (pseudo-atomic (pa-flag)
+		 (allocation res alloc list-pointer-type :temp-tn alloc-temp)
 		 (move ptr res)
 		 (dotimes (i (1- cons-cells))
 		   (storew (maybe-load (tn-ref-tn things)) ptr
@@ -98,6 +98,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)
@@ -111,9 +112,8 @@
       ;; Note: we don't have to subtract off the 4 that was added by
       ;; pseudo-atomic, because oring in other-pointer-type just adds
       ;; it right back.
-      (inst ori result alloc-tn other-pointer-type)
-      (inst add alloc-tn alloc-tn boxed)
-      (inst add alloc-tn alloc-tn unboxed)
+      (inst add size boxed unboxed)
+      (allocation result size other-pointer-type :temp-tn ndescr)
       (inst slwi ndescr boxed (- type-bits word-shift))
       (inst ori ndescr ndescr code-header-type)
       (storew ndescr result 0 other-pointer-type)
diff --git a/compiler/ppc/array.lisp b/compiler/ppc/array.lisp
index 99b26f7e1..77b9e93af 100644
--- a/compiler/ppc/array.lisp
+++ b/compiler/ppc/array.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/array.lisp,v 1.4 2004/07/25 18:15:52 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/array.lisp,v 1.5 2004/08/08 11:15:12 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -29,13 +29,13 @@
   (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
   (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
   (:temporary (:scs (non-descriptor-reg)) ndescr)
+  (:temporary (:scs (non-descriptor-reg)) gc-temp)	; gencgc
   (:results (result :scs (descriptor-reg)))
   (:generator 0
     (pseudo-atomic (pa-flag)
-      (inst ori header alloc-tn other-pointer-type)
       (inst addi ndescr rank (* (1+ array-dimensions-offset) vm:word-bytes))
       (inst clrrwi ndescr ndescr lowtag-bits)
-      (inst add alloc-tn alloc-tn ndescr)
+      (allocation header ndescr other-pointer-type :temp-tn gc-temp)
       (inst addi ndescr rank (fixnumize (1- vm:array-dimensions-offset)))
       (inst slwi ndescr ndescr vm:type-bits)
       (inst or ndescr ndescr type)
diff --git a/compiler/ppc/macros.lisp b/compiler/ppc/macros.lisp
index 78db756e0..55a363a11 100644
--- a/compiler/ppc/macros.lisp
+++ b/compiler/ppc/macros.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/macros.lisp,v 1.2 2004/07/25 18:15:52 pmai Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/macros.lisp,v 1.3 2004/08/08 11:15:12 rtoy Exp $
 ;;;
 ;;; This file contains various useful macros for generating PC code.
 ;;;
@@ -165,6 +165,21 @@
 
 ;;;; Storage allocation:
 
+(defmacro allocation (result-tn size lowtag &key stack-p temp-tn)
+  (declare (ignore stack-p temp-tn))
+  (let ((alloc-size (gensym)))
+    `(let ((,alloc-size ,size))
+       (if (logbitp (1- lowtag-bits) ,lowtag)
+	   (progn
+	     (inst ori ,result-tn alloc-tn ,lowtag))
+	   (progn
+	     (inst clrrwi ,result-tn alloc-tn lowtag-bits)
+	     (inst ori ,result-tn ,result-tn ,lowtag)))
+       (if (numberp ,alloc-size)
+	   (inst addi alloc-tn alloc-tn ,alloc-size)
+	   (inst add alloc-tn alloc-tn ,alloc-size)))))
+  
+#+nil
 (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
@@ -180,6 +195,24 @@
        (storew ,temp-tn ,result-tn 0 other-pointer-type)
        ,@body)))
 
+(defmacro with-fixed-allocation ((result-tn flag-tn temp-tn type-code size
+					    &key (lowtag other-pointer-type))
+				 &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
+  Result-TN, and Temp-TN is a non-descriptor temp (which may be randomly used
+  by the body.)  The body is placed inside the PSEUDO-ATOMIC, and presumably
+  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)
+       (allocation ,result-tn (pad-data-block ,size) ,lowtag
+		   :temp-tn temp-tn)
+       (when ,type-code
+	 (inst lr ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code))
+	 (storew ,temp-tn ,result-tn 0 other-pointer-type))
+       ,@body)))
+
 
 ;;;; Type testing noise.
 
-- 
GitLab