From fb135e12a473fd9a1612a59f904cfb90877fe775 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Wed, 9 Nov 2011 23:45:53 +0100
Subject: [PATCH] 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.
---
 module/language/tree-il/compile-glil.scm | 22 +++++++++++++++++++
 test-suite/tests/gc.test                 | 28 ++++++++++++++++--------
 2 files changed, 41 insertions(+), 9 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
diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test
index 57643e825..25dc5779d 100644
--- a/test-suite/tests/gc.test
+++ b/test-suite/tests/gc.test
@@ -16,8 +16,10 @@
 ;;;; License along with this library; if not, write to the Free Software
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
-(use-modules (ice-9 documentation)
-	     (test-suite lib))
+(define-module (test-suite tests gc)
+  #:use-module (ice-9 documentation)
+  #:use-module (test-suite lib)
+  #:use-module ((system base compile) #:select (compile)))
 
 
 ;;;
@@ -62,10 +64,8 @@
       (add-hook! after-gc-hook thunk)
       (gc)
       (remove-hook! after-gc-hook thunk)
-      foo)))
+      foo))
 
-
-(with-test-prefix "gc"
   (pass-if "Unused modules are removed"
     (let* ((guard (make-guardian))
            (total 1000))
@@ -76,12 +76,22 @@
       (stack-cleanup 20)
 
       (gc)
-      (gc) ;; twice: have to kill the weak vectors.
-      (gc) ;; thrice: because the test doesn't succeed with only
-           ;; one gc round. not sure why.
+      (gc)   ;; twice: have to kill the weak vectors.
+      (gc)   ;; thrice: because the test doesn't succeed with only
+      ;; one gc round. not sure why.
 
       (= (let lp ((i 0))
            (if (guard)
                (lp (1+ i))
                i))
-         total))))
+         total)))
+
+  (pass-if "Lexical vars are collectable"
+    (procedure?
+     (compile
+      '(begin
+         (define guardian (make-guardian))
+         (let ((f (lambda () (display "test\n"))))
+           (guardian f))
+         (gc)(gc)(gc)
+         (guardian))))))
-- 
2.20.1