X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Ffast-init.lisp;h=b43537601a6b7cf5c0f09e78716c9542b254bde7;hb=0704fd3f3f027ec1be05ddb986b6ca538aa165ca;hp=0154304db75de27b77bda8bd139144faf419c5a3;hpb=0a82f2db352cc348d2107a882e50af222ff97ed3;p=sbcl.git diff --git a/src/pcl/fast-init.lisp b/src/pcl/fast-init.lisp index 0154304..b435376 100644 --- a/src/pcl/fast-init.lisp +++ b/src/pcl/fast-init.lisp @@ -43,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)) @@ -51,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)) @@ -74,7 +74,7 @@ (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 @@ -84,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))) @@ -147,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)) @@ -160,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 @@ -169,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 (: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) @@ -294,7 +288,7 @@ ((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) @@ -316,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)) @@ -339,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) @@ -362,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 @@ -383,8 +377,8 @@ (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)) @@ -397,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)) @@ -437,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)))))))) @@ -479,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 @@ -522,11 +516,11 @@ `((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))) + ,(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 @@ -534,22 +528,22 @@ `((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)))) + ,(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)))))) + (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 @@ -568,9 +562,9 @@ 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)))))) @@ -588,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) @@ -625,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)) @@ -694,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) @@ -724,8 +718,8 @@ (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)))) @@ -740,23 +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) `(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 - `(load-precompiled-iis-entry - ',(car iis-entry) - #',(car iis-entry) - ',system - ',(cdddr iis-entry)))))))) + ,@(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) @@ -861,9 +856,9 @@ `((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)) @@ -883,9 +878,9 @@ 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) @@ -921,10 +916,10 @@ (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