From: Nikodemus Siivola Date: Mon, 27 Feb 2006 11:07:31 +0000 (+0000) Subject: 0.9.10.3: Faster function calls via constant symbols X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=4e0ff6bb79908436adea8375d4eea46d10079cec;p=sbcl.git 0.9.10.3: Faster function calls via constant symbols * Compile (FUNCALL 'FOO) as (FUNCALL (SB-C::GLOBAL-FUNCTION FOO)) which is like (FUNCALL (FUNCTION FOO)) except that inline functions are not expanded and the lexical functions are ignored. --- diff --git a/NEWS b/NEWS index fcc512e..127f97e 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,9 @@ changes in sbcl-0.9.11 relative to sbcl-0.9.10: * bug fix: as implied by AMOP, standardized classes no longer have slots named by external symbols of public packages. (reported by Pascal Costanza) + * optimization: calling functions via constant symbols -- as in + (FUNCALL 'FOO) -- is now roughly as efficient as calling them + via the function object as in (FUNCALL #'FOO). changes in sbcl-0.9.10 relative to sbcl-0.9.9: * new feature: new SAVE-LISP-AND-DIE keyword argument :EXECUTABLE can diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 7f20043..5976435 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -471,15 +471,18 @@ (dolist (lambda lambdas) (setf (functional-allocator lambda) allocator))))) -(defmacro with-fun-name-leaf ((leaf thing start) &body body) - `(multiple-value-bind (,leaf allocate-p) (fun-name-leaf ,thing) +(defmacro with-fun-name-leaf ((leaf thing start &key global) &body body) + `(multiple-value-bind (,leaf allocate-p) + (if ,global + (find-global-fun ,thing t) + (fun-name-leaf ,thing)) (if allocate-p - (let ((.new-start. (make-ctran))) - (ir1-convert ,start .new-start. nil `(%%allocate-closures ,leaf)) - (let ((,start .new-start.)) - ,@body)) - (locally - ,@body)))) + (let ((.new-start. (make-ctran))) + (ir1-convert ,start .new-start. nil `(%%allocate-closures ,leaf)) + (let ((,start .new-start.)) + ,@body)) + (locally + ,@body)))) (def-ir1-translator function ((thing) start next result) #!+sb-doc @@ -488,6 +491,22 @@ be a lambda expression." (with-fun-name-leaf (leaf thing start) (reference-leaf start next result leaf))) + +;;; Like FUNCTION, but ignores local definitions and inline +;;; expansions, and doesn't nag about undefined functions. +;;; Used for optimizing things like (FUNCALL 'FOO). +(def-ir1-translator global-function ((thing) start next result) + (with-fun-name-leaf (leaf thing start :global t) + (reference-leaf start next result leaf))) + +(defun constant-global-fun-name-p (thing) + ;; FIXME: Once we have a marginally better CONSTANTP and + ;; CONSTANT-VALUE we can use those instead. + (and (consp thing) + (eq 'quote (car thing)) + (null (cddr thing)) + (legal-fun-name-p (cadr thing)) + t)) ;;;; FUNCALL @@ -504,22 +523,29 @@ ,@arg-names)))) (def-ir1-translator %funcall ((function &rest args) start next result) - (if (and (consp function) (eq (car function) 'function)) - (with-fun-name-leaf (leaf (second function) start) - (ir1-convert start next result `(,leaf ,@args))) - (let ((ctran (make-ctran)) - (fun-lvar (make-lvar))) - (ir1-convert start ctran fun-lvar `(the function ,function)) - (ir1-convert-combination-args fun-lvar ctran next result args)))) + (cond ((and (consp function) (eq (car function) 'function)) + (with-fun-name-leaf (leaf (second function) start) + (ir1-convert start next result `(,leaf ,@args)))) + ((and (consp function) (eq (car function) 'global-function)) + (with-fun-name-leaf (leaf (second function) start :global t) + (ir1-convert start next result `(,leaf ,@args)))) + (t + (let ((ctran (make-ctran)) + (fun-lvar (make-lvar))) + (ir1-convert start ctran fun-lvar `(the function ,function)) + (ir1-convert-combination-args fun-lvar ctran next result args))))) ;;; This source transform exists to reduce the amount of work for the ;;; compiler. If the called function is a FUNCTION form, then convert ;;; directly to %FUNCALL, instead of waiting around for type ;;; inference. (define-source-transform funcall (function &rest args) - (if (and (consp function) (eq (car function) 'function)) - `(%funcall ,function ,@args) - (values nil t))) + (cond ((and (consp function) (eq (car function) 'function)) + `(%funcall ,function ,@args)) + ((constant-global-fun-name-p function) + `(%funcall (global-function ,(second function)) ,@args)) + (t + (values nil t)))) (deftransform %coerce-callable-to-fun ((thing) (function) *) "optimize away possible call to FDEFINITION at runtime" @@ -1000,9 +1026,12 @@ ;; MV-COMBINATIONS. (make-combination fun-lvar)))) (ir1-convert start ctran fun-lvar - (if (and (consp fun) (eq (car fun) 'function)) - fun - `(%coerce-callable-to-fun ,fun))) + (cond ((and (consp fun) (eq (car fun) 'function)) + fun) + ((constant-global-fun-name-p fun) + `(global-function ,(second fun))) + (t + `(%coerce-callable-to-fun ,fun)))) (setf (lvar-dest fun-lvar) node) (collect ((arg-lvars)) (let ((this-start ctran)) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 6516ca2..68cac62 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -64,7 +64,7 @@ ;;; Return a GLOBAL-VAR structure usable for referencing the global ;;; function NAME. -(defun find-free-really-fun (name) +(defun find-global-fun (name latep) (unless (info :function :kind name) (setf (info :function :kind name) :function) (setf (info :function :where-from name) :assumed)) @@ -75,15 +75,22 @@ ;; running Lisp. But at cross-compile time, the current ;; definedness of a function is irrelevant to the ;; definedness at runtime, which is what matters. - #-sb-xc-host (not (fboundp name))) + #-sb-xc-host (not (fboundp name)) + ;; LATEP is true when the user has indicated that + ;; late-late binding is desired by using eg. a quoted + ;; symbol -- in which case it makes little sense to + ;; complain about undefined functions. + (not latep)) (note-undefined-reference name :function)) (make-global-var :kind :global-function :%source-name name - :type (if (or *derive-function-types* - (eq where :declared) - (and (member name *fun-names-in-this-file* :test #'equal) - (not (fun-lexically-notinline-p name)))) + :type (if (and (not latep) + (or *derive-function-types* + (eq where :declared) + (and (member name *fun-names-in-this-file* + :test #'equal) + (not (fun-lexically-notinline-p name))))) (info :function :type name) (specifier-type 'function)) :where-from where))) @@ -165,7 +172,7 @@ :type (if (eq inlinep :notinline) (specifier-type 'function) (info :function :type name))) - (find-free-really-fun name)))))))) + (find-global-fun name nil)))))))) ;;; Return the LEAF structure for the lexically apparent function ;;; definition of NAME. @@ -1066,6 +1073,8 @@ (defined-fun-inline-expansion var)) (setf (defined-fun-functional res) (defined-fun-functional var))) + ;; FIXME: Is this really right? Needs we not set the FUNCTIONAL + ;; to the original global-var? res)) ;;; Parse an inline/notinline declaration. If it's a local function we're diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 1246cdb..5fd8828 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -1201,4 +1201,32 @@ (setf (fill-pointer result) index) (coerce result 'string))))) +;;; Callign thru constant symbols +(require :sb-introspect) + +(declaim (inline target-fun)) +(defun target-fun (arg0 arg1) + (+ arg0 arg1)) +(declaim (notinline target-fun)) + +(defun test-target-fun-called (fun res) + (assert (member #'target-fun + (sb-introspect:find-function-callees #'caller-fun-1))) + (assert (equal (funcall fun) res))) + +(defun caller-fun-1 () + (funcall 'target-fun 1 2)) +(test-target-fun-called #'caller-fun-1 3) + +(defun caller-fun-2 () + (declare (inline target-fun)) + (apply 'target-fun 1 '(3))) +(test-target-fun-called #'caller-fun-2 4) + +(defun caller-fun-3 () + (flet ((target-fun (a b) + (- a b))) + (list (funcall #'target-fun 1 4) (funcall 'target-fun 1 4)))) +(test-target-fun-called #'caller-fun-3 (list -3 5)) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index cfd0f5e..fcca4e2 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".) -"0.9.10.2" +"0.9.10.3"