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