(defvar *the-system-si-method* nil)
(defun install-optimized-constructor (ctor)
- (let ((class (find-class (ctor-class-name ctor))))
- (unless (class-finalized-p class)
- (finalize-inheritance class))
- (setf (ctor-class ctor) class)
- (pushnew ctor (plist-value class 'ctors))
- (setf (funcallable-instance-fun ctor)
- (multiple-value-bind (form locations names)
- (constructor-function-form ctor)
- (apply (compile nil `(lambda ,names ,form)) locations)))))
+ (with-world-lock ()
+ (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) :test #'eq)
+ (setf (funcallable-instance-fun ctor)
+ (multiple-value-bind (form locations names)
+ (constructor-function-form ctor)
+ (apply (compile nil `(lambda ,names ,form)) locations))))))
(defun constructor-function-form (ctor)
(let* ((class (ctor-class ctor))
(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)
(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
.instance.)
`(let* ((.instance. (,allocation-function ,wrapper))
(.slots. (,slots-fetcher .instance.)))
+ (declare (ignorable .slots.))
,body
.instance.))))
;;; 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))
;; 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* ((kind (if (constantp initform) 'constant 'var))
- (init (if (eq kind 'var) initfn initform)))
- (ecase kind
- (constant
- (push key defaulting-initargs)
- (push initform defaulting-initargs))
- (var
- (push key defaulting-initargs)
- (push (default-init-var-name i) defaulting-initargs)))
+ 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)