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