tests/gc.impure.lisp

   1 ;;;; gc tests
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absoluely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (in-package :cl-user)
  15
  16 (defparameter *x* ())
  17
  18 (defun cons-madly ()
  19   (loop repeat 10000 do
  20         (setq *x* (make-string 100000))))
  21
  22 ;; check that WITHOUT-INTERRUPTS doesn't block the gc trigger
  23 (sb-sys:without-interrupts (cons-madly))
  24
  25 ;; check that WITHOUT-INTERRUPTS doesn't block SIG_STOP_FOR_GC
  26 #+sb-thread
  27 (sb-sys:without-interrupts
  28   (let ((thread (sb-thread:make-thread (lambda () (sb-ext:gc)))))
  29     (loop while (sb-thread:thread-alive-p thread))))
  30
  31 (let ((gc-happend nil))
  32   (push (lambda () (setq gc-happend t)) sb-ext:*after-gc-hooks*)
  33
  34   ;; check GC-{ON,OFF} works and gc is deferred
  35   (gc-off)
  36   (gc)
  37   (assert (not gc-happend))
  38   (gc-on)
  39   (assert gc-happend)
  40
  41   ;; check that WITHOUT-GCING defers explicit gc
  42   (setq gc-happend nil)
  43   (sb-sys:without-gcing
  44     (gc)
  45     (assert (not gc-happend)))
  46   (assert gc-happend)
  47
  48   ;; check that WITHOUT-GCING defers SIG_STOP_FOR_GC
  49   #+sb-thread
  50   (let ((in-without-gcing nil))
  51     (setq gc-happend nil)
  52     (sb-thread:make-thread (lambda ()
  53                              (loop while (not in-without-gcing))
  54                              (sb-ext:gc)))
  55     (sb-sys:without-gcing
  56       (setq in-without-gcing t)
  57       (sleep 3)
  58       (assert (not gc-happend)))
  59     ;; give the hook time to run
  60     (sleep 1)
  61     (assert gc-happend))
  62
  63   ;; check GC-ON works even in a WITHOUT-GCING
  64   (setq gc-happend nil)
  65   (sb-sys:without-gcing
  66     (gc)
  67     (assert (not gc-happend))
  68     (gc-on)
  69     (assert gc-happend)
  70     (setq gc-happend nil))
  71   (assert (not gc-happend)))
  72