[Sbcl-commits] master: Implement COERCE-SYMBOL-TO-FUN more efficiently.

[Douglas K. <sn...@us...>]

The branch "master" has been updated in SBCL:
       via  a62fc2d1784276bee80036b17ec88f5e276ec52d (commit)
      from  981083041c53e6da66e4d6db63bd06cdf6b7bf39 (commit)

- Log -----------------------------------------------------------------
commit a62fc2d1784276bee80036b17ec88f5e276ec52d
Author: Douglas Katzman <do...@go...>
Date:   Fri May 2 14:20:32 2014 -0400

    Implement COERCE-SYMBOL-TO-FUN more efficiently.
    
    Rather than two globaldb inquiries we can do with just one.
    (FDEFINITION is conceptually a globaldb inquiry)
    As a side effect, this gives saner behavior in the perverse case
    in which the compiler's understanding of function :KIND differs
    from the runtime's reality.
---
 src/code/coerce.lisp     |   27 +++++++++++++++++++--------
 src/compiler/macros.lisp |    2 +-
 tests/coerce.pure.lisp   |   15 +++++++++++++++
 3 files changed, 35 insertions(+), 9 deletions(-)

diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp
index d4f212d..ae4a073 100644
--- a/src/code/coerce.lisp
+++ b/src/code/coerce.lisp
@@ -69,14 +69,25 @@
 (declaim (inline coerce-to-vector))
 
 (defun coerce-symbol-to-fun (object)
-  (let ((kind (info :function :kind object)))
-    (case kind
-      (:macro
-       (error "~S names a macro." object))
-      (:special-form
-       (error "~S names a special operator." object))
-      (t
-       (fdefinition object)))))
+  ;; FIXME? I would think to use SYMBOL-FUNCTION here which does not strip off
+  ;; encapsulations. But Stas wrote FDEFINITION so ...
+  ;; [Also note, we won't encapsulate a macro or special-form, so this
+  ;; introspective technique to decide what kind something is works either way]
+  (let* ((def (fdefinition object))
+         (widetag (%fun-pointer-widetag def)))
+    (cond ((and (eq widetag sb!vm:closure-header-widetag)
+                (eq (%closure-fun def)
+                    (load-time-value
+                     ;; pick a macro, any macro...
+                     (%closure-fun (symbol-function 'with-unique-names))
+                     t)))
+           (error "~S names a macro." object))
+          ((and (eq widetag sb!vm:simple-fun-header-widetag)
+                (let ((name (%simple-fun-name def)))
+                  (and (listp name) (eq (car name) 'special-operator))))
+           (error "~S names a special operator." object))
+          (t
+           def))))
 
 (defun coerce-to-fun (object)
   ;; (Unlike the other COERCE-TO-FOOs, this one isn't inline, because
diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp
index e7bb07a..8090ca4 100644
--- a/src/compiler/macros.lisp
+++ b/src/compiler/macros.lisp
@@ -70,7 +70,7 @@
                (error 'special-form-function :name ',name))
              (let ((fun #',guard-name))
                (setf (%simple-fun-arglist fun) ',lambda-list
-                     (%simple-fun-name fun) ',name
+                     (%simple-fun-name fun) '(sb!impl::special-operator ,name)
                      (symbol-function ',name) fun)
                (fmakunbound ',guard-name)))
            ;; FIXME: Evidently "there can only be one!" -- we overwrite any
diff --git a/tests/coerce.pure.lisp b/tests/coerce.pure.lisp
index fd57331..2f9cb95 100644
--- a/tests/coerce.pure.lisp
+++ b/tests/coerce.pure.lisp
@@ -100,3 +100,18 @@
     ;; (test-case #C(1/2 .5e0) '(complex (or (real 1) (integer -1 0)))       nil              t)
 
     ))
+
+(with-test (:name :coerce-symbol-to-fun)
+  (flet ((coerce-it (x)
+           (handler-case (sb-kernel:coerce-symbol-to-fun x)
+             (simple-error (c) (simple-condition-format-control c)))))
+    (assert (string= (coerce-it 'defun) "~S names a macro."))
+    (assert (string= (coerce-it 'progn) "~S names a special operator."))
+    (let ((foo (gensym)))
+      (eval `(defmacro ,foo () 5))
+      (setf (sb-int:info :function :kind foo) :function)
+      (assert (string= (coerce-it foo) "~S names a macro.")))
+    (let ((foo (gensym)))
+      (eval `(defun ,foo () 5))
+      (setf (sb-int:info :function :kind foo) :macro)
+      (assert (functionp (coerce-it foo))))))

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL