diff --git a/test-suite/lib.scm b/test-suite/lib.scm index 9a03dc915..681a0d158 100644 --- a/test-suite/lib.scm +++ b/test-suite/lib.scm @@ -1,6 +1,6 @@ ;;;; test-suite/lib.scm --- generic support for testing ;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009, 2010, -;;;; 2011 Free Software Foundation, Inc. +;;;; 2011, 2012 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -56,6 +56,9 @@ ;; Using the debugging evaluator. with-debugging-evaluator with-debugging-evaluator* + ;; Clearing stale references on the C stack for GC-sensitive tests. + clear-stale-stack-references + ;; Using a given locale with-locale with-locale* with-latin1-locale with-latin1-locale* @@ -484,6 +487,17 @@ (define-macro (with-debugging-evaluator . body) `(with-debugging-evaluator* (lambda () ,@body))) +;; Recurse through a C function that should clear any values that might +;; have spilled on the stack temporarily. (The salient feature of +;; with-continuation-barrier is that currently it is implemented as a C +;; function that recursively calls the VM.) +;; +(define* (clear-stale-stack-references #:optional (n 10)) + (if (positive? n) + (with-continuation-barrier + (lambda () + (clear-stale-stack-references (1- n)))))) + ;;; Call THUNK with a given locale (define (with-locale* nloc thunk) (let ((loc #f)) diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test index 97eeb195e..1afcea332 100644 --- a/test-suite/tests/gc.test +++ b/test-suite/tests/gc.test @@ -49,13 +49,6 @@ ;;; ;;; -(define (stack-cleanup depth) - ;; Clean up stack space for DEPTH words. This is defined here so that - ;; `peval' doesn't inline it. - (let cleanup ((i depth)) - (and (> i 0) - (begin (cleanup (1- i)) i)))) - (with-test-prefix "gc" (pass-if "after-gc-hook gets called" @@ -73,7 +66,7 @@ (for-each (lambda (x) (guard (make-module))) (iota total)) ;; Avoid false references to the modules on the stack. - (stack-cleanup 20) + (clear-stale-stack-references) (gc) (gc) ;; twice: have to kill the weak vectors. @@ -92,21 +85,9 @@ (define guardian (make-guardian)) (let ((f (list 'foo))) (guardian f)) - ;; See below. - ;; ((lambda () #t)) + ((@ (test-suite lib) clear-stale-stack-references)) (gc)(gc)(gc) (guardian)) ;; Prevent the optimizer from propagating f. #:opts '(#:partial-eval? #f)))) - (if (not l) - ;; We think that something on the C stack in the VM is holding - ;; on to a reference to the list. This happens on - ;; register-poor architectures, where more locals are spilled - ;; to the stack. If more code runs before the (gc) is run, - ;; like a ((lambda () #t)), then the test passes. So given - ;; that at some point, the reference will be dropped, we will - ;; count these cases as "unresolved" instead of "fail". - ;; - ;; See http://debbugs.gnu.org/cgi/bugreport.cgi?bug=10336. - (throw 'unresolved) - (equal? l '(foo)))))) + (equal? l '(foo))))) diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index 85a7c38ef..be722fc75 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -1,6 +1,6 @@ ;;;; threads.test --- Tests for Guile threading. -*- scheme -*- ;;;; -;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012 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 @@ -36,13 +36,6 @@ (equal? '(a b c) '(a b c)) a)) -(define (stack-cleanup depth) - ;; Clean up stack space for DEPTH words. This is defined here so that - ;; `peval' doesn't inline it. - (let cleanup ((i depth)) - (and (> i 0) - (begin (cleanup (1- i)) i)))) - (if (provided? 'threads) (begin @@ -410,7 +403,7 @@ (g (let ((m (make-mutex))) (lock-mutex m) m)) ;; Avoid false references to M on the stack. - (stack-cleanup 20) + (clear-stale-stack-references) (gc) (gc) (let ((m (g)))