when leaving a non-tail let, allow bound vals to be collected

* module/language/tree-il/compile-glil.scm (flatten-lambda-case): Clear
  lexical stack slots at the end of a non-tail let, letrec, or fix.
  Fixes http://debbugs.gnu.org/9900.

* test-suite/tests/gc.test ("gc"): Add test.

1 files changed, 22 insertions, 0 deletions

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 3daac7fca..de55026ab 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -237,6 +237,24 @@
           (if (eq? context 'tail)
               (emit-code #f (make-glil-call 'return 1)))))
     
+    ;; After lexical binding forms in non-tail context, call this
+    ;; function to clear stack slots, allowing their previous values to
+    ;; be collected.
+    (define (clear-stack-slots context syms)
+      (case context
+        ((push drop)
+         (for-each (lambda (v)
+                     (and=>
+                      ;; Can be #f if the var is labels-allocated.
+                      (hashq-ref allocation v)
+                      (lambda (h)
+                        (pmatch (hashq-ref h self)
+                          ((#t _ . ,n)
+                           (emit-code #f (make-glil-void))
+                           (emit-code #f (make-glil-lexical #t #f 'set n)))
+                          (,loc (error "bad let var allocation" x loc))))))
+                   syms))))
+
     (record-case x
       ((<void>)
        (case context
@@ -802,6 +820,7 @@
                      (,loc (error "bad let var allocation" x loc))))
                  (reverse gensyms))
        (comp-tail body)
+       (clear-stack-slots context gensyms)
        (emit-code #f (make-glil-unbind)))
 
       ((<letrec> src in-order? names gensyms vals body)
@@ -834,6 +853,7 @@
                        (,loc (error "bad letrec var allocation" x loc))))
                    (reverse gensyms))))
        (comp-tail body)
+       (clear-stack-slots context gensyms)
        (emit-code #f (make-glil-unbind)))
 
       ((<fix> src names gensyms vals body)
@@ -922,6 +942,7 @@
          (comp-tail body)
          (if new-RA
              (emit-label new-RA))
+         (clear-stack-slots context gensyms)
          (emit-code #f (make-glil-unbind))))
 
       ((<let-values> src exp body)
@@ -947,6 +968,7 @@
                           (,loc (error "bad let-values var allocation" x loc))))
                       (reverse gensyms))
             (comp-tail body)
+            (clear-stack-slots context gensyms)
             (emit-code #f (make-glil-unbind))))))
 
       ;; much trickier than i thought this would be, at first, due to the need