From 5f6bcb37bc0facee4a9819369c116a1a5c0e1a52 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Fri, 26 Feb 1993 08:42:59 +0000
Subject: [PATCH] new structure branch & tuning, see new_struct

---
 compiler/dump.lisp                |  32 ++++-
 compiler/fndb.lisp                |  16 ++-
 compiler/generic/interr.lisp      |  10 +-
 compiler/generic/new-genesis.lisp | 135 ++++++++++++++++++--
 compiler/generic/objdef.lisp      |  16 +--
 compiler/generic/primtype.lisp    |  35 +++---
 compiler/generic/vm-fndb.lisp     |  27 ++--
 compiler/generic/vm-tran.lisp     |  13 +-
 compiler/generic/vm-type.lisp     |  16 +--
 compiler/globaldb.lisp            |  72 ++++++-----
 compiler/ir1tran.lisp             | 121 ++++++++++++------
 compiler/ir2tran.lisp             |   8 +-
 compiler/knownfun.lisp            |   5 +-
 compiler/main.lisp                |   5 +-
 compiler/meta-vmdef.lisp          |   8 +-
 compiler/node.lisp                |  15 ++-
 compiler/proclaim.lisp            | 196 ++----------------------------
 compiler/typetran.lisp            |  94 ++++++++------
 compiler/vop.lisp                 |   5 +-
 19 files changed, 445 insertions(+), 384 deletions(-)

diff --git a/compiler/dump.lisp b/compiler/dump.lisp
index 354937ea5..2281a5ef6 100644
--- a/compiler/dump.lisp
+++ b/compiler/dump.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/dump.lisp,v 1.47 1993/01/13 18:09:43 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.48 1993/02/26 08:38:17 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -835,7 +835,10 @@
 	      (unless (equal-check-table x file)
 		(dump-list x file)
 		(equal-save-object x file)))
-	     (structure
+	     (layout
+	      (dump-layout x file)
+	      (eq-save-object x file))
+	     (instance
 	      (dump-structure x file)
 	      (eq-save-object x file))
 	     (array
@@ -923,7 +926,7 @@
 ;;; overhead on types of objects that might be circular.
 ;;;
 (defun dump-object (x file)
-  (if (or (array-header-p x) (simple-vector-p x) (consp x) (structurep x))
+  (if (or (array-header-p x) (simple-vector-p x) (consp x) (%instancep x))
       (let ((*circularities-detected* ())
 	    (circ (fasl-file-circularity-table file)))
 	(clrhash circ)
@@ -1421,11 +1424,16 @@
 	     struct)))
   (note-potential-circularity struct file)
   (do ((index 0 (1+ index))
-       (length (structure-length struct))
+       (length (%instance-length struct))
        (circ (fasl-file-circularity-table file)))
       ((= index length)
        (dump-fop* length lisp::fop-small-struct lisp::fop-struct file))
-    (let* ((obj (structure-ref struct index))
+    (let* ((obj #+ns-boot
+		(if (zerop index)
+		    (%instance-layout struct)
+		    (%instance-ref struct index))
+		#-ns-boot
+		(%instance-ref struct index))
 	   (ref (gethash obj circ)))
       (cond (ref
 	     (push (make-circularity :type :struct-set
@@ -1438,3 +1446,17 @@
 	    (t
 	     (sub-dump-object obj file))))))
 
+(defun dump-layout (obj file)
+  (unless (member (layout-invalid obj) '(nil :compiler))
+    (compiler-error "Dumping reference to obsolete class: ~S"
+		    (layout-class obj)))
+  (let ((name (class-name (layout-class obj))))
+    (assert name)
+    (dump-fop 'lisp::fop-normal-load file)
+    (let ((*cold-load-dump* t))
+      (dump-object name file))
+    (dump-fop 'lisp::fop-maybe-cold-load file))
+  (sub-dump-object (layout-inherits obj) file)
+  (sub-dump-object (layout-inheritance-depth obj) file)
+  (sub-dump-object (layout-length obj) file)
+  (dump-fop 'lisp::fop-layout file))
diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp
index 8c2960a33..95411451f 100644
--- a/compiler/fndb.lisp
+++ b/compiler/fndb.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/fndb.lisp,v 1.53 1993/01/17 20:37:22 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.54 1993/02/26 08:38:24 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -93,6 +93,18 @@
 (defknown (eq eql) (t t) boolean (movable foldable flushable))
 (defknown (equal equalp) (t t) boolean (foldable flushable recursive))
 
+
+;;;; Classes:
+
+(deftype name-for-class () 't)
+(defknown class-name (class) name-for-class (flushable))
+(defknown find-class (name-for-class &optional t lexical-environment)
+  (or class null) ())
+(defknown class-of (t) class (flushable))
+(defknown layout-of (t) layout (flushable))
+(defknown copy-structure (structure-object) structure-object
+  (flushable unsafe))
+
 
 ;;;; In the "Control Structure" chapter:
 
@@ -1150,7 +1162,7 @@
 ;;; into non-standard unary predicates.
 
 (defknown (fixnump bignump ratiop short-float-p single-float-p double-float-p
-	   long-float-p base-char-p %standard-char-p structurep
+	   long-float-p base-char-p %standard-char-p %instancep
 	   array-header-p)
   (t) boolean (movable foldable flushable))
 
diff --git a/compiler/generic/interr.lisp b/compiler/generic/interr.lisp
index 03407dada..8d4dec4d1 100644
--- a/compiler/generic/interr.lisp
+++ b/compiler/generic/interr.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/generic/interr.lisp,v 1.2 1992/03/22 17:30:26 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/interr.lisp,v 1.3 1993/02/26 08:42:49 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -147,9 +147,11 @@
    "Object is not of type COMPLEX.")
   (object-not-weak-pointer
    "Object is not a WEAK-POINTER.")
-  (object-not-structure
-   "Object is not a STRUCTURE.")
+  (object-not-instance
+   "Object is not a INSTANCE.")
   (object-not-base-char
    "Object is not of type BASE-CHAR.")
   (nil-function-returned
-   "Function with declared result type NIL returned."))
+   "Function with declared result type NIL returned.")
+  (layout-invalid
+   "Layout is invalid (instance obsolete.)"))
diff --git a/compiler/generic/new-genesis.lisp b/compiler/generic/new-genesis.lisp
index 2bcd73327..9666ca9a7 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.4 1993/02/26 08:42:50 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*)
@@ -463,6 +463,18 @@
   "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 +639,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 +682,6 @@
 
     (frob *lisp-initialization-functions* *current-init-functions-cons*)
 
-    
-
     ;; Nothing should be allocated after this.
     ;;
     (frob *read-only-space-free-pointer*
@@ -802,6 +814,86 @@
 	     *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 16)
+
+(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
+      (write-indexed result (+ base 6) *nil-descriptor*)); pure
+    (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 (number-to-core target-layout-length)
+			  *nil-descriptor* (number-to-core 3)))
+  (write-indexed *layout-layout* vm:instance-slots-offset *layout-layout*)
+  (let* ((t-layout
+	  (make-cold-layout 't (number-to-core 0)
+			    (cold-vector) (number-to-core 0)))
+	 (inst-layout
+	  (make-cold-layout 'instance (number-to-core 0)
+			    (cold-vector t-layout) (number-to-core 1)))
+	 (so-layout
+	  (make-cold-layout 'structure-object (number-to-core 1)
+			    (cold-vector t-layout inst-layout)
+			    (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 (allocate-cons *dynamic* (cold-intern key) value)
+			    result))
+	     *cold-layouts*)
+    result))
 
 
 ;;;; Reading FASL files.
@@ -872,15 +964,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 +1293,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 +1875,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)
@@ -1838,17 +1939,29 @@
 			   (push (cons name (descriptor-bits addr))
 				 funs)))))
 	       *fdefn-objects*)
-      (format t "~2%Initially defined functions:~2%")
+      (format t "~%~|~%Initially defined functions:~2%")
       (dolist (info (sort funs #'< :key #'cdr))
 	(format t "#x~8,'0X: ~S~%" (cdr info) (car info)))
-      (format t "~2%Undefined function references:~2%")
+      (format t "~%~|~%Undefined function references:~2%")
       (labels ((key (name)
 		 (etypecase name
 		   (symbol (symbol-name name))
 		   (integer (prin1-to-string name))
 		   (list (key (second name))))))
 	(dolist (fun (sort undefs #'string< :key #'key))
-	  (format t "~S~%" fun)))))
+	  (format t "~S~%" fun)))
+
+      (format t "~%~|~%Layout names:~2%")
+      (collect ((stuff))
+	(maphash #'(lambda (name desc)
+		     (stuff (cons (logior (ash (descriptor-high desc)
+					       descriptor-low-bits)
+					  (descriptor-low desc))
+				  name)))
+		 *cold-layouts*)
+	(dolist (x (sort (stuff) #'< :key #'car))
+	  (format t "~8,'0X: ~S~%" (car x) (cdr x))))))
+	      
   (undefined-value))
 
 
diff --git a/compiler/generic/objdef.lisp b/compiler/generic/objdef.lisp
index 10f2632e2..cfeed72c4 100644
--- a/compiler/generic/objdef.lisp
+++ b/compiler/generic/objdef.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/generic/objdef.lisp,v 1.23 1992/12/16 21:36:27 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/objdef.lisp,v 1.24 1993/02/26 08:42:54 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -21,7 +21,7 @@
 (export '(lowtag-bits lowtag-mask lowtag-limit type-bits type-mask
 	  target-most-positive-fixnum target-most-negative-fixnum
 	  even-fixnum-type function-pointer-type other-immediate-0-type
-	  list-pointer-type odd-fixnum-type structure-pointer-type
+	  list-pointer-type odd-fixnum-type instance-pointer-type
 	  other-immediate-1-type other-pointer-type bignum-type ratio-type
 	  single-float-type double-float-type complex-type
 	  simple-array-type simple-string-type simple-bit-vector-type
@@ -38,7 +38,7 @@
 	  dylan-function-header-type
 	  value-cell-header-type symbol-header-type base-char-type
 	  sap-type unbound-marker-type weak-pointer-type
-	  structure-header-type funcallable-instance-header-type
+	  instance-header-type funcallable-instance-header-type
 	  fdefn-type vector-normal-subtype
 	  vector-valid-hashing-subtype vector-must-rehash-subtype
 	  forwarding-pointer-type scavenger-hook-type))
@@ -93,7 +93,7 @@
   other-immediate-0
   list-pointer
   odd-fixnum
-  structure-pointer
+  instance-pointer
   other-immediate-1
   other-pointer)
 
@@ -141,7 +141,7 @@
   sap
   unbound-marker
   weak-pointer
-  structure-header
+  instance-header
   fdefn
   #+gengc scavenger-hook
   )
@@ -163,9 +163,9 @@
   (car :ref-trans car :set-trans c::%rplaca :init :arg)
   (cdr :ref-trans cdr :set-trans c::%rplacd :init :arg))
 
-(define-primitive-object (structure :lowtag structure-pointer-type
-				    :header structure-header-type
-				    :alloc-trans make-structure)
+(define-primitive-object (instance :lowtag instance-pointer-type
+				    :header instance-header-type
+				    :alloc-trans %make-instance)
   (slots :rest-p t))
 
 (define-primitive-object (bignum :lowtag other-pointer-type
diff --git a/compiler/generic/primtype.lisp b/compiler/generic/primtype.lisp
index 0ae82c9da..3f82a8527 100644
--- a/compiler/generic/primtype.lisp
+++ b/compiler/generic/primtype.lisp
@@ -1,4 +1,4 @@
-;;; -*- Package: C; Log: C.Log -*-
+;;; -*- Package: VM -*-
 ;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the CMU Common Lisp project at
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/primtype.lisp,v 1.8 1992/12/05 22:11:35 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/primtype.lisp,v 1.9 1993/02/26 08:42:55 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/primtype.lisp,v 1.8 1992/12/05 22:11:35 wlott Exp $
-;;;
 ;;; This file contains the machine independent aspects of the object
 ;;; representation and primitive types.
 ;;;
@@ -60,7 +58,7 @@
 ;;; 
 (def-primitive-type function (descriptor-reg))
 (def-primitive-type list (descriptor-reg))
-(def-primitive-type structure (descriptor-reg))
+(def-primitive-type instance (descriptor-reg))
 
 ;;; Primitive other-pointer number types.
 ;;; 
@@ -241,27 +239,26 @@
 	   (unless (eq (primitive-type-of mem) res)
 	     (return (values *any-primitive-type* nil))))))
       (named-type
-       (case (named-type-name type)
-	 ((t bignum ratio complex function structure
-	     system-area-pointer weak-pointer)
-	  (values (primitive-type-or-lose (named-type-name type) *backend*) t))
-	 ((character base-char string-char)
+       (ecase (named-type-name type)
+	 ((t *) (values *any-primitive-type* t))
+	 ((nil) (values *any-primitive-type* nil))))
+      (built-in-class
+       (case (class-name type)
+	 ((complex function generic-function instance
+		   system-area-pointer weak-pointer)
+	  (values (primitive-type-or-lose (class-name type) *backend*) t))
+	 (base-char
 	  (exactly base-char))
-	 (standard-char
-	  (part-of base-char))
 	 (cons
 	  (part-of list))
-	 ((dylan::dylan-function dylan::generic-function dylan::exit-function
-	   dylan::next-method-func dylan::method dylan::defined-method
-	   dylan::builtin-method dylan::slot-accessor-method
-	   dylan::slot-setter-method dylan::slot-getter-method)
-	  (part-of function))
 	 (t
 	  (any))))
       (function-type
        (exactly function))
-      (structure-type
-       (part-of structure))
+      (class
+       (if (csubtypep type (specifier-type 'function))
+	   (part-of function)
+	   (part-of instance)))
       (ctype
        (any)))))
 
diff --git a/compiler/generic/vm-fndb.lisp b/compiler/generic/vm-fndb.lisp
index 27567617e..50836a43f 100644
--- a/compiler/generic/vm-fndb.lisp
+++ b/compiler/generic/vm-fndb.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/generic/vm-fndb.lisp,v 1.47 1992/12/17 09:30:26 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-fndb.lisp,v 1.48 1993/02/26 08:42:56 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -47,7 +47,7 @@
 ;;; into non-standard unary predicates.
 
 (defknown (fixnump bignump ratiop short-float-p single-float-p double-float-p
-	   long-float-p base-char-p %string-char-p %standard-char-p structurep
+	   long-float-p base-char-p %string-char-p %standard-char-p %instancep
 	   array-header-p simple-array-p simple-array-unsigned-byte-2-p
 	   simple-array-unsigned-byte-4-p simple-array-unsigned-byte-8-p
 	   simple-array-unsigned-byte-16-p simple-array-unsigned-byte-32-p
@@ -89,18 +89,29 @@
   (unsafe))
 
 
-(defknown make-structure (structure-index) structure
+(defknown %make-instance (index) instance
   (unsafe))
-(defknown structure-type (structure) t
+(defknown %instance-layout (instance) layout
   (foldable flushable))
-(defknown structure-length (structure) structure-index
+(defknown %set-instance-layout (instance layout) layout
+  (unsafe))
+(defknown %instance-length (instance) index
   (foldable flushable))
-(defknown structure-ref (structure structure-index) t
+(defknown %instance-ref (instance index) t
   (flushable))
-(defknown structure-set (structure structure-index t) t
+(defknown %instance-set (instance index t) t
   (unsafe))
+(defknown %layout-invalid-error (t layout) nil)
 
-
+(deftype raw-vector () '(simple-array (unsigned-byte 32) (*)))
+(defknown %raw-ref-single (raw-vector index) single-float
+  (foldable flushable))
+(defknown %raw-ref-double (raw-vector index) double-float
+  (foldable flushable))
+(defknown %raw-set-single (raw-vector index single-float) single-float
+  (unsafe))
+(defknown %raw-set-double (raw-vector index double-float) double-float
+  (unsafe))
 
 (defknown %raw-bits (t fixnum) (unsigned-byte 32)
   (foldable flushable))
diff --git a/compiler/generic/vm-tran.lisp b/compiler/generic/vm-tran.lisp
index 48edf76b2..facbf5320 100644
--- a/compiler/generic/vm-tran.lisp
+++ b/compiler/generic/vm-tran.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/generic/vm-tran.lisp,v 1.28 1993/01/15 22:42:16 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.29 1993/02/26 08:42:57 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -33,6 +33,14 @@
 (deftransform abs ((x) (rational))
   '(if (< x 0) (- x) x))
 
+;;; For now, the layout is stored in slot 0.
+;;;
+(def-source-transform %instance-layout (x)
+  `(truly-the layout (%instance-ref ,x 0)))
+;;;
+(def-source-transform %set-instance-layout (x val)
+  `(%instance-set ,x 0 (the layout ,val)))
+
 
 ;;;; Charater support.
 
@@ -41,7 +49,6 @@
 (def-source-transform characterp (obj)
   `(base-char-p ,obj))
 
-
 
 ;;;; Transforms for data-vector-ref for strange array types.
 
@@ -112,8 +119,6 @@
   (frob (simple-array (unsigned-byte 2) (*)) 2)
   (frob (simple-array (unsigned-byte 4) (*)) 4))
 
-
-
 
 ;;;; Simple string transforms:
 
diff --git a/compiler/generic/vm-type.lisp b/compiler/generic/vm-type.lisp
index 57a2c815a..e386961f9 100644
--- a/compiler/generic/vm-type.lisp
+++ b/compiler/generic/vm-type.lisp
@@ -7,12 +7,10 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-type.lisp,v 1.28 1991/12/16 10:09:55 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-type.lisp,v 1.29 1993/02/26 08:42:59 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-type.lisp,v 1.28 1991/12/16 10:09:55 wlott Exp $
-;;;
 ;;;    This file contains implementation-dependent parts of the type support
 ;;; code.  This is stuff which deals with the mapping from types defined in
 ;;; Common Lisp to types actually supported by an implementation.
@@ -36,15 +34,6 @@
 (deftype short-float (&optional low high)
   `(single-float ,low ,high))
 
-;;; Compiled-function is the same as function in this implementation.
-;;;
-(deftype compiled-function () 'function)
-
-;;; Character is the same as base-char.
-(setf (info type builtin 'character) nil)
-(setf (info type kind 'character) :defined)
-(deftype character () 'base-char)
-
 ;;;
 ;;; An index into an integer.
 (deftype bit-index () `(integer 0 ,most-positive-fixnum))
@@ -86,8 +75,11 @@
 (deftype bignum-type () 'bignum)
 (deftype bignum-index () 'index)
 
+#+ns-boot
 (deftype structure-index () `(unsigned-byte ,(- vm:word-bits vm:type-bits)))
 
+(deftype instance-index () `(unsigned-byte ,(- vm:word-bits vm:type-bits)))
+
 
 ;;;; Hooks into type system:
 
diff --git a/compiler/globaldb.lisp b/compiler/globaldb.lisp
index afa8ff092..32cd981e7 100644
--- a/compiler/globaldb.lisp
+++ b/compiler/globaldb.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/globaldb.lisp,v 1.26 1992/12/17 11:31:24 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/globaldb.lisp,v 1.27 1993/02/26 08:38:31 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -526,6 +526,7 @@
 ;;;
 (defstruct (compact-info-env
 	    (:include info-env)
+	    (:pure t)
 	    (:print-function %print-info-environment))
   ;;
   ;; If this value is EQ to the name we want to look up, then the cache hit
@@ -1038,9 +1039,12 @@
 ;;; function.
 (define-info-type function ir1-transform (or function null))
 
-;;; If a function is a defstruct slot accessor or setter, then this is the
-;;; defstruct-definition for the structure that it belongs to.
-(define-info-type function accessor-for (or defstruct-description null)
+;;; If a function is a slot accessor or setter, then this is the class that it
+;;; accesses slots of.
+;;;
+(define-info-type function accessor-for
+  #+ns-boot (or c::defstruct-description class null)
+  #-ns-boot (or class null)
   nil)
 
 ;;; If a function is "known" to the compiler, then this is FUNCTION-INFO
@@ -1091,47 +1095,55 @@
 
 (define-info-class type)
 
-;;; The kind of type described.  We return :Structure for standard types that
+;;; The kind of type described.  We return :Instance for standard types that
 ;;; are implemented as structures.
 ;;;
-(define-info-type type kind (member :primitive :defined :structure nil)
-  (if (or (info type builtin name)
-	  (info type translator name))
-      :primitive
-      nil))
+(define-info-type type kind (member :primitive :defined :instance
+				    #+ns-boot :structure
+				    nil)
+  nil)
 
 ;;; Expander function for a defined type.
 (define-info-type type expander (or function null) nil)
 
-;;; Print function for a type.
-(define-info-type type printer (or function symbol null) nil)
-
-;;; Make-load-form function for a type.
-(define-info-type type load-form-maker (or function symbol null) nil)
-
-;;; Defstruct description information for a structure type.  DEFINED is the
-;;; current global definition, and is not shadowed by compilation of
-;;; structure definitions.
-;;;
-(define-info-type type structure-info (or defstruct-description null) nil)
-(define-info-type type defined-structure-info (or defstruct-description null)
-  nil)
-
-;;; True if this type has been frozen with the FREEZE-TYPE declaration.  Only
-;;; interesting for structure types.
-;;;
-(define-info-type type frozen boolean nil)
-
 (define-info-type type documentation (or string null))
 
 ;;; Function that parses type specifiers into CTYPE structures.
 ;;;
 (define-info-type type translator (or function null) nil)
 
-;;; If true, then the type coresponding to this name.
+;;; If true, then the type coresponding to this name.  Note that if this is a
+;;; built-in class with a translation, then this is the translation, not the
+;;; class object.  This info type keeps track of random atomic types (NIL etc.)
+;;; and also serves as a cache to ensure that common standard types (atomic and
+;;; otherwise) are only consed once.
 ;;;
 (define-info-type type builtin (or ctype null) nil)
 
+;;; If this type is a class name, then this is the corresponding class.  Note
+;;; that for built-in classes, the kind may be :PRIMITIVE and not :INSTANCE.
+;;;
+(define-info-type type class (or class null) nil)
+
+;;; Layout for this type being used by the compiler.
+;;;
+(define-info-type type compiler-layout (or layout null)
+  (let ((class (info type class name)))
+    (when class (class-layout class))))
+
+#+ns-boot
+(define-info-type type printer (or function symbol null) nil)
+#+ns-boot
+(define-info-type type load-form-maker (or function symbol null) nil)
+
+#+ns-boot
+(define-info-type type structure-info (or defstruct-description null) nil)
+#+ns-boot
+(define-info-type type defined-structure-info (or defstruct-description null)
+  nil)
+
+(define-info-class typed-structure)
+(define-info-type typed-structure info t nil)
 
 (define-info-class declaration)
 (define-info-type declaration recognized boolean)
diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp
index 374a37f15..8347a2fbc 100644
--- a/compiler/ir1tran.lisp
+++ b/compiler/ir1tran.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/ir1tran.lisp,v 1.83 1992/12/10 16:48:17 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.84 1993/02/26 08:38:35 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -141,12 +141,33 @@
 		     :where-from where)))
 
 
-;;; Find-Slot-Accessor  --  Internal
+;;; Find-Structure-Slot-Accessor  --  Internal
 ;;;
 ;;;    Return a Slot-Accessor structure usable for referencing the slot
-;;; accessor Name.  Info is the structure definition.
-;;;
-(defun find-slot-accessor (info name)
+;;; accessor Name.  Class is the structure class.
+;;;
+(defun find-structure-slot-accessor (class name)
+  (declare (type class class))
+  (let* ((info (layout-info
+		(or (info type compiler-layout (class-name class))
+		    (class-layout class))))
+	 (accessor (if (listp name) (cadr name) name))
+	 (slot (find accessor (kernel:dd-slots info)
+		     :key #'kernel:dsd-accessor))
+	 (type (kernel:dd-name info))
+	 (slot-type (kernel:dsd-type slot)))
+    (assert slot () "Can't find slot ~S." type)
+    (make-slot-accessor
+     :name name
+     :type (specifier-type
+	    (if (listp name)
+		`(function (,slot-type ,type) ,slot-type)
+		`(function (,type) ,slot-type)))
+     :for class
+     :slot slot)))
+
+#+ns-boot
+(defun find-old-slot-accessor (info name)
   (declare (type defstruct-description info))
   (let* ((accessor (if (listp name) (cadr name) name))
 	 (slot (find accessor (dd-slots info)
@@ -188,14 +209,28 @@
 	       (inlinep (info function inlinep name)))
 	   (setf (gethash name *free-functions*)
 		 (if (or expansion inlinep)
-		     (make-defined-function :name name
-					    :inline-expansion expansion
-					    :inlinep inlinep
-					    :type (info function type name))
+		     (make-defined-function
+		      :name name
+		      :inline-expansion expansion
+		      :inlinep inlinep
+		      :where-from (info function where-from name)
+		      :type (info function type name))
 		     (let ((info (info function accessor-for name)))
-		       (if info
-			   (find-slot-accessor info name)
-			   (find-free-really-function name))))))))))
+		       (etypecase info
+			 (null
+			  (find-free-really-function name))
+			 (structure-class
+			  #+ns-boot
+			  (if (layout-info (info type compiler-layout
+						 (class-name info)))
+			      (find-structure-slot-accessor info name)
+			      (find-free-really-function name))
+			  #-ns-boot
+			  (find-structure-slot-accessor info name))
+			 #+ns-boot
+			 (defstruct-description
+			  (find-old-slot-accessor info name)))))))))))
+
 
 ;;; Find-Lexically-Apparent-Function  --  Internal
 ;;;
@@ -302,10 +337,10 @@
 		 ((array t)
 		  (dotimes (i (array-total-size value))
 		    (grovel (row-major-aref value i))))
-		 (structure
+		 (instance
 		  (when (emit-make-load-form value)
-		    (dotimes (i (structure-length value))
-		      (grovel (structure-ref value i)))))
+		    (dotimes (i (%instance-length value))
+		      (grovel (%instance-ref value i)))))
 		 (t
 		  (compiler-error
 		   "Cannot dump objects of type ~S into fasl files."
@@ -1254,7 +1289,7 @@
 			  (supplied-var (varify-lambda-arg supplied-p (names-so-far))))
 		     (setf (arg-info-supplied-p info) supplied-var)
 		     (names-so-far supplied-p)
-		     (when (> (length spec) 3)
+		     (when (> (length (the list spec)) 3)
 		       (compiler-error "Arg specifier is too long: ~S." spec)))))))
 	
 	(dolist (name required)
@@ -1303,7 +1338,7 @@
 	      (parse-default spec info)))
 	   (t
 	    (let ((head (first spec)))
-	      (unless (= (length head) 2)
+	      (unless (= (length (the list head)) 2)
 		(error "Malformed keyword arg specifier: ~S." spec))
 	      (let* ((name (second head))
 		     (var (varify-lambda-arg name (names-so-far)))
@@ -1352,7 +1387,8 @@
       (ir1-convert-progn-body start cont body)
       (let ((fun-cont (make-continuation))
 	    (fun (ir1-convert-lambda-body body (list (first aux-vars))
-					  (rest aux-vars) (rest aux-vals))))
+					  (rest aux-vars) (rest aux-vals)
+					  interface)))
 	(reference-leaf start fun-cont fun)
 	(let ((*lexical-environment*
 	       (if interface
@@ -1376,12 +1412,13 @@
 ;;; being the innermost one.  We force Cont to start a block outside of this
 ;;; cleanup, causing cleanup code to be emitted when the scope is exited.
 ;;;
-(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals svars)
+(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals
+					   interface svars)
   (declare (type continuation start cont)
 	   (list body aux-vars aux-vals svars))
   (cond
    ((null svars)
-    (ir1-convert-aux-bindings start cont body aux-vars aux-vals t))
+    (ir1-convert-aux-bindings start cont body aux-vars aux-vals interface))
    (t
     (continuation-starts-block cont)
     (let ((cleanup (make-cleanup :kind :special-bind))
@@ -1394,7 +1431,8 @@
       (let ((*lexical-environment* (make-lexenv :cleanup cleanup)))
 	(ir1-convert next-cont nnext-cont '(%cleanup-point))
 	(ir1-convert-special-bindings nnext-cont cont body aux-vars aux-vals
-				      (rest svars)))))))
+				      interface (rest svars))))))
+  (undefined-value))
 
 
 ;;; IR1-Convert-Lambda-Body  --  Internal
@@ -1415,9 +1453,11 @@
 ;;;
 ;;; Aux-Vars is a list of Var structures for variables that are to be
 ;;; sequentially bound.  Each Aux-Val is a form that is to be evaluated to get
-;;; the initial value for the corresponding Aux-Var.
+;;; the initial value for the corresponding Aux-Var.  Interface is a flag as T
+;;; when there are real aux values (see let* and ir1-convert-aux-bindings.)
 ;;;
-(defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals result)
+(defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals
+				     interface result)
   (declare (list body vars aux-vars aux-vals)
 	   (type (or continuation null) result))
   (let* ((bind (make-bind))
@@ -1448,7 +1488,7 @@
 	  (prev-link bind cont1)
 	  (use-continuation bind cont2)
 	  (ir1-convert-special-bindings cont2 result body aux-vars aux-vals
-					(svars)))
+					interface (svars)))
 
 	(let ((block (continuation-block result)))
 	  (when block
@@ -1747,6 +1787,7 @@
     (let* ((main-entry (ir1-convert-lambda-body body (main-vars)
 						(append (bind-vars) aux-vars)
 						(append (bind-vals) aux-vals)
+						t
 						cont))
 	   (last-entry (convert-optional-entry main-entry default-vars
 					       (main-vals) ())))
@@ -1811,7 +1852,7 @@
 			       nil vars supplied-p-p body aux-vars
 			       aux-vals cont)
 	     (let ((fun (ir1-convert-lambda-body body (reverse default-vars)
-						 aux-vars aux-vals cont)))
+						 aux-vars aux-vals t cont)))
 	       (setf (optional-dispatch-main-entry res) fun)
 	       (push (if supplied-p-p
 			 (convert-optional-entry fun entry-vars entry-vals ())
@@ -1909,7 +1950,8 @@
       (let* ((context-decls
 	      (and parent-form
 		   (loop for fun in *context-declarations*
-		         append (funcall fun name parent-form))))
+		         append (funcall (the function fun)
+					 name parent-form))))
 	     (cont (make-continuation))
 	     (*lexical-environment*
 	      (process-declarations (append context-decls decls)
@@ -1920,7 +1962,7 @@
 						allow-other-keys
 						aux-vars aux-vals cont)
 		      (ir1-convert-lambda-body body vars aux-vars aux-vals
-					       cont))))
+					       t cont))))
 	(setf (functional-inline-expansion res) form)
 	(setf (functional-arg-documentation res) (cadr form))
 	(setf (leaf-name res) name)
@@ -2586,7 +2628,7 @@
 				      form)))))
 	  
 	  (unless ignore
-	    (funcall #'%proclaim form))
+	    (%proclaim form))
 	  (if ignore
 	      (ir1-convert start cont nil)
 	      (ir1-convert start cont `(%proclaim ,what)))))
@@ -2596,20 +2638,23 @@
 ;;; %Compiler-Defstruct IR1 Convert  --  Internal
 ;;;
 ;;;    This is a frob that DEFMACRO expands into to establish the compiler
-;;; semantics.  %%COMPILER-DEFSTRUCT does most of the work, we just clear all
-;;; of the functions out of *FREE-FUNCTIONS* to keep things in synch.
+;;; semantics.  The other code in the expansion and %%COMPILER-DEFSTRUCT do
+;;; most of the work, we just clear all of the functions out of
+;;; *FREE-FUNCTIONS* to keep things in synch.  %%COMPILER-DEFSTRUCT is also
+;;; called at load-time.
 ;;;
-(def-ir1-translator %compiler-defstruct ((info) start cont :kind :function)
+(def-ir1-translator kernel:%compiler-defstruct
+		    ((info) start cont :kind :function)
   (let* ((info (eval info)))
-    (funcall #'%%compiler-defstruct info)
-    (dolist (slot (dd-slots info))
-      (let ((fun (dsd-accessor slot)))
+    (kernel:%%compiler-defstruct info)
+    (dolist (slot (kernel:dd-slots info))
+      (let ((fun (kernel:dsd-accessor slot)))
 	(remhash fun *free-functions*)
-	(unless (dsd-read-only slot)
+	(unless (kernel:dsd-read-only slot)
 	  (remhash `(setf ,fun) *free-functions*))))
-    (remhash (dd-predicate info) *free-functions*)
-    (remhash (dd-copier info) *free-functions*)
-    (ir1-convert start cont `(%%compiler-defstruct ',info))))
+    (remhash (kernel:dd-predicate info) *free-functions*)
+    (remhash (kernel:dd-copier info) *free-functions*)
+    (ir1-convert start cont `(kernel:%%compiler-defstruct ',info))))
 
 
 ;;;; Let and Let*:
diff --git a/compiler/ir2tran.lisp b/compiler/ir2tran.lisp
index 0b6526c2d..d19d42480 100644
--- a/compiler/ir2tran.lisp
+++ b/compiler/ir2tran.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/ir2tran.lisp,v 1.45 1992/12/13 15:12:24 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir2tran.lisp,v 1.46 1993/02/26 08:38:47 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -21,7 +21,7 @@
 (export '(%caller-frame-and-pc))
 (in-package "C")
 
-(export '(safe-fdefn-function return-single))
+(export '(safe-fdefn-function return-single instance-ref instance-set))
 
 
 
@@ -1600,7 +1600,7 @@
 	 (res (continuation-result-tns cont
 				       (list (backend-any-primitive-type
 					      *backend*)))))
-    (vop structure-ref node block
+    (vop instance-ref node block
 	 (continuation-tn node block str)
 	 (dsd-index
 	  (slot-accessor-slot
@@ -1612,7 +1612,7 @@
 
 (defoptimizer (%slot-setter ir2-convert) ((value str) node block)
   (let ((val (continuation-tn node block value)))
-    (vop structure-set node block
+    (vop instance-set node block
 	 (continuation-tn node block str)
 	 val
 	 (dsd-index
diff --git a/compiler/knownfun.lisp b/compiler/knownfun.lisp
index 4538838df..a3f4efa1b 100644
--- a/compiler/knownfun.lisp
+++ b/compiler/knownfun.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/knownfun.lisp,v 1.17 1992/12/13 07:32:00 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/knownfun.lisp,v 1.18 1993/02/26 08:38:56 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -82,7 +82,8 @@
   explicit-check)
 
 (defstruct (function-info
-	    (:print-function %print-function-info))
+	    (:print-function %print-function-info)
+	    (:pure t))
   ;;
   ;; Boolean attributes of this function.
   (attributes (required-argument) :type attributes)
diff --git a/compiler/main.lisp b/compiler/main.lisp
index 17e42f076..fa573a424 100644
--- a/compiler/main.lisp
+++ b/compiler/main.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/main.lisp,v 1.78 1992/11/25 10:32:29 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.79 1993/02/26 08:38:58 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1024,6 +1024,9 @@
 	     (process-cold-load-form form path t))
 	    ((error cerror break signal)
 	     (process-cold-load-form form path nil))
+	    (kernel:%compiler-defstruct
+	     (convert-and-maybe-compile form path)
+	     (compile-top-level-lambdas () t))
 	    ((eval-when)
 	     (unless (>= (length form) 2)
 	       (compiler-error "EVAL-WHEN form is too short: ~S." form))
diff --git a/compiler/meta-vmdef.lisp b/compiler/meta-vmdef.lisp
index c5b075eac..90fe7de24 100644
--- a/compiler/meta-vmdef.lisp
+++ b/compiler/meta-vmdef.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/meta-vmdef.lisp,v 1.2 1992/09/05 02:34:47 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/meta-vmdef.lisp,v 1.3 1993/02/26 08:39:04 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -422,7 +422,8 @@
 ;;;
 (defstruct (vop-parse
 	    (:print-function %print-vop-parse)
-	    (:make-load-form-fun :just-dump-it-normally))
+	    (:make-load-form-fun :just-dump-it-normally)
+	    (:pure t))
   ;;
   ;; The name of this VOP.
   (name nil :type symbol)
@@ -528,7 +529,8 @@
 ;;;
 (defstruct (operand-parse
 	    (:print-function %print-operand-parse)
-	    (:make-load-form-fun :just-dump-it-normally))
+	    (:make-load-form-fun :just-dump-it-normally)
+	    (:pure t))
   ;;
   ;; Name of the operand (which we bind to the TN).
   (name nil :type symbol)
diff --git a/compiler/node.lisp b/compiler/node.lisp
index 07f9ec935..1459fabb6 100644
--- a/compiler/node.lisp
+++ b/compiler/node.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/node.lisp,v 1.26 1992/09/22 00:02:26 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/node.lisp,v 1.27 1993/02/26 08:39:09 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -36,8 +36,9 @@
 				     lambda cleanup cookie
 				     interface-cookie options)))
   ;;
-  ;; Alist (name . what), where What is either a Functional (a local function)
-  ;; or a list (MACRO . <function>) (a local macro, with the specifier
+  ;; Alist (name . what), where What is either a Functional (a local function),
+  ;; a DEFINED-FUNCTION, representing an INLINE/NOTINLINE declaration, or
+  ;; a list (MACRO . <function>) (a local macro, with the specifier
   ;; expander.)    Note that Name may be a (SETF <name>) function.
   (functions nil :type list)
   ;;
@@ -699,7 +700,7 @@
   kind)
 
 
-;;; The Slot-Accessor structure represents defstruct slot accessors.  It is a
+;;; The Slot-Accessor structure represents slot accessor functions.  It is a
 ;;; subtype of Global-Var to make it look more like a normal function.
 ;;;
 (defstruct (slot-accessor (:include global-var
@@ -708,10 +709,12 @@
 			  (:print-function %print-slot-accessor))
   ;;
   ;; The description of the structure that this is an accessor for.
-  (for (required-argument) :type defstruct-description)
+  (for (required-argument)
+       :type #+ns-boot (or class defstruct-description)
+       #-ns-boot class)
   ;;
   ;; The slot description of the slot.
-  (slot (required-argument) :type defstruct-slot-description))
+  (slot (required-argument)))
 
 (defprinter slot-accessor
   name
diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp
index fcf49db28..2f6497d3f 100644
--- a/compiler/proclaim.lisp
+++ b/compiler/proclaim.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/proclaim.lisp,v 1.26 1992/09/15 16:10:16 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.27 1993/02/26 08:39:13 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -21,6 +21,9 @@
 
 (in-package "EXTENSIONS")
 (export '(inhibit-warnings freeze-type optimize-interface constant-function))
+(in-package "KERNEL")
+(export '(note-name-defined define-function-name undefine-function-name
+			    *type-system-initialized* %note-type-defined))
 (in-package "LISP")
 (export '(declaim proclaim))
 (in-package "C")
@@ -219,8 +222,8 @@
        (when for
 	 (compiler-warning
 	  "Undefining structure type:~%  ~S~@
-	  so that this slot accessor can be redefined:~%  ~S"
-	  (dd-name for) name)
+	   so that this slot accessor can be redefined:~%  ~S"
+	  (class-name for) name)
 	 (undefine-structure for)
 	 (setf (info function kind name) :function))))
     (:macro
@@ -344,8 +347,8 @@
       (freeze-type
        (dolist (type args)
 	 (specifier-type type); Give undefined type warnings...
-	 (when (eq (info type kind type) :structure)
-	   (freeze-structure-type type))))
+	 (when (eq (info type kind type) :instance)
+	   (setf (class-state (find-class type)) :sealed))))
       (function
        ;;
        ;; Handle old-style FUNCTION declaration, which is a shorthand for
@@ -390,189 +393,6 @@
 ;;;
 (setf (symbol-function 'proclaim) #'%proclaim)
 
-
-;;; UNDEFINE-STRUCTURE  --  Interface
-;;;
-;;;    Blow away all the compiler info for the structure described by Info.
-;;; This recursively descends the inheritance hierarchy.
-;;; 
-(defun undefine-structure (info)
-  (declare (type defstruct-description info))
-  (let* ((name (dd-name info))
-	 (all-types (cons name (dd-included-by info))))
-    ;;
-    ;; Iterate over this type and all subtypes, clearing the compiler structure
-    ;; type info, and undefining all the associated functions.
-    (dolist (type all-types)
-      (let ((this-info (info type structure-info type)))
-	(setf (info type kind type) nil)
-	(setf (info type structure-info type) nil)
-	(setf (info type frozen type) nil)
-	(undefine-function-name (dd-copier this-info))
-	(undefine-function-name (dd-predicate this-info))
-	(dolist (slot (dd-slots this-info))
-	  (let ((fun (dsd-accessor slot)))
-	    (undefine-function-name fun)
-	    (unless (dsd-read-only slot)
-	      (undefine-function-name `(setf ,fun)))))))
-    ;;
-    ;; Iterate over all types that include this type, removing this type and
-    ;; all subtypes from the list of subtypes of the included type.  We copy
-    ;; the DD and included list so that we don't clobber the type in the
-    ;; compiler's Lisp.
-    (dolist (include (dd-includes info))
-      (let ((new (copy-defstruct-description
-		  (info type structure-info include))))
-	(setf (dd-included-by new)
-	      (set-difference (dd-included-by new) all-types))
-	(setf (info type structure-info include) new))))
-  ;;
-  ;; Clear out the SPECIFIER-TYPE cache so that subsequent references are
-  ;; unknown types.
-  (values-specifier-type-cache-clear)
-  (undefined-value))
-
-
-;;; DEFINE-DEFSTRUCT-NAME  --  Internal
-;;;
-;;;    Like DEFINE-FUNCTION-NAME, but we also set the kind to :DECLARED and
-;;; blow away any ASSUMED-TYPE.  Also, if the thing is a slot accessor
-;;; currently, quietly unaccessorize it.  And if there are any undefined
-;;; warnings, we nuke them.
-;;;
-(defun define-defstruct-name (name)
-  (when name
-    (when (info function accessor-for name)
-      (setf (info function accessor-for name) nil))
-    (define-function-name name)
-    (note-name-defined name :function)
-    (setf (info function where-from name) :declared)
-    (when (info function assumed-type name)
-      (setf (info function assumed-type name) nil)))
-  (undefined-value))
-
-
-;;; FREEZE-STRUCTURE-TYPE  --  Internal
-;;;
-;;;    Freeze the named structure type and all its inferiors.
-;;;
-(defun freeze-structure-type (name)
-  (let ((def (info type structure-info name)))
-    (when def
-      (setf (info type frozen name) t)
-      (dolist (incl (dd-included-by def))
-	(setf (info type frozen incl) t))))
-  (undefined-value))
-
-
-;;; CHECK-FOR-STRUCTURE-REDEFINITION  --  Internal
-;;;
-;;;    Called when we process a DEFSTRUCT for a type that is already defined
-;;; for a structure.  We check for incompatible redefinition and undefine the
-;;; old structure if so.  We ignore the structures that DEFSTRUCT is built out
-;;; of, since they have to be hackishly defined in type-boot.  If the structure
-;;; is not incompatibly redefined, then we copy the old INCLUDED-BY into the
-;;; new structure.
-;;;
-(defun check-for-structure-redefinition (info)
-  (declare (type defstruct-description info))
-  (let* ((name (dd-name info))
-	 (old (info type structure-info name)))
-    (cond ((member name
-		   '(defstruct-description defstruct-slot-description)))
-	  ((and (equal (dd-includes old) (dd-includes info))
-		(equalp (dd-slots old) (dd-slots info)))
-	   (setf (dd-included-by info) (dd-included-by old)))
-	  (t
-	   (compiler-warning
-	    "Incompatibly redefining structure ~S.~@
-	    Removing the old definition~:[.~;~:* and these subtypes:~%  ~S~]"
-	    name (dd-included-by old))
-	   (undefine-structure old))))
-  (undefined-value))
-
-
-;;; ADD-NEW-SUBTYPE  --  Internal
-;;;
-;;;    Add a new subtype NAME to the structure type INC.  INFO is INC's current
-;;; info.
-;;;
-(defun add-new-subtype (name inc info)
-  (let ((new (copy-defstruct-description info)))
-    (setf (info type structure-info inc) new)
-    (push name (dd-included-by new))
-    (when (info type frozen inc)
-      (compiler-warning "Adding new subtype ~S to frozen type ~S.~@
-      			 Unfreezing this type and its inferiors.~@
-			 Previously compiled type tests must be recompiled."
-			name inc)
-      (setf (info type frozen inc) nil)
-      (dolist (subtype (dd-included-by info))
-	(setf (info type frozen subtype) nil)))))
-
-
-;;; %%Compiler-Defstruct  --  Interface
-;;;
-;;;    This function updates the global compiler information to represent the
-;;; definition of the the structure described by Info.  In addition to defining
-;;; all the functions and slots, we also update the INCLUDED-BY info in the
-;;; compiler's environment.  Note that at the first time the DEFSTRUCT is
-;;; loaded, STRUCTURE-INFO is EQ to DEFINED-STRUCTURE-INFO, so the name will
-;;; already be in INCLUDED-BY.  When we do update this info, we copy the
-;;; defstruct description so that the type definition in the compiler's Lisp
-;;; isn't trashed.
-;;;
-(defun %%compiler-defstruct (info)
-  (declare (type defstruct-description info))
-  (let ((name (dd-name info)))
-    (ecase (info type kind name)
-      ((nil))
-      (:structure
-       (check-for-structure-redefinition info))
-      (:primitive
-       (compiler-error "Illegal to redefine standard type ~S." name))
-      (:defined
-       (compiler-warning "Redefining DEFTYPE type to be a DEFSTRUCT: ~S."
-			 name)
-       (setf (info type expander name) nil)))
-    
-    (dolist (inc (dd-includes info))
-      (let ((info (info type structure-info inc)))
-	(unless info
-	  (error "Structure type ~S is included by ~S but not defined."
-		 inc name))
-	(unless (member name (dd-included-by info))
-	  (add-new-subtype name inc info))))
-    
-    (setf (info type kind name) :structure)
-    (setf (info type structure-info name) info)
-    (%note-type-defined name)
-    
-    (let ((copier (dd-copier info)))
-      (when copier
-	(%proclaim `(ftype (function (,name) ,name) ,copier))))
-    
-    (let ((pred (dd-predicate info)))
-      (when pred
-	(define-defstruct-name pred)
-	(setf (info function inlinep pred) :inline)
-	(setf (info function inline-expansion pred)
-	      `(lambda (x) (typep x ',name))))))
-
-  (dolist (slot (dd-slots info))
-    (let* ((fun (dsd-accessor slot))
-	   (setf-fun `(setf ,fun)))
-      (when fun
-      (define-defstruct-name fun)
-      (setf (info function accessor-for fun) info)
-      (unless (dsd-read-only slot)
-	(define-defstruct-name setf-fun)
-	(setf (info function accessor-for setf-fun) info)))))
-  (undefined-value))
-
-(setf (symbol-function '%compiler-defstruct) #'%%compiler-defstruct)
-
-
 ;;; %NOTE-TYPE-DEFINED  --  Interface
 ;;;
 ;;;    Note that the type Name has been (re)defined, updating the undefined
diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp
index 0b081e9c6..a147a3482 100644
--- a/compiler/typetran.lisp
+++ b/compiler/typetran.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/typetran.lisp,v 1.14 1992/04/27 19:46:44 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.15 1993/02/26 08:39:29 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -137,7 +137,7 @@
   (define-type-predicate simple-string-p simple-string)
   (define-type-predicate simple-vector-p simple-vector)
   (define-type-predicate stringp string)
-  (define-type-predicate structurep structure)
+  (define-type-predicate %instancep instance)
   (define-type-predicate symbolp symbol)
   (define-type-predicate vectorp vector))
 
@@ -234,7 +234,7 @@
     (cond ((unknown-type-p type)
 	   (when (policy nil (> speed brevity))
 	     (compiler-note "Can't open-code test of unknown type ~S."
-			    (specifier-type type)))
+			    (type-specifier type)))
 	   `(%typep ,object ',spec))
 	  (t
 	   (ecase (first spec)
@@ -337,42 +337,62 @@
 	`(%typep ,obj ',(type-specifier type)))))
 
 
-;;; SOURCE-TRANSFORM-STRUCTURE-TYPEP  --  Internal
+;;; SOURCE-TRANSFORM-INSTANCE-TYPEP  --  Internal
 ;;;
-;;;    If not currently defined as a structure to the compiler (must have been
-;;; undefined) or there is no predicate, then we call STRUCTURE-TYPEP.
-;;; Otherwise, we do an EQ test for a direct type match, and if that fails,
-;;; deal with inherited types.  If the type is frozen, we can inline the
-;;; supertype check, otherwise we have to call the predicate.
+;;;    Transform a type test against some instance type.  If not properly
+;;; named, error.  If a structure, call S-T-STRUCTURE-TYPEP.  Otherwise, call
+;;; CLASS-TYPEP at run-time with the layout and class object.
 ;;;
-(defun source-transform-structure-typep (obj desc)
-  (let* ((type (structure-type-name desc))
-	 (def (info type structure-info type)))
+(defun source-transform-instance-typep (obj class)
+  (let* ((name (class-name class))
+	 (layout (info type compiler-layout name)))
     (cond
-     ((not def)
-      `(lisp::structure-typep ,obj ',type))
-     ((not (eq (dd-type def) 'structure))
-      (compiler-error "Structure type has :TYPE specified, so it can't ~
-      		       be used as an argument to TYPEP:~%  ~S"
-		      type))
+     ((not (and name (eq (find-class name) class)))
+      (compiler-error "Can't compile TYPEP of anonymous or undefined ~
+		       class:~%  ~S"
+		      class))
+     ((and (structure-class-p class)
+	   layout
+	   (member (layout-invalid layout) '(:compiler nil)))
+      (source-transform-structure-typep obj layout))
      (t
-      (let ((frozen (info type frozen type))
-	    (included (dd-included-by def))
-	    (predicate (dd-predicate def))
-	    (n-name (gensym)))
-	(if (or frozen predicate)
-	    (once-only ((object obj))
-	      `(and (structurep ,object)
-		    (let ((,n-name (structure-ref ,object 0)))
-		      (if (eq ,n-name ',type)
-			  t
-			  ,(if frozen
-			       (when included
-				 `(if (member ,n-name ',included :test #'eq)
-				      t nil))
-			       `(locally (declare (notinline ,predicate))
-				  (,predicate ,object)))))))
-	    `(lisp::structure-typep ,obj ',type)))))))
+      (multiple-value-bind
+	  (pred layout)
+	  (if (csubtypep class (specifier-type 'generic-function))
+	      (values 'funcallable-instance-p 'funcallable-instance-layout)
+	      (values '%instancep '%instance-layout))
+	(once-only ((object obj))
+	  `(and (,pred ,object)
+		(class-typep (,layout ,object) ',class))))))))
+
+
+;;; SOURCE-TRANSFORM-STRUCTURE-TYPEP  --  Internal
+;;;
+;;;    Transform a call to an actual structure type predicate with the
+;;; specified layout.  If sealed and has no subclasses, just test for
+;;; layout-EQ, otherwise do the EQ test and then a general test based on
+;;; layout-inherits.  If safety is important, then we also check if the layout
+;;; for the object is invalid and signal an error if so.
+;;;
+(defun source-transform-structure-typep (obj layout)
+  (let ((class (layout-class layout))
+	(idepth (layout-inheritance-depth layout))
+	(n-layout (gensym)))
+    (once-only ((object obj))
+      `(and (%instancep ,object)
+	    (let ((,n-layout (%instance-layout ,object)))
+	      ,@(when (policy nil (>= safety speed))
+		  `((when (layout-invalid ,n-layout)
+		      (%layout-invalid-error ,object ',layout))))
+	      ,(if (and (eq (class-state class) :sealed)
+			(not (class-subclasses class)))
+		   `(eq ,n-layout ',layout)
+		   `(if (eq ,n-layout ',layout)
+			t
+			(and (> (layout-inheritance-depth ,n-layout) ,idepth)
+			     (locally (declare (optimize (safety 0)))
+			       (eq (svref (layout-inherits ,n-layout) ,idepth)
+				   ',layout))))))))))
 
 
 ;;; Source-Transform-Typep  --  Internal
@@ -406,8 +426,8 @@
 	       (source-transform-union-typep object type))
 	      (member-type
 	       `(member ,object ',(member-type-members type)))
-	      (structure-type
-	       (source-transform-structure-typep object type))
+	      (class
+	       (source-transform-instance-typep object type))
 	      (args-type
 	       (compiler-warning "Illegal type specifier for Typep: ~S."
 				 (cadr spec))
diff --git a/compiler/vop.lisp b/compiler/vop.lisp
index 0d3c8f62c..4197fdda3 100644
--- a/compiler/vop.lisp
+++ b/compiler/vop.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/vop.lisp,v 1.36 1992/09/07 16:08:20 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/vop.lisp,v 1.37 1993/02/26 08:39:32 ram Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -653,7 +653,8 @@
 ;;; function.
 ;;;
 (defstruct (template
-	    (:print-function %print-template))
+	    (:print-function %print-template)
+	    (:pure t))
   ;;
   ;; The symbol name of this VOP.  This is used when printing the VOP and is
   ;; also used to provide a handle for definition and translation.
-- 
GitLab