1.0.33.5: improve DESCRIBE (#lp488976)
[sbcl/llvm.git] / tests / gc.impure.lisp
blobc00438b57867331ba6be337e85976282f43a717a
1 ;;;; gc tests
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.
14 (in-package :cl-user)
16 (defparameter *x* ())
18 (defun cons-madly ()
19 (loop repeat 10000 do
20 (setq *x* (make-string 100000))))
22 ;; check that WITHOUT-INTERRUPTS doesn't block the gc trigger
23 (sb-sys:without-interrupts (cons-madly))
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))))
31 (let ((gc-happend nil))
32 (push (lambda () (setq gc-happend t)) sb-ext:*after-gc-hooks*)
34 ;; check that WITHOUT-GCING defers explicit gc
35 (sb-sys:without-gcing
36 (gc)
37 (assert (not gc-happend)))
38 (assert gc-happend)
40 ;; check that WITHOUT-GCING defers SIG_STOP_FOR_GC
41 #+sb-thread
42 (let ((in-without-gcing nil))
43 (setq gc-happend nil)
44 (sb-thread:make-thread (lambda ()
45 (loop while (not in-without-gcing))
46 (sb-ext:gc)))
47 (sb-sys:without-gcing
48 (setq in-without-gcing t)
49 (sleep 3)
50 (assert (not gc-happend)))
51 ;; give the hook time to run
52 (sleep 1)
53 (assert gc-happend)))