X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=6ef538662feda23224bd756c223fb49b2380818e;hb=3c5609fe910bae51ff885c8cfd4be879151e7489;hp=0e094b57dbfaf1e46a15950d208751f637bf135a;hpb=a110dc1207382adf09d84a49be2381de0c688ec8;p=sbcl.git diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 0e094b5..6ef5386 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -62,6 +62,14 @@ ;;; Utilities ******* ;;; ****************** +(defun quote-plist-keys (plist) + (loop for (key . more) on plist by #'cddr + if (null more) do + (error "Not a property list: ~S" plist) + else + collect `(quote ,key) + and collect (car more))) + (defun plist-keys (plist &key test) (loop for (key . more) on plist by #'cddr if (null more) do @@ -108,10 +116,8 @@ (defun make-ctor-parameter-list (ctor) (plist-values (ctor-initargs ctor) :test (complement #'constantp))) -;;; ;;; Reset CTOR to use a default function that will compute an ;;; optimized constructor function when called. -;;; (defun install-initial-constructor (ctor &key force-p) (when (or force-p (ctor-class ctor)) (setf (ctor-class ctor) nil) @@ -122,37 +128,31 @@ (setf (%funcallable-instance-info ctor 1) (ctor-function-name ctor)))) -;;; ;;; Keep this a separate function for testing. -;;; (defun make-ctor-function-name (class-name initargs) (let ((*package* *pcl-package*) (*print-case* :upcase) (*print-pretty* nil) (*print-gensym* t)) - (intern (format nil "CTOR ~S::~S ~S ~S" - (package-name (symbol-package class-name)) - (symbol-name class-name) - (plist-keys initargs) - (plist-values initargs :test #'constantp)) - *pcl-package*))) + (format-symbol *pcl-package* "CTOR ~S::~S ~S ~S" + (package-name (symbol-package class-name)) + (symbol-name class-name) + (plist-keys initargs) + (plist-values initargs :test #'constantp)))) -;;; ;;; Keep this a separate function for testing. -;;; (defun ensure-ctor (function-name class-name initargs) (unless (fboundp function-name) (make-ctor function-name class-name initargs))) -;;; ;;; Keep this a separate function for testing. -;;; (defun make-ctor (function-name class-name initargs) - (let ((ctor (%make-ctor function-name class-name nil initargs))) - (push ctor *all-ctors*) - (setf (symbol-function function-name) ctor) - (install-initial-constructor ctor :force-p t) - ctor)) + (without-package-locks ; for (setf symbol-function) + (let ((ctor (%make-ctor function-name class-name nil initargs))) + (push ctor *all-ctors*) + (setf (symbol-function function-name) ctor) + (install-initial-constructor ctor :force-p t) + ctor))) ;;; *********************************************** @@ -174,14 +174,12 @@ (let ((ps #(.p0. .p1. .p2. .p3. .p4. .p5.))) (if (array-in-bounds-p ps i) (aref ps i) - (intern (format nil ".P~D." i) *pcl-package*)))) - ;; + (format-symbol *pcl-package* ".P~D." i)))) ;; Check if CLASS-NAME is a constant symbol. Give up if ;; not. (check-class () (unless (and class-name (constant-symbol-p class-name)) (return-from make-instance->constructor-call nil))) - ;; ;; Check if ARGS are suitable for an optimized constructor. ;; Return NIL from the outer function if not. (check-args () @@ -192,7 +190,6 @@ (return-from make-instance->constructor-call nil))))) (check-class) (check-args) - ;; ;; Collect a plist of initargs and constant values/parameter names ;; in INITARGS. Collect non-constant initialization forms in ;; VALUE-FORMS. @@ -208,7 +205,6 @@ (return (values initargs value-forms))) (let* ((class-name (eval class-name)) (function-name (make-ctor-function-name class-name initargs))) - ;; ;; Prevent compiler warnings for calling the ctor. (proclaim-as-fun-name function-name) (note-name-defined function-name :function) @@ -216,33 +212,32 @@ (setf (info :function :where-from function-name) :defined) (when (info :function :assumed-type function-name) (setf (info :function :assumed-type function-name) nil))) - ;; ;; Return code constructing a ctor at load time, which, when ;; called, will set its funcallable instance function to an ;; optimized constructor function. - `(let ((.x. (load-time-value - (ensure-ctor ',function-name ',class-name ',initargs)))) - (declare (ignore .x.)) - ;;; ??? check if this is worth it. - (declare - (ftype (or (function ,(make-list (length value-forms) - :initial-element t) - t) - (function (&rest t) t)) - ,function-name)) - (,function-name ,@value-forms))))))) + `(locally + (declare (disable-package-locks ,function-name)) + (let ((.x. (load-time-value + (ensure-ctor ',function-name ',class-name ',initargs)))) + (declare (ignore .x.)) + ;; ??? check if this is worth it. + (declare + (ftype (or (function ,(make-list (length value-forms) + :initial-element t) + t) + (function (&rest t) t)) + ,function-name)) + (,function-name ,@value-forms)))))))) ;;; ************************************************** ;;; Load-Time Constructor Function Generation ******* ;;; ************************************************** -;;; ;;; The system-supplied primary INITIALIZE-INSTANCE and -;;; SHARED-INITIALIZE methods. One cannot initialized these variables +;;; SHARED-INITIALIZE methods. One cannot initialize these variables ;;; to the right values here because said functions don't exist yet ;;; when this file is first loaded. -;;; (defvar *the-system-ii-method* nil) (defvar *the-system-si-method* nil) @@ -258,6 +253,9 @@ ;; deal with INSTANCE-LAMBDA expressions, only with LAMBDA ;; expressions. The below should be equivalent, since we ;; have a compiler-only implementation. + ;; + ;; (except maybe for optimization qualities? -- CSR, + ;; 2004-07-12) (eval `(function ,(constructor-function-form ctor)))))) (defun constructor-function-form (ctor) @@ -267,10 +265,37 @@ (compute-applicable-methods #'make-instance (list class))) (allocate-instance-methods (compute-applicable-methods #'allocate-instance (list class))) + ;; I stared at this in confusion for a while, thinking + ;; carefully about the possibility of the class prototype not + ;; being of sufficient discrimiating power, given the + ;; possibility of EQL-specialized methods on + ;; INITIALIZE-INSTANCE or SHARED-INITIALIZE. However, given + ;; that this is a constructor optimization, the user doesn't + ;; yet have the instance to create a method with such an EQL + ;; specializer. + ;; + ;; There remains the (theoretical) possibility of someone + ;; coming along with code of the form + ;; + ;; (defmethod initialize-instance :before ((o foo) ...) + ;; (eval `(defmethod shared-initialize :before ((o foo) ...) ...))) + ;; + ;; but probably we can afford not to worry about this too + ;; much for now. -- CSR, 2004-07-12 (ii-methods (compute-applicable-methods #'initialize-instance (list proto))) (si-methods - (compute-applicable-methods #'shared-initialize (list proto t)))) + (compute-applicable-methods #'shared-initialize (list proto t))) + (setf-svuc-slots-methods + (loop for slot in (class-slots class) + collect (compute-applicable-methods + #'(setf slot-value-using-class) + (list nil class proto slot)))) + (sbuc-slots-methods + (loop for slot in (class-slots class) + collect (compute-applicable-methods + #'slot-boundp-using-class + (list class proto slot))))) ;; Cannot initialize these variables earlier because the generic ;; functions don't exist when PCL is built. (when (null *the-system-si-method*) @@ -285,14 +310,26 @@ ;; together with the system-defined ones in what ;; COMPUTE-APPLICABLE-METHODS returns. (or (and (not (structure-class-p class)) + (not (condition-class-p class)) (null (cdr make-instance-methods)) (null (cdr allocate-instance-methods)) + (every (lambda (x) + (member (slot-definition-allocation x) + '(:instance :class))) + (class-slots class)) (null (check-initargs-1 class (plist-keys (ctor-initargs ctor)) (append ii-methods si-methods) nil nil)) (not (around-or-nonstandard-primary-method-p ii-methods *the-system-ii-method*)) (not (around-or-nonstandard-primary-method-p si-methods *the-system-si-method*)) + ;; the instance structure protocol goes through + ;; slot-value(-using-class) and friends (actually just + ;; (SETF SLOT-VALUE-USING-CLASS) and + ;; SLOT-BOUNDP-USING-CLASS), so if there are non-standard + ;; applicable methods we can't shortcircuit them. + (every (lambda (x) (= (length x) 1)) setf-svuc-slots-methods) + (every (lambda (x) (= (length x) 1)) sbuc-slots-methods) (optimizing-generator ctor ii-methods si-methods)) (fallback-generator ctor ii-methods si-methods)))) @@ -313,6 +350,11 @@ (defun fallback-generator (ctor ii-methods si-methods) (declare (ignore ii-methods si-methods)) `(instance-lambda ,(make-ctor-parameter-list ctor) + ;; The CTOR MAKE-INSTANCE optimization only kicks in when the + ;; first argument to MAKE-INSTANCE is a constant symbol: by + ;; calling it with a class, as here, we inhibit the optimization, + ;; so removing the possibility of endless recursion. -- CSR, + ;; 2004-07-12 (make-instance ,(ctor-class ctor) ,@(ctor-initargs ctor)))) (defun optimizing-generator (ctor ii-methods si-methods) @@ -322,14 +364,12 @@ (declare #.*optimize-speed*) ,(wrap-in-allocate-forms ctor body before-method-p)))) -;;; ;;; Return a form wrapped around BODY that allocates an instance ;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run ;;; before-methods, in which case we initialize instance slots to ;;; +SLOT-UNBOUND+. The resulting form binds the local variables ;;; .INSTANCE. to the instance, and .SLOTS. to the instance's slot ;;; vector around BODY. -;;; (defun wrap-in-allocate-forms (ctor body before-method-p) (let* ((class (ctor-class ctor)) (wrapper (class-wrapper class)) @@ -351,21 +391,17 @@ ,body .instance.)))) -;;; ;;; Return a form for invoking METHOD with arguments from ARGS. As ;;; can be seen in METHOD-FUNCTION-FROM-FAST-FUNCTION, method ;;; functions look like (LAMBDA (ARGS NEXT-METHODS) ...). We could ;;; call fast method functions directly here, but benchmarks show that ;;; there's no speed to gain, so lets avoid the hair here. -;;; (defmacro invoke-method (method args) `(funcall ,(method-function method) ,args ())) -;;; ;;; Return a form that is sort of an effective method comprising all ;;; calls to INITIALIZE-INSTANCE and SHARED-INITIALIZE that would ;;; normally have taken place when calling MAKE-INSTANCE. -;;; (defun fake-initialization-emf (ctor ii-methods si-methods) (multiple-value-bind (ii-around ii-before ii-primary ii-after) (standard-sort-methods ii-methods) @@ -378,9 +414,11 @@ (slot-inits (slot-init-forms ctor (or ii-before si-before)))) (values `(let (,@(when (or ii-before ii-after) - `((.ii-args. (list .instance. ,@initargs)))) + `((.ii-args. + (list .instance. ,@(quote-plist-keys initargs))))) ,@(when (or si-before si-after) - `((.si-args. (list .instance. t ,@initargs))))) + `((.si-args. + (list .instance. t ,@(quote-plist-keys initargs)))))) ,@(loop for method in ii-before collect `(invoke-method ,method .ii-args.)) ,@(loop for method in si-before @@ -392,12 +430,10 @@ collect `(invoke-method ,method .ii-args.))) (or ii-before si-before)))))) -;;; ;;; Return four values from APPLICABLE-METHODS: around methods, before ;;; methods, the applicable primary method, and applicable after ;;; methods. Before and after methods are sorted in the order they ;;; must be called. -;;; (defun standard-sort-methods (applicable-methods) (loop for method in applicable-methods as qualifiers = (method-qualifiers method) @@ -412,7 +448,6 @@ finally (return (values around before (first primary) (reverse after))))) -;;; ;;; Return a form initializing instance and class slots of an object ;;; costructed by CTOR. The variable .SLOTS. is assumed to bound to ;;; the instance's slot vector. BEFORE-METHOD-P T means @@ -420,7 +455,6 @@ ;;; initialize instance slots to +SLOT-UNBOUND+ before the ;;; before-methods are run, and that we have to check if these ;;; before-methods have set slots. -;;; (defun slot-init-forms (ctor before-method-p) (let* ((class (ctor-class ctor)) (initargs (ctor-initargs ctor)) @@ -455,7 +489,7 @@ (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.))) (if (array-in-bounds-p ps i) (aref ps i) - (intern (format nil ".D~D." i) *the-pcl-package*))))) + (format-symbol *pcl-package* ".D~D." i))))) ;; Loop over supplied initargs and values and record which ;; instance and class slots they initialize. (loop for (key value) on initargs by #'cddr @@ -465,7 +499,7 @@ (if (consp location) (class-init location 'constant value) (instance-init location 'constant value))) - (dolist (location locations) + (dolist (location locations) (if (consp location) (class-init location 'param value) (instance-init location 'param value))))) @@ -477,16 +511,16 @@ ;; if not actually used for initializing a slot. (loop for (key initfn initform) in default-initargs and i from 0 unless (member key initkeys :test #'eq) do - (let* ((type (if (constantp initform) 'constant 'var)) - (init (if (eq type 'var) initfn initform))) - (when (eq type 'var) - (let ((init-var (default-init-var-name i))) - (setq init init-var) - (push (cons init-var initfn) default-inits))) - (dolist (location (initarg-locations key)) - (if (consp location) - (class-init location type init) - (instance-init location type init))))) + (let* ((type (if (constantp initform) 'constant 'var)) + (init (if (eq type 'var) initfn initform))) + (when (eq type 'var) + (let ((init-var (default-init-var-name i))) + (setq init init-var) + (push (cons init-var initfn) default-inits))) + (dolist (location (initarg-locations key)) + (if (consp location) + (class-init location type init) + (instance-init location type init))))) ;; Loop over all slots of the class, filling in the rest from ;; slot initforms. (loop for slotd in (class-slots class) @@ -547,11 +581,9 @@ ,@(delete nil instance-init-forms) ,@class-init-forms)))))) -;;; ;;; Return an alist of lists (KEY LOCATION ...) telling, for each ;;; key in INITKEYS, which locations the initarg initializes. ;;; CLASS is the class of the instance being initialized. -;;; (defun compute-initarg-locations (class initkeys) (loop with slots = (class-slots class) for key in initkeys collect @@ -579,11 +611,9 @@ (dolist (subclass (class-direct-subclasses class)) (reset subclass ri-cache-p ctorsp)))) (ecase reason - ;; ;; CLASS must have been specified. (finalize-inheritance (reset class t)) - ;; ;; NAME must have been specified. (setf-find-class (loop for ctor in *all-ctors* @@ -591,7 +621,6 @@ (when (ctor-class ctor) (reset (ctor-class ctor))) (loop-finish))) - ;; ;; GENERIC-FUNCTION and METHOD must have been specified. ((add-method remove-method) (flet ((class-of-1st-method-param (method) @@ -601,7 +630,15 @@ initialize-instance shared-initialize) (reset (class-of-1st-method-param method) t t)) ((reinitialize-instance) - (reset (class-of-1st-method-param method) t nil)))))))) + (reset (class-of-1st-method-param method) t nil)) + (t (when (or (eq (generic-function-name generic-function) + 'slot-boundp-using-class) + (equal (generic-function-name generic-function) + '(setf slot-value-using-class))) + ;; this looks awfully expensive, but given that one + ;; can specialize on the SLOTD argument, nothing is + ;; safe. -- CSR, 2004-07-12 + (reset (find-class 'standard-object)))))))))) (defun precompile-ctors () (dolist (ctor *all-ctors*)