Add :application-type parameter for save-lisp-and-die on Windows.
[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 that WITHOUT-GCING defers explicit gc
35   (sb-sys:without-gcing
36     (gc)
37     (assert (not gc-happend)))
38   (assert gc-happend)
39
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)))
54
55 ;;; SB-EXT:GENERATION-* accessors returned bogus values for generation > 0
56 (with-test (:name :bug-529014 :skipped-on '(not :gencgc))
57   (loop for i from 0 to sb-vm:+pseudo-static-generation+
58      do (assert (= (sb-ext:generation-bytes-consed-between-gcs i)
59                    (truncate (sb-ext:bytes-consed-between-gcs)
60                              sb-vm:+highest-normal-generation+)))
61         ;; FIXME: These parameters are a) tunable in the source and b)
62         ;; duplicated multiple times there and now here.  It would be good to
63         ;; OAOO-ify them (probably to src/compiler/generic/params.lisp).
64         (assert (= (sb-ext:generation-minimum-age-before-gc i) 0.75))
65         (assert (= (sb-ext:generation-number-of-gcs-before-promotion i) 1))))
66
67 (defun stress-gc ()
68   ;; Kludge or not?  I don't know whether the smaller allocation size
69   ;; for sb-safepoint is a legitimate correction to the test case, or
70   ;; rather hides the actual bug this test is checking for...  It's also
71   ;; not clear to me whether the issue is actually safepoint-specific.
72   ;; But the main problem safepoint-related bugs tend to introduce is a
73   ;; delay in the GC triggering -- and if bug-936304 fails, it also
74   ;; causes bug-981106 to fail, even though there is a full GC in
75   ;; between, which makes it seem unlikely to me that the problem is
76   ;; delay- (and hence safepoint-) related. --DFL
77   (let* ((x (make-array (truncate #-sb-safepoint (* 0.2 (dynamic-space-size))
78                                   #+sb-safepoint (* 0.1 (dynamic-space-size))
79                                   sb-vm:n-word-bytes))))
80     (elt x 0)))
81
82 (with-test (:name :bug-936304)
83   (gc :full t)
84   (time
85    (assert (eq :ok (handler-case
86                        (progn
87                          (loop repeat 50 do (stress-gc))
88                          :ok)
89                      (storage-condition ()
90                        :oom))))))
91
92 (with-test (:name :bug-981106)
93   (gc :full t)
94   (time
95    (assert (eq :ok
96                (handler-case
97                    (dotimes (runs 100 :ok)
98                      (let* ((n (truncate (dynamic-space-size) 1200))
99                             (len (length
100                                   (with-output-to-string (string)
101                                     (dotimes (i n)
102                                       (write-sequence "hi there!" string))))))
103                        (assert (eql len (* n (length "hi there!"))))))
104                  (storage-condition ()
105                    :oom))))))
106
107 (with-test (:name :gc-logfile)
108   (assert (not (gc-logfile)))
109   (let ((p #p"gc.log"))
110     (assert (not (probe-file p)))
111     (assert (equal p (setf (gc-logfile) p)))
112     (gc)
113     (let ((p2 (gc-logfile)))
114       (assert (equal (truename p2) (truename p))))
115     (assert (not (setf (gc-logfile) nil)))
116     (assert (not (gc-logfile)))
117     (delete-file p)))