X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fctor.lisp;h=0aae966df2eadadaef4d633ca249c1313277b890;hb=57b330cc8334015f9953d7fb82a30afc82d2a471;hp=9ae7add091bf9f1c8c95c6b05814159b74364078;hpb=0aecc2b20142e08068c3434273500131cb13fe2d;p=sbcl.git diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 9ae7add..0aae966 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -86,7 +86,7 @@ (defun constant-symbol-p (form) (and (constantp form) - (let ((constant (eval form))) + (let ((constant (constant-form-value form))) (and (symbolp constant) (not (null (symbol-package constant))))))) @@ -107,11 +107,11 @@ ;;; funcallable instance is set to it. ;;; (!defstruct-with-alternate-metaclass ctor - :slot-names (function-name class-name class initargs) + :slot-names (function-name class-name class initargs safe-p) :boa-constructor %make-ctor :superclass-name function - :metaclass-name random-pcl-classoid - :metaclass-constructor make-random-pcl-classoid + :metaclass-name static-classoid + :metaclass-constructor make-static-classoid :dd-type funcallable-structure :runtime-type-checks-p nil) @@ -134,18 +134,18 @@ (setf (%funcallable-instance-info ctor 1) (ctor-function-name ctor)))) -(defun make-ctor-function-name (class-name initargs) - (list* 'ctor class-name initargs)) +(defun make-ctor-function-name (class-name initargs safe-code-p) + (list* 'ctor class-name safe-code-p initargs)) ;;; Keep this a separate function for testing. -(defun ensure-ctor (function-name class-name initargs) +(defun ensure-ctor (function-name class-name initargs safe-code-p) (unless (fboundp function-name) - (make-ctor function-name class-name initargs))) + (make-ctor function-name class-name initargs safe-code-p))) ;;; Keep this a separate function for testing. -(defun make-ctor (function-name class-name initargs) +(defun make-ctor (function-name class-name initargs safe-p) (without-package-locks ; for (setf symbol-function) - (let ((ctor (%make-ctor function-name class-name nil initargs))) + (let ((ctor (%make-ctor function-name class-name nil initargs safe-p))) (push ctor *all-ctors*) (setf (fdefinition function-name) ctor) (install-initial-constructor ctor :force-p t) @@ -156,12 +156,12 @@ ;;; Compile-Time Expansion of MAKE-INSTANCE ******* ;;; *********************************************** -(define-compiler-macro make-instance (&whole form &rest args) +(define-compiler-macro make-instance (&whole form &rest args &environment env) (declare (ignore args)) - (or (make-instance->constructor-call form) + (or (make-instance->constructor-call form (safe-code-p env)) form)) -(defun make-instance->constructor-call (form) +(defun make-instance->constructor-call (form safe-code-p) (destructuring-bind (fn class-name &rest args) form (declare (ignore fn)) (flet (;; @@ -183,7 +183,7 @@ (loop for (key . more) on args by #'cddr do (when (or (null more) (not (constant-symbol-p key)) - (eq :allow-other-keys (eval key))) + (eq :allow-other-keys (constant-form-value key))) (return-from make-instance->constructor-call nil))))) (check-class) (check-args) @@ -192,7 +192,7 @@ ;; VALUE-FORMS. (multiple-value-bind (initargs value-forms) (loop for (key value) on args by #'cddr and i from 0 - collect (eval key) into initargs + collect (constant-form-value key) into initargs if (constantp value) collect value into initargs else @@ -200,8 +200,9 @@ and collect value into value-forms finally (return (values initargs value-forms))) - (let* ((class-name (eval class-name)) - (function-name (make-ctor-function-name class-name initargs))) + (let* ((class-name (constant-form-value class-name)) + (function-name (make-ctor-function-name class-name initargs + safe-code-p))) ;; Prevent compiler warnings for calling the ctor. (proclaim-as-fun-name function-name) (note-name-defined function-name :function) @@ -215,7 +216,8 @@ `(locally (declare (disable-package-locks ,function-name)) (let ((.x. (load-time-value - (ensure-ctor ',function-name ',class-name ',initargs)))) + (ensure-ctor ',function-name ',class-name ',initargs + ',safe-code-p)))) (declare (ignore .x.)) ;; ??? check if this is worth it. (declare @@ -242,8 +244,15 @@ (let ((class (find-class (ctor-class-name ctor)))) (unless (class-finalized-p class) (finalize-inheritance class)) + ;; We can have a class with an invalid layout here. Such a class + ;; cannot have a LAYOUT-INVALID of (:FLUSH ...) or (:OBSOLETE + ;; ...), because part of the deal is that those only happen from + ;; FORCE-CACHE-FLUSHES, which create a new valid wrapper for the + ;; class. An invalid layout of T needs to be flushed, however. + (when (eq (layout-invalid (class-wrapper class)) t) + (force-cache-flushes class)) (setf (ctor-class ctor) class) - (pushnew ctor (plist-value class 'ctors)) + (pushnew ctor (plist-value class 'ctors) :test #'eq) (setf (funcallable-instance-fun ctor) (multiple-value-bind (form locations names) (constructor-function-form ctor) @@ -333,7 +342,9 @@ (methods &optional standard-method) (loop with primary-checked-p = nil for method in methods - as qualifiers = (method-qualifiers method) + as qualifiers = (if (consp method) + (early-method-qualifiers method) + (safe-method-qualifiers method)) when (or (eq :around (car qualifiers)) (and (null qualifiers) (not primary-checked-p) @@ -351,17 +362,23 @@ ;; 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)))) + (make-instance ,(ctor-class ctor) + ,@(quote-plist-keys (ctor-initargs ctor))))) (defun optimizing-generator (ctor ii-methods si-methods) (multiple-value-bind (locations names body before-method-p) (fake-initialization-emf ctor ii-methods si-methods) - (values - `(lambda ,(make-ctor-parameter-list ctor) - (declare #.*optimize-speed*) - ,(wrap-in-allocate-forms ctor body before-method-p)) - locations - names))) + (let ((wrapper (class-wrapper (ctor-class ctor)))) + (values + `(lambda ,(make-ctor-parameter-list ctor) + (declare #.*optimize-speed*) + (block nil + (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))) + locations + names)))) ;;; Return a form wrapped around BODY that allocates an instance ;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run @@ -387,6 +404,7 @@ .instance.) `(let* ((.instance. (,allocation-function ,wrapper)) (.slots. (,slots-fetcher .instance.))) + (declare (ignorable .slots.)) ,body .instance.)))) @@ -440,7 +458,9 @@ ;;; must be called. (defun standard-sort-methods (applicable-methods) (loop for method in applicable-methods - as qualifiers = (method-qualifiers method) + as qualifiers = (if (consp method) + (early-method-qualifiers method) + (safe-method-qualifiers method)) if (null qualifiers) collect method into primary else if (eq :around (car qualifiers)) @@ -452,6 +472,15 @@ finally (return (values around before (first primary) (reverse after))))) +(defmacro with-type-checked ((type safe-p) &body body) + (if safe-p + ;; To handle FUNCTION types reasonable, we use SAFETY 3 and + ;; THE instead of e.g. CHECK-TYPE. + `(locally + (declare (optimize (safety 3))) + (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 @@ -464,6 +493,7 @@ (let* ((class (ctor-class ctor)) (initargs (ctor-initargs ctor)) (initkeys (plist-keys initargs)) + (safe-p (ctor-safe-p ctor)) (slot-vector (make-array (layout-length (class-wrapper class)) :initial-element nil)) @@ -483,14 +513,14 @@ ((integerp location) (not (null (aref slot-vector location)))) (t (bug "Weird location in ~S" 'slot-init-forms)))) - (class-init (location type val) + (class-init (location kind val type) (aver (consp location)) (unless (initializedp location) - (push (list location type val) class-inits))) - (instance-init (location type val) + (push (list location kind val type) class-inits))) + (instance-init (location kind val type) (aver (integerp location)) (unless (initializedp location) - (setf (aref slot-vector location) (list type val)))) + (setf (aref slot-vector location) (list kind val type)))) (default-init-var-name (i) (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.))) (if (array-in-bounds-p ps i) @@ -504,16 +534,12 @@ ;; Loop over supplied initargs and values and record which ;; instance and class slots they initialize. (loop for (key value) on initargs by #'cddr - as locations = (initarg-locations key) do - (if (constantp value) - (dolist (location locations) - (if (consp location) - (class-init location 'constant value) - (instance-init location 'constant value))) - (dolist (location locations) - (if (consp location) - (class-init location 'param value) - (instance-init location 'param value))))) + as kind = (if (constantp value) 'constant 'param) + as locations = (initarg-locations key) + do (loop for (location . type) in locations + do (if (consp location) + (class-init location kind value type) + (instance-init location kind value type)))) ;; 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 @@ -521,28 +547,29 @@ ;; initargs, that is, their values must be evaluated even ;; if not actually used for initializing a slot. (loop for (key initform initfn) 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))) - (ecase type - (constant - (push key defaulting-initargs) - (push initform defaulting-initargs)) - (var - (push key defaulting-initargs) - (push (default-init-var-name i) defaulting-initargs))) - (when (eq type 'var) + unless (member key initkeys :test #'eq) + do (let* ((kind (if (constantp initform) 'constant 'var)) + (init (if (eq kind 'var) initfn initform))) + (ecase kind + (constant + (push (list 'quote key) defaulting-initargs) + (push initform defaulting-initargs)) + (var + (push (list 'quote key) defaulting-initargs) + (push (default-init-var-name i) defaulting-initargs))) + (when (eq kind '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 for (location . type) in (initarg-locations key) + do (if (consp location) + (class-init location kind init type) + (instance-init location kind init type))))) ;; Loop over all slots of the class, filling in the rest from ;; slot initforms. (loop for slotd in (class-slots class) as location = (slot-definition-location slotd) + as type = (slot-definition-type slotd) as allocation = (slot-definition-allocation slotd) as initfn = (slot-definition-initfunction slotd) as initform = (slot-definition-initform slotd) do @@ -550,53 +577,64 @@ (null initfn) (initializedp location)) (if (constantp initform) - (instance-init location 'initform initform) - (instance-init location 'initform/initfn initfn)))) + (instance-init location 'initform initform type) + (instance-init location 'initform/initfn initfn type)))) ;; Generate the forms for initializing instance and class slots. (let ((instance-init-forms (loop for slot-entry across slot-vector and i from 0 - as (type value) = slot-entry collect - (ecase type + as (kind value type) = slot-entry collect + (ecase kind ((nil) (unless before-method-p `(setf (clos-slots-ref .slots. ,i) +slot-unbound+))) ((param var) - `(setf (clos-slots-ref .slots. ,i) ,value)) + `(setf (clos-slots-ref .slots. ,i) + (with-type-checked (,type ,safe-p) + ,value))) (initfn - `(setf (clos-slots-ref .slots. ,i) (funcall ,value))) + `(setf (clos-slots-ref .slots. ,i) + (with-type-checked (,type ,safe-p) + (funcall ,value)))) (initform/initfn (if before-method-p `(when (eq (clos-slots-ref .slots. ,i) +slot-unbound+) (setf (clos-slots-ref .slots. ,i) - (funcall ,value))) + (with-type-checked (,type ,safe-p) + (funcall ,value)))) `(setf (clos-slots-ref .slots. ,i) - (funcall ,value)))) + (with-type-checked (,type ,safe-p) + (funcall ,value))))) (initform (if before-method-p `(when (eq (clos-slots-ref .slots. ,i) +slot-unbound+) (setf (clos-slots-ref .slots. ,i) - ',(eval value))) + (with-type-checked (,type ,safe-p) + ',(constant-form-value value)))) `(setf (clos-slots-ref .slots. ,i) - ',(eval value)))) + (with-type-checked (,type ,safe-p) + ',(constant-form-value value))))) (constant - `(setf (clos-slots-ref .slots. ,i) ',(eval value))))))) + `(setf (clos-slots-ref .slots. ,i) + (with-type-checked (,type ,safe-p) + ',(constant-form-value value)))))))) ;; we are not allowed to modify QUOTEd locations, so we can't ;; generate code like (setf (cdr ',location) arg). Instead, ;; we have to do (setf (cdr .L0.) arg) and arrange for .L0. to ;; be bound to the location. (multiple-value-bind (names locations class-init-forms) - (loop for (location type value) in class-inits + (loop for (location kind value type) in class-inits for i upfrom 0 for name = (location-var-name i) collect name into names collect location into locations collect `(setf (cdr ,name) - ,(case type - (constant `',(eval value)) - ((param var) `,value) - (initfn `(funcall ,value)))) + (with-type-checked (,type ,safe-p) + ,(case kind + (constant `',(constant-form-value value)) + ((param var) `,value) + (initfn `(funcall ,value))))) into class-init-forms finally (return (values names locations class-init-forms))) (multiple-value-bind (vars bindings) @@ -610,15 +648,18 @@ `(,@(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. +;;; Return an alist of lists (KEY (LOCATION . TYPE-SPECIFIER) ...) +;;; telling, for each key in INITKEYS, which locations the initarg +;;; initializes and the associated type with the location. 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 (loop for slot in slots if (memq key (slot-definition-initargs slot)) - collect (slot-definition-location slot) into locations + collect (cons (slot-definition-location slot) + (slot-definition-type slot)) + into locations else collect slot into remaining-slots finally