From e8294d58085b6e60607a3a9a0eae6161979e25d4 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Sat, 23 Jan 1993 14:48:04 +0000 Subject: [PATCH] New structure hax. --- code/type-boot.lisp | 45 +---------------------- compiler/dump.lisp | 27 +++++++++++--- compiler/generic/interr.lisp | 5 +-- compiler/generic/vm-tran.lisp | 3 +- compiler/globaldb.lisp | 67 +++++++++++++++++++++-------------- compiler/ir1tran.lisp | 10 +++--- compiler/mips/call.lisp | 3 +- compiler/proclaim.lisp | 26 ++------------ compiler/typetran.lisp | 4 +-- 9 files changed, 81 insertions(+), 109 deletions(-) diff --git a/code/type-boot.lisp b/code/type-boot.lisp index 4c632dd71..3cb91b329 100644 --- a/code/type-boot.lisp +++ b/code/type-boot.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type-boot.lisp,v 1.6 1991/02/08 13:36:35 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type-boot.lisp,v 1.6.1.1 1993/01/23 14:30:29 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -16,51 +16,8 @@ ;;; (in-package "C") -;;; Make these types be sort-of-defined to allow bootstrapping. -(setf (info type defined-structure-info 'defstruct-description) - (make-defstruct-description)) - -(setf (info type defined-structure-info 'defstruct-slot-description) - (make-defstruct-description)) - - -;;; Define this now so that EQUAL works: -;;; -(defun pathnamep (x) - (and (structurep x) (eq (structure-ref x 0) 'pathname))) - -;;; Define so that we can test for VOLATILE-INFO-ENVs from the beginning of -;;; initialization. -;;; -(defun volatile-info-env-p (x) - (and (structurep x) (eq (structure-ref x 0) 'volatile-info-env))) - - (deftype inlinep () '(member :inline :maybe-inline :notinline nil)) (deftype boolean () '(member t nil)) - -;;; Define this so that we can define the type system. -(in-package "KERNEL") -(defun ctype-p (thing) - (and (structurep thing) - (member (c::structure-ref thing 0) - '(ctype hairy-type named-type numeric-type array-type - member-type structure-type union-type args-type - values-type function-type)))) - -(defun values-type-p (thing) - (and (structurep thing) (eq (c::structure-ref thing 0) 'values-type))) - -;;; Define this so that we can copy type-class structures before the defstruct -;;; for type-class runs. -;;; -(defun copy-type-class (tc) - (let ((new (make-type-class))) - (dotimes (i (c::structure-length tc)) - (declare (type index i)) - (setf (c::structure-ref new i) - (c::structure-ref tc i))) - new)) diff --git a/compiler/dump.lisp b/compiler/dump.lisp index eb135a1a4..c4450924d 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.1.1 1993/01/15 15:30:50 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/dump.lisp,v 1.47.1.2 1993/01/23 14:38:03 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,11 @@ 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 (%instance-ref struct index)) (ref (gethash obj circ))) (cond (ref (push (make-circularity :type :struct-set @@ -1438,3 +1441,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/generic/interr.lisp b/compiler/generic/interr.lisp index 03407dada..b60b17185 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.2.1.1 1993/01/23 14:44:53 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -152,4 +152,5 @@ (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 diff --git a/compiler/generic/vm-tran.lisp b/compiler/generic/vm-tran.lisp index c8e289c7e..354dbe7d3 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.27.1.1 1993/01/14 21:02:52 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.27.1.2 1993/01/23 14:45:45 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -47,6 +47,7 @@ `(truly-the nil (%primitive ,',primitive ,@foo))))) (frob %type-check-error type-check-error) + (frob %layout-invalid-error layout-invalid-error) (frob %odd-keyword-arguments-error odd-keyword-arguments-error) (frob %unknown-keyword-argument-error unknown-keyword-argument-error) (frob %argument-count-error argument-count-error)) diff --git a/compiler/globaldb.lisp b/compiler/globaldb.lisp index afa8ff092..cba638fed 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.26.1.1 1993/01/23 14:41:11 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -36,7 +36,7 @@ (in-package "EXTENSIONS") (export '(info clear-info define-info-class define-info-type make-info-environment do-info *info-environment* - compact-info-environment)) + compact-info-environment undefine-function-name)) (in-package "C") @@ -1091,36 +1091,17 @@ (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 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. +;;; Layout for this type being used by the compiler. ;;; -(define-info-type type frozen boolean nil) +(define-info-type type compiler-layout (or layout null) nil) (define-info-type type documentation (or string null)) @@ -1128,10 +1109,21 @@ ;;; (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) + +(define-info-class typed-structure) +(define-info-type typed-structure info) (define-info-class declaration) (define-info-type declaration recognized boolean) @@ -1160,3 +1152,26 @@ (define-info-type random-documentation stuff list ()) ); defun other-info-init + +;;;; Random utilities: + +;;; UNDEFINE-FUNCTION-NAME -- Interface +;;; +;;; Make Name no longer be a function name: clear everything back to the +;;; default. +;;; +(defun undefine-function-name (name) + (when name + (macrolet ((frob (type &optional val) + `(unless (eq (info function ,type name) ,val) + (setf (info function ,type name) ,val)))) + (frob info) + (frob type (specifier-type 'function)) + (frob where-from :assumed) + (frob inlinep) + (frob kind) + (frob accessor-for) + (frob inline-expansion) + (frob source-transform) + (frob assumed-type))) + (undefined-value)) diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index a75a7754f..56f2b06f9 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.1.1 1993/01/15 15:31:34 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.83.1.2 1993/01/23 14:42:04 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -2596,13 +2596,13 @@ ;;; %Compiler-Defstruct IR1 Convert -- Internal ;;; ;;; This is a frob that DEFMACRO expands into to establish the compiler -;;; semantics. %COMPILER-ONLY-DEFSTRUCT 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. +;;; 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) (let* ((info (eval info))) - (%compiler-only-defstruct info) (%%compiler-defstruct info) (dolist (slot (dd-slots info)) (let ((fun (dsd-accessor slot))) diff --git a/compiler/mips/call.lisp b/compiler/mips/call.lisp index e0c1e6437..aa75867fb 100644 --- a/compiler/mips/call.lisp +++ b/compiler/mips/call.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/mips/call.lisp,v 1.52.1.1 1993/01/15 14:16:10 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/call.lisp,v 1.52.1.2 1993/01/23 14:48:04 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1264,6 +1264,7 @@ default-value-8 (error-call vop ,error ,@args))))) (frob argument-count-error invalid-argument-count-error nargs) (frob type-check-error object-not-type-error object type) + (frob layout-invalid-error layout-invalid-error object layout) (frob odd-keyword-arguments-error odd-keyword-arguments-error) (frob unknown-keyword-argument-error unknown-keyword-argument-error key) (frob nil-function-returned-error nil-function-returned-error fun)) diff --git a/compiler/proclaim.lisp b/compiler/proclaim.lisp index e291e0fbf..ebc0d99b6 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.1.1 1993/01/15 15:31:55 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/proclaim.lisp,v 1.26.1.2 1993/01/23 14:39:22 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -21,6 +21,8 @@ (in-package "EXTENSIONS") (export '(inhibit-warnings freeze-type optimize-interface constant-function)) +(in-package "KERNEL") +(export '(note-name-defined *type-system-initialized*)) (in-package "LISP") (export '(declaim proclaim)) (in-package "C") @@ -236,28 +238,6 @@ name) -;;; UNDEFINE-FUNCTION-NAME -- Interface -;;; -;;; Make Name no longer be a function name: clear everything back to the -;;; default. -;;; -(defun undefine-function-name (name) - (when name - (macrolet ((frob (type &optional val) - `(unless (eq (info function ,type name) ,val) - (setf (info function ,type name) ,val)))) - (frob info) - (frob type (specifier-type 'function)) - (frob where-from :assumed) - (frob inlinep) - (frob kind) - (frob accessor-for) - (frob inline-expansion) - (frob source-transform) - (frob assumed-type))) - (undefined-value)) - - ;;; Process-Optimize-Declaration -- Interface ;;; ;;; Return a new cookie containing the policy information represented by the diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp index 5d11343d9..2e8cd9d6a 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.1.1 1993/01/15 15:32:22 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.14.1.2 1993/01/23 14:34:43 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)) -- GitLab