X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Ffast-init.lisp;h=2d723e159c14c0c676c4eac813b39510541b5102;hb=683874b497a99cd2c11b6c5d9b47e2785b1ede5f;hp=ac2f9d49f7609e14546e8d1e772a9580a5313c94;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp index ac2f9d4..2d723e1 100644 --- a/src/pcl/fast-init.lisp +++ b/src/pcl/fast-init.lisp @@ -60,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 @@ -83,12 +95,6 @@ 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))) @@ -166,7 +172,7 @@ 'initialize-info name))) *initialize-info-cached-slots*))) `(progn - (defstruct initialize-info + (defstruct (initialize-info (:copier nil)) key wrapper ,@(mapcar #'(lambda (name) `(,name :unknown)) @@ -218,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)) @@ -272,7 +282,8 @@ ((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))) @@ -371,7 +382,8 @@ (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))) @@ -502,7 +514,8 @@ (get-secondary-dispatch-function #'shared-initialize shared-initialize-methods `((class-eq ,class) t t) - `((,(find-standard-ii-method shared-initialize-methods 'slot-object) + `((,(find-standard-ii-method shared-initialize-methods + 'slot-object) ,#'(lambda (instance init-type &rest initargs) (declare (ignore init-type)) (call-initialize-function initialize-function @@ -513,7 +526,8 @@ (get-secondary-dispatch-function #'initialize-instance initialize-instance-methods `((class-eq ,class) t) - `((,(find-standard-ii-method initialize-instance-methods 'slot-object) + `((,(find-standard-ii-method initialize-instance-methods + 'slot-object) ,#'(lambda (instance &rest initargs) (invoke-effective-method-function shared-initialize t instance t initargs)))) @@ -531,15 +545,21 @@ initialize-instance t instance initargs) instance)))))) -(defun get-simple-initialization-function (class keys &optional allow-other-keys-arg) +(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)) @@ -599,7 +619,7 @@ (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) @@ -626,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)) @@ -638,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))))) @@ -692,7 +713,7 @@ (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)))) @@ -718,22 +739,19 @@ :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) @@ -830,7 +848,9 @@ 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 @@ -846,11 +866,16 @@ ,(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) @@ -858,7 +883,8 @@ (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)))) @@ -896,13 +922,15 @@ 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)) @@ -911,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