From 9734fb4424ce00ae2a6d0b920b2443c9275883f0 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Fri, 15 Jan 1993 01:33:03 +0000
Subject: [PATCH] Added stuff for new var-alloc and fixed-alloc vops.

---
 compiler/hppa/alloc.lisp | 137 ++++++++++++++++++---------------------
 1 file changed, 64 insertions(+), 73 deletions(-)

diff --git a/compiler/hppa/alloc.lisp b/compiler/hppa/alloc.lisp
index 95b58f1b3..8657db296 100644
--- a/compiler/hppa/alloc.lisp
+++ b/compiler/hppa/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/hppa/alloc.lisp,v 1.1 1992/07/13 03:48:14 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/hppa/alloc.lisp,v 1.2 1993/01/15 01:33:03 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -120,78 +120,69 @@
       (storew null-tn result fdefn-function-slot other-pointer-type)
       (storew temp result fdefn-raw-addr-slot other-pointer-type))))
 
+(define-vop (make-closure)
+  (:args (function :to :save :scs (descriptor-reg)))
+  (:info length)
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 10
+    (let ((size (+ length closure-info-offset)))
+      (pseudo-atomic (:extra (pad-data-block size))
+	(inst move alloc-tn result)
+	(inst dep function-pointer-type 31 3 result)
+	(inst li (logior (ash (1- size) type-bits) closure-header-type) temp)
+	(storew temp result 0 function-pointer-type)))
+    (storew function result closure-function-slot function-pointer-type)))
+
+;;; The compiler likes to be able to directly make value cells.
+;;; 
+(define-vop (make-value-cell)
+  (:args (value :to :save :scs (descriptor-reg any-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:results (result :scs (descriptor-reg)))
+  (:generator 10
+    (with-fixed-allocation
+	(result temp value-cell-header-type value-cell-size))
+    (storew value result value-cell-value-slot other-pointer-type)))
+
+
 
 ;;;; Automatic allocators for primitive objects.
 
-(define-for-each-primitive-object (obj)
-  (collect ((forms))
-    (let* ((options (primitive-object-options obj))
-	   (alloc-trans (getf options :alloc-trans))
-	   (alloc-vop (getf options :alloc-vop alloc-trans))
-	   (header (primitive-object-header obj))
-	   (lowtag (primitive-object-lowtag obj))
-	   (size (primitive-object-size obj))
-	   (variable-length (primitive-object-variable-length obj))
-	   (need-unbound-marker nil))
-      (collect ((args) (init-forms))
-	(when (and alloc-vop variable-length)
-	  (args 'extra-words))
-	(dolist (slot (primitive-object-slots obj))
-	  (let* ((name (slot-name slot))
-		 (offset (slot-offset slot)))
-	    (ecase (getf (slot-options slot) :init :zero)
-	      (:zero)
-	      (:null
-	       (init-forms `(storew null-tn result ,offset ,lowtag)))
-	      (:unbound
-	       (setf need-unbound-marker t)
-	       (init-forms `(storew temp result ,offset ,lowtag)))
-	      (:arg
-	       (args name)
-	       (init-forms `(storew ,name result ,offset ,lowtag))))))
-	(when (and (null alloc-vop) (args))
-	  (error "Slots ~S want to be initialized, but there is no alloc vop ~
-	          defined for ~S."
-		 (args) (primitive-object-name obj)))
-	(when alloc-vop
-	  (forms
-	   `(define-vop (,alloc-vop)
-	      (:args ,@(mapcar #'(lambda (name)
-				   `(,name :scs (any-reg descriptor-reg)))
-			       (args)))
-	      ,@(when (or need-unbound-marker header variable-length)
-		  `((:temporary (:scs (non-descriptor-reg)) temp)))
-	      (:results (result :scs (descriptor-reg) :from :load))
-	      (:policy :fast-safe)
-	      ,@(when alloc-trans
-		  `((:translate ,alloc-trans)))
-	      (:generator 37
-		(pseudo-atomic (,@(unless variable-length
-				    `(:extra (pad-data-block ,size))))
-		  (move alloc-tn result)
-		  (inst dep ,lowtag 31 3 result)
-		  ,@(cond
-		     ((and header variable-length)
-		      `((inst addi (* (1+ ,size) word-bytes) extra-words temp)
-			(inst dep 0 31 3 temp)
-			(inst add temp alloc-tn alloc-tn)
-			(inst sll extra-words (- type-bits word-shift) temp)
-			(inst addi (+ (ash (1- ,size) type-bits) ,header)
-			      temp temp)
-			(storew temp result 0 ,lowtag)))
-		     (variable-length
-		      (error ":REST-P T with no header in ~S?"
-			     (primitive-object-name obj)))
-		     (header
-		      `((inst li ,(logior (ash (1- size) type-bits)
-					  (symbol-value header))
-			      temp)
-			(storew temp result 0 ,lowtag)))
-		     (t
-		      nil))
-		  ,@(when need-unbound-marker
-		      `((inst li unbound-marker-type temp)))
-		  ,@(init-forms))))))))
-    (when (forms)
-      `(progn
-	 ,@(forms)))))
+(define-vop (make-unbound-marker)
+  (:args)
+  (:results (result :scs (any-reg)))
+  (:generator 1
+    (inst li unbound-marker-type result)))
+
+(define-vop (fixed-alloc)
+  (:args)
+  (:info name words type lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:scs (non-descriptor-reg)) temp)
+  (:generator 4
+    (pseudo-atomic (:extra (pad-data-block words))
+      (inst move alloc-tn result)
+      (inst dep lowtag 31 3 result)
+      (when type
+	(inst li (logior (ash (1- words) type-bits) type) temp)
+	(storew temp result 0 lowtag)))))
+
+(define-vop (var-alloc)
+  (:args (extra :scs (any-reg)))
+  (:arg-types positive-fixnum)
+  (:info name words type lowtag)
+  (:ignore name)
+  (:results (result :scs (descriptor-reg)))
+  (:temporary (:scs (any-reg)) bytes header)
+  (:generator 6
+    (inst addi (* (1+ words) word-bytes) extra bytes)
+    (inst sll bytes (- type-bits 2) header)
+    (inst addi (+ (ash -2 type-bits) type) header header)
+    (inst dep 0 31 3 bytes)
+    (pseudo-atomic ()
+      (inst move alloc-tn result)
+      (inst dep lowtag 31 3 result)
+      (storew header result 0 lowtag)
+      (inst add alloc-tn bytes alloc-tn))))
-- 
GitLab