test-suite/tests/gc.test

   1 ;;;; gc.test --- test guile's garbage collection    -*- scheme -*-
   2 ;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008, 2009,
   3 ;;;;   2011, 2012, 2013 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (tests gc)
  20   #:use-module (ice-9 documentation)
  21   #:use-module (test-suite lib)
  22   #:use-module ((system base compile) #:select (compile)))
  23
  24
  25 ;; Some of these tests verify that things are collectable.  As we use a
  26 ;; third-party conservative collector, we really can't guarantee that --
  27 ;; we can try, but on some platforms, on some versions (possibly), the
  28 ;; test might fail.  But we don't want that to stop the build.  So,
  29 ;; instead of failing, throw 'unresolved.
  30 ;;
  31 (define (maybe-gc-flakiness result)
  32   (or result
  33       (throw 'unresolved)))
  34
  35 ;;;
  36 ;;; miscellaneous
  37 ;;;
  38
  39
  40 (define (documented? object)
  41   (not (not (object-documentation object))))
  42
  43 ;; In guile 1.6.4 this test bombed, due to the record in h being collected
  44 ;; by the gc, but not removed from h, leaving "x" as a freed cell.
  45 ;; The usual correct result here is for x to be #f, but there's always a
  46 ;; chance gc will mark something used when it isn't, so we allow x to be a
  47 ;; record too.
  48 (pass-if "weak-values versus records"
  49   (let ((rec-type (make-record-type "foo" '()))
  50         (h        (make-weak-value-hash-table 61)))
  51     (hash-set! h "foo" ((record-constructor rec-type)))
  52     (gc)
  53     (let ((x (hash-ref h "foo")))
  54       (or (not x)
  55           ((record-predicate rec-type) x)))))
  56
  57
  58 ;;;
  59 ;;;
  60 ;;;
  61
  62 (with-test-prefix "gc"
  63
  64   (pass-if "after-gc-hook gets called"
  65     (let* ((foo #f)
  66            (thunk (lambda () (set! foo #t))))
  67       (add-hook! after-gc-hook thunk)
  68       (gc)
  69       (remove-hook! after-gc-hook thunk)
  70       foo))
  71
  72   (pass-if "Unused modules are removed"
  73     (let* ((guard (make-guardian))
  74            (total 1000))
  75
  76       (for-each (lambda (x) (guard (make-module))) (iota total))
  77
  78       ;; Avoid false references to the modules on the stack.
  79       (clear-stale-stack-references)
  80
  81       (gc)
  82       (gc)   ;; twice: have to kill the weak vectors.
  83       (gc)   ;; thrice: because the test doesn't succeed with only
  84       ;; one gc round. not sure why.
  85
  86       (maybe-gc-flakiness
  87        (= (let lp ((i 0))
  88             (if (guard)
  89                 (lp (1+ i))
  90                 i))
  91           total))))
  92
  93   (pass-if "Lexical vars are collectable"
  94     (let ((l (compile
  95               '(begin
  96                  (define guardian (make-guardian))
  97                  (let ((f (list 'foo)))
  98                    (guardian f))
  99                  ((@ (test-suite lib) clear-stale-stack-references))
 100                  (gc)(gc)(gc)
 101                  (guardian))
 102               ;; Prevent the optimizer from propagating f.
 103               #:opts '(#:partial-eval? #f))))
 104       (maybe-gc-flakiness (equal? l '(foo))))))