1.0.23.21: Stack allocated conses for MIPS.
[sbcl.git] / 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