X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=aa925880239d59b18e472ad73c01a9fec4512ed9;hb=8886298f2c0e50e595cf481c426b6331ab898a23;hp=7f200433237d5dc5fc13a5a2ccbd7c0d89738596;hpb=d604a358d8e5eb5587989e0a4f1d31dbe6ac5ffe;p=sbcl.git diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 7f20043..aa92588 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -284,8 +284,8 @@ (unless (symbolp name) (fail "The local macro name ~S is not a symbol." name)) (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked - name "binding ~A as a local macro")) + (program-assert-symbol-home-package-unlocked + context name "binding ~A as a local macro")) (unless (listp arglist) (fail "The local macro argument list ~S is not a list." arglist)) @@ -335,8 +335,8 @@ (unless (symbolp name) (fail "The local symbol macro name ~S is not a symbol." name)) (when (or (boundp name) (eq (info :variable :kind name) :macro)) - (compiler-assert-symbol-home-package-unlocked - name "binding ~A as a local symbol-macro")) + (program-assert-symbol-home-package-unlocked + context name "binding ~A as a local symbol-macro")) (let ((kind (info :variable :kind name))) (when (member kind '(:special :constant)) (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" @@ -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,19 @@ 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 (thing) + (let ((constantp (sb!xc:constantp thing))) + (and constantp + (let ((name (constant-form-value thing))) + (and (legal-fun-name-p name) name))))) ;;;; FUNCALL @@ -504,13 +520,17 @@ ,@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 @@ -519,7 +539,10 @@ (define-source-transform funcall (function &rest args) (if (and (consp function) (eq (car function) 'function)) `(%funcall ,function ,@args) - (values nil t))) + (let ((name (constant-global-fun-name function))) + (if name + `(%funcall (global-function ,name) ,@args) + (values nil t))))) (deftransform %coerce-callable-to-fun ((thing) (function) *) "optimize away possible call to FDEFINITION at runtime" @@ -567,8 +590,8 @@ (vals (second spec))))))) (dolist (name (names)) (when (eq (info :variable :kind name) :macro) - (compiler-assert-symbol-home-package-unlocked - name "lexically binding symbol-macro ~A"))) + (program-assert-symbol-home-package-unlocked + :compile name "lexically binding symbol-macro ~A"))) (values (vars) (vals)))) (def-ir1-translator let ((bindings &body body) start next result) @@ -660,8 +683,8 @@ (let ((name (first def))) (check-fun-name name) (when (fboundp name) - (compiler-assert-symbol-home-package-unlocked - name "binding ~A as a local function")) + (program-assert-symbol-home-package-unlocked + :compile name "binding ~A as a local function")) (names name) (multiple-value-bind (forms decls) (parse-body (cddr def)) (defs `(lambda ,(second def) @@ -1002,7 +1025,10 @@ (ir1-convert start ctran fun-lvar (if (and (consp fun) (eq (car fun) 'function)) fun - `(%coerce-callable-to-fun ,fun))) + (let ((name (constant-global-fun-name fun))) + (if name + `(global-function ,name) + `(%coerce-callable-to-fun ,fun))))) (setf (lvar-dest fun-lvar) node) (collect ((arg-lvars)) (let ((this-start ctran))