From b9ec1808bb690fe4dc1f11c54692389d5aa222fa Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Sun, 24 Jan 1993 19:22:12 +0000
Subject: [PATCH] New structure hax.

---
 compiler/generic/new-genesis.lisp | 119 +++++++++++++++++++++++++++---
 1 file changed, 108 insertions(+), 11 deletions(-)

diff --git a/compiler/generic/new-genesis.lisp b/compiler/generic/new-genesis.lisp
index 2bcd73327..b6b285914 100644
--- a/compiler/generic/new-genesis.lisp
+++ b/compiler/generic/new-genesis.lisp
@@ -6,7 +6,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.3 1992/12/17 09:29:25 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.3.1.1 1993/01/24 19:22:12 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -176,7 +176,7 @@
 	    (high (descriptor-high des))
 	    (low (descriptor-low des)))
 	(when (or (eql lowtag vm:function-pointer-type)
-		  (eql lowtag vm:structure-pointer-type)
+		  (eql lowtag vm:instance-pointer-type)
 		  (eql lowtag vm:list-pointer-type)
 		  (eql lowtag vm:other-pointer-type))
 	  (dolist (space (list *dynamic* *static* *read-only*)
@@ -459,10 +459,19 @@
     (write-indexed dest 1 cdr)
     dest))
 
-(defmacro cold-push (thing list)
-  "Generates code to push the THING onto the given cold load LIST."
-  `(setq ,list (allocate-cons *dynamic* ,thing ,list)))
 
+;;; COLD-VECTOR  --  Internal
+;;;
+;;;    Make a simple-vector that holds the specified Objects and return its
+;;; decriptor.
+;;;
+(defun cold-vector (&rest objects)
+  (let* ((size (length objects))
+	 (result (allocate-vector-object *dynamic* vm:word-bits size
+					 vm:simple-vector-type)))
+    (dotimes (index size)
+      (write-indexed result (+ index vm:vector-data-offset) (pop objects)))
+    result))
 
 
 ;;;; Symbol magic.
@@ -627,6 +636,8 @@
 
     (frob *free-interrupt-context-index* (make-fixnum-descriptor 0))
 
+    (frob *initial-layouts* (list-all-layouts))
+
     (let ((res *nil-descriptor*))
       (dolist (cpkg *cold-packages*)
 	(let* ((pkg (car cpkg))
@@ -668,8 +679,6 @@
 
     (frob *lisp-initialization-functions* *current-init-functions-cons*)
 
-    
-
     ;; Nothing should be allocated after this.
     ;;
     (frob *read-only-space-free-pointer*
@@ -802,6 +811,85 @@
 	     *fdefn-objects*)
     result))
 
+
+;;;; Layouts & type system pre-initialization:
+;;;
+;;; Since we want to be able to dump structure constants and predicates with
+;;; reference layouts, we need to create layouts at cold-load time.  We use the
+;;; name to intern layouts by, and dump a list of all cold layouts in
+;;; *INITIAL-LAYOUTS* so that type-system initialization can find them.  The
+;;; only thing that's tricky is initializing layout's layout, which must point
+;;; to itself.
+
+;;; Table mapping from class names to descriptors for their layouts.
+;;;
+(defvar *cold-layouts* (make-hash-table :test #'equal))
+
+;;; The descriptor for layout's layout, which we need when making layouts.
+;;;
+(defvar *layout-layout*)
+
+(defparameter target-layout-length 15)
+
+(defun make-cold-layout (name length inherits depth)
+  (let ((result (allocate-boxed-object *dynamic* (1+ target-layout-length)
+				       vm:instance-pointer-type)))
+    (write-memory result (make-other-immediate-descriptor
+			  target-layout-length vm:instance-header-type))
+    (write-indexed result vm:instance-slots-offset *layout-layout*)
+    (let ((base (+ vm:instance-slots-offset
+		   kernel:layout-hash-length
+		   1)))
+      ;0 class uninitialized
+      (write-indexed result (+ base 1) *nil-descriptor*); invalid
+      (write-indexed result (+ base 2) inherits)
+      (write-indexed result (+ base 3) depth)
+      (write-indexed result (+ base 4) length)
+      (write-indexed result (+ base 5) *nil-descriptor*)); info
+    (setf (gethash name *cold-layouts*) result)
+    result))
+
+
+;;; INITIALIZE-LAYOUTS  --  Internal
+;;;
+;;;    Clear the layout table and set *layout-layout*.  We initially create
+;;; LAYOUT with NIL as the LAYOUT and INHERITS, then back-patch with itself and
+;;; the correct INHERITS vector (which includes T, INSTANCE and
+;;; STRUCTURE-OBJECT).
+;;;
+(defun initialize-layouts ()
+  (clrhash *cold-layouts*)
+  (setq *layout-layout* *nil-descriptor*)
+  (setq *layout-layout*
+	(make-cold-layout 'layout *nil-handle*
+			  (number-to-core target-layout-length)
+			  (number-to-core 3)))
+  (write-indexed *layout-layout* vm:instance-slots-offset *layout-layout*)
+  (let* ((t-layout
+	  (make-cold-layout 't (cold-vector)
+			    (number-to-core 0) (number-to-core 0)))
+	 (inst-layout
+	  (make-cold-layout 'instance (cold-vector t-layout)
+			    (number-to-core 0) (number-to-core 1)))
+	 (so-layout
+	  (make-cold-layout 'structure-object
+			    (cold-vector t-layout inst-layout)
+			    (number-to-core 1) (number-to-core 2))))
+    (write-indexed *layout-layout*
+		   (+ vm:instance-slots-offset layout-hash-length 1 2)
+		   (cold-vector t-layout inst-layout so-layout))))
+
+
+;;; LIST-ALL-LAYOUTS  --  Internal
+;;;
+;;;    Return a cold alist that we're going to store in INITIAL-LAYOUTS.
+;;;
+(defun list-all-layouts ()
+  (let ((result *nil-descriptor*))
+    (maphash #'(lambda (key value)
+		 (cold-push (cold-cons (cold-intern key) value) result))
+	     *cold-layouts*)
+    result))
 
 
 ;;;; Reading FASL files.
@@ -872,15 +960,23 @@
 		(fop-small-struct)
   (let* ((size (clone-arg))
 	 (result (allocate-boxed-object *dynamic* (1+ size)
-					vm:structure-pointer-type)))
+					vm:instance-pointer-type)))
     (write-memory result (make-other-immediate-descriptor
-			  size vm:structure-header-type))
+			  size vm:instance-header-type))
     (do ((index (1- size) (1- index)))
 	((minusp index))
       (declare (fixnum index))
-      (write-indexed result (+ index vm:structure-slots-offset) (pop-stack)))
+      (write-indexed result (+ index vm:instance-slots-offset) (pop-stack)))
     result))
 
+(define-cold-fop (fop-layout)
+  (let ((length (pop-stack))
+	(depth (pop-stack))
+	(inherits (pop-stack))
+	(name (pop-stack)))
+    (or (gethash name *cold-layouts*)
+	(make-cold-layout name length inherits depth))))
+
 
 ;;; Loading symbols...
 
@@ -1193,7 +1289,7 @@
     (write-indexed obj
 		   (+ idx
 		      (ecase (descriptor-lowtag obj)
-			(#.vm:structure-pointer-type 1)
+			(#.vm:instance-pointer-type 1)
 			(#.vm:other-pointer-type 2)))
 		   (pop-stack))))
 
@@ -1775,6 +1871,7 @@
 	  (let ((version (load-foreign-symbol-table symbol-table)))
 	    (initialize-spaces)
 	    (initialize-symbols)
+	    (initialize-layouts)
 	    (setf *current-init-functions-cons* *nil-descriptor*)
 	    (initialize-static-fns)
 	    (dolist (file (if (listp file-list)
-- 
GitLab