From e4b8ced9469facaddae849f982eab90c290ba820 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Thu, 4 Mar 2021 06:19:12 -0800
Subject: compiler: bug: duplicate code in load-time lifting.

This issue affects the original code which lifts lambdas to
load-time, as well as the new, recently added code for
similarly lifting functional combinator expressions.

The problem is that the trick works by compiling an expression
twice. The result of the first compile is thrown away in the
case when we compile it again in the load-time context.
But compiling has a side effect: the expression itself
may have an embedded load-time-liftable expression, which gets
deposited into the load-time fragment list. Thus garbage ends
up in the list of load-time fragments.

We likely want to save and restore other things, like
allocated D regisers.

* share/txr/stdlib/compiler.tl (compiler shapshot, compiler
restore): New methods.
(comp-lambda-impl, comp-fun): Save a snapshot of the compiler state
before doing the speculative compilation. If we don't use that
compilation, we restore the state from the snapshot.
---
 share/txr/stdlib/compiler.tl | 27 ++++++++++++++++++++++-----
 1 file changed, 22 insertions(+), 5 deletions(-)

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index de5788c2..c74a7fb2 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -185,7 +185,19 @@
     (stab (hash :eql-based))
     lt-frags
     last-form
-    var-spies))
+    var-spies
+
+    (:method snapshot (me)
+      (let ((snap (copy me)))
+        (set snap.dreg (copy me.dreg)
+             snap.data (copy me.data)
+             snap.sidx (copy me.sidx)
+             snap.stab (copy me.stab))
+        snap))
+
+    (:method restore (me snap)
+      (replace-struct me snap))))
+
 
 (eval-only
   (defmacro compile-in-toplevel (me . body)
@@ -1100,16 +1112,19 @@
 (defmeth compiler comp-lambda (me oreg env form)
   (if *load-time*
     me.(comp-lambda-impl oreg env form)
-    (let* ((lambda-frag me.(comp-lambda-impl oreg env form))
+    (let* ((snap me.(snapshot))
+           (lambda-frag me.(comp-lambda-impl oreg env form))
            (ok-lift-var-pov (all lambda-frag.fvars
                                  (lambda (sym)
                                    (not env.(lookup-var sym)))))
            (ok-lift-fun-pov (all lambda-frag.ffuns
                                  (lambda (sym)
                                    (not env.(lookup-fun sym))))))
-      (if (and ok-lift-var-pov ok-lift-fun-pov)
-        me.(compile oreg env ^(sys:load-time-lit nil ,form))
-        lambda-frag))))
+      (cond
+        ((and ok-lift-var-pov ok-lift-fun-pov)
+         me.(restore snap)
+         me.(compile oreg env ^(sys:load-time-lit nil ,form)))
+        (t lambda-frag)))))
 
 (defmeth compiler comp-fun (me oreg env form)
   (mac-param-bind form (op arg) form
@@ -1252,6 +1267,7 @@
 
   (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)))
@@ -1265,6 +1281,7 @@
                                            (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)))
-- 
cgit v1.2.3