From 76272c4ebd1570eec4f2e323723be3272e8ea3c7 Mon Sep 17 00:00:00 2001 From: gerd <gerd> Date: Wed, 7 May 2003 17:14:24 +0000 Subject: [PATCH] Add a deftransform for extracting slot vectors. This can be done because redefinitions from funcallable instances to instances aren't required to work, and cannot be made to work. * src/pcl/low.lisp (fsc-instance-wrapper, fsc-instance-slots) (fsc-instance-hash): Moved here from fin.lisp. (pcl::pcl-instance-p) <deftransform>: Use info-standard-class-p and info-funcallable-standard-class-p. (pcl::slot-vector-or-nil) <deftransform>: New. (slot-vector-or-nil): New function. * src/pcl/info.lisp (info-std-class-p): Removed. (info-standard-class-p, info-funcallable-standard-class-p): New functions. * src/pcl/fin.lisp (fsc-instance-wrapper, fsc-instance-slots) (fsc-instance-hash): Moved to low.lisp. * src/pcl/vector.lisp (pv-binding1): Use slot-vector-or-nil instead of get-slots-or-nil. --- pcl/fin.lisp | 17 +--------- pcl/info.lisp | 24 +++++++------- pcl/low.lisp | 85 +++++++++++++++++++++++++++++++++++++++---------- pcl/vector.lisp | 4 +-- 4 files changed, 84 insertions(+), 46 deletions(-) diff --git a/pcl/fin.lisp b/pcl/fin.lisp index 05ce22ce3..38e9d89c2 100644 --- a/pcl/fin.lisp +++ b/pcl/fin.lisp @@ -25,7 +25,7 @@ ;;; ************************************************************************* (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fin.lisp,v 1.21 2003/05/04 13:11:21 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/fin.lisp,v 1.22 2003/05/07 17:14:24 gerd Rel $") ;;; ;; @@ -150,18 +150,3 @@ explicitly marked saying who wrote it. (assert (funcallable-instance-p fin)) (setf (kernel:funcallable-instance-function fin) new-value)) - -;;;; Slightly Higher-Level stuff built on the implementation-dependent stuff. -;;; - -(defmacro fsc-instance-p (fin) - `(funcallable-instance-p ,fin)) - -(defmacro fsc-instance-wrapper (fin) - `(kernel:%funcallable-instance-layout ,fin)) - -(defmacro fsc-instance-slots (fin) - `(kernel:%funcallable-instance-info ,fin 0)) - -(defmacro fsc-instance-hash (fin) - `(kernel:%funcallable-instance-info ,fin 2)) diff --git a/pcl/info.lisp b/pcl/info.lisp index 99a60b7f4..0b547236b 100644 --- a/pcl/info.lisp +++ b/pcl/info.lisp @@ -36,7 +36,7 @@ ;;; GF is actually non-accessor GF. Clean this up. ;;; (setf symbol-value) should be handled like (setf fdefinition) -(file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/info.lisp,v 1.4 2003/05/04 13:11:21 gerd Exp $") +(file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/info.lisp,v 1.5 2003/05/07 17:14:24 gerd Exp $") (in-package "PCL") @@ -233,18 +233,18 @@ (slot-definition-type slotd))))) ;;; -;;; Return T if CLASS-NAME names a STD-CLASS, that is, either a -;;; STANDARD-CLASS or FUNCALLABLE-STANDARD-CLASS in normal MOP spaak. +;;; Test if a class names a STANDARD-CLASS or FUNCALLABLE-STANDARD-CLASS. ;;; -;;; Structure classes are defined at compile-time, see the EVAL in -;;; EXPAND-DEFCLASS. If it's a structure, the class must be defined, -;;; and be a structure class. -;;; -(defun info-std-class-p (class-name) - (let ((class (find-class class-name nil))) - (if class - (std-class-p class) - (class-info class-name)))) +(macrolet ((defpred (name metaclass) + `(defun ,name (class-name) + (let ((class (find-class class-name nil))) + (if class + (typep class ',metaclass) + (let* ((info (class-info class-name)) + (meta (and info (class-info-metaclass info)))) + (eq meta ',metaclass))))))) + (defpred info-funcallable-standard-class-p funcallable-standard-class) + (defpred info-standard-class-p standard-class)) ;;; ************** diff --git a/pcl/low.lisp b/pcl/low.lisp index 1f7a36bf2..62aa373fb 100644 --- a/pcl/low.lisp +++ b/pcl/low.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.24 2003/05/04 13:11:21 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/low.lisp,v 1.25 2003/05/07 17:14:24 gerd Exp $") ;;; ;;; This file contains optimized low-level constructs for PCL. @@ -167,14 +167,36 @@ the compiler as completely as possible. Currently this means that ;;;; STD-INSTANCE -;;; Under CMU17 conditional, STD-INSTANCE-P is only used to discriminate -;;; between functions (including FINs) and normal instances, so we can return -;;; true on structures also. A few uses of (or std-instance-p fsc-instance-p) +;;; STD-INSTANCE-P is only used to discriminate between functions +;;; (including FINs) and normal instances, so we can return true on +;;; structures also. A few uses of (or std-instance-p fsc-instance-p) ;;; are changed to pcl-instance-p. ;;; (defmacro std-instance-p (x) `(kernel:%instancep ,x)) +(defmacro std-instance-slots (x) + `(kernel:%instance-ref ,x 1)) + +(defmacro std-instance-hash (x) + `(kernel:%instance-ref ,x 2)) + +(defmacro std-instance-wrapper (x) + `(kernel:%instance-layout ,x)) + +(defmacro fsc-instance-p (fin) + `(funcallable-instance-p ,fin)) + +(defmacro fsc-instance-wrapper (fin) + `(kernel:%funcallable-instance-layout ,fin)) + +(defmacro fsc-instance-slots (fin) + `(kernel:%funcallable-instance-info ,fin 0)) + +(defmacro fsc-instance-hash (fin) + `(kernel:%funcallable-instance-info ,fin 2)) + + ;;; PCL-INSTANCE-P is implemented via a compiler transform so that the ;;; test can be optimised away when the result is known, such as is ;;; typically the case during slot access within methods, see @@ -186,20 +208,56 @@ the compiler as completely as possible. Currently this means that (movable foldable flushable explicit-check)) (deftransform pcl::pcl-instance-p ((object)) - (let* ((object-type (continuation-type object)) + (let* ((ctype (continuation-type object)) (standard-object (specifier-type 'standard-object))) - (cond ((csubtypep object-type standard-object) + (cond ((csubtypep ctype standard-object) t) - ((not (types-intersect object-type standard-object)) + ((not (types-intersect ctype standard-object)) nil) - ((and (kernel::standard-class-p object-type) - (pcl::info-std-class-p (kernel:%class-name object-type))) + ((and (kernel::standard-class-p ctype) + (let ((class-name (kernel:%class-name ctype))) + (or (pcl::info-standard-class-p class-name) + (pcl::info-funcallable-standard-class-p class-name)))) t) (t `(typep (kernel:layout-of object) 'pcl::wrapper))))) +(defknown pcl::slot-vector-or-nil (t) + (or null simple-vector) + (movable foldable flushable)) + +(deftransform pcl::slot-vector-or-nil ((object)) + (let ((ctype (continuation-type object)) + (funcallable-standard-object + (specifier-type 'mop:funcallable-standard-object)) + (standard-object (specifier-type 'standard-object))) + (cond ((or (csubtypep ctype funcallable-standard-object) + (and (kernel::standard-class-p ctype) + (pcl::info-funcallable-standard-class-p + (kernel:%class-name ctype)))) + (print "funcallable") + '(kernel:%funcallable-instance-info object 0)) + ((or (csubtypep ctype standard-object) + (and (kernel::standard-class-p ctype) + (pcl::info-standard-class-p (kernel:%class-name ctype)))) + (print "instance") + '(kernel:%instance-ref object 1)) + (t + (print "give-up") + `(when (pcl::pcl-instance-p object) + (if (pcl::std-instance-p object) + (pcl::std-instance-slots object) + (pcl::fsc-instance-slots object))))))) + (in-package "PCL") +;;; Definition for interpreted code. +(defun slot-vector-or-nil (obj) + (when (pcl-instance-p obj) + (if (std-instance-p obj) + (std-instance-slots obj) + (fsc-instance-slots obj)))) + ;;; Definition for interpreted code. (defun pcl-instance-p (x) (typep (kernel:layout-of x) 'wrapper)) @@ -225,13 +283,6 @@ the compiler as completely as possible. Currently this means that (hash-code (get-instance-hash-code) :type fixnum)) -;;; Both of these operations "work" on structures, which allows the above -;;; weakening of std-instance-p. -;;; -(defmacro std-instance-slots (x) `(kernel:%instance-ref ,x 1)) -(defmacro std-instance-hash (x) `(kernel:%instance-ref ,x 2)) -(defmacro std-instance-wrapper (x) `(kernel:%instance-layout ,x)) - (defmacro built-in-or-structure-wrapper (x) `(kernel:layout-of ,x)) (defmacro get-wrapper (inst) @@ -397,6 +448,7 @@ the compiler as completely as possible. Currently this means that (in-package "PCL") +#+bootable-pcl (defun early-pcl-init () ;; defsys (setq *the-pcl-package* (find-package "PCL")) @@ -410,6 +462,7 @@ the compiler as completely as possible. Currently this means that ;; invoke the compiler. (setq *cold-boot-state* t)) +#+bootable-pcl (defun final-pcl-init () (setq *cold-boot-state* nil) (setq *compile-lambda-silent-p* t) diff --git a/pcl/vector.lisp b/pcl/vector.lisp index b0d3daa9b..fd2ea8540 100644 --- a/pcl/vector.lisp +++ b/pcl/vector.lisp @@ -26,7 +26,7 @@ ;;; (file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.28 2003/05/04 13:11:20 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/pcl/vector.lisp,v 1.29 2003/05/07 17:14:24 gerd Rel $") (in-package :pcl) @@ -716,7 +716,7 @@ (multiple-value-bind (bindings vars) (loop for v in slot-vars and p in pv-parameters when v - collect `(,v (get-slots-or-nil ,p)) into bindings + collect `(,v (slot-vector-or-nil ,p)) into bindings and collect v into vars finally (return (values bindings vars))) -- GitLab