0.9.14.3:

[sbcl.git] / src / compiler / ir1-translators.lisp

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 7f20043..aa92588 100644 (file)
--- 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)))))
 \f
 ;;;; 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))