diff --git a/pcl/cache.lisp b/pcl/cache.lisp index 268d8bbbd09457e9ccc638e7409510c52e230bed..427069ea112caeb9a9ac58db6c8e72a5b9389058 100644 --- a/pcl/cache.lisp +++ b/pcl/cache.lisp @@ -147,6 +147,9 @@ (vector #() :type simple-vector) (overflow nil :type list)) +#+cmu +(declaim (ext:freeze-type cache)) + (defun print-cache (cache stream depth) (declare (ignore depth)) (printing-random-thing (cache stream) @@ -243,10 +246,14 @@ ;;; forms of this constant which it is more convenient for the runtime code ;;; to use. ;;; +#-cmu17 (eval-when (compile load eval) (defconstant wrapper-cache-number-adds-ok 4) +;;; Incorrect. This actually allows 15 or 16 adds, depending on whether +;;; most-positive-fixnum is all-ones. -- Ram +;;; (defconstant wrapper-cache-number-length (- (integer-length most-positive-fixnum) wrapper-cache-number-adds-ok)) @@ -275,6 +282,16 @@ You may want to consider changing the value of the constant~@ WRAPPER-CACHE-NUMBER-ADDS-OK."))) +#+cmu17 +(progn + (defconstant wrapper-cache-number-length + (integer-length kernel:layout-hash-max)) + + (defconstant wrapper-cache-number-mask kernel:layout-hash-max) + + (defconstant wrapper-cache-number-adds-ok + (truncate most-positive-fixnum kernel:layout-hash-max))) + ;;; ;;; wrappers themselves @@ -384,10 +401,12 @@ #+structure-wrapper (eval-when (compile load eval) -(defconstant wrapper-cache-number-vector-length 8) +(defconstant wrapper-cache-number-vector-length + #+cmu17 kernel:layout-hash-length #-cmu17 8) +#-cmu17 (deftype cache-number-vector () - `(simple-array fixnum (8))) + `(simple-array fixnum (,wrapper-cache-number-vector-length))) (defconstant wrapper-layout (make-list wrapper-cache-number-vector-length :initial-element 'number)) @@ -397,7 +416,7 @@ #+structure-wrapper (progn -#-new-kcl-wrapper +#-(or new-kcl-wrapper cmu17) (defun make-wrapper-cache-number-vector () (let ((cnv (make-array #.wrapper-cache-number-vector-length :element-type 'fixnum))) @@ -405,6 +424,8 @@ (setf (aref cnv i) (get-wrapper-cache-number))) cnv)) + +#-cmu17 (defstruct (wrapper #+new-kcl-wrapper (:include si::basic-wrapper) (:print-function print-wrapper) @@ -426,12 +447,61 @@ #-new-kcl-wrapper (class *the-class-t* :type class)) + (unless (boundp '*the-class-t*) (setq *the-class-t* nil)) #+new-kcl-wrapper (defmacro wrapper-no-of-instance-slots (wrapper) `(si::s-data-length ,wrapper)) + +;;; Note that for CMU, the WRAPPER of a built-in or structure class will be +;;; some other kind of KERNEL:LAYOUT, but this shouldn't matter, since the only +;;; two slots that WRAPPER adds are meaningless in those cases. +;;; +#+cmu17 +(progn + (defstruct (wrapper + (:include kernel:layout) + (:conc-name %wrapper-) + (:print-function print-wrapper) + (:constructor make-wrapper-internal)) + (instance-slots-layout nil :type list) + (class-slots nil :type list)) + (declaim (ext:freeze-type wrapper)) + + (defmacro wrapper-class (wrapper) + `(kernel:class-pcl-class (kernel:layout-class ,wrapper))) + (defmacro wrapper-no-of-instance-slots (wrapper) + `(kernel:layout-length ,wrapper)) + (declaim (inline wrapper-state (setf wrapper-state))) + + (defun wrapper-state (wrapper) + (let ((invalid (kernel:layout-invalid wrapper))) + (cond ((null invalid) + t) + ((atom invalid) + ;; Some non-pcl object. invalid is probably :INVALID + ;; We should compute the new wrapper here instead + ;; of returning nil, but why bother, since + ;; obsolete-instance-trap can't use it. + '(:obsolete nil)) + (t + invalid)))) + + (defun (setf wrapper-state) (new-value wrapper) + (setf (kernel:layout-invalid wrapper) + (if (eq new-value 't) + nil + new-value))) + + (defmacro wrapper-instance-slots-layout (wrapper) + `(%wrapper-instance-slots-layout ,wrapper)) + (defmacro wrapper-class-slots (wrapper) + `(%wrapper-class-slots ,wrapper)) + (defmacro wrapper-cache-number-vector (x) x)) + + #+new-kcl-wrapper (defun make-wrapper (size &optional class) (multiple-value-bind (raw slot-positions) @@ -449,6 +519,62 @@ :size (* size #.(si::size-of t)) :class class))) +#+cmu17 +;;; BOOT-MAKE-WRAPPER -- Interface +;;; +;;; Called in BRAID when we are making wrappers for classes whose slots are +;;; not initialized yet, and which may be built-in classes. We pass in the +;;; class name in addition to the class. +;;; +(defun boot-make-wrapper (length name &optional class) + (let ((found (lisp:find-class name nil))) + (cond + (found + (unless (kernel:class-pcl-class found) + (setf (kernel:class-pcl-class found) class)) + (assert (eq (kernel:class-pcl-class found) class)) + (let ((layout (kernel:class-layout found))) + (assert layout) + layout)) + (t + (kernel:initialize-layout-hash + (make-wrapper-internal + :length length + :class (kernel:make-standard-class :name name :pcl-class class))))))) + + +#+cmu17 +;;; MAKE-WRAPPER -- Interface +;;; +;;; In CMU CL, the layouts (a.k.a wrappers) for built-in and structure +;;; classes already exist when PCL is initialized, so we don't necessarily +;;; always make a wrapper. Also, we help maintain the mapping between +;;; lisp:class and pcl::class objects. +;;; +(defun make-wrapper (length class) + (cond + ((typep class 'std-class) + (kernel:initialize-layout-hash + (make-wrapper-internal + :length length + :class + (let ((owrap (class-wrapper class))) + (cond (owrap + (kernel:layout-class owrap)) + ((*subtypep (class-of class) + *the-class-standard-class*) + (kernel:make-standard-class :pcl-class class)) + (t + (kernel:make-random-pcl-class :pcl-class class))))))) + (t + (let* ((found (lisp:find-class (slot-value class 'name))) + (layout (kernel:class-layout found))) + (unless (kernel:class-pcl-class found) + (setf (kernel:class-pcl-class found) class)) + (assert (eq (kernel:class-pcl-class found) class)) + (assert layout) + layout)))) + (defun print-wrapper (wrapper stream depth) (declare (ignore depth)) (printing-random-thing (wrapper stream) @@ -461,26 +587,37 @@ `(and (< ,field-number #.(1- wrapper-cache-number-vector-length)) (1+ ,field-number))) +#-cmu17 (defmacro cache-number-vector-ref (cnv n) `(#-kcl svref #+kcl aref ,cnv ,n)) +#+cmu17 +(defmacro cache-number-vector-ref (cnv n) + `(wrapper-cache-number-vector-ref ,cnv ,n)) + ) +#-cmu17 (defmacro wrapper-cache-number-vector-ref (wrapper n) `(the fixnum (#-structure-wrapper svref #+structure-wrapper aref (wrapper-cache-number-vector ,wrapper) ,n))) +#+cmu17 +(defmacro wrapper-cache-number-vector-ref (wrapper n) + `(kernel:layout-hash ,wrapper ,n)) (defmacro class-no-of-instance-slots (class) `(wrapper-no-of-instance-slots (class-wrapper ,class))) (defmacro wrapper-class* (wrapper) - #-new-kcl-wrapper + #-(or new-kcl-wrapper cmu17) `(wrapper-class ,wrapper) - #+new-kcl-wrapper + #+(or new-kcl-wrapper cmu17) `(let ((wrapper ,wrapper)) (or (wrapper-class wrapper) - (find-structure-class (si::s-data-name wrapper))))) + (find-structure-class + #+new-kcl-wrapper (si::s-data-name wrapper) + #+cmu17 (lisp:class-name (kernel:layout-class wrapper)))))) ;;; ;;; The wrapper cache machinery provides general mechanism for trapping on @@ -555,6 +692,7 @@ (error "Wrapper returned from trap invalid."))) nwrapper)))) +#-cmu17 (defmacro check-wrapper-validity1 (object) (let ((owrapper (gensym))) `(let ((,owrapper (cond ((std-instance-p ,object) @@ -569,6 +707,16 @@ ,owrapper (check-wrapper-validity ,object))))) +#+cmu17 +;;; semantically equivalent, but faster. +;;; +(defmacro check-wrapper-validity1 (object) + (let ((owrapper (gensym))) + `(let ((,owrapper (kernel:layout-of object))) + (if (kernel:layout-invalid ,owrapper) + (check-wrapper-validity ,object) + ,owrapper)))) + (defvar *free-caches* nil) diff --git a/pcl/defclass.lisp b/pcl/defclass.lisp index 747be0110cacc562e7468f31b9d15eabe6c5eeba..6a7f900f37fb6bc6ca67132c50d85476be4f7071 100644 --- a/pcl/defclass.lisp +++ b/pcl/defclass.lisp @@ -150,7 +150,14 @@ (error "The value of the :metaclass option (~S) is not a~%~ legal class name." (cadr option))) + #-cmu17 (setq metaclass (cadr option)) + #+cmu17 + (setq metaclass + (case (cadr option) + (lisp:standard-class 'standard-class) + (lisp:structure-class 'structure-class) + (t (cadr option)))) (setf options (remove option options)) (return t)))) diff --git a/pcl/defs.lisp b/pcl/defs.lisp index 99a18934c04930cfbb37e710a5a59c70ae4007b9..fdb8d486e7b471f1ff41197d3413e95e98451b2e 100644 --- a/pcl/defs.lisp +++ b/pcl/defs.lisp @@ -34,7 +34,8 @@ (defvar *defmethod-times* '(load eval)) (defvar *defgeneric-times* '(load eval)) -(defvar *boot-state* ()) ;NIL +; defvar is now actually in macros +;(defvar *boot-state* ()) ;NIL ;EARLY ;BRAID ;COMPLETE @@ -74,6 +75,7 @@ (non-setf-var . non-setf-case) (setf-var . setf-case)) (declare (indentation 1 1)) + #+setf (declare (ignore setf-var setf-case)) (once-only (spec) `(cond (#-setf (symbolp ,spec) #+setf t (let ((,non-setf-var ,spec)) ,@non-setf-case)) @@ -212,12 +214,16 @@ *the-wrapper-of-complex* *the-wrapper-of-character* *the-wrapper-of-bit-vector* *the-wrapper-of-array*)) +;;;; Type specifier hackery: + +;;; internal to this file. (defun coerce-to-class (class &optional make-forward-referenced-class-p) (if (symbolp class) (or (find-class class (not make-forward-referenced-class-p)) (ensure-class class)) class)) +;;; Interface (defun specializer-from-type (type &aux args) (when (consp type) (setq args (cdr type) type (car type))) @@ -229,8 +235,13 @@ :object (coerce-to-class (car args)))) (class-eq (class-eq-specializer (coerce-to-class (car args)))) (eql (intern-eql-specializer (car args)))))) + #+cmu17 + ((and (null args) (typep type 'lisp:class)) + (or (kernel:class-pcl-class type) + (find-structure-class (lisp:class-name type)))) ((specializerp type) type))) +;;; interface (defun type-from-specializer (specl) (cond ((eq specl 't) 't) @@ -299,12 +310,12 @@ `(satisfies ,(make-class-eq-predicate class))) ||# -#-excl +#-(or excl cmu17) (deftype eql (type-object) `(member ,type-object)) - +;;; Internal to this file. ;;; ;;; These functions are a pale imitiation of their namesake. They accept ;;; class objects or types where they should. @@ -328,9 +339,13 @@ (t (error "~s is not a type" type)))) +;;; Not used... +#+nil (defun unparse-type-list (tlist) (mapcar #'unparse-type tlist)) +;;; Not used... +#+nil (defun unparse-type (type) (if (atom type) (if (specializerp type) @@ -342,16 +357,21 @@ (class (class-name (cadr type))) (t `(,(car type) ,@(unparse-type-list (cdr type))))))) +;;; internal to this file... (defun convert-to-system-type (type) (case (car type) - ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type (cdr type)))) - (class (class-name (cadr type))) ; it had better be a named class - (class-eq (class-name (cadr type))) ; this one is impossible to do right + ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type + (cdr type)))) + ((class class-eq) ; class-eq is impossible to do right + #-cmu17 (class-name (cadr type)) + #+cmu17 (kernel:layout-class (class-wrapper (cadr type)))) (eql type) (t (if (null (cdr type)) (car type) type)))) +;;; not used... +#+nil (defun *typep (object type) (setq type (*normalize-type type)) (cond ((member (car type) '(eql wrapper-eq class-eq class)) @@ -361,6 +381,9 @@ (t (typep object (convert-to-system-type type))))) + +;;; *SUBTYPEP -- Interface +;;; ;Writing the missing NOT and AND clauses will improve ;the quality of code generated by generate-discrimination-net, but ;calling subtypep in place of just returning (values nil nil) can be @@ -390,6 +413,7 @@ (convert-to-system-type type2)))))))) (defun do-satisfies-deftype (name predicate) + #+cmu17 (declare (ignore name predicate)) #+(or :Genera (and :Lucid (not :Prime)) ExCL :coral) (let* ((specifier `(satisfies ,predicate)) (expand-fn #'(lambda (&rest ignore) @@ -406,7 +430,7 @@ (setf (get name 'excl::deftype-expander) expand-fn) #+:coral (setf (get name 'ccl::deftype-expander) expand-fn))) - #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral) + #-(or :Genera (and :Lucid (not :Prime)) ExCL :coral cmu17) ;; This is the default for ports for which we don't know any ;; better. Note that for most ports, providing this definition ;; should just speed up class definition. It shouldn't have an @@ -547,6 +571,40 @@ list) () (symbol list sequence t) nil))) +#+cmu17 +(labels ((direct-supers (class) + (if (typep class 'lisp:built-in-class) + (kernel:built-in-class-direct-superclasses class) + (let ((inherits (kernel:layout-inherits + (kernel:class-layout class)))) + (list (svref inherits (1- (length inherits))))))) + (direct-subs (class) + (ext:collect ((res)) + (let ((subs (kernel:class-subclasses class))) + (when subs + (ext:do-hash (sub v subs) + (declare (ignore v)) + (when (member class (direct-supers sub)) + (res sub))))) + (res)))) + (ext:collect ((res)) + (dolist (bic kernel::built-in-classes) + (let* ((name (car bic)) + (class (lisp:find-class name))) + (unless (member name '(t kernel:instance kernel:funcallable-instance + function)) + (res `(,name + ,(mapcar #'lisp:class-name (direct-supers class)) + ,(mapcar #'lisp:class-name (direct-subs class)) + ,(map 'list #'(lambda (x) + (lisp:class-name (kernel:layout-class x))) + (reverse + (kernel:layout-inherits + (kernel:class-layout class)))) + ,(let ((found (assoc name *built-in-classes*))) + (if found (fifth found) 42))))))) + (setq *built-in-classes* (res)))) + ;;; ;;; The classes that define the kernel of the metabraid. @@ -554,15 +612,27 @@ (defclass t () () (:metaclass built-in-class)) -(defclass slot-object (t) () +#+cmu17 +(progn + (defclass kernel:instance (t) () + (:metaclass built-in-class)) + + (defclass function (t) () + (:metaclass built-in-class)) + + (defclass kernel:funcallable-instance (function) () + (:metaclass built-in-class))) + +(defclass slot-object (#-cmu17 t #+cmu17 kernel:instance) () (:metaclass slot-class)) (defclass structure-object (slot-object) () (:metaclass structure-class)) -(defstruct (structure-object +(defstruct (#-cmu17 structure-object #+cmu17 dead-beef-structure-object (:constructor |STRUCTURE-OBJECT class constructor|))) + (defclass standard-object (slot-object) ()) (defclass metaobject (standard-object) ()) @@ -836,7 +906,8 @@ (defclass generic-function (dependent-update-mixin definition-source-mixin documentation-mixin - metaobject) + metaobject + #+cmu17 kernel:funcallable-instance) () (:metaclass funcallable-standard-class)) diff --git a/pcl/defsys.lisp b/pcl/defsys.lisp index 210c613e2720a06ba06e16724c730b7739e37d9e..f84658c2ce06dd9e3ff00b374c75b1b214947916 100644 --- a/pcl/defsys.lisp +++ b/pcl/defsys.lisp @@ -218,7 +218,7 @@ ;;; (defvar *the-pcl-package* (find-package :pcl)) -(defvar *pcl-system-date* "September 16 92 PCL (e)") +(defvar *pcl-system-date* "September 16 92 PCL (f)") #+cmu (setf (getf ext:*herald-items* :pcl) @@ -301,22 +301,7 @@ (eval-when (eval compile load) (pushnew :excl-sun4 *features*)) -#+cmu -(eval-when (compile load eval) - (let ((vs (lisp-implementation-version))) - (cond ((and (<= 2 (length vs)) - (eql #\1 (aref vs 0)) - (let ((d (digit-char-p (aref vs 1)))) - (and d (<= 6 d)))) - (pushnew :cmu16 *features*)) - ((string= "20-Dec-1992" vs) - (pushnew :cmu16 *features*) - (pushnew :cmu17 *features*) - (when (fboundp 'pcl::original-defstruct) - (setf (macro-function 'defstruct) - (macro-function 'pcl::original-defstruct)))) - (t - (error "what version of cmucl is this?"))))) + ;;; Yet Another Sort Of General System Facility and friends. ;;; @@ -652,6 +637,9 @@ and load your system with: (declare (ignore ignore)) 't) +#+cmu17 +(defparameter *byte-files* '(defclass defcombin iterate env)) + (defun operate-on-system (name mode &optional arg print-only) (let ((system (get-system name))) (unless system (error "Can't find system with name ~S." name)) @@ -673,7 +661,12 @@ and load your system with: :output-file (make-pathname :defaults (make-binary-pathname name) - :version :newest)))))) + :version :newest) + #+cmu17 :byte-compile #+cmu17 + (if (and (member name *byte-files*) + (member :small *features*)) + t + :maybe)))))) (#+Genera compiler:compiler-warnings-context-bind #+TI @@ -773,15 +766,15 @@ and load your system with: #+cmu17 *load-truename* #-(or Lispm excl Xerox (and dec vax common) LUCID akcl cmu17) nil)) -#-(or (and cmu (not cmu17)) Symbolics) +#-(or cmu Symbolics) (defvar *pcl-directory* (or (load-truename t) (error "Because load-truename is not implemented in this port~%~ of PCL, you must manually edit the definition of the~%~ variable *pcl-directory* in the file defsys.lisp."))) -#+(and cmu (not cmu17)) -(defvar *pcl-directory* (pathname "pcl:")) +#+cmu +(defvar *pcl-directory* (pathname "target:pcl/")) #+Genera (defvar *pcl-directory* @@ -1048,8 +1041,6 @@ and load your system with: (or (c::info setf inverse sym) (c::info setf expander sym) (c::info type kind sym) - (c::info type structure-info sym) - (c::info type defined-structure-info sym) (c::info function macro-function sym) (c::info function compiler-macro-function sym))) (unintern sym pkg) diff --git a/pcl/dlisp.lisp b/pcl/dlisp.lisp index f8538ad5f6b1f37f4c698c5d108ef7f1867ea9a4..0fe3b48389bdd7620717860d5fdb0f1538aaf765 100644 --- a/pcl/dlisp.lisp +++ b/pcl/dlisp.lisp @@ -104,7 +104,7 @@ (lambda `(lambda ,closure-variables ,@(when (member 'miss-fn closure-variables) `((declare (type function miss-fn)))) - #'(lambda ,args + #'(#+cmu kernel:instance-lambda #-cmu lambda ,args #+copy-&rest-arg ,@(when rest `((setq .lap-rest-arg. @@ -117,6 +117,12 @@ (compile-lambda lambda)) nil))) +;;; cmu17 note: since std-instance-p is weakened, that branch may run +;;; on non-pcl instances (structures). The result will be the +;;; non-wrapper layout for the structure, which will cause a miss. The "slots" +;;; will be whatever the first slot is, but will be ignored. Similarly, +;;; fsc-instance-p returns true on funcallable structures as well as PCL fins. +;;; (defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p) (when (and (null *precompiling-lap*) *emit-function-p*) (return-from emit-reader/writer @@ -392,6 +398,12 @@ #-lucid `(the fixnum ,form)))))))) wrappers)))) +;;; cmu17 note: since std-instance-p is weakened, that branch may run +;;; on non-pcl instances (structures). The result will be the +;;; non-wrapper layout for the structure, which will cause a miss. The "slots" +;;; will be whatever the first slot is, but will be ignored. Similarly, +;;; fsc-instance-p returns true on funcallable structures as well as PCL fins. +;;; (defun emit-fetch-wrapper (metatype argument miss-label &optional slot) (ecase metatype ((standard-instance #+new-kcl-wrapper structure-instance) diff --git a/pcl/env.lisp b/pcl/env.lisp index 000ee3e7837cc2630d36d0d12b7422169efb10b1..7c286fa77ca217ead9924e4daa9a2a464e435025 100644 --- a/pcl/env.lisp +++ b/pcl/env.lisp @@ -67,12 +67,15 @@ (values))) (defmethod describe-object (object stream) - (let ((*standard-output* stream)) + #-cmu (cond ((or #+kcl (packagep object)) (describe-package object stream)) (t - (funcall (original-definition 'describe) object))))) + (funcall (original-definition 'describe) object))) + #+cmu + (describe object stream)) +#-cmu (redefine-function 'describe 'pcl-describe) ) @@ -218,7 +221,7 @@ (format stream "~&Its rehash-size is ~d." (lisp::hash-table-rehash-size object)) (format stream "~&Its rehash-threshold is ~d." - (lisp::hash-table-rehash-threshold object)) + (hash-table-rehash-threshold object)) (format stream "~&It currently holds ~d entries." (lisp::hash-table-number-entries object))) @@ -329,3 +332,75 @@ (pushnew :pcl *features*) (pushnew :portable-commonloops *features*) (pushnew :pcl-structures *features*) + +#+cmu +(when (find-package "OLD-PCL") + (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl)) + (symbol-function 'pcl::print-object))) + + +;;;; MAKE-LOAD-FORM + +#+cmu17 +(export '(cl::make-load-form cl::make-load-form-saving-slots) "CL") + +#+cmu17 +(progn + (defgeneric make-load-form (object &optional environment)) + + (defmethod make-load-form ((object structure-object) &optional environment) + (declare (ignore environment)) + (kernel:make-structure-load-form object)) + + (defmethod make-load-form ((object wrapper) &optional env) + (declare (ignore env)) + (let ((pname (kernel:class-proper-name (kernel:layout-class object)))) + (unless pname + (error "Can't dump wrapper for anonymous class:~% ~S" + (kernel:layout-class object))) + `(kernel:class-layout (lisp:find-class ',pname)))) + + (defun make-load-form-saving-slots (object &key slot-names environment) + (declare (ignore environment)) + (when slot-names + (warn ":SLOT-NAMES MAKE-LOAD-FORM option not implemented, dumping all ~ + slots:~% ~S" + object)) + :just-dump-it-normally)) + + +;;; The following are hacks to deal with CMU CL having two different CLASS +;;; classes. +;;; +#+cmu17 +(defun coerce-to-pcl-class (class) + (if (typep class 'lisp:class) + (or (kernel:class-pcl-class class) + (find-structure-class (lisp:class-name class))) + class)) + +#+cmu17 +(progn + (defmethod make-instance ((class lisp:class) &rest stuff) + (apply #'make-instance (coerce-to-pcl-class class) stuff)) + (defmethod change-class (instance (class lisp:class)) + (apply #'change-class instance (coerce-to-pcl-class class)))) + +#+cmu17 +(macrolet ((frob (&rest names) + `(progn + ,@(mapcar #'(lambda (name) + `(defmethod ,name ((class lisp:class)) + (funcall #',name + (coerce-to-pcl-class class)))) + names)))) + (frob + class-direct-slots + class-prototype + class-precedence-list + class-direct-default-initargs + class-direct-superclasses + compute-class-precedence-list + class-default-initargs class-finalized-p + class-direct-subclasses class-slots + make-instances-obsolete)) diff --git a/pcl/fast-init.lisp b/pcl/fast-init.lisp index 31224265c19e4bfabcb508400c48b497759b5073..b475c5fac17dbfa4a1d283ba5774cc538569e178 100644 --- a/pcl/fast-init.lisp +++ b/pcl/fast-init.lisp @@ -562,14 +562,25 @@ (defun make-default-initargs-form-list (class keys &optional (separate-p t)) (let ((initargs-form-list (cons nil nil)) (default-initargs (class-default-initargs class)) - (nkeys keys)) + (nkeys keys) + (slots-alist + (mapcan #'(lambda (slot) + (mapcar #'(lambda (arg) + (cons arg slot)) + (slot-definition-initargs slot))) + (class-slots class))) + (nslots nil)) + (dolist (key nkeys) + (pushnew (cdr (assoc key slots-alist)) nslots)) (dolist (default default-initargs) - (let ((key (car default)) - (function (cadr default))) - (unless (member key nkeys) + (let* ((key (car default)) + (slot (cdr (assoc key slots-alist))) + (function (cadr default))) + (unless (member slot nslots) (add-forms `((funcall ,function) (push-initarg ,key)) initargs-form-list) - (push key nkeys)))) + (push key nkeys) + (push slot nslots)))) (when separate-p (add-forms `((update-initialize-info-cache ,class ,(initialize-info class nkeys nil))) @@ -886,3 +897,36 @@ (iis-body ,@body) initargs)) (list pv-cell (coerce cvector cvector-type))))) + + +;The effect of this is to cause almost all of the overhead of make-instance +;to happen at load time (or maybe at precompile time, as explained in a +;previous message) rather than the first time make-instance is called with +;a given class-name and sequence of keywords. + +;This optimization applys only when the first argument and all the even +;numbered arguments are constants evaluating to interned symbols. + +#+cmu +(declaim (ftype (function (t) symbol) get-make-instance-function-symbol)) + +; Use this definition in any CL implementation supporting +; both define-compiler-macro and load-time-value. +#+cmu +(define-compiler-macro make-instance (&whole form &rest args) + (declare (ignore args)) + (let* ((*make-instance-function-keys* nil) + (expanded-form (expand-make-instance-form form))) + (if expanded-form + `(funcall (symbol-function + ;; The symbol is guaranteed to be fbound. + ;; Is there a way to declare this? + (load-time-value + (get-make-instance-function-symbol + ',(first *make-instance-function-keys*)))) + ,@(cdr expanded-form)) + form))) + +(defun get-make-instance-function-symbol (key) + (get-make-instance-functions (list key)) + (make-instance-function-symbol key)) diff --git a/pcl/fin.lisp b/pcl/fin.lisp index 5328c488046c55ac02ea3f46562f9f7b6bad0414..c5edfc06df35d83cf0389abac8e1f62ee2285d6b 100644 --- a/pcl/fin.lisp +++ b/pcl/fin.lisp @@ -1247,63 +1247,28 @@ dbg: ;;;; Implementation of funcallable instances for CMU Common Lisp: ;;; -;;; We represent a FIN like a closure, but the header has a distinct type -;;; tag. The FIN data slots are stored at the end of a fixed-length closure -;;; (at FIN-DATA-OFFSET.) When the function is set to a closure that has no -;;; more than FIN-DATA-OFFSET slots, we can just replace the slots in the FIN -;;; with the closure slots. If the closure has too many slots, we must -;;; indirect through a trampoline with a rest arg. For non-closures, we just -;;; set the function slot. -;;; -;;; We can get away with this efficient and relatively simple scheme because -;;; the compiler currently currently only references closure slots during the -;;; initial call and on entry into the function. So we don't have to worry -;;; about bad things happening when the FIN is clobbered (the problem JonL -;;; flames about somewhere...) -;;; -;;; We also stick in a slot for the function name at the end, but before the -;;; data slots. +(defstruct (pcl-funcallable-instance + (:alternate-metaclass kernel:funcallable-instance + kernel:random-pcl-class + kernel:make-random-pcl-class) + (:type kernel:funcallable-structure) + (:constructor allocate-funcallable-instance-1 ()) + (:conc-name nil)) + ;; + ;; PCL wrapper is in the layout slot. + ;; + ;; PCL data vector. + (pcl-funcallable-instance-slots nil) + ;; + ;; The debug-name for this function. + (funcallable-instance-name nil)) #+CMU +;;; Note: returns true for non-pcl funcallable structures. (import 'kernel:funcallable-instance-p) #+CMU (progn - -(eval-when (compile load eval) - ;;; The offset of the function's name & the max number of real closure slots. - ;;; - (defconstant fin-name-slot 14) - - ;;; The offset of the data slots. - ;;; - (defconstant fin-data-offset 15)) - - -;;; ALLOCATE-FUNCALLABLE-INSTANCE-1 -- Interface -;;; -;;; Allocate a funcallable instance, setting the function to an error -;;; function and initializing the data slots to NIL. -;;; -(defun allocate-funcallable-instance-1 () - (let* ((len (+ (length funcallable-instance-data) fin-data-offset)) - (res (kernel:%make-funcallable-instance - len - #'called-fin-without-function))) - (dotimes (i (length funcallable-instance-data)) - (kernel:%set-funcallable-instance-info res (+ i fin-data-offset) nil)) - (kernel:%set-funcallable-instance-info res fin-name-slot nil) - res)) - - -;;; FUNCALLABLE-INSTANCE-P -- Interface -;;; -;;; Return true if X is a funcallable instance. This is an interpreter -;;; stub; the compiler directly implements this function. -;;; -(defun funcallable-instance-p (x) (funcallable-instance-p x)) - - ;;; SET-FUNCALLABLE-INSTANCE-FUNCTION -- Interface ;;; ;;; Set the function that is called when FIN is called. @@ -1311,80 +1276,23 @@ dbg: (defun set-funcallable-instance-function (fin new-value) (declare (type function new-value)) (assert (funcallable-instance-p fin)) - (ecase (kernel:get-type new-value) - (#.vm:closure-header-type - (let ((len (- (kernel:get-closure-length new-value) - (1- vm:closure-info-offset)))) - (cond ((> len fin-name-slot) - (set-funcallable-instance-function - fin - #'(lambda (&rest args) - (apply new-value args)))) - (t - (dotimes (i fin-data-offset) - (kernel:%set-funcallable-instance-info - fin i - (if (>= i len) - nil - (kernel:%closure-index-ref new-value i)))) - (kernel:%set-funcallable-instance-function - fin - (kernel:%closure-function new-value)))))) - (#.vm:function-header-type - (kernel:%set-funcallable-instance-function fin new-value))) - new-value) - - -;;; FUNCALLABLE-INSTANCE-NAME, SET-FUNCALLABLE-INSTANCE-NAME -- Interface -;;; -;;; Read or set the name slot in a funcallable instance. -;;; -(defun funcallable-instance-name (fin) - (kernel:%closure-index-ref fin fin-name-slot)) -;;; -(defun set-funcallable-instance-name (fin new-value) - (kernel:%set-funcallable-instance-info fin fin-name-slot new-value) - new-value) -;;; -(defsetf funcallable-instance-name set-funcallable-instance-name) + (setf (kernel:funcallable-instance-function fin) new-value)) ;;; FUNCALLABLE-INSTANCE-DATA-1 -- Interface ;;; -;;; If the slot is constant, use CLOSURE-REF with the appropriate offset, -;;; otherwise do a run-time lookup of the slot offset. +;;; This "works" on non-PCL FINs, which allows us to weaken +;;; FUNCALLABLE-INSTANCE-P to return trure for all FINs. This is also +;;; necessary for bootstrapping to work, since the layouts for early GFs are +;;; not initially initialized. ;;; (defmacro funcallable-instance-data-1 (fin slot) - (if (constantp slot) - `(sys:%primitive c:closure-ref ,fin - ,(+ (or (position (eval slot) funcallable-instance-data) - (error "Unknown slot: ~S." (eval slot))) - fin-data-offset)) - (ext:once-only ((n-slot slot)) - `(kernel:%closure-index-ref - ,fin - (+ (or (position ,n-slot funcallable-instance-data) - (error "Unknown slot: ~S." ,n-slot)) - fin-data-offset))))) -;;; -(defmacro %set-funcallable-instance-data-1 (fin slot new-value) - (ext:once-only ((n-fin fin) - (n-slot slot) - (n-val new-value)) - `(progn - (kernel:%set-funcallable-instance-info - ,n-fin - ,(if (constantp slot) - (+ (or (position (eval slot) funcallable-instance-data) - (error "Unknown slot: ~S." (eval slot))) - fin-data-offset) - `(+ (or (position ,n-slot funcallable-instance-data) - (error "Unknown slot: ~S." ,n-slot)) - fin-data-offset)) - ,n-val) - ,n-val))) -;;; -(defsetf funcallable-instance-data-1 %set-funcallable-instance-data-1) + (ecase (eval slot) + (wrapper `(kernel:%funcallable-instance-layout ,fin)) + (slots `(kernel:%funcallable-instance-info ,fin 0)))) + +(defmacro pcl-funcallable-instance-wrapper (x) + `(kernel:%funcallable-instance-layout ,x)) ); End of #+cmu progn @@ -1957,6 +1865,3 @@ make_turbo_trampoline_internal(base0) (defmacro fsc-instance-slots (fin) `(funcallable-instance-data-1 ,fin 'slots)) - - - diff --git a/pcl/init.lisp b/pcl/init.lisp index ea607bc93a3610b504b2798d373f92f8b6bccdde..a46abe9bcbb82b0674acb35852472d39763271fe 100644 --- a/pcl/init.lisp +++ b/pcl/init.lisp @@ -169,7 +169,10 @@ (let* ((class (class-of instance)) (slotds (class-slots class)) #-new-kcl-wrapper - (std-p (or (std-instance-p instance) (fsc-instance-p instance)))) + (std-p #+cmu17 + (pcl-instance-p instance) + #-cmu17 + (or (std-instance-p instance) (fsc-instance-p instance)))) (dolist (slotd slotds) (let ((slot-name (slot-definition-name slotd)) (slot-initargs (slot-definition-initargs slotd))) diff --git a/pcl/low.lisp b/pcl/low.lisp index 2f8937f662f9534c6b7f8d794dee6dc34083a440..e543c85f60369549538991f911037ba2c393adbb 100644 --- a/pcl/low.lisp +++ b/pcl/low.lisp @@ -111,6 +111,7 @@ ;;; #-new-kcl-wrapper (progn +#-cmu17 (defstruct (std-instance (:predicate std-instance-p) (:conc-name %std-instance-) (:constructor %%allocate-instance--class ()) @@ -370,10 +371,8 @@ (if ,x *the-wrapper-of-symbol* *the-wrapper-of-null*)) (built-in-or-structure-wrapper1 ,x))))) - ;Low level functions for structures - ;Functions on arbitrary objects (defvar *structure-table* (make-hash-table :test 'eq)) diff --git a/pcl/macros.lisp b/pcl/macros.lisp index 117f448e773414bc1683327a83aecb191a8d91a0..b8be040cef8cfd6be04411fe5ab16c58ea41b0e4 100644 --- a/pcl/macros.lisp +++ b/pcl/macros.lisp @@ -333,12 +333,18 @@ ;;; Similar to printing-random-object in the lisp machine but much simpler ;;; and machine independent. (defmacro printing-random-thing ((thing stream) &body body) - (once-only (stream) - `(progn (format ,stream "#<") - ,@body - (format ,stream " ") - (printing-random-thing-internal ,thing ,stream) - (format ,stream ">")))) + #+cmu17 + `(print-unreadable-object (,thing ,stream :identity t) ,@body) + #-cmu17 + (once-only (thing stream) + `(progn + (when *print-readably* + (error "~S cannot be printed readably." thing)) + (format ,stream "#<") + ,@body + (format ,stream " ") + (printing-random-thing-internal ,thing ,stream) + (format ,stream ">")))) (defun printing-random-thing-internal (thing stream) (declare (ignore thing stream)) @@ -373,6 +379,7 @@ ;(warn "****** Things will go faster if you fix define-compiler-macro") ) +#-cmu (defmacro define-compiler-macro (name arglist &body body) #+(or lucid kcl) `(#+lucid lcl:def-compiler-macro #+kcl si::define-compiler-macro @@ -456,21 +463,54 @@ (find-class-predicate-from-cell symbol (find-class-cell symbol errorp) errorp)) +(defvar *boot-state* nil) ; duplicate defvar to defs.lisp + +; Use this definition in any CL implementation supporting +; both define-compiler-macro and load-time-value. +#+cmu ; Note that in CMU, lisp:find-class /= pcl:find-class +(define-compiler-macro find-class (&whole form + symbol &optional (errorp t) environment) + (declare (ignore environment)) + (if (and (constantp symbol) + (legal-class-name-p (eval symbol)) + (constantp errorp) + (member *boot-state* '(braid complete))) + (let ((symbol (eval symbol)) + (errorp (not (null (eval errorp)))) + (class-cell (make-symbol "CLASS-CELL"))) + `(let ((,class-cell (load-time-value (find-class-cell ',symbol)))) + (or (find-class-cell-class ,class-cell) + #-cmu17 + (find-class-from-cell ',symbol ,class-cell ,errorp) + #+cmu17 + ,(if errorp + `(find-class-from-cell ',symbol ,class-cell t) + `(and (kernel:class-cell-class + ',(kernel:find-class-cell symbol)) + (find-class-from-cell ',symbol ,class-cell nil)))))) + form)) + #-setf (defsetf find-class (symbol &optional (errorp t) environment) (new-value) (declare (ignore errorp environment)) `(SETF\ PCL\ FIND-CLASS ,new-value ,symbol)) (defun #-setf SETF\ PCL\ FIND-CLASS #+setf (setf find-class) (new-value symbol) - (declare (special *boot-state*)) (if (legal-class-name-p symbol) (let ((cell (find-class-cell symbol))) (setf (find-class-cell-class cell) new-value) (when (or (eq *boot-state* 'complete) (eq *boot-state* 'braid)) + #+cmu17 + (let ((lclass (kernel:layout-class (class-wrapper new-value)))) + (setf (lisp:class-name lclass) (class-name new-value)) + (unless (eq (lisp:find-class symbol nil) lclass) + (setf (lisp:find-class symbol) lclass))) + (setf (find-class-cell-predicate cell) (symbol-function (class-predicate-name new-value))) (when (and new-value (not (forward-referenced-class-p new-value))) + (dolist (keys+aok (find-class-cell-make-instance-function-keys cell)) (update-initialize-info-internal (initialize-info new-value (car keys+aok) nil (cdr keys+aok)) diff --git a/pcl/methods.lisp b/pcl/methods.lisp index 625b5bd4ad64951e129c03973e592dafc0309acf..0f7862c6a52cfd681576dcb49d07c63fac58c3fa 100644 --- a/pcl/methods.lisp +++ b/pcl/methods.lisp @@ -1028,15 +1028,18 @@ (cond ((eq class *the-class-t*) 't) ((eq class *the-class-slot-object*) + #-(or new-kcl-wrapper cmu17) + `(not (eq *the-class-built-in-class* + (wrapper-class (std-instance-wrapper (class-of ,arg))))) #+new-kcl-wrapper `(or (std-instance-p ,arg) (fsc-instance-p ,arg)) - #-new-kcl-wrapper - `(not (eq *the-class-built-in-class* - (wrapper-class (std-instance-wrapper (class-of ,arg)))))) + #+cmu17 + `(not (lisp:typep (lisp:class-of ,arg) 'lisp:built-in-class))) #-new-kcl-wrapper ((eq class *the-class-standard-object*) `(or (std-instance-p ,arg) (fsc-instance-p ,arg))) + #-cmu17 ((eq class *the-class-structure-object*) `(memq ',class (class-precedence-list (class-of ,arg)))) ;; TYPEP is now sometimes faster than doing memq of the cpl @@ -1367,52 +1370,60 @@ (defun compute-secondary-dispatch-function1 (generic-function net &optional function-p) - (if (eq (car net) 'methods) - (get-effective-method-function1 generic-function (cadr net)) - (let* ((name (generic-function-name generic-function)) - (arg-info (gf-arg-info generic-function)) - (metatypes (arg-info-metatypes arg-info)) - (applyp (arg-info-applyp arg-info)) - (fmc-arg-info (cons (length metatypes) applyp)) - (arglist (if function-p - (make-dfun-lambda-list metatypes applyp) - (make-fast-method-call-lambda-list metatypes applyp)))) - (multiple-value-bind (cfunction constants) - (get-function1 `(lambda ,arglist - ,@(unless function-p - `((declare (ignore .pv-cell. - .next-method-call.)))) - #+copy-&rest-arg - ,@(when (and applyp function-p) - `((setq .dfun-rest-arg. - (copy-list .dfun-rest-arg.)))) - (let ((emf ,net)) - ,(make-emf-call metatypes applyp 'emf))) - #'net-test-converter - #'net-code-converter - #'(lambda (form) - (net-constant-converter form generic-function))) - #'(lambda (method-alist wrappers) - (let* ((alist (list nil)) - (alist-tail alist)) - (dolist (constant constants) - (let* ((a (or (dolist (a alist nil) - (when (eq (car a) constant) - (return a))) - (cons constant - (or (convert-table - constant method-alist wrappers) - (convert-methods - constant method-alist wrappers))))) - (new (list a))) - (setf (cdr alist-tail) new) - (setf alist-tail new))) - (let ((function (apply cfunction (mapcar #'cdr (cdr alist))))) - (if function-p - function - (make-fast-method-call - :function (set-function-name function `(sdfun-method ,name)) - :arg-info fmc-arg-info))))))))) + (cond + ((and (eq (car net) 'methods) (not function-p)) + (get-effective-method-function1 generic-function (cadr net))) + (t + (let* ((name (generic-function-name generic-function)) + (arg-info (gf-arg-info generic-function)) + (metatypes (arg-info-metatypes arg-info)) + (applyp (arg-info-applyp arg-info)) + (fmc-arg-info (cons (length metatypes) applyp)) + (arglist (if function-p + (make-dfun-lambda-list metatypes applyp) + (make-fast-method-call-lambda-list metatypes applyp)))) + (multiple-value-bind + (cfunction constants) + (get-function1 `(#+cmu ,(if function-p + 'kernel:instance-lambda + 'lambda) + #-cmu lambda + ,arglist + ,@(unless function-p + `((declare (ignore .pv-cell. + .next-method-call.)))) + #+copy-&rest-arg + ,@(when (and applyp function-p) + `((setq .dfun-rest-arg. + (copy-list .dfun-rest-arg.)))) + (locally (declare #.*optimize-speed*) + (let ((emf ,net)) + ,(make-emf-call metatypes applyp 'emf)))) + #'net-test-converter + #'net-code-converter + #'(lambda (form) + (net-constant-converter form generic-function))) + #'(lambda (method-alist wrappers) + (let* ((alist (list nil)) + (alist-tail alist)) + (dolist (constant constants) + (let* ((a (or (dolist (a alist nil) + (when (eq (car a) constant) + (return a))) + (cons constant + (or (convert-table + constant method-alist wrappers) + (convert-methods + constant method-alist wrappers))))) + (new (list a))) + (setf (cdr alist-tail) new) + (setf alist-tail new))) + (let ((function (apply cfunction (mapcar #'cdr (cdr alist))))) + (if function-p + function + (make-fast-method-call + :function (set-function-name function `(sdfun-method ,name)) + :arg-info fmc-arg-info)))))))))) (defvar *show-make-unordered-methods-emf-calls* nil) diff --git a/pcl/pkg.lisp b/pcl/pkg.lisp index b09f2f47a3bf5add580cba95c1a1ed49b951d4bf..bba0234984d35b5dace25a31f916fb865f5ebcc1 100644 --- a/pcl/pkg.lisp +++ b/pcl/pkg.lisp @@ -64,6 +64,11 @@ #+CMU (shadow '(destructuring-bind) *the-pcl-package*) +#+cmu17 +(shadow '(find-class class-name class-of + class built-in-class structure-class + standard-class) + *the-pcl-package*) #+GCLisp (shadow '(string-append memq assq delq neq make-instance) @@ -154,7 +159,7 @@ #+cmu (shadow 'lisp:dotimes) #+cmu -(import '(kernel:funcallable-instance-p ext:structurep) +(import '(kernel:funcallable-instance-p) *the-pcl-package*) @@ -205,12 +210,12 @@ slot-unbound slot-value standard - standard-class + #-cmu17 standard-class standard-generic-function standard-method standard-object - structure-class - #-cmu symbol-macrolet + #-cmu17 structure-class + #-cmu17 symbol-macrolet update-instance-for-different-class update-instance-for-redefined-class with-accessors @@ -251,9 +256,9 @@ standard-effective-slot-definition specializer eql-specializer - built-in-class + #-cmu17 built-in-class forward-referenced-class - standard-class + #-cmu17 standard-class funcallable-standard-class)) (defvar *chapter-6-exports* diff --git a/pcl/quadlap.lisp b/pcl/quadlap.lisp index 695222bd35f1e91e59696eab80d022a41df7d073..ad90099e53fda91099a6e68bb6c246cb19b7d716 100644 --- a/pcl/quadlap.lisp +++ b/pcl/quadlap.lisp @@ -1,6 +1,6 @@ ;; -[Thu Mar 1 10:54:27 1990 by jkf]- ;; pcl to quad translation -;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/quadlap.lisp,v 1.5 1992/11/09 15:21:37 ram Exp $ +;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/Attic/quadlap.lisp,v 1.6 1997/02/06 21:24:19 pw Exp $ ;; ;; copyright (c) 1990 Franz Inc. ;; diff --git a/pcl/slots-boot.lisp b/pcl/slots-boot.lisp index 56a897169348ae4e97acaea5118ee31216cca742..dadb07cec77c86c5140c0970d87969dfcf974e91 100644 --- a/pcl/slots-boot.lisp +++ b/pcl/slots-boot.lisp @@ -59,10 +59,8 @@ (,sym ,@args) (no-slot ',sym ',slot-name))) -(defun no-slot (slot-name sym) - (error "No class has a slot named ~S (~s has no function binding) - (or maybe your files were compiled with an old version of PCL:~ - try recompiling.)" +(defun no-slot (sym slot-name) + (error "No class has a slot named ~S (~s has no function binding)." slot-name sym)) (defmacro accessor-slot-value (object slot-name) @@ -305,10 +303,7 @@ (list* ':method-spec `(internal-reader-method ,class-name ,slot-name) (make-method-function (lambda (instance) - (let ((wrapper (cond ((std-instance-p instance) - (std-instance-wrapper instance)) - ((fsc-instance-p instance) - (fsc-instance-wrapper instance))))) + (let ((wrapper (get-instance-wrapper-or-nil instance))) (if wrapper (let* ((class (wrapper-class* wrapper)) (index (or (instance-slot-index wrapper slot-name) diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index 6ba1fb0eff126c3191b66114dc6a722840ac1742..480a8d78cd213501fa240444be2d2742e53502cb 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -318,12 +318,14 @@ (defun real-load-defclass (name metaclass-name supers slots other accessors) (do-standard-defsetfs-for-defclass accessors) ;*** - (apply #'ensure-class name :metaclass metaclass-name - :direct-superclasses supers - :direct-slots slots - :definition-source `((defclass ,name) - ,(load-truename)) - other)) + (let ((res (apply #'ensure-class name :metaclass metaclass-name + :direct-superclasses supers + :direct-slots slots + :definition-source `((defclass ,name) + ,(load-truename)) + other))) + #+cmu17 (kernel:layout-class (class-wrapper res)) + #-cmu17 res)) (setf (gdefinition 'load-defclass) #'real-load-defclass) @@ -413,8 +415,10 @@ (dolist (superclass direct-superclasses) (unless (validate-superclass class superclass) (error "The class ~S was specified as a~%super-class of the class ~S;~%~ - but the meta-classes ~S and~%~S are incompatible." - superclass class (class-of superclass) (class-of class)))) + but the meta-classes ~S and~%~S are incompatible.~% + Define a method for ~S to avoid this error." + superclass class (class-of superclass) (class-of class) + 'validate-superclass))) (setf (slot-value class 'direct-superclasses) direct-superclasses)) (setq direct-superclasses (slot-value class 'direct-superclasses))) (setq direct-slots @@ -552,9 +556,13 @@ (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class)) (setf (slot-value class 'slots) (compute-slots class)) - #-new-kcl-wrapper + #-(or cmu17 new-kcl-wrapper) (unless (slot-value class 'wrapper) (setf (slot-value class 'wrapper) (make-wrapper 0 class))) + #+cmu17 + (let ((lclass (lisp:find-class (class-name class)))) + (setf (kernel:class-pcl-class lclass) class) + (setf (slot-value class 'wrapper) (kernel:class-layout lclass))) #+new-kcl-wrapper (let ((wrapper (get (class-name class) 'si::s-data))) (setf (slot-value class 'wrapper) wrapper) @@ -689,14 +697,18 @@ ;; (make-instances-obsolete class) (class-wrapper class))))) + (with-slots (wrapper slots) class #+new-kcl-wrapper (setf (si::s-data-name nwrapper) (class-name class)) + #+cmu17 + (update-lisp-class-layout class nwrapper) (setf slots eslotds (wrapper-instance-slots-layout nwrapper) nlayout (wrapper-class-slots nwrapper) nwrapper-class-slots (wrapper-no-of-instance-slots nwrapper) nslots wrapper nwrapper)) + (unless (eq owrapper nwrapper) (update-pv-table-cache-info class))))) @@ -1021,6 +1033,8 @@ (setf (wrapper-class-slots nwrapper) (wrapper-class-slots owrapper)) (without-interrupts + #+cmu17 + (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) (invalidate-wrapper owrapper ':flush nwrapper)))))) @@ -1044,6 +1058,8 @@ (setf (wrapper-class-slots nwrapper) (wrapper-class-slots owrapper)) (without-interrupts + #+cmu17 + (update-lisp-class-layout class nwrapper) (setf (slot-value class 'wrapper) nwrapper) (invalidate-wrapper owrapper ':obsolete nwrapper) class))) @@ -1072,66 +1088,101 @@ ;;; happening when they should, and that the trap methods are computing ;;; apropriate new wrappers. ;;; -(defun obsolete-instance-trap (owrapper nwrapper instance) - ;; - ;; local --> local transfer - ;; local --> shared discard - ;; local --> -- discard - ;; shared --> local transfer - ;; shared --> shared discard - ;; shared --> -- discard - ;; -- --> local add - ;; -- --> shared -- - ;; - (let* ((class (wrapper-class* nwrapper)) - (guts (allocate-instance class)) ;??? allocate-instance ??? - (olayout (wrapper-instance-slots-layout owrapper)) - (nlayout (wrapper-instance-slots-layout nwrapper)) - (oslots (get-slots instance)) - (nslots (get-slots guts)) - (oclass-slots (wrapper-class-slots owrapper)) - (added ()) - (discarded ()) - (plist ())) - ;; - ;; Go through all the old local slots. - ;; - (iterate ((name (list-elements olayout)) - (opos (interval :from 0))) - (let ((npos (posq name nlayout))) - (if npos - (setf (instance-ref nslots npos) (instance-ref oslots opos)) - (progn (push name discarded) - (unless (eq (instance-ref oslots opos) *slot-unbound*) - (setf (getf plist name) (instance-ref oslots opos))))))) - ;; - ;; Go through all the old shared slots. - ;; - (iterate ((oclass-slot-and-val (list-elements oclass-slots))) - (let ((name (car oclass-slot-and-val)) - (val (cdr oclass-slot-and-val))) - (let ((npos (posq name nlayout))) - (if npos - (setf (instance-ref nslots npos) (cdr oclass-slot-and-val)) - (progn (push name discarded) - (unless (eq val *slot-unbound*) - (setf (getf plist name) val))))))) - ;; - ;; Go through all the new local slots to compute the added slots. - ;; - (dolist (nlocal nlayout) - (unless (or (memq nlocal olayout) - (assq nlocal oclass-slots)) - (push nlocal added))) - - (swap-wrappers-and-slots instance guts) - (update-instance-for-redefined-class instance - added - discarded - plist) - nwrapper)) +;;; obsolete-instance-trap might be called on structure instances +;;; after a structure is redefined. In most cases, obsolete-instance-trap +;;; will not be able to fix the old instance, so it must signal an +;;; error. The hard part of this is that the error system and debugger +;;; might cause obsolete-instance-trap to be called again, so in that +;;; case, we have to return some reasonable wrapper, instead. + +(defvar *in-obsolete-instance-trap* nil) +(defvar *the-wrapper-of-structure-object* + (class-wrapper (find-class 'structure-object))) + +#+cmu17 +(define-condition obsolete-structure (error) + ((datum :reader obsolete-structure-datum :initarg :datum)) + (:report + (lambda (condition stream) + ;; Don't try to print the structure, since it probably + ;; won't work. + (format stream "Obsolete structure error in ~S:~@ + For a structure of type: ~S" + (conditions::condition-function-name condition) + (type-of (obsolete-structure-datum condition)))))) + +(defun obsolete-instance-trap (owrapper nwrapper instance) + (if (not #-(or cmu17 new-kcl-wrapper) + (or (std-instance-p instance) (fsc-instance-p instance)) + #+cmu17 + (pcl-instance-p instance) + #+new-kcl-wrapper + nil) + (if *in-obsolete-instance-trap* + *the-wrapper-of-structure-object* + (let ((*in-obsolete-instance-trap* t)) + #-cmu17 + (error "The structure ~S is obsolete." instance) + #+cmu17 + (error 'obsolete-structure :datum instance))) + (let* ((class (wrapper-class* nwrapper)) + (copy (allocate-instance class)) ;??? allocate-instance ??? + (olayout (wrapper-instance-slots-layout owrapper)) + (nlayout (wrapper-instance-slots-layout nwrapper)) + (oslots (get-slots instance)) + (nslots (get-slots copy)) + (oclass-slots (wrapper-class-slots owrapper)) + (added ()) + (discarded ()) + (plist ())) + ;; local --> local transfer + ;; local --> shared discard + ;; local --> -- discard + ;; shared --> local transfer + ;; shared --> shared discard + ;; shared --> -- discard + ;; -- --> local add + ;; -- --> shared -- + ;; + ;; Go through all the old local slots. + ;; + (iterate ((name (list-elements olayout)) + (opos (interval :from 0))) + (let ((npos (posq name nlayout))) + (if npos + (setf (instance-ref nslots npos) (instance-ref oslots opos)) + (progn + (push name discarded) + (unless (eq (instance-ref oslots opos) *slot-unbound*) + (setf (getf plist name) (instance-ref oslots opos))))))) + ;; + ;; Go through all the old shared slots. + ;; + (iterate ((oclass-slot-and-val (list-elements oclass-slots))) + (let ((name (car oclass-slot-and-val)) + (val (cdr oclass-slot-and-val))) + (let ((npos (posq name nlayout))) + (if npos + (setf (instance-ref nslots npos) (cdr oclass-slot-and-val)) + (progn (push name discarded) + (unless (eq val *slot-unbound*) + (setf (getf plist name) val))))))) + ;; + ;; Go through all the new local slots to compute the added slots. + ;; + (dolist (nlocal nlayout) + (unless (or (memq nlocal olayout) + (assq nlocal oclass-slots)) + (push nlocal added))) + + (swap-wrappers-and-slots instance copy) + (update-instance-for-redefined-class instance + added + discarded + plist) + nwrapper))) ;;; @@ -1151,14 +1202,13 @@ (defun change-class-internal (instance new-class) (let* ((old-class (class-of instance)) - (copy (copy-instance-internal instance)) - (guts (allocate-instance new-class)) - (new-wrapper (get-wrapper guts)) + (copy (allocate-instance new-class)) + (new-wrapper (get-wrapper copy)) (old-wrapper (class-wrapper old-class)) (old-layout (wrapper-instance-slots-layout old-wrapper)) (new-layout (wrapper-instance-slots-layout new-wrapper)) (old-slots (get-slots instance)) - (new-slots (get-slots guts)) + (new-slots (get-slots copy)) (old-class-slots (wrapper-class-slots old-wrapper))) ;; @@ -1184,7 +1234,7 @@ ;; Make the copy point to the old instance's storage, and make the ;; old instance point to the new storage. - (swap-wrappers-and-slots instance guts) + (swap-wrappers-and-slots instance copy) (update-instance-for-different-class copy instance) instance))