From c8acbfab96f162c933c043f9063b63417494a172 Mon Sep 17 00:00:00 2001 From: Taylor R Campbell Date: Mon, 11 Feb 2019 00:56:37 +0000 Subject: [PATCH] Simplify and factor out carefully checking for stack overflows. --- tests/runtime/test-list.scm | 41 ---------------------------------- tests/runtime/test-pp.scm | 41 ---------------------------------- tests/runtime/test-promise.scm | 41 ---------------------------------- tests/unit-testing.scm | 32 +++++++++++++++++++++++++- 4 files changed, 31 insertions(+), 124 deletions(-) diff --git a/tests/runtime/test-list.scm b/tests/runtime/test-list.scm index 438e723eb..8fe5c174d 100644 --- a/tests/runtime/test-list.scm +++ b/tests/runtime/test-list.scm @@ -28,47 +28,6 @@ USA. (declare (usual-integrations)) -(define (carefully procedure if-overflow if-timeout) - (let ((thread #f) - (mutex (make-thread-mutex)) - (condvar (make-condition-variable)) - (gc-env (->environment '(runtime garbage-collector)))) - (define (start-it) - (with-thread-mutex-lock mutex - (lambda () - (do () (thread) - (condition-variable-wait! condvar mutex)))) - (let ((default/stack-overflow (access default/stack-overflow gc-env))) - (define (give-up) - (if (eq? thread (current-thread)) - (exit-current-thread (if-overflow)) - (default/stack-overflow))) - (call-with-current-continuation - (lambda (abort) - (fluid-let (((access hook/stack-overflow gc-env) - (lambda () (within-continuation abort give-up)))) - (exit-current-thread (procedure))))))) - (define (stop-it) - (assert thread) - (signal-thread-event thread - (lambda () - (exit-current-thread (if-timeout))))) - (let ((t (create-thread #f start-it))) - (with-thread-mutex-lock mutex - (lambda () - (set! thread t) - (condition-variable-broadcast! condvar)))) - (let ((result #f)) - (define (done-it thread* value) - (assert (eq? thread* thread)) - (set! result value)) - (join-thread thread done-it) - (let ((timer)) - (dynamic-wind - (lambda () (set! timer (register-timer-event 1000 stop-it))) - (lambda () (do () (result) (suspend-current-thread))) - (lambda () (deregister-timer-event (set! timer)))))))) - (define (words-in-stack) (let ((status (gc-space-status))) (let ((bytes-per-word (vector-ref status 0)) diff --git a/tests/runtime/test-pp.scm b/tests/runtime/test-pp.scm index 4667ef44a..33ca650dc 100644 --- a/tests/runtime/test-pp.scm +++ b/tests/runtime/test-pp.scm @@ -31,47 +31,6 @@ USA. (define assert-string (predicate-assertion string? "string")) -(define (carefully procedure if-overflow if-timeout) - (let ((thread #f) - (mutex (make-thread-mutex)) - (condvar (make-condition-variable)) - (gc-env (->environment '(runtime garbage-collector)))) - (define (start-it) - (with-thread-mutex-lock mutex - (lambda () - (do () (thread) - (condition-variable-wait! condvar mutex)))) - (let ((default/stack-overflow (access default/stack-overflow gc-env))) - (define (give-up) - (if (eq? thread (current-thread)) - (exit-current-thread (if-overflow)) - (default/stack-overflow))) - (call-with-current-continuation - (lambda (abort) - (fluid-let (((access hook/stack-overflow gc-env) - (lambda () (within-continuation abort give-up)))) - (exit-current-thread (procedure))))))) - (define (stop-it) - (assert thread) - (signal-thread-event thread - (lambda () - (exit-current-thread (if-timeout))))) - (let ((t (create-thread #f start-it))) - (with-thread-mutex-lock mutex - (lambda () - (set! thread t) - (condition-variable-broadcast! condvar)))) - (let ((result #f)) - (define (done-it thread* value) - (assert (eq? thread* thread)) - (set! result value)) - (join-thread thread done-it) - (let ((timer)) - (dynamic-wind - (lambda () (set! timer (register-timer-event 1000 stop-it))) - (lambda () (do () (result) (suspend-current-thread))) - (lambda () (deregister-timer-event (set! timer)))))))) - (define-test 'circular/simple (lambda () (define (doit) diff --git a/tests/runtime/test-promise.scm b/tests/runtime/test-promise.scm index 123cfa5ec..dbd4b0685 100644 --- a/tests/runtime/test-promise.scm +++ b/tests/runtime/test-promise.scm @@ -28,47 +28,6 @@ USA. (declare (usual-integrations)) -(define (carefully procedure if-overflow if-timeout) - (let ((thread #f) - (mutex (make-thread-mutex)) - (condvar (make-condition-variable)) - (gc-env (->environment '(runtime garbage-collector)))) - (define (start-it) - (with-thread-mutex-lock mutex - (lambda () - (do () (thread) - (condition-variable-wait! condvar mutex)))) - (let ((default/stack-overflow (access default/stack-overflow gc-env))) - (define (give-up) - (if (eq? thread (current-thread)) - (exit-current-thread (if-overflow)) - (default/stack-overflow))) - (call-with-current-continuation - (lambda (abort) - (fluid-let (((access hook/stack-overflow gc-env) - (lambda () (within-continuation abort give-up)))) - (exit-current-thread (procedure))))))) - (define (stop-it) - (assert thread) - (signal-thread-event thread - (lambda () - (exit-current-thread (if-timeout))))) - (let ((t (create-thread #f start-it))) - (with-thread-mutex-lock mutex - (lambda () - (set! thread t) - (condition-variable-broadcast! condvar)))) - (let ((result #f)) - (define (done-it thread* value) - (assert (eq? thread* thread)) - (set! result value)) - (join-thread thread done-it) - (let ((timer)) - (dynamic-wind - (lambda () (set! timer (register-timer-event 1000 stop-it))) - (lambda () (do () (result) (suspend-current-thread))) - (lambda () (deregister-timer-event (set! timer)))))))) - (define-test 'delay-force-loop (lambda () (assert-error diff --git a/tests/unit-testing.scm b/tests/unit-testing.scm index 1bc25a7ba..c50a087bc 100644 --- a/tests/unit-testing.scm +++ b/tests/unit-testing.scm @@ -698,4 +698,34 @@ USA. (list "an object" (if- "not") "matching" (marker)))) (define-for-tests assert-matches (match-assertion #f)) -(define-for-tests assert-!matches (match-assertion #t)) \ No newline at end of file +(define-for-tests assert-!matches (match-assertion #t)) + +(define-for-tests (carefully procedure if-overflow if-timeout) + (let ((gc-env (->environment '(runtime garbage-collector)))) + (define (start-it) + (let ((default/stack-overflow (access default/stack-overflow gc-env)) + (thread (current-thread))) + (define (give-up) + (if (eq? thread (current-thread)) + (exit-current-thread (if-overflow)) + (default/stack-overflow))) + (call-with-current-continuation + (lambda (abort) + (fluid-let (((access hook/stack-overflow gc-env) + (lambda () (within-continuation abort give-up)))) + (exit-current-thread (procedure))))))) + (let ((thread (create-thread #f start-it))) + (define (stop-it) + (signal-thread-event thread + (lambda () + (exit-current-thread (if-timeout))))) + (let ((result #f)) + (define (done-it thread* value) + (assert (eq? thread* thread)) + (set! result value)) + (join-thread thread done-it) + (let ((timer)) + (dynamic-wind + (lambda () (set! timer (register-timer-event 1000 stop-it))) + (lambda () (do () (result) (suspend-current-thread))) + (lambda () (deregister-timer-event (set! timer))))))))) \ No newline at end of file -- 2.25.1