X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=6ef538662feda23224bd756c223fb49b2380818e;hb=3c5609fe910bae51ff885c8cfd4be879151e7489;hp=5a3dd010ac6f255739832f4a26abe119cf80da2a;hpb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;p=sbcl.git diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 5a3dd01..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,9 +128,7 @@ (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) @@ -136,16 +140,12 @@ (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) (without-package-locks ; for (setf symbol-function) (let ((ctor (%make-ctor function-name class-name nil initargs))) @@ -175,13 +175,11 @@ (if (array-in-bounds-p ps i) (aref ps i) (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,7 +212,6 @@ (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. @@ -239,12 +234,10 @@ ;;; 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) @@ -260,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) @@ -269,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*) @@ -290,12 +313,23 @@ (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)))) @@ -316,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) @@ -325,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)) @@ -354,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) @@ -381,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 @@ -395,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) @@ -415,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 @@ -423,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)) @@ -468,18 +499,16 @@ (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))))) - ;; ;; Loop over default initargs of the class, recording ;; initializations of slots that have not been initialized ;; above. Default initargs which are not in the supplied ;; initargs are treated as if they were appended to supplied ;; initargs, that is, their values must be evaluated even ;; 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)) @@ -552,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 @@ -584,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* @@ -596,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) @@ -606,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*)