test-suite/tests/guardians.test

   1 ;;;; guardians.test --- test suite for Guile Guardians     -*- scheme -*-
   2 ;;;; Jim Blandy <jimb@red-bean.com> --- July 1999
   3 ;;;;
   4 ;;;;    Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This program is free software; you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation; either version 2, or (at your option)
   9 ;;;; any later version.
  10 ;;;;
  11 ;;;; This program is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with this software; see the file COPYING.  If not, write to
  18 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  19 ;;;; Boston, MA 02110-1301 USA
  20
  21 ;;; These tests make some questionable assumptions.
  22 ;;;
  23 ;;; - They assume that a GC will find all dead objects, so they
  24 ;;;   will become flaky if we have a generational GC.
  25 ;;;
  26 ;;; - More generally, when a weakly referenced object doesn't disappear as
  27 ;;;   expected, it's hard to tell whether that's because of a guardian bug of
  28 ;;;   because a reference to it is being held somewhere, e.g., one some part
  29 ;;;   of the stack that hasn't been overwritten.  Thus, most tests cannot
  30 ;;;   fail, they can just throw `unresolved'.  We try hard to clear
  31 ;;;   references that may have been left on the stacks (see "clear refs left
  32 ;;;   on the stack" lines).
  33 ;;;
  34 ;;; - They assume that objects won't be saved by the guardian until
  35 ;;;   they explicitly invoke GC --- in other words, they assume that GC
  36 ;;;   won't happen too often.
  37
  38 (define-module (test-guardians)
  39   :use-module (test-suite lib)
  40   :use-module (ice-9 documentation)
  41   :use-module (ice-9 weak-vector))
  42
  43 \f
  44 ;;;
  45 ;;; miscellaneous
  46 ;;;
  47
  48 (define (documented? object)
  49   (not (not (object-documentation object))))
  50
  51
  52 (gc)
  53
  54 ;;; Who guards the guardian?
  55
  56 ;;; Note: We use strings rather than symbols because symbols are usually
  57 ;;; ``interned'', i.e., kept in a weakly-keyed hash table, thus making them
  58 ;;; inappropriate for the tests below.  Furthermore, we use `string-copy' in
  59 ;;; order to make sure that no string is kept around in the interpreter
  60 ;;; unwillingly (e.g., in the source-property weak hash table).
  61
  62 (gc)
  63 (define g2 (make-guardian))
  64 (g2 (list (string-copy "g2-garbage")))
  65 (define g3 (make-guardian))
  66 (g3 (list (string-copy "g3-garbage")))
  67 (g3 g2)
  68 (pass-if "g2-garbage not collected yet" (equal? (g2) #f))
  69 (pass-if "g3-garbage not collected yet" (equal? (g3) #f))
  70 (set! g2 #f)
  71 (gc)
  72 (let ((seen-g3-garbage #f)
  73       (seen-g2 #f)
  74       (seen-something-else #f))
  75   (let loop ()
  76     (let ((saved (g3)))
  77       (if saved
  78           (begin
  79             (cond
  80              ((equal? saved (list (string-copy "g3-garbage")))
  81               (set! seen-g3-garbage #t))
  82              ((procedure? saved) (set! seen-g2 saved))
  83              (else (pk 'junk saved) (set! seen-something-else #t)))
  84             (loop)))))
  85   (pass-if "g3-garbage saved" (or seen-g3-garbage (throw 'unresolved)))
  86   (pass-if "g2-saved" (or (procedure? seen-g2) (throw 'unresolved)))
  87   (pass-if "nothing else saved" (not seen-something-else))
  88
  89   ;; FIXME: The following test fails because the guardian for `g2-garbage'
  90   ;; disappared from the weak-car guardian list of `g2-garbage' right before
  91   ;; `g2-garbage' was finalized (in `finalize_guarded ()').  Sample session
  92   ;; (compiled with `-DDEBUG_GUARDIANS'):
  93   ;;
  94   ;; guile> (define g (make-guardian))
  95   ;; guile> (let ((g2 (make-guardian)))
  96   ;;          (format #t "g2 = ~x~%" (object-address g2))
  97   ;;          (g2 (string-copy "foo"))
  98   ;;          (g g2))
  99   ;; g2 = 81fde18
 100   ;; guile> (gc)
 101   ;; finalizing guarded 0x827f6a0 (1 guardians)
 102   ;;   guardian for 0x827f6a0 vanished
 103   ;; end of finalize (0x827f6a0)
 104   ;; finalizing guarded 0x81fde18 (1 guardians)
 105   ;; end of finalize (0x81fde18)
 106
 107   (pass-if "g2-garbage saved" (or (and (procedure? seen-g2)
 108                                        (equal? (seen-g2)
 109                                                (list (string-copy
 110                                                       "g2-garbage"))))
 111                                   (throw 'unresolved))))
 112
 113 (with-test-prefix "standard guardian functionality"
 114
 115   (with-test-prefix "make-guardian"
 116
 117     (pass-if "documented?"
 118       (documented? make-guardian))
 119
 120     (pass-if "returns procedure"
 121       (procedure? (make-guardian)))
 122
 123     (pass-if "returns new procedure each time"
 124       (not (equal? (make-guardian) (make-guardian)))))
 125
 126   (with-test-prefix "empty guardian"
 127
 128     (pass-if "returns #f"
 129       (eq? ((make-guardian)) #f))
 130
 131     (pass-if "returns always #f"
 132       (let ((g (make-guardian)))
 133         (and (eq? (g) #f)
 134              (begin (gc) (eq? (g) #f))
 135              (begin (gc) (eq? (g) #f))))))
 136
 137   (with-test-prefix "guarding independent objects"
 138
 139     (pass-if "guarding immediate"
 140       (let ((g (make-guardian)))
 141         (g #f)
 142         (and (eq? (g) #f)
 143              (begin (gc) (eq? (g) #f))
 144              (begin (gc) (eq? (g) #f)))))
 145
 146     (pass-if "guarding non-immediate"
 147       (let ((g (make-guardian)))
 148         (gc)
 149         (g (cons #f #f))
 150         (cons 'clear 'stack)  ;; clear refs left on the stack
 151         (if (not (eq? (g) #f))
 152             (throw 'unresolved)
 153             (begin
 154               (gc)
 155               (if (not (equal? (g) (cons #f #f)))
 156                   (throw 'unresolved)
 157                   (eq? (g) #f))))))
 158
 159     (pass-if "guarding two non-immediates"
 160       (let ((g (make-guardian)))
 161         (gc)
 162         (g (cons #f #f))
 163         (g (cons #t #t))
 164         (cons 'clear 'stack)  ;; clear refs left on the stack
 165         (if (not (eq? (g) #f))
 166             (throw 'unresolved)
 167             (begin
 168               (gc)
 169               (let ((l (list (g) (g))))
 170                 (if (not (or (equal? l (list (cons #f #f) (cons #t #t)))
 171                              (equal? l (list (cons #t #t) (cons #f #f)))))
 172                     (throw 'unresolved)
 173                     (eq? (g) #f)))))))
 174
 175     (pass-if "re-guarding non-immediates"
 176       (let ((g (make-guardian)))
 177         (gc)
 178         (g (cons #f #f))
 179         (cons 'clear 'stack)  ;; clear refs left on the stack
 180         (if (not (eq? (g) #f))
 181             (throw 'unresolved)
 182             (begin
 183               (gc)
 184               (let ((p (g)))
 185                 (if (not (equal? p (cons #f #f)))
 186                     (throw 'unresolved)
 187                     (begin
 188                       (g p)
 189                       (set! p #f)
 190                       (gc)
 191                       (if (not (equal? (g) (cons #f #f)))
 192                           (throw 'unresolved)
 193                           (eq? (g) #f)))))))))
 194
 195     (pass-if "guarding living non-immediate"
 196       (let ((g (make-guardian))
 197             (p (cons #f #f)))
 198         (g p)
 199         (if (not (eq? (g) #f))
 200             (throw 'fail)
 201             (begin
 202               (gc)
 203               (not (eq? (g) p)))))))
 204
 205   (with-test-prefix "guarding weakly referenced objects"
 206
 207     (pass-if "guarded weak vector element gets returned from guardian"
 208       (let ((g (make-guardian))
 209             (v (weak-vector #f)))
 210         (gc)
 211         (let ((p (cons #f #f)))
 212           (g p)
 213           (vector-set! v 0 p)
 214           (set! p #f))           ;; clear refs left on the stack
 215         (if (not (eq? (g) #f))
 216             (throw 'unresolved)
 217             (begin
 218               (gc)
 219               (if (not (equal? (g) (cons #f #f)))
 220                   (throw 'unresolved)
 221                   (eq? (g) #f))))))
 222
 223     (pass-if "guarded element of weak vector gets eventually removed from weak vector"
 224       (let ((g (make-guardian))
 225             (v (weak-vector #f)))
 226         (gc)
 227         (let ((p (cons #f #f)))
 228           (g p)
 229           (vector-set! v 0 p)
 230           (set! p #f))        ;; clear refs left on the stack
 231         (begin
 232           (gc)
 233           (if (not (equal? (g) (cons #f #f)))
 234               (throw 'unresolved)
 235               (begin
 236                 (gc)
 237                 (or (not (vector-ref v 0))
 238                     (throw 'unresolved))))))))
 239
 240   (with-test-prefix "guarding weak containers"
 241
 242     (pass-if "element of guarded weak vector gets collected"
 243       (let ((g (make-guardian))
 244             (v (weak-vector #f)))
 245         ;; Note: We don't pass `(cons #f #f)' as an argument to `weak-vector'
 246         ;; otherwise references to it are likely to be left on the stack.
 247         (vector-set! v 0 (cons #f #f))
 248
 249         (g v)
 250         (gc)
 251         (if (equal? (vector-ref v 0) (cons #f #f))
 252             (throw 'unresolved)
 253             #t))))
 254
 255   (with-test-prefix "guarding guardians"
 256     #t)
 257
 258   (with-test-prefix "guarding dependent objects"
 259
 260     ;; We don't make any guarantees about the order objects are
 261     ;; returned from guardians and therefore we skip the following
 262     ;; test.
 263
 264     (if #f
 265         (pass-if "guarding vector and element"
 266           (let ((g (make-guardian)))
 267             (gc)
 268             (let ((p (cons #f #f)))
 269               (g p)
 270               (g (vector p)))
 271             (if (not (eq? (g) #f))
 272                 (throw 'unresolved)
 273                 (begin
 274                   (gc)
 275                   (if (not (equal? (g) (vector (cons #f #f))))
 276                       (throw 'unresolved)
 277                       (if (not (eq? (g) #f))
 278                           (throw 'unresolved)
 279                           (begin
 280                             (gc)
 281                             (if (not (equal? (g) (cons #f #f)))
 282                                 (throw 'unresolved)
 283                                 (eq? (g) #f)))))))))))
 284
 285   (with-test-prefix "guarding objects more than once"
 286
 287     (pass-if "guarding twice in one guardian"
 288        (let ((g (make-guardian)))
 289          (gc)
 290          (let ((p (cons #f #f)))
 291            (g p)
 292            (g p)
 293            (set! p #f))       ;; clear refs left on the stack
 294          (if (not (eq? (g) #f))
 295              (throw 'unresolved)
 296              (begin
 297                (gc)
 298                (or (and (and=> (g) (lambda (o) (equal? o (cons #f #f))))
 299                         (and=> (g) (lambda (o) (equal? o (cons #f #f)))))
 300                    (throw 'unresolved))))))
 301
 302     (pass-if "guarding twice in two guardians"
 303        (let ((g (make-guardian))
 304              (h (make-guardian)))
 305          (gc)
 306          (let ((p (cons #f #f)))
 307            (g p)
 308            (h p)
 309            (set! p #f))         ;; clear refs left on the stack
 310          (if (not (eq? (g) #f))
 311              (throw 'unresolved)
 312              (begin
 313                (gc)
 314                (or (and (and=> (g) (lambda (o) (equal? o (cons #f #f))))
 315                         (and=> (h) (lambda (o) (equal? o (cons #f #f)))))
 316                    (throw 'unresolved)))))))
 317
 318   (with-test-prefix "guarding cyclic dependencies"
 319     #t)
 320
 321   )