X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Ffast-init.lisp;h=b43537601a6b7cf5c0f09e78716c9542b254bde7;hb=0704fd3f3f027ec1be05ddb986b6ca538aa165ca;hp=37200f3032dbb99bf1e78a69952cabc6b6f26cd2;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp index 37200f3..b435376 100644 --- a/src/pcl/fast-init.lisp +++ b/src/pcl/fast-init.lisp @@ -24,9 +24,6 @@ ;;;; specification. (in-package "SB-PCL") - -(sb-int:file-comment - "$Header$") (defvar *compile-make-instance-functions-p* nil) @@ -46,7 +43,7 @@ (defun expand-make-instance-form (form) (let ((class (cadr form)) (initargs (cddr form)) - (keys nil)(allow-other-keys-p nil) key value) + (keys nil) (allow-other-keys-p nil) key value) (when (and (constant-symbol-p class) (let ((initargs-tail initargs)) (loop (when (null initargs-tail) (return t)) @@ -54,7 +51,7 @@ (return nil)) (setq key (eval (pop initargs-tail))) (setq value (pop initargs-tail)) - (when (eq ':allow-other-keys key) + (when (eq :allow-other-keys key) (setq allow-other-keys-p value)) (push key keys)))) (let* ((class (eval class)) @@ -63,9 +60,21 @@ (sym (make-instance-function-symbol key))) (push key *make-instance-function-keys*) (when sym + ;; (famous last words: + ;; 1. Don't worry, I know what I'm doing. + ;; 2. You and what army? + ;; 3. If you were as smart as you think you are, you + ;; wouldn't be a copy. + ;; This is case #1.:-) Even if SYM hasn't been defined yet, + ;; it must be an implementation function, or we we wouldn't + ;; have expanded into it. So declare SYM as defined, so that + ;; even if it hasn't been defined yet, the user doesn't get + ;; obscure warnings about undefined internal implementation + ;; functions like HAIRY-MAKE-instance-name. + (sb-kernel:become-defined-fun-name sym) `(,sym ',class (list ,@initargs))))))) -(defmacro expanding-make-instance-top-level (&rest forms &environment env) +(defmacro expanding-make-instance-toplevel (&rest forms &environment env) (let* ((*make-instance-function-keys* nil) (form (macroexpand `(expanding-make-instance ,@forms) env))) `(progn @@ -75,23 +84,17 @@ (defmacro expanding-make-instance (&rest forms &environment env) `(progn - ,@(mapcar #'(lambda (form) - (walk-form form env - #'(lambda (subform context env) - (declare (ignore env)) - (or (and (eq context ':eval) - (consp subform) - (eq (car subform) 'make-instance) - (expand-make-instance-form subform)) - subform)))) + ,@(mapcar (lambda (form) + (walk-form form env + (lambda (subform context env) + (declare (ignore env)) + (or (and (eq context :eval) + (consp subform) + (eq (car subform) 'make-instance) + (expand-make-instance-form subform)) + subform)))) forms))) -(defmacro defconstructor - (name class lambda-list &rest initialization-arguments) - `(expanding-make-instance-top-level - (defun ,name ,lambda-list - (make-instance ',class ,@initialization-arguments)))) - (defun get-make-instance-functions (key-list) (dolist (key key-list) (let* ((cell (find-class-cell (car key))) @@ -138,7 +141,7 @@ (cached-name (intern (format nil "~A-CACHED-~A" type name)))) `(defmacro ,reader-name (info) `(let ((value (,',cached-name ,info))) - (if (eq value ':unknown) + (if (eq value :unknown) (progn (,',trap ,info ',',name) (,',cached-name ,info)) @@ -151,8 +154,8 @@ initargs-form-list new-keys default-initargs-function - shared-initialize-t-function - shared-initialize-nil-function + shared-initialize-t-fun + shared-initialize-nil-fun constants combined-initialize-function ; allocate-instance + shared-initialize make-instance-function ; nil means use gf @@ -160,35 +163,35 @@ (defmacro define-initialize-info () (let ((cached-slot-names - (mapcar #'(lambda (name) - (intern (format nil "CACHED-~A" name))) + (mapcar (lambda (name) + (intern (format nil "CACHED-~A" name))) *initialize-info-cached-slots*)) (cached-names - (mapcar #'(lambda (name) - (intern (format nil "~A-CACHED-~A" - 'initialize-info name))) + (mapcar (lambda (name) + (intern (format nil "~A-CACHED-~A" + 'initialize-info name))) *initialize-info-cached-slots*))) `(progn - (defstruct initialize-info + (defstruct (initialize-info (:copier nil)) key wrapper - ,@(mapcar #'(lambda (name) - `(,name :unknown)) + ,@(mapcar (lambda (name) + `(,name :unknown)) cached-slot-names)) (defmacro reset-initialize-info-internal (info) `(progn - ,@(mapcar #'(lambda (cname) - `(setf (,cname ,info) ':unknown)) + ,@(mapcar (lambda (cname) + `(setf (,cname ,info) :unknown)) ',cached-names))) (defun initialize-info-bound-slots (info) (let ((slots nil)) - ,@(mapcar #'(lambda (name cached-name) - `(unless (eq ':unknown (,cached-name info)) - (push ',name slots))) + ,@(mapcar (lambda (name cached-name) + `(unless (eq :unknown (,cached-name info)) + (push ',name slots))) *initialize-info-cached-slots* cached-names) slots)) - ,@(mapcar #'(lambda (name) - `(define-cached-reader initialize-info ,name - update-initialize-info-internal)) + ,@(mapcar (lambda (name) + `(define-cached-reader initialize-info ,name + update-initialize-info-internal)) *initialize-info-cached-slots*)))) (define-initialize-info) @@ -221,7 +224,11 @@ (dolist (a alist) (reset-class-initialize-info-1 (cdr a)))))) -(defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg) +(defun initialize-info (class + initargs + &optional + (plist-p t) + allow-other-keys-arg) (let ((info nil)) (if (and (eq *initialize-info-cache-class* class) (eq *initialize-info-cache-initargs* initargs)) @@ -275,12 +282,13 @@ ((initargs-form-list new-keys) (multiple-value-bind (initargs-form-list new-keys) (make-default-initargs-form-list class keys) - (setf (initialize-info-cached-initargs-form-list info) initargs-form-list) + (setf (initialize-info-cached-initargs-form-list info) + initargs-form-list) (setf (initialize-info-cached-new-keys info) new-keys))) ((default-initargs-function) (let ((initargs-form-list (initialize-info-initargs-form-list info))) (setf (initialize-info-cached-default-initargs-function info) - (initialize-instance-simple-function + (initialize-instance-simple-fun 'default-initargs-function info class initargs-form-list)))) ((valid-p ri-valid-p) @@ -302,21 +310,21 @@ (compute-valid-p (list (list* 'reinitialize-instance proto nil) (list* 'shared-initialize proto nil nil))))))) - ((shared-initialize-t-function) + ((shared-initialize-t-fun) (multiple-value-bind (initialize-form-list ignore) (make-shared-initialize-form-list class keys t nil) (declare (ignore ignore)) - (setf (initialize-info-cached-shared-initialize-t-function info) - (initialize-instance-simple-function - 'shared-initialize-t-function info + (setf (initialize-info-cached-shared-initialize-t-fun info) + (initialize-instance-simple-fun + 'shared-initialize-t-fun info class initialize-form-list)))) - ((shared-initialize-nil-function) + ((shared-initialize-nil-fun) (multiple-value-bind (initialize-form-list ignore) (make-shared-initialize-form-list class keys nil nil) (declare (ignore ignore)) - (setf (initialize-info-cached-shared-initialize-nil-function info) - (initialize-instance-simple-function - 'shared-initialize-nil-function info + (setf (initialize-info-cached-shared-initialize-nil-fun info) + (initialize-instance-simple-fun + 'shared-initialize-nil-fun info class initialize-form-list)))) ((constants combined-initialize-function) (let ((initargs-form-list (initialize-info-initargs-form-list info)) @@ -325,7 +333,7 @@ (make-shared-initialize-form-list class new-keys t t) (setf (initialize-info-cached-constants info) constants) (setf (initialize-info-cached-combined-initialize-function info) - (initialize-instance-simple-function + (initialize-instance-simple-fun 'combined-initialize-function info class (append initargs-form-list initialize-form-list)))))) ((make-instance-function-symbol) @@ -348,7 +356,7 @@ (setq class (find-class class))) (when (classp class) (unless (class-finalized-p class) (finalize-inheritance class))) - (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys)) + (let* ((initargs (mapcan (lambda (key) (list key nil)) keys)) (class-and-initargs (list* class initargs)) (make-instance (gdefinition 'make-instance)) (make-instance-methods @@ -369,12 +377,13 @@ (list* proto t initargs))))) (when (null make-instance-methods) (return-from get-make-instance-function - #'(lambda (class initargs) - (apply #'no-applicable-method make-instance class initargs)))) + (lambda (class initargs) + (apply #'no-applicable-method make-instance class initargs)))) (unless (and (null (cdr make-instance-methods)) (eq (car make-instance-methods) std-mi-meth) (null (cdr default-initargs-methods)) - (eq (car (method-specializers (car default-initargs-methods))) + (eq (car (method-specializers + (car default-initargs-methods))) *the-class-slot-class*) (flet ((check-meth (meth) (let ((quals (method-qualifiers meth))) @@ -382,8 +391,8 @@ (eq (car (method-specializers meth)) *the-class-slot-object*) (and (null (cdr quals)) - (or (eq (car quals) ':before) - (eq (car quals) ':after))))))) + (or (eq (car quals) :before) + (eq (car quals) :after))))))) (and (every #'check-meth initialize-instance-methods) (every #'check-meth shared-initialize-methods)))) (return-from get-make-instance-function nil)) @@ -422,7 +431,7 @@ (defun complicated-instance-creation-method (m) (let ((qual (method-qualifiers m))) (if qual - (not (and (null (cdr qual)) (eq (car qual) ':after))) + (not (and (null (cdr qual)) (eq (car qual) :after))) (let ((specl (car (method-specializers m)))) (or (not (classp specl)) (not (eq 'slot-object (class-name specl)))))))) @@ -464,36 +473,36 @@ (std-si-meth (find-standard-ii-method shared-initialize-methods 'slot-object)) (shared-initfns - (nreverse (mapcar #'(lambda (method) - (make-effective-method-function - #'shared-initialize - `(call-method ,method nil) - nil lwrapper)) + (nreverse (mapcar (lambda (method) + (make-effective-method-function + #'shared-initialize + `(call-method ,method nil) + nil lwrapper)) (remove std-si-meth shared-initialize-methods)))) (std-ii-meth (find-standard-ii-method initialize-instance-methods 'slot-object)) (initialize-initfns - (nreverse (mapcar #'(lambda (method) - (make-effective-method-function - #'initialize-instance - `(call-method ,method nil) - nil lwrapper)) + (nreverse (mapcar (lambda (method) + (make-effective-method-function + #'initialize-instance + `(call-method ,method nil) + nil lwrapper)) (remove std-ii-meth initialize-instance-methods))))) - #'(lambda (class1 initargs) - (if (not (eq wrapper (class-wrapper class))) - (let* ((info (initialize-info class1 initargs)) - (fn (initialize-info-make-instance-function info))) - (declare (type function fn)) - (funcall fn class1 initargs)) - (let* ((instance (funcall allocate-function wrapper constants)) - (initargs (call-initialize-function initialize-function - instance initargs))) - (dolist (fn shared-initfns) - (invoke-effective-method-function fn t instance t initargs)) - (dolist (fn initialize-initfns) - (invoke-effective-method-function fn t instance initargs)) - instance)))))) + (lambda (class1 initargs) + (if (not (eq wrapper (class-wrapper class))) + (let* ((info (initialize-info (coerce-to-class class1) initargs)) + (fn (initialize-info-make-instance-function info))) + (declare (type function fn)) + (funcall fn class1 initargs)) + (let* ((instance (funcall allocate-function wrapper constants)) + (initargs (call-initialize-function initialize-function + instance initargs))) + (dolist (fn shared-initfns) + (invoke-effective-method-function fn t instance t initargs)) + (dolist (fn initialize-initfns) + (invoke-effective-method-function fn t instance initargs)) + instance)))))) (defun make-instance-function-complex (key class keys initialize-instance-methods @@ -505,49 +514,57 @@ (get-secondary-dispatch-function #'shared-initialize shared-initialize-methods `((class-eq ,class) t t) - `((,(find-standard-ii-method shared-initialize-methods 'slot-object) - ,#'(lambda (instance init-type &rest initargs) - (declare (ignore init-type)) - (call-initialize-function initialize-function - instance initargs) - instance))) + `((,(find-standard-ii-method shared-initialize-methods + 'slot-object) + ,(lambda (instance init-type &rest initargs) + (declare (ignore init-type)) + (call-initialize-function initialize-function + instance initargs) + instance))) (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*))) (initialize-instance (get-secondary-dispatch-function #'initialize-instance initialize-instance-methods `((class-eq ,class) t) - `((,(find-standard-ii-method initialize-instance-methods 'slot-object) - ,#'(lambda (instance &rest initargs) - (invoke-effective-method-function - shared-initialize t instance t initargs)))) + `((,(find-standard-ii-method initialize-instance-methods + 'slot-object) + ,(lambda (instance &rest initargs) + (invoke-effective-method-function + shared-initialize t instance t initargs)))) (list wrapper *the-wrapper-of-t*)))) - #'(lambda (class1 initargs) - (if (not (eq wrapper (class-wrapper class))) - (let* ((info (initialize-info class1 initargs)) - (fn (initialize-info-make-instance-function info))) - (declare (type function fn)) - (funcall fn class1 initargs)) - (let* ((initargs (call-initialize-function initargs-function - nil initargs)) - (instance (apply #'allocate-instance class initargs))) - (invoke-effective-method-function - initialize-instance t instance initargs) - instance)))))) - -(defun get-simple-initialization-function (class keys &optional allow-other-keys-arg) + (lambda (class1 initargs) + (if (not (eq wrapper (class-wrapper class))) + (let* ((info (initialize-info (coerce-to-class class1) initargs)) + (fn (initialize-info-make-instance-function info))) + (declare (type function fn)) + (funcall fn class1 initargs)) + (let* ((initargs (call-initialize-function initargs-function + nil initargs)) + (instance (apply #'allocate-instance class initargs))) + (invoke-effective-method-function + initialize-instance t instance initargs) + instance)))))) + +(defun get-simple-initialization-function (class + keys + &optional allow-other-keys-arg) (let ((info (initialize-info class keys nil allow-other-keys-arg))) (values (initialize-info-combined-initialize-function info) (initialize-info-constants info)))) -(defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg - separate-p) +(defun get-complex-initialization-functions (class + keys + &optional + allow-other-keys-arg + separate-p) (let* ((info (initialize-info class keys nil allow-other-keys-arg)) - (default-initargs-function (initialize-info-default-initargs-function info))) + (default-initargs-function (initialize-info-default-initargs-function + info))) (if separate-p (values default-initargs-function - (initialize-info-shared-initialize-t-function info)) + (initialize-info-shared-initialize-t-fun info)) (values default-initargs-function - (initialize-info-shared-initialize-t-function + (initialize-info-shared-initialize-t-fun (initialize-info class (initialize-info-new-keys info) nil allow-other-keys-arg)))))) @@ -565,10 +582,10 @@ (default-initargs (class-default-initargs class)) (nkeys keys) (slots-alist - (mapcan #'(lambda (slot) - (mapcar #'(lambda (arg) - (cons arg slot)) - (slot-definition-initargs slot))) + (mapcan (lambda (slot) + (mapcar (lambda (arg) + (cons arg slot)) + (slot-definition-initargs slot))) (class-slots class))) (nslots nil)) (dolist (key nkeys) @@ -602,15 +619,15 @@ (wrapper (class-wrapper class)) (constants (when simple-p (make-list (wrapper-no-of-instance-slots wrapper) - ':initial-element *slot-unbound*))) + :initial-element +slot-unbound+))) (slots (class-slots class)) (slot-names (mapcar #'slot-definition-name slots)) - (slots-key (mapcar #'(lambda (slot) - (let ((index most-positive-fixnum)) - (dolist (key (slot-definition-initargs slot)) - (let ((pos (position key keys))) - (when pos (setq index (min index pos))))) - (cons slot index))) + (slots-key (mapcar (lambda (slot) + (let ((index most-positive-fixnum)) + (dolist (key (slot-definition-initargs slot)) + (let ((pos (position key keys))) + (when pos (setq index (min index pos))))) + (cons slot index))) slots)) (slots (stable-sort slots-key #'< :key #'cdr))) (let ((n-popped 0)) @@ -629,7 +646,7 @@ (let* ((slot (car slot+index)) (name (slot-definition-name slot))) (when (and (eql (cdr slot+index) most-positive-fixnum) - (or (eq si-slot-names 't) + (or (eq si-slot-names t) (member name si-slot-names))) (let* ((initform (slot-definition-initform slot)) (initfunction (slot-definition-initfunction slot)) @@ -641,7 +658,8 @@ ((constantp initform) (let ((value (funcall initfunction))) (if (and simple-p (integerp location)) - (progn (setf (nth location constants) value) + (progn (setf (nth location constants) + value) nil) `((const ,value) (instance-set ,pv-offset ,slot))))) @@ -670,21 +688,21 @@ (defvar *initialize-instance-simple-alist* nil) (defvar *note-iis-entry-p* nil) -(defvar *compiled-initialize-instance-simple-functions* +(defvar *compiled-initialize-instance-simple-funs* (make-hash-table :test 'equal)) -(defun initialize-instance-simple-function (use info class form-list) +(defun initialize-instance-simple-fun (use info class form-list) (let* ((pv-cell (get-pv-cell-for-class class)) (key (initialize-info-key info)) (sf-key (list* use (class-name (car key)) (cdr key)))) (if (or *compile-make-instance-functions-p* - (gethash sf-key *compiled-initialize-instance-simple-functions*)) + (gethash sf-key *compiled-initialize-instance-simple-funs*)) (multiple-value-bind (form args) (form-list-to-lisp pv-cell form-list) (let ((entry (assoc form *initialize-instance-simple-alist* :test #'equal))) (setf (gethash sf-key - *compiled-initialize-instance-simple-functions*) + *compiled-initialize-instance-simple-funs*) t) (if entry (setf (cdddr entry) (union (list sf-key) (cdddr entry) @@ -695,13 +713,13 @@ (nconc *initialize-instance-simple-alist* (list entry))))) (unless (or *note-iis-entry-p* (cadr entry)) - (setf (cadr entry) (compile-lambda (car entry)))) + (setf (cadr entry) (compile nil (car entry)))) (if (cadr entry) (apply (the function (cadr entry)) args) `(call-initialize-instance-simple ,pv-cell ,form-list)))) #|| - #'(lambda (instance initargs) - (initialize-instance-simple pv-cell form-list instance initargs)) + (lambda (instance initargs) + (initialize-instance-simple pv-cell form-list instance initargs)) ||# `(call-initialize-instance-simple ,pv-cell ,form-list)))) @@ -716,27 +734,24 @@ (setf (cadr entry) function) (setf (caddr entry) system) (dolist (use uses) - (setf (gethash use *compiled-initialize-instance-simple-functions*) t)) + (setf (gethash use *compiled-initialize-instance-simple-funs*) t)) (setf (cdddr entry) (union uses (cdddr entry) :test #'equal)))) (defmacro precompile-iis-functions (&optional system) - (let ((index -1)) - `(progn - ,@(gathering1 (collecting) - (dolist (iis-entry *initialize-instance-simple-alist*) - (when (or (null (caddr iis-entry)) - (eq (caddr iis-entry) system)) - (when system (setf (caddr iis-entry) system)) - (gather1 - (make-top-level-form - `(precompile-initialize-instance-simple ,system ,(incf index)) - '(:load-toplevel) - `(load-precompiled-iis-entry - ',(car iis-entry) - #',(car iis-entry) - ',system - ',(cdddr iis-entry)))))))))) + `(progn + ,@(let (collect) + (dolist (iis-entry *initialize-instance-simple-alist*) + (when (or (null (caddr iis-entry)) + (eq (caddr iis-entry) system)) + (when system (setf (caddr iis-entry) system)) + (push `(load-precompiled-iis-entry + ',(car iis-entry) + #',(car iis-entry) + ',system + ',(cdddr iis-entry)) + collect))) + (nreverse collect)))) (defun compile-iis-functions (after-p) (let ((*compile-make-instance-functions-p* t) @@ -833,15 +848,17 @@ value))) (if *inline-iis-instance-locations-p* (typecase location - (fixnum `((setf (%instance-ref slots ,(const location)) value))) + (fixnum `((and slots + (setf (clos-slots-ref slots ,(const location)) + value)))) (cons `((setf (cdr ,(const location)) value))) (t `(,default))) `((instance-write-internal pv slots ,(const pv-offset) value ,default ,(typecase location - (fixnum ':instance) - (cons ':class) - (t ':default))))))) + (fixnum :instance) + (cons :class) + (t :default))))))) (skip-when-instance-boundp (let* ((pv-offset (cadr form)) (location (pvref pv pv-offset)) @@ -849,19 +866,25 @@ ,(const (caddr form))))) `((unless ,(if *inline-iis-instance-locations-p* (typecase location - (fixnum `(not (eq (%instance-ref slots ,(const location)) - ',*slot-unbound*))) - (cons `(not (eq (cdr ,(const location)) ',*slot-unbound*))) + (fixnum `(not (and slots + (eq (clos-slots-ref + slots + ,(const location)) + +slot-unbound+)))) + (cons `(not (eq (cdr ,(const location)) + +slot-unbound+))) (t default)) - `(instance-boundp-internal pv slots ,(const pv-offset) + `(instance-boundp-internal + pv slots ,(const pv-offset) ,default ,(typecase (pvref pv pv-offset) - (fixnum ':instance) - (cons ':class) - (t ':default)))) + (fixnum :instance) + (cons :class) + (t :default)))) ,@(let ((sforms (cons nil nil))) (dotimes-fixnum (i (cadddr form) (car sforms)) - (add-forms (first-form-to-lisp forms cvector pv) sforms))))))) + (add-forms (first-form-to-lisp forms cvector pv) + sforms))))))) (update-initialize-info-cache `((when (consp initargs) (setq initargs (cons (car initargs) (cdr initargs)))) @@ -893,19 +916,21 @@ (values `(lambda (pv-cell cvector) (declare (type ,cvector-type cvector)) - #'(lambda (instance initargs) - (declare #.*optimize-speed*) - (iis-body ,@body) - initargs)) + (lambda (instance initargs) + (declare #.*optimize-speed*) + (iis-body ,@body) + initargs)) (list pv-cell (coerce cvector cvector-type))))) -;;; The effect of this is to cause almost all of the overhead of MAKE-INSTANCE -;;; to happen at load time (or maybe at precompile time, as explained in a -;;; previous message) rather than the first time that MAKE-INSTANCE is called -;;; with a given class-name and sequence of keywords. +;;; The effect of this is to cause almost all of the overhead of +;;; MAKE-INSTANCE to happen at load time (or maybe at precompile time, +;;; as explained in a previous message) rather than the first time +;;; that MAKE-INSTANCE is called with a given class-name and sequence +;;; of keywords. -;;; This optimization applies only when the first argument and all the even -;;; numbered arguments are constants evaluating to interned symbols. +;;; This optimization applies only when the first argument and all the +;;; even numbered arguments are constants evaluating to interned +;;; symbols. (declaim (ftype (function (t) symbol) get-make-instance-function-symbol)) @@ -914,8 +939,8 @@ (let* ((*make-instance-function-keys* nil) (expanded-form (expand-make-instance-form form))) (if expanded-form - `(funcall (symbol-function - ;; The symbol is guaranteed to be fbound. + `(funcall (fdefinition + ;; The name is guaranteed to be fbound. ;; Is there a way to declare this? (load-time-value (get-make-instance-function-symbol