From 43ca0eb0f70108e2bcd01da617e64cd691672769 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Sat, 9 Jun 1990 13:54:31 +0000
Subject: [PATCH] Seperated the automatic primitive object generation stuff
 into the accessors (still in cell.lisp), the allocation stuff (in alloc.lisp)
 and the defknowns (in vm-fndb.lisp).  This was prompted by the the old loader
 barfing on the huge form generated when they were all in cell.lisp.

---
 compiler/generic/vm-fndb.lisp |  34 ++++++-
 compiler/mips/alloc.lisp      |  95 ++++++++++++++++++-
 compiler/mips/cell.lisp       | 170 ++++++++--------------------------
 3 files changed, 164 insertions(+), 135 deletions(-)

diff --git a/compiler/generic/vm-fndb.lisp b/compiler/generic/vm-fndb.lisp
index f25c2d116..d9462972a 100644
--- a/compiler/generic/vm-fndb.lisp
+++ b/compiler/generic/vm-fndb.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-fndb.lisp,v 1.12 1990/06/08 01:18:34 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-fndb.lisp,v 1.13 1990/06/09 13:54:31 wlott Exp $
 ;;;
 ;;; This file defines the machine specific function signatures.
 ;;;
@@ -184,3 +184,35 @@
 	   (simple-unboxed-array (*)) index index)
   null
   ())
+
+
+
+;;;; Automatic defknowns for primitive objects.
+
+(vm:define-for-each-primitive-object (obj)
+  (collect ((forms))
+    (let* ((options (vm:primitive-object-options obj))
+	   (obj-type (getf options :type t)))
+      (dolist (slot (vm:primitive-object-slots obj))
+	(let* ((name (vm:slot-name slot))
+	       (slot-opts (vm:slot-options slot))
+	       (slot-type (getf slot-opts :type t))
+	       (ref-trans (getf slot-opts :ref-trans))
+	       (ref-known (getf slot-opts :ref-known))
+	       (set-trans (getf slot-opts :set-trans))
+	       (set-known (getf slot-opts :set-known)))
+	  (when ref-known
+	    (if ref-trans
+		(forms `(defknown (,ref-trans) (,obj-type) ,slot-type
+			  ,ref-known))
+		(error "Can't spec a :ref-known with no :ref-trans. ~S in ~S"
+		       name (vm:primitive-object-name obj))))
+	  (when set-known
+	    (if set-trans
+		(forms `(defknown (,set-trans) (,obj-type ,slot-type)
+			  ,slot-type ,set-known))
+		(error "Can't spec a :set-known with no :set-trans. ~S in ~S"
+		       name (vm:primitive-object-name obj)))))))
+    (when (forms)
+      `(progn
+	 ,@(forms)))))
diff --git a/compiler/mips/alloc.lisp b/compiler/mips/alloc.lisp
index aed3aed9e..a99468040 100644
--- a/compiler/mips/alloc.lisp
+++ b/compiler/mips/alloc.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.7 1990/05/31 03:42:18 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/alloc.lisp,v 1.8 1990/06/09 13:54:24 wlott Exp $
 ;;;
 ;;; Allocation VOPs for the MIPS port.
 ;;;
@@ -16,6 +16,8 @@
 
 (in-package "C")
 
+
+;;;; LIST and LIST*
 
 (define-vop (list-or-list*)
   (:args (things :more t))
@@ -74,6 +76,8 @@
 (define-vop (list* list-or-list*)
   (:variant t))
 
+
+;;;; Special purpose inline allocators.
 
 (define-vop (allocate-code-object)
   (:args (boxed-arg :scs (any-reg))
@@ -99,3 +103,92 @@
       (storew unboxed result vm:code-code-size-slot vm:other-pointer-type)
       (storew null-tn result vm:code-entry-points-slot vm:other-pointer-type)
       (storew null-tn result vm:code-debug-info-slot vm:other-pointer-type))))
+
+
+;;;; Automatic allocators for primitive objects.
+
+(vm:define-for-each-primitive-object (obj)
+  (collect ((forms))
+    (let* ((options (vm:primitive-object-options obj))
+	   (obj-type (getf options :type t))
+	   (alloc-trans (getf options :alloc-trans))
+	   (alloc-vop (getf options :alloc-vop alloc-trans))
+	   (header (vm:primitive-object-header obj))
+	   (lowtag (vm:primitive-object-lowtag obj))
+	   (size (vm:primitive-object-size obj))
+	   (variable-length (vm:primitive-object-variable-length obj))
+	   (need-unbound-marker nil))
+      (collect ((args) (init-forms))
+	(when (and alloc-vop variable-length)
+	  (args 'extra-words))
+	(dolist (slot (vm:primitive-object-slots obj))
+	  (let* ((name (vm:slot-name slot))
+		 (offset (vm:slot-offset slot)))
+	    (ecase (getf (vm: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) (vm:primitive-object-name obj)))
+	(when alloc-vop
+	  (forms
+	   `(define-vop (,alloc-vop)
+	      (:args ,@(mapcar #'(lambda (name)
+				   `(,name :scs (any-reg descriptor-reg)))
+			       (args)))
+	      (:temporary (:scs (non-descriptor-reg) :type random)
+			  ndescr
+			  ,@(when (or need-unbound-marker header
+				      variable-length)
+			      '(temp)))
+	      (:temporary (:scs (descriptor-reg) :to (:result 0)
+				:target real-result) result)
+	      (:results (real-result :scs (descriptor-reg)))
+	      (:policy :fast-safe)
+	      ,@(when alloc-trans
+		  `((:translate ,alloc-trans)))
+	      (:generator 37
+		(pseudo-atomic (ndescr)
+		  (inst addu result alloc-tn ,lowtag)
+		  ,@(cond ((and header variable-length)
+			   `((inst addu temp extra-words
+				   (fixnum (1- ,size)))
+			     (inst addu alloc-tn alloc-tn temp)
+			     (inst sll temp temp
+				   (- vm:type-bits vm:word-shift))
+			     (inst or temp temp ,header)
+			     (storew temp result 0 ,lowtag)
+			     (inst addu alloc-tn alloc-tn
+				   (+ (fixnum 1) vm:lowtag-mask))
+			     (inst li temp (lognot vm:lowtag-mask))
+			     (inst and alloc-tn alloc-tn temp)))
+			  (variable-length
+			   (error ":REST-P T with no header in ~S?"
+				  (vm:primitive-object-name obj)))
+			  (header
+			   `((inst addu alloc-tn alloc-tn
+				   (vm:pad-data-block ,size))
+			     (inst li temp
+				   ,(logior (ash (1- size) vm:type-bits)
+					    (if (integerp header)
+						header
+						0)))
+			     (storew temp result 0 ,lowtag)))
+			  (t
+			   `((inst addu alloc-tn alloc-tn
+				   (vm:pad-data-block ,size)))))
+		  ,@(when need-unbound-marker
+		      `((inst li temp vm:unbound-marker-type)))
+		  ,@(init-forms)
+		  (move real-result result))))))))
+    (when (forms)
+      `(progn
+	 ,@(forms)))))
diff --git a/compiler/mips/cell.lisp b/compiler/mips/cell.lisp
index 4152f7696..1ae2026af 100644
--- a/compiler/mips/cell.lisp
+++ b/compiler/mips/cell.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.35 1990/06/04 05:23:32 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/cell.lisp,v 1.36 1990/06/09 13:52:14 wlott Exp $
 ;;;
 ;;;    This file contains the VM definition of various primitive memory access
 ;;; VOPs for the MIPS.
@@ -22,142 +22,50 @@
 
 ;;;; Data object definition macros.
 
-
 (vm:define-for-each-primitive-object (obj)
   (collect ((forms))
     (let* ((options (vm:primitive-object-options obj))
-	   (obj-type (getf options :type t))
-	   (alloc-trans (getf options :alloc-trans))
-	   (alloc-vop (getf options :alloc-vop alloc-trans))
-	   (header (vm:primitive-object-header obj))
-	   (lowtag (vm:primitive-object-lowtag obj))
-	   (size (vm:primitive-object-size obj))
-	   (variable-length (vm:primitive-object-variable-length obj))
-	   (need-unbound-marker nil))
-      (collect ((args) (init-forms))
-	(when (and alloc-vop variable-length)
-	  (args 'extra-words))
-	(dolist (slot (vm:primitive-object-slots obj))
-	  (let* ((name (vm:slot-name slot))
-		 (offset (vm:slot-offset slot))
-		 (rest-p (vm:slot-rest-p slot))
-		 (slot-opts (vm:slot-options slot))
-		 (slot-type (getf slot-opts :type t))
-		 (ref-trans (getf slot-opts :ref-trans))
-		 (ref-vop (getf slot-opts :ref-vop ref-trans))
-		 (ref-known (getf slot-opts :ref-known))
-		 (set-trans (getf slot-opts :set-trans))
-		 (setf-vop (getf slot-opts :setf-vop
-				 (when (and (listp set-trans)
-					    (= (length set-trans) 2)
-					    (eq (car set-trans) 'setf))
-				   (intern (concatenate
-					    'simple-string
-					    "SET-"
-					    (string (cadr set-trans)))))))
-		 (set-vop (getf slot-opts :set-vop
-				(if setf-vop nil set-trans)))
-		 (set-known (getf slot-opts :set-known)))
-	    (when ref-known
-	      (if ref-trans
-		  (forms `(defknown (,ref-trans) (,obj-type) ,slot-type
-			    ,ref-known))
-		  (error "Can't spec a :ref-known with no :ref-trans. ~S in ~S"
-			 name (vm:primitive-object-name obj))))
-	    (when ref-vop
-	      (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref))
-			(:variant ,offset ,lowtag)
-			,@(when ref-trans
-			    `((:translate ,ref-trans))))))
-	    (when set-known
-	      (if set-trans
-		  (forms `(defknown (,set-trans) (,obj-type ,slot-type)
-			    ,slot-type ,set-known))
-		  (error "Can't spec a :set-known with no :set-trans. ~S in ~S"
-			 name (vm:primitive-object-name obj))))
-	    (when (or set-vop setf-vop)
-	      (forms `(define-vop ,(cond ((and rest-p setf-vop)
-		  (error "Can't automatically generate a setf VOP for :rest-p ~
-		          slots: ~S in ~S"
-			 name
-			 (vm:primitive-object-name obj)))
-					 (rest-p `(,set-vop slot-set))
-					 (set-vop `(,set-vop cell-set))
-					 (t `(,setf-vop cell-setf)))
-			(:variant ,offset ,lowtag)
-			,@(when set-trans
-			    `((:translate ,set-trans))))))
-	    (ecase (getf (vm: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 (vm:slot-name slot))
-	       (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) (vm:primitive-object-name obj)))
-	(when alloc-vop
-	  (forms
-	   `(define-vop (,alloc-vop)
-	      (:args ,@(mapcar #'(lambda (name)
-				   `(,name :scs (any-reg descriptor-reg)))
-			       (args)))
-	      (:temporary (:scs (non-descriptor-reg) :type random)
-			  ndescr
-			  ,@(when (or need-unbound-marker header
-				      variable-length)
-			      '(temp)))
-	      (:temporary (:scs (descriptor-reg) :to (:result 0)
-				:target real-result) result)
-	      (:results (real-result :scs (descriptor-reg)))
-	      (:policy :fast-safe)
-	      ,@(when alloc-trans
-		  `((:translate ,alloc-trans)))
-	      (:generator 37
-		(pseudo-atomic (ndescr)
-		  (inst addu result alloc-tn ,lowtag)
-		  ,@(cond ((and header variable-length)
-			   `((inst addu temp extra-words
-				   (fixnum (1- ,size)))
-			     (inst addu alloc-tn alloc-tn temp)
-			     (inst sll temp temp
-				   (- vm:type-bits vm:word-shift))
-			     (inst or temp temp ,header)
-			     (storew temp result 0 ,lowtag)
-			     (inst addu alloc-tn alloc-tn
-				   (+ (fixnum 1) vm:lowtag-mask))
-			     (inst li temp (lognot vm:lowtag-mask))
-			     (inst and alloc-tn alloc-tn temp)))
-			  (variable-length
-			   (error ":REST-P T with no header in ~S?"
-				  (vm:primitive-object-name obj)))
-			  (header
-			   `((inst addu alloc-tn alloc-tn
-				   (vm:pad-data-block ,size))
-			     (inst li temp
-				   ,(logior (ash (1- size) vm:type-bits)
-					    (if (integerp header)
-						header
-						0)))
-			     (storew temp result 0 ,lowtag)))
-			  (t
-			   `((inst addu alloc-tn alloc-tn
-				   (vm:pad-data-block ,size)))))
-		  ,@(when need-unbound-marker
-		      `((inst li temp vm:unbound-marker-type)))
-		  ,@(init-forms)
-		  (move real-result result))))))))
+	   (lowtag (vm:primitive-object-lowtag obj)))
+      (dolist (slot (vm:primitive-object-slots obj))
+	(let* ((name (vm:slot-name slot))
+	       (offset (vm:slot-offset slot))
+	       (rest-p (vm:slot-rest-p slot))
+	       (slot-opts (vm:slot-options slot))
+	       (ref-trans (getf slot-opts :ref-trans))
+	       (ref-vop (getf slot-opts :ref-vop ref-trans))
+	       (set-trans (getf slot-opts :set-trans))
+	       (setf-vop (getf slot-opts :setf-vop
+			       (when (and (listp set-trans)
+					  (= (length set-trans) 2)
+					  (eq (car set-trans) 'setf))
+				 (intern (concatenate
+					  'simple-string
+					  "SET-"
+					  (string (cadr set-trans)))))))
+	       (set-vop (getf slot-opts :set-vop
+			      (if setf-vop nil set-trans))))
+	  (when ref-vop
+	    (forms `(define-vop (,ref-vop ,(if rest-p 'slot-ref 'cell-ref))
+				(:variant ,offset ,lowtag)
+		      ,@(when ref-trans
+			  `((:translate ,ref-trans))))))
+	  (when (or set-vop setf-vop)
+	    (forms `(define-vop ,(cond ((and rest-p setf-vop)
+					(error "Can't automatically generate a setf VOP for :rest-p ~
+					slots: ~S in ~S"
+					       name
+					       (vm:primitive-object-name obj)))
+				       (rest-p `(,set-vop slot-set))
+				       (set-vop `(,set-vop cell-set))
+				       (t `(,setf-vop cell-setf)))
+				(:variant ,offset ,lowtag)
+		      ,@(when set-trans
+			  `((:translate ,set-trans)))))))))
     (when (forms)
       `(progn
 	 ,@(forms)))))
 
 
-
 
 ;;;; Symbol hacking VOPs:
 
@@ -229,10 +137,6 @@
     (loadw value object vm:symbol-function-slot vm:other-pointer-type)
     (test-simple-type value temp target not-p vm:function-pointer-type)))
 
-#+nil
-(def-source-transform makunbound (x)
-  `(set ,x (%primitive make-immediate-type 0 system:%trap-type)))
-
 
 (define-vop (fast-symbol-value cell-ref)
   (:variant vm:symbol-value-slot vm:other-pointer-type)
-- 
GitLab