From: Christophe Rhodes Date: Fri, 30 Jul 2010 21:01:12 +0000 (+0000) Subject: 1.0.41.1: much faster MAKE-INITIAL-DFUN X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=6e9a41e3ec4205f3a6e02ba50ff36f4159a3dfd9;p=sbcl.git 1.0.41.1: much faster MAKE-INITIAL-DFUN Don't attempt to precompute any kind of effective methods in MAKE-INITIAL-DFUN (called from COMPUTE-DISCRIMINATING-FUNCTION, among other places), because C-D-F is called really quite often. This allows us to delete FINALIZE-SPECIALIZERS and PRECOMPUTE-EFFECTIVE-METHODS, respectively responsible for about 3% each of the time in loading asdf.fasl. We can also delete the INITIAL-DISPATCH discriminating function kind, which (to my surprise) was already not mentioned in the internals documentation about the possible dfun states. --- diff --git a/NEWS b/NEWS index 09295ed..4cdd5ea 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,8 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- +changes relative to sbcl-1.0.41 + * optimization: the default implementation of + COMPUTE-DISCRIMINATING-FUNCTION does much less wasted work. + changes in sbcl-1.0.41 relative to sbcl-1.0.40: * optimization: validity of observed keyword initargs to MAKE-INSTANCE is cached, leading to many fewer expensive calls to diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index a60d6cf..be7a9a8 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -406,16 +406,10 @@ (defun gf-requires-emf-keyword-checks (generic-function) (member '&key (gf-lambda-list generic-function))) -(defvar *in-precompute-effective-methods-p* nil) - (defun standard-compute-effective-method (generic-function combin applicable-methods) (collect ((before) (primary) (after) (around)) - (flet ((invalid (gf combin m) - (if *in-precompute-effective-methods-p* - (return-from standard-compute-effective-method - `(%invalid-qualifiers ',gf ',combin ',m)) - (invalid-qualifiers gf combin m)))) + (flet ((invalid (gf combin m) (invalid-qualifiers gf combin m))) (dolist (m applicable-methods) (let ((qualifiers (if (listp m) (early-method-qualifiers m) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 777338a..f057b9f 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -155,16 +155,14 @@ ;;; ;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use ;;; in the compiler. Could we share some of it here? +(defvar *in-*subtypep* nil) + (defun *subtypep (type1 type2) (if (equal type1 type2) (values t t) (if (eq **boot-state** 'early) (values (eq type1 type2) t) - (let ((*in-precompute-effective-methods-p* t)) - (declare (special *in-precompute-effective-methods-p*)) - ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a - ;; good name. It changes the way - ;; CLASS-APPLICABLE-USING-CLASS-P works. + (let ((*in-*subtypep* t)) (setq type1 (*normalize-type type1)) (setq type2 (*normalize-type type2)) (case (car type2) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index e90c550..be3c163 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -272,10 +272,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (:include dfun-info) (:copier nil))) -(defstruct (initial-dispatch (:constructor initial-dispatch-dfun-info ()) - (:include dfun-info) - (:copier nil))) - (defstruct (dispatch (:constructor dispatch-dfun-info ()) (:include dfun-info) (:copier nil))) @@ -674,7 +670,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (make-dispatch-dfun gf)) (defun update-dispatch-dfuns () - (dolist (gf (gfs-of-type '(dispatch initial-dispatch))) + (dolist (gf (gfs-of-type '(dispatch))) (dfun-update gf #'make-dispatch-dfun))) (defun make-final-ordinary-dfun-cache @@ -732,71 +728,21 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defvar *lazy-dfun-compute-p* t) (defvar *early-p* nil) -;;; This variable is used for controlling the load-time effective -;;; method precomputation: precomputation will only be done for emfs -;;; with fewer than methods than this value. This value has -;;; traditionally been NIL on SBCL (meaning that precomputation will -;;; always be done) but that makes method loading O(n^2). Use a small -;;; value for now, to flush out any possible problems that doing a -;;; limited amount of precomputation might cause. If none appear, we -;;; might change it to a larger value later. -- JES, 2006-12-01 -(declaim (type (or null unsigned-byte) *max-emf-precomputation-methods*)) -(defvar *max-emf-precomputation-methods* 1) - -(defun finalize-specializers (gf) - (let ((methods (generic-function-methods gf))) - (when (or (null *max-emf-precomputation-methods*) - (<= (length methods) *max-emf-precomputation-methods*)) - (let ((all-finalized t)) - (dolist (method methods all-finalized) - (dolist (specializer (method-specializers method)) - (when (and (classp specializer) - (not (class-finalized-p specializer))) - (if (class-has-a-forward-referenced-superclass-p specializer) - (setq all-finalized nil) - (finalize-inheritance specializer))))))))) - (defun make-initial-dfun (gf) - (let ((initial-dfun - #'(lambda (&rest args) - (initial-dfun gf args)))) + (let ((initial-dfun #'(lambda (&rest args) (initial-dfun gf args)))) (multiple-value-bind (dfun cache info) - (cond - ((and (eq **boot-state** 'complete) - (not (finalize-specializers gf))) - (values initial-dfun nil (initial-dfun-info))) - ((and (eq **boot-state** 'complete) - (compute-applicable-methods-emf-std-p gf)) - (let* ((caching-p (use-caching-dfun-p gf)) - ;; KLUDGE: the only effect of this (when - ;; *LAZY-DFUN-COMPUTE-P* is true, as it usually is) - ;; is to signal an error when we try to add methods - ;; with the wrong qualifiers to a generic function. - (classes-list (precompute-effective-methods - gf caching-p - (not *lazy-dfun-compute-p*)))) - (if *lazy-dfun-compute-p* - (cond ((use-dispatch-dfun-p gf caching-p) - (values initial-dfun - nil - (initial-dispatch-dfun-info))) - (caching-p - (insure-caching-dfun gf) - (values initial-dfun nil (initial-dfun-info))) - (t - (values initial-dfun nil (initial-dfun-info)))) - (make-final-dfun-internal gf classes-list)))) - (t - (let ((arg-info (if (early-gf-p gf) - (early-gf-arg-info gf) - (gf-arg-info gf))) - (type nil)) - (if (and (gf-precompute-dfun-and-emf-p arg-info) - (setq type (final-accessor-dfun-type gf))) - (if *early-p* - (values (make-early-accessor gf type) nil nil) - (make-final-accessor-dfun gf type)) - (values initial-dfun nil (initial-dfun-info)))))) + (if (eq **boot-state** 'complete) + (values initial-dfun nil (initial-dfun-info)) + (let ((arg-info (if (early-gf-p gf) + (early-gf-arg-info gf) + (gf-arg-info gf))) + (type nil)) + (if (and (gf-precompute-dfun-and-emf-p arg-info) + (setq type (final-accessor-dfun-type gf))) + (if *early-p* + (values (make-early-accessor gf type) nil nil) + (make-final-accessor-dfun gf type)) + (values initial-dfun nil (initial-dfun-info))))) (set-dfun gf dfun cache info)))) (defun make-early-accessor (gf type) @@ -1464,9 +1410,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; CMUCL comment: used only in map-all-orders (defun class-might-precede-p (class1 class2) - (if (not *in-precompute-effective-methods-p*) - (not (member class1 (cdr (class-precedence-list class2)) :test #'eq)) - (class-can-precede-p class1 class2))) + (not (member class1 (cdr (class-precedence-list class2)) :test #'eq))) (defun compute-precedence (lambda-list nreq argument-precedence-order) (if (null argument-precedence-order) @@ -1553,7 +1497,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((pred (memq specl (cpl-or-nil type)))) (values pred (or pred - (if (not *in-precompute-effective-methods-p*) + (if (not *in-*subtypep*) ;; classes might get common subclass (superclasses-compatible-p specl type) ;; worry only about existing classes diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index bbbf499..2d63c9b 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -1183,35 +1183,6 @@ (class-eq (cadr type)) (class (cadr type))))) -(defun precompute-effective-methods (gf caching-p &optional classes-list-p) - (let* ((arg-info (gf-arg-info gf)) - (methods (generic-function-methods gf)) - (precedence (arg-info-precedence arg-info)) - (*in-precompute-effective-methods-p* t) - (classes-list nil)) - (generate-discrimination-net-internal - gf methods nil - (lambda (methods known-types) - (when methods - (when classes-list-p - (push (mapcar #'class-from-type known-types) classes-list)) - (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p - methods)))) - (map-all-orders - methods precedence - (lambda (methods) - (get-secondary-dispatch-function1 - gf methods known-types - nil caching-p no-eql-specls-p)))))) - (lambda (position type true-value false-value) - (declare (ignore position type true-value false-value)) - nil) - (lambda (type) - (if (and (consp type) (eq (car type) 'eql)) - `(class-eq ,(class-of (cadr type))) - type))) - classes-list)) - ;;; We know that known-type implies neither new-type nor `(not ,new-type). (defun augment-type (new-type known-type) (if (or (eq known-type t) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index e08f7a7..412948e 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -1112,7 +1112,9 @@ (assert (= (method-on-defined-type-and-class 3) 4))))) ;; bug 281 -(let ((sb-pcl::*max-emf-precomputation-methods* 0)) +(let (#+nil ; no more sb-pcl::*max-emf-precomputation-methods* as of + ; sbcl-1.0.41.x + (sb-pcl::*max-emf-precomputation-methods* 0)) (eval '(defgeneric bug-281 (x) (:method-combination +) (:method ((x symbol)) 1) diff --git a/version.lisp-expr b/version.lisp-expr index 28b9ebd..fbe8c50 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.41" +"1.0.41.1"