common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

run-tests: add --gc-stress

Browse source
This commit is contained in:
Stas Boukarev 2023-11-29 20:24:17 +03:00
parent c17571f4f7
commit f07a4bdb04
9 changed files with 94 additions and 55 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
tests/compiler-test-util.lisp
View file

@ -145,12 +145,14 @@
(collect-consing-stats thunk times)
(let* ((consed-bytes (- after before))
(bytes-per-iteration (float (/ consed-bytes times))))
(assert (funcall (if yes/no #'not #'identity)
;; If allocation really happened, it can't have been less than one cons cell
;; per iteration (unless the test is nondeterministic - but in that case
;; we can't really use this strategy anyway). So consider it to have consed
;; nothing if the fraction is too small.
(< bytes-per-iteration (* 2 sb-vm:n-word-bytes)))
(assert (progn
(funcall (if yes/no #'not #'identity)
;; If allocation really happened, it can't have been less than one cons cell
;; per iteration (unless the test is nondeterministic - but in that case
;; we can't really use this strategy anyway). So consider it to have consed
;; nothing if the fraction is too small.
(< bytes-per-iteration (* 2 sb-vm:n-word-bytes)))
#+gc-stress t)
()
"~@<Expected the form ~
~4I~@:_~A ~0I~@:_~

4
tests/gc-smoketest.pure.lisp
View file

@ -15,4 +15,6 @@
;;; Don't loop infinitely in mark_obj() on circular lists
(defvar *foo* (cons nil nil))
(rplacd *foo* *foo*)
(with-test (:name :circular-list) (gc :gen 7))
(with-test (:name :circular-list :skipped-on (and :arm64 :gc-stress))
(gc :gen 7))
(setf *l* nil)

3
tests/lockfree-list.pure.lisp
View file

@ -249,7 +249,8 @@
;; Show that nodes which are referenced only via a "fixnum" pointer
;; can and do actually move via GC, which adjusts the fixnum accordingly.
(test-util:with-test (:name :lfl-not-pinned)
(test-util:with-test (:name :lfl-not-pinned
:skipped-on :gc-stress)
(gc)
(assert (= (sb-kernel:generation-of *5*) 0))
(assert (= (sb-kernel:generation-of *10*) 0))

1
tests/make-thread.pure.lisp
View file

@ -28,6 +28,7 @@
(let ((threads sb-thread::*starting-threads*))
(when (find-if-not #'thread-ephemeral-p threads)
(error "Should not see new thread in starting list: ~S" threads)))
#-gc-stress
(let ((threads (remove sb-thread::*initial-thread*
(sb-thread::avltree-list sb-thread::*all-threads*))))
(when (find-if-not #'thread-ephemeral-p threads)

1
tests/pathnames.pure.lisp
View file

@ -958,7 +958,6 @@
(assert (equal (compile-file-pathname "a/b/srcfile.lsp")
#P"a/b/srcfile.fasl"))))
(load "compiler-test-util.lisp")
(with-test (:name :intern-pathname-non-consy
:skipped-on :interpreter)
(ctu:assert-no-consing (make-pathname :name "hi" :type "txt")))

107
tests/run-tests.lisp
View file

@ -1,3 +1,6 @@
(when (member "--gc-stress" *posix-argv* :test #'equal)
(push :gc-stress *features*))
(load "test-util.lisp")
(load "assertoid.lisp")
(load "compiler-test-util.lisp")
@ -19,50 +22,67 @@
(load "test-funs")
(defun run-all (&aux (start-time (get-internal-real-time)))
(loop :with remainder = (rest *posix-argv*)
:for arg = (car remainder)
:while remainder
:do
(pop remainder)
(cond
((string= arg "--evaluator-mode")
(let ((mode (pop remainder)))
(cond
((string= mode "interpret")
(setf *test-evaluator-mode* :interpret))
((string= mode "compile")
(setf *test-evaluator-mode* :compile))
(t
(error "~@<Invalid evaluator mode: ~A. Must be one ~
(let (skip-to)
(loop :with remainder = (rest *posix-argv*)
:for arg = (car remainder)
:while remainder
:do
(pop remainder)
(cond
((string= arg "--evaluator-mode")
(let ((mode (pop remainder)))
(cond
((string= mode "interpret")
(setf *test-evaluator-mode* :interpret))
((string= mode "compile")
(setf *test-evaluator-mode* :compile))
(t
(error "~@<Invalid evaluator mode: ~A. Must be one ~
of interpret, compile.~@:>"
mode)))))
((string= arg "--break-on-failure")
(setf *break-on-error* t)
(setf test-util:*break-on-failure* t))
((string= arg "--break-on-expected-failure")
(setf test-util:*break-on-expected-failure* t))
((string= arg "--report-skipped-tests")
(setf *report-skipped-tests* t))
((string= arg "--no-color"))
((string= arg "--slow")
(push :slow *features*))
(t
(push (merge-pathnames (parse-namestring arg)) *explicit-test-files*))))
(setf *explicit-test-files* (nreverse *explicit-test-files*))
;; FIXME: randomizing the order tests are run in, especially the "pure" ones,
;; might help detect accidental side-effects by inducing failures elsewhere.
;; And/or try all permutations using an infinite number of machines.
(with-open-file (log "test.log" :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(pure-runner (pure-load-files) 'load-test log)
(pure-runner (pure-cload-files) 'cload-test log)
(impure-runner (impure-load-files) 'load-test log)
(impure-runner (impure-cload-files) 'cload-test log)
(impure-runner (sh-files) 'sh-test log)
(log-file-elapsed-time "GRAND TOTAL" start-time log))
(report)
(sb-ext:exit :code (if (unexpected-failures) 1 104)))
mode)))))
((string= arg "--break-on-failure")
(setf *break-on-error* t)
(setf test-util:*break-on-failure* t))
((string= arg "--break-on-expected-failure")
(setf test-util:*break-on-expected-failure* t))
((string= arg "--report-skipped-tests")
(setf *report-skipped-tests* t))
((string= arg "--no-color"))
((string= arg "--slow")
(push :slow *features*))
((string= arg "--gc-stress"))
((string= arg "--skip-to")
(setf skip-to (pop remainder)))
(t
(push (merge-pathnames (parse-namestring arg)) *explicit-test-files*))))
(setf *explicit-test-files* (nreverse *explicit-test-files*))
;; FIXME: randomizing the order tests are run in, especially the "pure" ones,
;; might help detect accidental side-effects by inducing failures elsewhere.
;; And/or try all permutations using an infinite number of machines.
(with-open-file (log "test.log" :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(let ((pure-load (pure-load-files))
(pure-cload (pure-cload-files))
(impure-load (impure-load-files))
(impure-cload (impure-cload-files))
(sh (sh-files)))
(when skip-to
(flet ((skip (files)
(member skip-to files :key #'file-namestring :test #'equal)))
(or (setf pure-load (skip pure-load))
(setf pure-cload (skip pure-cload))
(setf impure-load (skip impure-load))
(setf impure-cload (skip impure-cload))
(setf sh (skip sh)))))
(pure-runner pure-load 'load-test log)
(pure-runner pure-cload 'cload-test log)
(impure-runner impure-load 'load-test log)
(impure-runner impure-cload 'cload-test log)
(impure-runner sh 'sh-test log))
(log-file-elapsed-time "GRAND TOTAL" start-time log))
(report)
(sb-ext:exit :code (if (unexpected-failures) 1 104))))
(defun report ()
(terpri)
@ -517,6 +537,7 @@
"--no-userinit"
"--noprint"
"--disable-debugger"
#+gc-sress "--eval" #+gc-sress "(push :gc-stress *features*)"
"--load" load
"--eval" (write-to-string eval
:right-margin 1000))

1
tests/sleepytests.pure.lisp
View file

@ -52,6 +52,7 @@
(funcall fun0b)
(funcall fun1 1/7)
(funcall fun1 1/100000000000000000000000000)
#-gc-stress
(assert (< (- (get-universal-time) start-time) 2))))
(with-test (:name (sleep :return-value))

11
tests/test-util.lisp
View file

@ -1,3 +1,8 @@
#+gc-sress
(sb-thread:make-thread (lambda ()
(break)
(loop (gc :full t) (sleep 0.001))))
(defpackage :test-util
(:use :cl :sb-ext)
(:export #:with-test #:report-test-status #:*failures*
@ -1058,3 +1063,9 @@
(funcall
(compile nil
`(lambda () (sb-kernel:%make-funcallable-instance ,n)))))
#+gc-stress
(sb-thread:make-thread (lambda ()
(loop (gc :full t) (sleep 0.001)))
:name "gc stress")

7
tests/threads.pure.lisp
View file

@ -118,7 +118,7 @@
(mapc #'join-thread threads)
(assert (not oops))))
(with-test (:name :semaphore-multiple-waiters :skipped-on (not :sb-thread))
(with-test (:name :semaphore-multiple-waiters :skipped-on (or (not :sb-thread) :gc-stress))
(let ((semaphore (make-semaphore :name "test sem")))
(labels ((make-readers (n i)
(values
@ -341,14 +341,15 @@
(error "oops"))
(sb-sys:deadline-timeout () :deadline)))))
(with-test (:name (:condition-wait :timeout :one-thread))
(with-test (:name (:condition-wait :timeout :one-thread)
:skipped-on :gc-stress)
(let ((mutex (make-mutex))
(waitqueue (make-waitqueue)))
(assert (not (with-mutex (mutex)
(condition-wait waitqueue mutex :timeout 0.01))))))
(with-test (:name (:condition-wait :timeout :many-threads)
:skipped-on (not :sb-thread))
:skipped-on (or (not :sb-thread) :gc-stress))
(let* ((mutex (make-mutex))
(waitqueue (make-waitqueue))
(sem (make-semaphore))