From f1e848ee50f5511579f38f1c2ee0f6fb03a3cf79 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Thu, 4 Mar 2021 06:41:09 -0800
Subject: compiler: streamline load-time hoisting of calls.

* share/txr/stdlib/compiler.tl (compiler comp-fun-form):
Rearrange the logic so that we only try the speculative
compilation when the three main conditions are right,
not before. This drastically reduces the number of times
we need to take the compiler snapshot.
---
 share/txr/stdlib/compiler.tl | 40 +++++++++++++++++++++++-----------------
 1 file changed, 23 insertions(+), 17 deletions(-)

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index c74a7fb2..b5bc75ab 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -1266,25 +1266,31 @@
     (return-from comp-fun-form me.(compile oreg env form)))
 
   (tree-bind (sym . args) form
-    (let* ((fbind env.(lookup-fun sym t))
-           (snap me.(snapshot))
-           (cfrag me.(comp-call-impl oreg env (if fbind 'call 'gcall)
-                                     (if fbind fbind.loc me.(get-sidx sym))
-                                     args)))
-      (when (and (not fbind)
+    (let* ((fbind env.(lookup-fun sym t)))
+      (macrolet ((comp-fun ()
+                    'me.(comp-call-impl oreg env (if fbind 'call 'gcall)
+                                        (if fbind fbind.loc me.(get-sidx sym))
+                                        args)))
+        (if (and (not fbind)
                  (not *load-time*)
                  [%functional% sym])
-        (let ((ok-lift-var-pov (null cfrag.fvars))
-              (ok-lift-fun-pov (all cfrag.ffuns
-                                    (lambda (sym)
-                                      (and (not env.(lookup-fun sym))
-                                           (eq (symbol-package sym)
-                                               user-package))))))
-          (when (and ok-lift-var-pov ok-lift-fun-pov)
-            me.(restore snap)
-            (set cfrag me.(compile oreg env ^(sys:load-time-lit nil ,form))))))
-      (pushnew sym cfrag.ffuns)
-      cfrag)))
+          (let* ((snap me.(snapshot))
+                 (cfrag (comp-fun))
+                 (ok-lift-var-pov (null cfrag.fvars))
+                 (ok-lift-fun-pov (all cfrag.ffuns
+                                       (lambda (sym)
+                                         (and (not env.(lookup-fun sym))
+                                              (eq (symbol-package sym)
+                                                  user-package))))))
+            (cond
+              ((and ok-lift-var-pov ok-lift-fun-pov)
+               me.(restore snap)
+               me.(compile oreg env ^(sys:load-time-lit nil ,form)))
+              (t (pushnew sym cfrag.ffuns)
+                 cfrag)))
+          (let ((cfrag (comp-fun)))
+            (pushnew sym cfrag.ffuns)
+            cfrag))))))
 
 (defmeth compiler comp-apply-call (me oreg env form)
   (tree-bind (sym . oargs) form
-- 
cgit v1.2.3