Calculate usecs correctly in thread-sleep!

[bpt/guile.git] / test-suite / tests / gc.test

diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test
index badf2b7..04f3539 100644 (file)
--- a/test-suite/tests/gc.test
+++ b/test-suite/tests/gc.test
@@ -1,10 +1,11 @@
 ;;;; gc.test --- test guile's garbage collection    -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008, 2009,
+;;;;   2011, 2012, 2013 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
 ;;;; License as published by the Free Software Foundation; either
-;;;; version 2.1 of the License, or (at your option) any later version.
+;;;; version 3 of the License, or (at your option) any later version.
 ;;;; 
 ;;;; This library is distributed in the hope that it will be useful,
 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@@ -15,10 +16,22 @@
 ;;;; 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 (tests gc)
+  #:use-module (ice-9 documentation)
+  #:use-module (test-suite lib)
+  #:use-module ((system base compile) #:select (compile)))
 
 
+;; Some of these tests verify that things are collectable.  As we use a
+;; third-party conservative collector, we really can't guarantee that --
+;; we can try, but on some platforms, on some versions (possibly), the
+;; test might fail.  But we don't want that to stop the build.  So,
+;; instead of failing, throw 'unresolved.
+;;
+(define (maybe-gc-flakiness result)
+  (or result
+      (throw 'unresolved)))
+
 ;;;
 ;;; miscellaneous
 ;;;
@@ -54,27 +67,38 @@
       (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*
-              ((dummy (gc))
-               (last-count (cdr (assoc
-                                 "eval-closure" (gc-live-object-stats)))))
-
-            (for-each (lambda (x) (make-module)) (iota 1000))
-
-            ;; XXX: This hack aims to clean up the stack to make sure we
-            ;; don't leave a reference to one of the modules we created.  It
-            ;; proved to be useful on SPARC:
-            ;; http://lists.gnu.org/archive/html/guile-devel/2008-02/msg00006.html .
-             (let cleanup ((i 10))
-               (and (> i 0)
-                    (begin (cleanup (1- i)) i)))
-
-            (gc)
-            (gc) ;; twice: have to kill the weak vectors.
-            (= last-count (cdr (assoc "eval-closure" (gc-live-object-stats)))))
-          ))
+    (let* ((guard (make-guardian))
+           (total 1000))
+
+      (for-each (lambda (x) (guard (make-module))) (iota total))
+
+      ;; Avoid false references to the modules on the stack.
+      (clear-stale-stack-references)
+
+      (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.
+
+      (maybe-gc-flakiness
+       (= (let lp ((i 0))
+            (if (guard)
+                (lp (1+ i))
+                i))
+          total))))
+
+  (pass-if "Lexical vars are collectable"
+    (let ((l (compile
+              '(begin
+                 (define guardian (make-guardian))
+                 (let ((f (list 'foo)))
+                   (guardian f))
+                 ((@ (test-suite lib) clear-stale-stack-references))
+                 (gc)(gc)(gc)
+                 (guardian))
+              ;; Prevent the optimizer from propagating f.
+              #:opts '(#:partial-eval? #f))))
+      (maybe-gc-flakiness (equal? l '(foo))))))