compiler: split variable spies into two types.

We have the situation that there are effectively two kinds of
spies: let constructs plant spies only in order to learn about
what variables are being captured, whereas lambdas plant spies
in order to intercept variable accesses (and to inform the
spies that are interested in what is captured). Let us split
these up into two separate types, with different methods,
in different stacks.

* share/txr/stdlib/compiler.tl (struct var-spy): Renamed to
closure-spy.
(var-spy accessed, var-spy assigned): Methods removed: the
closure-spy type has only the captured method.
(struct capture-var-spy): Renamed to accesss-spy.
(capture-var-spy var-spies): Renamed to access-spy
closure-spies.
(capture-var-spy captured): Method removed; the access spy is
doesn't receive captured calls.
(struct compiler): Slot var-spies removed, replaced with
closure-spies and access-spies.
(with-var-spy): Macro removed.
(with-spy): New function.
(with-closure-spy, with-access-spy): New macros.
(compiler push-var-spy, compiler pop-var-spy): Methods
removed.
(compiler push-closure-spy, compiler pop-closure-spy,
compiler push-access-spy, compiler pop-access-spy): New
methods.
(compiler comp-var, compiler comp-setq, compiler
comp-lisp1-setq, compiler comp-lisp1-value): Walk new
access-spies list rather than var-spies to report about
accesses and assignments.
(compiler comp-let): Use with-closure-spy macro rather than
with var-spy. The spy object is now a closure-spy type,
and the variable is cspy rather than vspy.
(compiler comp-lambda-impl): Use with-access-spy instead of
with-var-spy. The spy object is now of type access-spy.
It refers to the current me.closure-spies from the compiler.

1 files changed, 44 insertions, 33 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 622ac476..c810267d 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -138,32 +138,26 @@
     (let* ((bn (new blockinfo sym sym env me)))
       (set me.bb (acons sym bn me.bb)))))
 
-(defstruct var-spy ()
+(defstruct closure-spy ()
   env
   cap-vars
 
-  (:method accessed (me vbin sym))
-
-  (:method assigned (me vbin sym))
-
   (:method captured (me vbin sym)
     (when (eq vbin.env me.env)
       (pushnew sym me.cap-vars))))
 
-(defstruct capture-var-spy ()
-  var-spies
+(defstruct access-spy ()
+  closure-spies
 
   (:method accessed (me vbin sym)
-    (each ((spy me.var-spies))
+    (each ((spy me.closure-spies))
       (when (neq spy me)
         spy.(captured vbin sym))))
 
   (:method assigned (me vbin sym)
-    (each ((spy me.var-spies))
+    (each ((spy me.closure-spies))
       (when (neq spy me)
-        spy.(captured vbin sym))))
-
-  (:method captured (me vbin sym)))
+        spy.(captured vbin sym)))))
 
 (compile-only
   (defstruct compiler nil
@@ -181,7 +175,8 @@
     symvec
     lt-frags
     last-form
-    var-spies
+    closure-spies
+    access-spies
 
     (:method snapshot (me)
       (let ((snap (copy me)))
@@ -230,13 +225,19 @@
                 (qref ,me treg-cntr) ,saved-treg-cntr
                 (qref ,me discards) ,saved-discards)))))
 
-  (defmacro with-var-spy (me flag spy spy-expr . body)
+  (defun with-spy (me flag spy spy-expr body push-meth pop-meth)
     ^(let ((,spy (if ,flag ,spy-expr)))
        (unwind-protect
          (progn
-           (if ,spy (qref ,me (push-var-spy ,spy)))
+           (if ,spy (qref ,me (,push-meth ,spy)))
            ,*body)
-         (if ,spy (qref ,me (pop-var-spy ,spy)))))))
+         (if ,spy (qref ,me (,pop-meth ,spy))))))
+
+  (defmacro with-closure-spy (me flag spy spy-expr . body)
+    (with-spy me flag spy spy-expr body 'push-closure-spy 'pop-closure-spy))
+
+  (defmacro with-access-spy (me flag spy spy-expr . body)
+    (with-spy me flag spy spy-expr body 'push-access-spy 'pop-access-spy)))
 
 (defvarl %gcall-op% (relate '(apply usr:apply call) '(gapply gapply gcall)))
 
@@ -442,15 +443,25 @@
                      "code too complex: lexical nesting too deep"))
     (set me.nlev (succ env.lev))))
 
-(defmeth compiler push-var-spy (me spy)
-  (push spy me.var-spies))
+(defmeth compiler push-closure-spy (me spy)
+  (push spy me.closure-spies))
+
+(defmeth compiler pop-closure-spy (me spy)
+  (let ((top (pop me.closure-spies)))
+    (unless spy
+      (error "closure spy stack bug in compiler"))
+    (unless (eq top spy)
+      (error "closure spy stack balance problem in compiler"))))
+
+(defmeth compiler push-access-spy (me spy)
+  (push spy me.access-spies))
 
-(defmeth compiler pop-var-spy (me spy)
-  (let ((top (pop me.var-spies)))
+(defmeth compiler pop-access-spy (me spy)
+  (let ((top (pop me.access-spies)))
     (unless spy
-      (error "spy stack bug in compiler"))
+      (error "access spy stack bug in compiler"))
     (unless (eq top spy)
-      (error "spy stack balance problem in compiler"))))
+      (error "access spy stack balance problem in compiler"))))
 
 (defmeth compiler compile (me oreg env form)
   (set me.last-form form)
@@ -532,7 +543,7 @@
   (let ((vbin env.(lookup-var sym)))
     (cond
       (vbin
-        (each ((spy me.var-spies))
+        (each ((spy me.access-spies))
           spy.(accessed vbin sym))
         (new (frag vbin.loc nil (list sym))))
       ((special-var-p sym)
@@ -550,7 +561,7 @@
                    (t me.(get-sidx sym))))
            (vfrag me.(compile (if bind vloc oreg) env value)))
       (when bind
-        (each ((spy me.var-spies))
+        (each ((spy me.access-spies))
           spy.(assigned bind sym)))
       (new (frag vfrag.oreg
                  ^(,*vfrag.code
@@ -576,7 +587,7 @@
                         (setl1 ,vfrag.oreg ,l1loc))
                       (uni (list sym) vfrag.fvars)
                       vfrag.ffuns))))
-        (t (each ((spy me.var-spies))
+        (t (each ((spy me.access-spies))
              spy.(assigned bind sym))
           me.(compile oreg env ^(sys:setq ,sym ,val)))))))
 
@@ -944,9 +955,9 @@
            (seq (eq sym 'let*))
            (nenv (new env up env co me))
            (fenv (if seq nenv (new env up env co me))))
-      (with-var-spy me (and (not specials-occur)
-                            (>= *opt-level* 2))
-                    vspy (new var-spy env nenv)
+      (with-closure-spy me (and (not specials-occur)
+                                (>= *opt-level* 2))
+                        cspy (new closure-spy env nenv)
         (unless seq
           (each ((lsym lexsyms))
             nenv.(extend-var lsym)))
@@ -992,7 +1003,7 @@
                (code (append code bfrag.code
                              me.(maybe-mov boreg bfrag.oreg)
                              ^((end ,boreg)))))
-          (when (and vspy (null vspy.cap-vars))
+          (when (and cspy (null cspy.cap-vars))
             (set code me.(eliminate-frame code nenv)))
           (when treg
             me.(free-treg treg))
@@ -1044,9 +1055,9 @@
 
 (defmeth compiler comp-lambda-impl (me oreg env form)
   (mac-param-bind form (op par-syntax . body) form
-    (with-var-spy me me.var-spies
-                  spy (new capture-var-spy
-                           var-spies me.var-spies)
+    (with-access-spy me me.closure-spies
+                     spy (new access-spy
+                              closure-spies me.closure-spies)
       (compile-with-fresh-tregs me
         (let* ((*load-time* nil)
                (pars (new (fun-param-parser par-syntax form)))
@@ -1511,7 +1522,7 @@
        (let ((bind env.(lookup-lisp1 arg t)))
          (cond
            (bind
-             (each ((spy me.var-spies))
+             (each ((spy me.access-spies))
                spy.(accessed bind arg))
              (new (frag bind.loc
                         nil