From 65fbb5c536e243c7284d736e999c28546d05d6ae Mon Sep 17 00:00:00 2001
From: toy <toy>
Date: Fri, 10 May 2002 14:48:24 +0000
Subject: [PATCH] Abstract all allocation through the ALLOCATION macro.

---
 assembly/sparc/array.lisp  | 15 ++++++++++-----
 compiler/sparc/alloc.lisp  | 38 ++++++++++++++------------------------
 compiler/sparc/array.lisp  |  5 ++---
 compiler/sparc/call.lisp   |  9 ++++-----
 compiler/sparc/macros.lisp | 31 ++++++++++++++++++++++++++-----
 5 files changed, 56 insertions(+), 42 deletions(-)

diff --git a/assembly/sparc/array.lisp b/assembly/sparc/array.lisp
index 738dd0a5a..d4829a284 100644
--- a/assembly/sparc/array.lisp
+++ b/assembly/sparc/array.lisp
@@ -5,11 +5,11 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.5 1995/02/27 00:51:49 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.6 2002/05/10 14:48:23 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.5 1995/02/27 00:51:49 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/assembly/sparc/array.lisp,v 1.6 2002/05/10 14:48:23 toy Exp $
 ;;;
 ;;;    This file contains the support routines for arrays and vectors.
 ;;;
@@ -32,16 +32,21 @@
 			  (:temp ndescr non-descriptor-reg nl0-offset)
 			  (:temp vector descriptor-reg a3-offset))
   (pseudo-atomic ()
-    (inst or vector alloc-tn vm:other-pointer-type)
     (inst add ndescr words (* (1+ vm:vector-data-offset) vm:word-bytes))
     (inst andn ndescr 7)
-    (inst add alloc-tn ndescr)
+    (allocation vector ndescr other-pointer-type)
     (inst srl ndescr type vm:word-shift)
     (storew ndescr vector 0 vm:other-pointer-type)
     (storew length vector vm:vector-length-slot vm:other-pointer-type))
   ;; 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.
-  (storew zero-tn alloc-tn 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.
+  (storew zero-tn alloc-tn -1)
   (move result vector))
 
 
diff --git a/compiler/sparc/alloc.lisp b/compiler/sparc/alloc.lisp
index 53dade920..40dd14cf9 100644
--- a/compiler/sparc/alloc.lisp
+++ b/compiler/sparc/alloc.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/alloc.lisp,v 1.12 2001/05/18 16:22:53 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/alloc.lisp,v 1.13 2002/05/10 14:48:23 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -46,9 +46,8 @@
 			temp)))))
 	     (let* ((cons-cells (if star (1- num) num))
 		    (alloc (* (pad-data-block cons-size) cons-cells)))
-	       (pseudo-atomic (:extra alloc)
-		 (inst andn res alloc-tn lowtag-mask)
-		 (inst or res list-pointer-type)
+	       (pseudo-atomic ()
+		 (allocation res alloc list-pointer-type)
 		 (move ptr res)
 		 (dotimes (i (1- cons-cells))
 		   (storew (maybe-load (tn-ref-tn things)) ptr
@@ -80,6 +79,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)
   (:generator 100
@@ -92,9 +92,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 or result alloc-tn other-pointer-type)
-      (inst add alloc-tn boxed)
-      (inst add alloc-tn unboxed)
+      (inst add size boxed unboxed)
+      (allocation result size other-pointer-type)
       (inst sll ndescr boxed (- type-bits word-shift))
       (inst or ndescr code-header-type)
       (storew ndescr result 0 other-pointer-type)
@@ -123,9 +122,8 @@
   (:results (result :scs (descriptor-reg)))
   (:generator 10
     (let ((size (+ length closure-info-offset)))
-      (pseudo-atomic (:extra (pad-data-block size))
-	(inst andn result alloc-tn lowtag-mask)
-	(inst or result function-pointer-type)
+      (pseudo-atomic ()
+        (allocation result (pad-data-block size) function-pointer-type)
 	(inst li temp (logior (ash (1- size) type-bits) closure-header-type))
 	(storew temp result 0 function-pointer-type)))
     (storew function result closure-function-slot function-pointer-type)))
@@ -158,12 +156,8 @@
   (:results (result :scs (descriptor-reg)))
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:generator 4
-    (pseudo-atomic (:extra (pad-data-block words))
-      (cond ((logbitp (1- 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)
       (when type
 	(inst li temp (logior (ash (1- words) type-bits) type))
 	(storew temp result 0 lowtag)))))
@@ -175,6 +169,7 @@
   (:ignore name)
   (:results (result :scs (descriptor-reg)))
   (:temporary (:scs (any-reg)) bytes header)
+  (:temporary (:scs (descriptor-reg)) temp)
   (:generator 6
     (inst add bytes extra (* (1+ words) word-bytes))
     (inst sll header bytes (- type-bits 2))
@@ -182,11 +177,6 @@
     (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- 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))))
+      ;; are not compatible
+      (allocation result bytes lowtag)
+      (storew header result 0 lowtag))))
diff --git a/compiler/sparc/array.lisp b/compiler/sparc/array.lisp
index f682960ea..42e1953e9 100644
--- a/compiler/sparc/array.lisp
+++ b/compiler/sparc/array.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/array.lisp,v 1.22 2001/05/18 16:22:53 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/array.lisp,v 1.23 2002/05/10 14:48:24 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -31,10 +31,9 @@
   (:results (result :scs (descriptor-reg)))
   (:generator 0
     (pseudo-atomic ()
-      (inst or header alloc-tn other-pointer-type)
       (inst add ndescr rank (* (1+ array-dimensions-offset) vm:word-bytes))
       (inst andn ndescr 4)
-      (inst add alloc-tn ndescr)
+      (allocation header ndescr other-pointer-type)
       (inst add ndescr rank (fixnum (1- vm:array-dimensions-offset)))
       (inst sll ndescr ndescr vm:type-bits)
       (inst or ndescr ndescr type)
diff --git a/compiler/sparc/call.lisp b/compiler/sparc/call.lisp
index c876b6afc..70cf8b1ad 100644
--- a/compiler/sparc/call.lisp
+++ b/compiler/sparc/call.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/call.lisp,v 1.29 2001/09/25 21:28:04 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/call.lisp,v 1.30 2002/05/10 14:48:24 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1189,12 +1189,11 @@ default-value-8
     (pseudo-atomic ()
       (assemble ()
 	;; Allocate a cons (2 words) for each item.
-	(inst andn result alloc-tn lowtag-mask)
-	(inst or result list-pointer-type)
-	(move dst result)
 	(inst sll temp count 1)
+	(allocation result temp list-pointer-type)
 	(inst b enter)
-	(inst add alloc-tn temp)
+	(move dst result)
+
 
 	;; Compute the next cons and store it in the current one.
 	LOOP
diff --git a/compiler/sparc/macros.lisp b/compiler/sparc/macros.lisp
index 58c2eea51..b08fe960b 100644
--- a/compiler/sparc/macros.lisp
+++ b/compiler/sparc/macros.lisp
@@ -5,11 +5,11 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.15 2001/09/24 15:59:43 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.16 2002/05/10 14:48:24 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.15 2001/09/24 15:59:43 toy Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/sparc/macros.lisp,v 1.16 2002/05/10 14:48:24 toy Exp $
 ;;;
 ;;; This file contains various useful macros for generating SPARC code.
 ;;;
@@ -169,6 +169,28 @@
 
 ;;;; 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)
+  ;; 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.
+  `(if (logbitp (1- lowtag-bits) ,lowtag)
+     (progn
+       (inst or ,result-tn alloc-tn ,lowtag)
+       (inst add alloc-tn ,size))
+     (progn
+       (inst andn ,result-tn alloc-tn lowtag-mask)
+       (inst or ,result-tn ,lowtag)
+       (inst add alloc-tn ,size))))
+
+
 (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
@@ -178,8 +200,8 @@
   initializes the object."
   (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-type)
+    `(pseudo-atomic ()
+       (allocation ,result-tn (pad-data-block ,size) other-pointer-type)
        (inst li ,temp-tn (logior (ash (1- ,size) type-bits) ,type-code))
        (storew ,temp-tn ,result-tn 0 other-pointer-type)
        ,@body)))
@@ -466,7 +488,6 @@
        ,@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))
 	;; Check to see if pseudo-atomic interrupted flag is set (bit 0 = 1)
-- 
GitLab