From 9264b512a21d1200fb9ab21874206c4bf436ed27 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Thu, 31 Jul 2008 12:52:37 +0000 Subject: [PATCH] 1.0.19.9: elide runtime calls to %COERCE-CALLABLE-TO-FUN in more cases * Core change: %COERCE-CALLABLE-TO-FUN can now convert to GLOBAL-FUNCTION. * While at it, refactor the whole "make up a form that returns a function to use instead of this lvar or source form" thing for clarity. * Record slightly crazy OPTIMIZATION possibility. --- NEWS | 2 + OPTIMIZATIONS | 15 ++++++ src/compiler/ir1-translators.lisp | 91 +++++++++++++++++++++---------------- version.lisp-expr | 2 +- 4 files changed, 71 insertions(+), 39 deletions(-) diff --git a/NEWS b/NEWS index 2a4bd38..63f1842 100644 --- a/NEWS +++ b/NEWS @@ -4,6 +4,8 @@ changes in sbcl-1.0.20 relative to 1.0.19: SB-C::STACK-ALLOCATE-DYNAMIC-EXTENT, SB-C::STACK-ALLOCATE-VECTOR, and SB-C::STACK-ALLOCATE-VALUE-CELLS no longer exist. See documentation and SB-EXT:*STACK-ALLOCATE-DYNAMIC-EXTENT* for details. + * optimization: runtime lookup of function definitions can be + elided in more cases, eg: (let ((x 'foo)) (funcall foo)). * bug fix: fixed #427: unused local aliens no longer cause compiler breakage. (reported by Stelian Ionescu, Andy Hefner and Stanislaw Halik) diff --git a/OPTIMIZATIONS b/OPTIMIZATIONS index bc02982..acbd0d0 100644 --- a/OPTIMIZATIONS +++ b/OPTIMIZATIONS @@ -390,3 +390,18 @@ currently compiles to code that ensures the TLS index at runtime, which is both a decently large chunk of code and unnecessary, as we could ensure the TLS index at load-time as well. +-------------------------------------------------------------------------------- +#40 + +When FTYPE is declared -- to say (function (t t t t t) t), and +function has a compiler-macro, + + (apply #'foo 'x1 x2 'x3 more) + +can be transformed into + + (apply (lambda (x2 x4 x5) (foo 'x1 x2 'x3 x4 x5)) x2 more) + +which allows compiler-macro-expansion for FOO. (Only constant +arguments can be moved inside the new lambda -- otherwise evaluation +order is altered.) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index d26e53a..acff2a9 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -540,9 +540,40 @@ be a lambda expression." (defun constant-global-fun-name (thing) (let ((constantp (sb!xc:constantp thing))) - (and constantp - (let ((name (constant-form-value thing))) - (and (legal-fun-name-p name) name))))) + (when constantp + (let ((name (constant-form-value thing))) + (when (legal-fun-name-p name) + name))))) + +(defun lvar-constant-global-fun-name (lvar) + (when (constant-lvar-p lvar) + (let ((name (lvar-value lvar))) + (when (legal-fun-name-p name) + name)))) + +(defun ensure-source-fun-form (source &optional give-up) + (let ((op (when (consp source) (car source)))) + (cond ((eq op '%coerce-callable-to-fun) + (ensure-source-fun-form (second source))) + ((member op '(function global-function lambda named-lambda)) + (values source nil)) + (t + (let ((cname (constant-global-fun-name source))) + (if cname + (values `(global-function ,cname) nil) + (values `(%coerce-callable-to-fun ,source) give-up))))))) + +(defun ensure-lvar-fun-form (lvar lvar-name &optional give-up) + (aver (and lvar-name (symbolp lvar-name))) + (if (csubtypep (lvar-type lvar) (specifier-type 'function)) + lvar-name + (let ((cname (lvar-constant-global-fun-name lvar))) + (cond (cname + `(global-function ,cname)) + (give-up + (give-up-ir1-transform give-up)) + (t + `(%coerce-callable-to-fun ,lvar-name)))))) ;;;; FUNCALL @@ -552,45 +583,35 @@ be a lambda expression." (deftransform funcall ((function &rest args) * *) (let ((arg-names (make-gensym-list (length args)))) `(lambda (function ,@arg-names) - (%funcall ,(if (csubtypep (lvar-type function) - (specifier-type 'function)) - 'function - '(%coerce-callable-to-fun function)) - ,@arg-names)))) + (declare (ignorable function)) + `(%funcall ,(ensure-lvar-fun-form function 'function) ,@arg-names)))) (def-ir1-translator %funcall ((function &rest args) start next result) - (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))))) + (let ((op (when (consp function) (car function)))) + (cond ((eq op 'function) + (with-fun-name-leaf (leaf (second function) start) + (ir1-convert start next result `(,leaf ,@args)))) + ((eq op '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) (member (car function) '(function lambda))) - `(%funcall ,function ,@args) - (let ((name (constant-global-fun-name function))) - (if name - `(%funcall (global-function ,name) ,@args) - (values nil t))))) + `(%funcall ,(ensure-source-fun-form function) ,@args)) -(deftransform %coerce-callable-to-fun ((thing) (function) *) - "optimize away possible call to FDEFINITION at runtime" - 'thing) +(deftransform %coerce-callable-to-fun ((thing) * *) + (ensure-lvar-fun-form thing 'thing "optimize away possible call to FDEFINITION at runtime")) (define-source-transform %coerce-callable-to-fun (thing) - (if (and (consp thing) (member (car thing) '(function lambda))) - thing - (values nil t))) + (ensure-source-fun-form thing t)) ;;;; LET and LET* ;;;; @@ -1094,13 +1115,7 @@ values from the first VALUES-FORM making up the first argument, etc." ;; important for simplifying compilation of ;; MV-COMBINATIONS. (make-combination fun-lvar)))) - (ir1-convert start ctran fun-lvar - (if (and (consp fun) (eq (car fun) 'function)) - fun - (let ((name (constant-global-fun-name fun))) - (if name - `(global-function ,name) - `(%coerce-callable-to-fun ,fun))))) + (ir1-convert start ctran fun-lvar (ensure-source-fun-form fun)) (setf (lvar-dest fun-lvar) node) (collect ((arg-lvars)) (let ((this-start ctran)) diff --git a/version.lisp-expr b/version.lisp-expr index de035f9..be72424 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.19.8" +"1.0.19.9" -- 1.7.10.4