compiler: treat nested load-time forms.

load-time forms nested in load-time forms have no special
semantics; it's wasteful to separately hoist them into load
time and store their value in their own D register.
We must be careful: this is not true if a nested form occurs
in a lambda.

* share/txr/stdlib/compiler.tl (*load-time*): New special
variable.
(compiler comp-lambda): Bind *load-time* to nil around
the compilation of the lambda, so load-time forms in the
lambda are hoisted to load time, even if the lambda itself
is wrapped in a load-time form.
(compiler comp-load-time-lit): Bind *load-time* true around
the compilation of the form. If *load-time* is already true,
then skip the special load-time logic and just compile the
enclosed form; the surrounding load-time compilation is taking
care of the load-time hoisting.

* txr.1: Document that load-time forms nested in load-time
forms don't do anything, except in the lambda case.

1 files changed, 19 insertions, 14 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index ca86db11..f1c4ca09 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -199,6 +199,8 @@
 
 (defvar *dedup*)
 
+(defvar *load-time*)
+
 (defun dedup (obj)
   (cond
     ((null obj) nil)
@@ -815,7 +817,8 @@
 
 (defmeth compiler comp-lambda (me oreg env form)
   (mac-param-bind form (op par-syntax . body) form
-    (let* ((pars (new (fun-param-parser par-syntax form)))
+    (let* ((*load-time* nil)
+           (pars (new (fun-param-parser par-syntax form)))
            (need-frame (or (plusp pars.nfix) pars.rest))
            (nenv (if need-frame (new env up env co me) env))
            lexsyms fvars specials need-dframe)
@@ -1239,19 +1242,21 @@
 
 (defmeth compiler comp-load-time-lit (me oreg env form)
   (mac-param-bind form (op loaded-p exp) form
-    (if loaded-p
-      me.(compile oreg env ^(quote ,exp))
-      (compile-in-toplevel me
-        (let* ((dreg me.(alloc-dreg))
-               (exp me.(compile dreg (new env co me) exp))
-               (lt-frag (new (frag dreg
-                                   ^(,*exp.code
-                                     ,*(maybe-mov dreg exp.oreg))
-                                   exp.fvars
-                                   exp.ffuns))))
-          (misleading-ref-check exp env form)
-          (push lt-frag me.lt-frags)
-          (new (frag dreg nil)))))))
+    (cond
+      (loaded-p me.(compile oreg env ^(quote ,exp)))
+      (*load-time* me.(compile oreg env exp))
+      (t (compile-in-toplevel me
+           (let* ((*load-time* t)
+                  (dreg me.(alloc-dreg))
+                  (exp me.(compile dreg (new env co me) exp))
+                  (lt-frag (new (frag dreg
+                                      ^(,*exp.code
+                                         ,*(maybe-mov dreg exp.oreg))
+                                      exp.fvars
+                                      exp.ffuns))))
+             (misleading-ref-check exp env form)
+             (push lt-frag me.lt-frags)
+             (new (frag dreg nil))))))))
 
 (defun maybe-mov (to-reg from-reg)
   (if (nequal to-reg from-reg)