X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=31fc178e16f22674ac67a3550498725866ee84df;hb=d0f65b07a30adc989e36a82ddc0ed54d135d638e;hp=a3c55ae3d922c456ad4ec38da8fff09e38868d7d;hpb=793d5728f040ca8882c24a6f8ac51624a1f0d702;p=sbcl.git diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index a3c55ae..31fc178 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -152,7 +152,21 @@ (ctor-function-name ctor)))) (defun make-ctor-function-name (class-name initargs safe-code-p) - (list* 'ctor class-name safe-code-p initargs)) + (labels ((arg-name (x) + (typecase x + ;; this list of types might look arbitrary but it is + ;; exactly the set of types descended into by EQUAL, + ;; which is the predicate used by globaldb to test for + ;; name equality. + (list (gensym "LIST-INITARG-")) + (string (gensym "STRING-INITARG-")) + (bit-vector (gensym "BIT-VECTOR-INITARG-")) + (pathname (gensym "PATHNAME-INITARG-")) + (t x))) + (munge (list) + (let ((*gensym-counter* 0)) + (mapcar #'arg-name list)))) + (list* 'ctor class-name safe-code-p (munge initargs)))) ;;; Keep this a separate function for testing. (defun ensure-ctor (function-name class-name initargs safe-code-p) @@ -545,7 +559,7 @@ '(:instance :class))) (class-slots class)) (not maybe-invalid-initargs) - (not (around-or-nonstandard-primary-method-p + (not (hairy-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*))) @@ -569,11 +583,28 @@ when (null qualifiers) do (setq primary-checked-p t))) +(defun hairy-around-or-nonstandard-primary-method-p + (methods &optional standard-method) + (loop with primary-checked-p = nil + for method in methods + as qualifiers = (if (consp method) + (early-method-qualifiers method) + (safe-method-qualifiers method)) + when (or (and (eq :around (car qualifiers)) + (not (simple-next-method-call-p method))) + (and (null qualifiers) + (not primary-checked-p) + (not (null standard-method)) + (not (eq standard-method method)))) + return t + when (null qualifiers) do + (setq primary-checked-p t))) + (defun fallback-generator (ctor ii-methods si-methods use-make-instance) (declare (ignore ii-methods si-methods)) (let ((class (ctor-class ctor)) (lambda-list (make-ctor-parameter-list ctor)) - (initargs (quote-plist-keys (ctor-initargs ctor)))) + (initargs (ctor-initargs ctor))) (if use-make-instance `(lambda ,lambda-list (declare #.*optimize-speed*) @@ -581,13 +612,13 @@ ;; *COMPILING-OPTIMIZED-CONSTRUCTOR* which is bound around ;; compilation of the constructor, hence avoiding the ;; possibility of endless recursion. - (make-instance ,class ,@initargs)) + (make-instance ,class ,@(quote-plist-keys initargs))) (let ((defaults (class-default-initargs class))) (when defaults (setf initargs (ctor-default-initargs initargs defaults))) `(lambda ,lambda-list (declare #.*optimize-speed*) - (fast-make-instance ,class ,@initargs)))))) + (fast-make-instance ,class ,@(quote-plist-keys initargs))))))) ;;; Not as good as the real optimizing generator, but faster than going ;;; via MAKE-INSTANCE: 1 GF call less, and no need to check initargs. @@ -600,7 +631,7 @@ (defun optimizing-generator (ctor ii-methods si-methods setf-svuc-slots sbuc-slots) - (multiple-value-bind (locations names body before-method-p) + (multiple-value-bind (locations names body early-unbound-markers-p) (fake-initialization-emf ctor ii-methods si-methods setf-svuc-slots sbuc-slots) (let ((wrapper (class-wrapper (ctor-class ctor)))) @@ -611,18 +642,17 @@ (when (layout-invalid ,wrapper) (install-initial-constructor ,ctor) (return (funcall ,ctor ,@(make-ctor-parameter-list ctor)))) - ,(wrap-in-allocate-forms ctor body before-method-p))) + ,(wrap-in-allocate-forms ctor body early-unbound-markers-p))) locations names t)))) -;;; 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) +;;; Return a form wrapped around BODY that allocates an instance constructed +;;; by CTOR. EARLY-UNBOUND-MARKERS-P means slots may be accessed before we +;;; have explicitly initialized them, requiring all slots to start as +;;; +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 early-unbound-markers-p) (let* ((class (ctor-class ctor)) (wrapper (class-wrapper class)) (allocation-function (raw-instance-allocator class)) @@ -632,8 +662,8 @@ (get-instance-hash-code))) (.slots. (make-array ,(layout-length wrapper) - ,@(when before-method-p - '(:initial-element +slot-unbound+))))) + ,@(when early-unbound-markers-p + '(:initial-element +slot-unbound+))))) (setf (std-instance-wrapper .instance.) ,wrapper) (setf (std-instance-slots .instance.) .slots.) ,body @@ -649,8 +679,8 @@ ;;; 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 ())) +(defmacro invoke-method (method args &optional next-methods) + `(funcall ,(the function (method-function method)) ,args ,next-methods)) ;;; Return a form that is sort of an effective method comprising all ;;; calls to INITIALIZE-INSTANCE and SHARED-INITIALIZE that would @@ -663,34 +693,59 @@ (multiple-value-bind (si-around si-before si-primary si-after) (standard-sort-methods si-methods) (declare (ignore si-primary)) - (aver (and (null ii-around) (null si-around))) - (let ((initargs (ctor-initargs ctor))) + (aver (null si-around)) + (let ((initargs (ctor-initargs ctor)) + ;; :BEFORE and :AROUND initialization methods, and SETF SVUC and + ;; SBUC methods can cause slots to be accessed before the we have + ;; touched them here, which requires the instance-vector to be + ;; initialized with +SLOT-UNBOUND+ to start with. + (early-unbound-markers-p (or ii-before si-before ii-around + setf-svuc-slots sbuc-slots))) (multiple-value-bind (locations names bindings vars defaulting-initargs body) (slot-init-forms ctor - (or ii-before si-before) + early-unbound-markers-p setf-svuc-slots sbuc-slots) (values locations names `(let ,bindings (declare (ignorable ,@vars)) - (let (,@(when (or ii-before ii-after) - `((.ii-args. - (list .instance. ,@(quote-plist-keys initargs) ,@defaulting-initargs)))) - ,@(when (or si-before si-after) - `((.si-args. - (list .instance. t ,@(quote-plist-keys initargs) ,@defaulting-initargs))))) - ,@(loop for method in ii-before - collect `(invoke-method ,method .ii-args.)) - ,@(loop for method in si-before - collect `(invoke-method ,method .si-args.)) - ,@body - ,@(loop for method in si-after - collect `(invoke-method ,method .si-args.)) - ,@(loop for method in ii-after - collect `(invoke-method ,method .ii-args.)))) - (or ii-before si-before))))))) + (flet ((initialize-it (.ii-args. .next-methods.) + ;; This has all the :BEFORE and :AFTER methods, + ;; and BODY does what primary SI method would do. + (declare (ignore .next-methods.)) + (let* ((.instance. (car .ii-args.)) + ,@(when (or si-before si-after) + `((.si-args. + (list* .instance. t (cdr .ii-args.)))))) + ,@(loop for method in ii-before + collect `(invoke-method ,method .ii-args.)) + ,@(loop for method in si-before + collect `(invoke-method ,method .si-args.)) + ,@body + ,@(loop for method in si-after + collect `(invoke-method ,method .si-args.)) + ,@(loop for method in ii-after + collect `(invoke-method ,method .ii-args.)) + .instance.))) + (declare (dynamic-extent #'initialize-it)) + (let ((.ii-args. + ,@(if (or ii-before ii-after ii-around si-before si-after) + `((list .instance. ,@(quote-plist-keys initargs) + ,@defaulting-initargs)) + `((list .instance.))))) + ,(if ii-around + ;; If there are :AROUND methods, call them first -- they get + ;; the normal chaining, with #'INITIALIZE-IT standing in for + ;; the rest. + `(let ((.next-methods. + (list ,@(cdr ii-around) #'initialize-it))) + (declare (dynamic-extent .next-methods.)) + (invoke-method ,(car ii-around) .ii-args. .next-methods.)) + ;; The simple case. + `(initialize-it .ii-args. nil))))) + early-unbound-markers-p)))))) ;;; Return four values from APPLICABLE-METHODS: around methods, before ;;; methods, the applicable primary method, and applicable after @@ -721,15 +776,14 @@ (the ,type (progn ,@body))) `(progn ,@body))) -;;; Return as multiple values bindings for default initialization -;;; arguments, variable names, defaulting initargs and a body for -;;; 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 before-methods will be -;;; called, which means that 1) other code will 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 setf-svuc-slots sbuc-slots) +;;; Return as multiple values bindings for default initialization arguments, +;;; variable names, defaulting initargs and a body for initializing instance +;;; and class slots of an object costructed by CTOR. The variable .SLOTS. is +;;; assumed to bound to the instance's slot vector. EARLY-UNBOUND-MARKERS-P +;;; means other code will initialize instance slots to +SLOT-UNBOUND+, and we +;;; have to check if something has already set slots before we initialize +;;; them. +(defun slot-init-forms (ctor early-unbound-markers-p setf-svuc-slots sbuc-slots) (let* ((class (ctor-class ctor)) (initargs (ctor-initargs ctor)) (initkeys (plist-keys initargs)) @@ -830,13 +884,13 @@ ,value-form)))) (not-boundp-form () (if (member slotd sbuc-slots :test #'eq) - `(slot-boundp-using-class - ,class .instance. ,slotd) + `(not (slot-boundp-using-class + ,class .instance. ,slotd)) `(eq (clos-slots-ref .slots. ,i) +slot-unbound+)))) (ecase kind ((nil) - (unless before-method-p + (unless early-unbound-markers-p `(setf (clos-slots-ref .slots. ,i) +slot-unbound+))) ((param var) @@ -844,12 +898,12 @@ (initfn (setf-form `(funcall ,value))) (initform/initfn - (if before-method-p + (if early-unbound-markers-p `(when ,(not-boundp-form) ,(setf-form `(funcall ,value))) (setf-form `(funcall ,value)))) (initform - (if before-method-p + (if early-unbound-markers-p `(when ,(not-boundp-form) ,(setf-form `',(constant-form-value value))) (setf-form `',(constant-form-value value))))