mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
* test-suite/tests/asyncs.test: Instead of wrapping abort-to-prompt with false-if-exception, to handle edge cases, guard with suspendable-continuation?: this also catches recursive invocations.
137 lines
5.2 KiB
Scheme
137 lines
5.2 KiB
Scheme
;;;; asyncs.test -*- mode: scheme; coding: utf-8; -*-
|
||
;;;;
|
||
;;;; Copyright (C) 2016, 2017 Free Software Foundation, Inc.
|
||
;;;;
|
||
;;;; This library is free software; you can redistribute it and/or
|
||
;;;; modify it under the terms of the GNU Lesser General Public
|
||
;;;; License as published by the Free Software Foundation; either
|
||
;;;; version 3 of the License, or (at your option) any later version.
|
||
;;;;
|
||
;;;; This library is distributed in the hope that it will be useful,
|
||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;;;; Lesser General Public License for more details.
|
||
;;;;
|
||
;;;; You should have received a copy of the GNU Lesser General Public
|
||
;;;; License along with this library; if not, write to the Free Software
|
||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
(define-module (test-asyncs)
|
||
#:use-module (ice-9 control)
|
||
#:use-module (ice-9 q)
|
||
#:use-module (ice-9 atomic)
|
||
#:use-module (ice-9 threads)
|
||
#:use-module (test-suite lib))
|
||
|
||
|
||
(with-test-prefix "interrupts"
|
||
(pass-if-equal "self-interruptable v1" 42
|
||
(let/ec break
|
||
(let lp ((n 0))
|
||
(when (= n 10)
|
||
(system-async-mark (lambda () (break 42))))
|
||
(lp (1+ n)))))
|
||
|
||
(pass-if-equal "self-interruptable v2" 42
|
||
(let/ec break
|
||
(begin
|
||
(system-async-mark (lambda () (break 42)))
|
||
(let lp () (lp))))))
|
||
|
||
(define (with-sigprof-interrupts hz interrupt proc)
|
||
(let ((prev-handler #f)
|
||
(period-usecs (inexact->exact (round (/ 1e6 hz)))))
|
||
(define (profile-signal-handler _) (interrupt))
|
||
(dynamic-wind
|
||
(lambda ()
|
||
(set! prev-handler (car (sigaction SIGPROF profile-signal-handler)))
|
||
(setitimer ITIMER_PROF 0 period-usecs 0 period-usecs))
|
||
proc
|
||
(lambda ()
|
||
(setitimer ITIMER_PROF 0 0 0 0)
|
||
(sigaction SIGPROF prev-handler)))))
|
||
|
||
(when (and (defined? 'setitimer)
|
||
(provided? 'ITIMER_PROF))
|
||
(pass-if "preemption via sigprof"
|
||
;; Use an atomic box as a compiler barrier.
|
||
(let* ((box (make-atomic-box 0))
|
||
(preempt-tag (make-prompt-tag))
|
||
(runqueue (make-q)))
|
||
(define (run-cothreads)
|
||
(unless (q-empty? runqueue)
|
||
(let ((k (deq! runqueue)))
|
||
(call-with-prompt preempt-tag
|
||
k
|
||
(lambda (k) (enq! runqueue k))))
|
||
(run-cothreads)))
|
||
(enq! runqueue (lambda ()
|
||
(let lp ()
|
||
(let ((x (atomic-box-ref box)))
|
||
(unless (= x 100)
|
||
(when (even? x)
|
||
(atomic-box-set! box (1+ x)))
|
||
(lp))))))
|
||
(enq! runqueue (lambda ()
|
||
(let lp ()
|
||
(let ((x (atomic-box-ref box)))
|
||
(unless (= x 100)
|
||
(when (odd? x)
|
||
(atomic-box-set! box (1+ x)))
|
||
(lp))))))
|
||
(with-sigprof-interrupts
|
||
1000 ; Hz
|
||
(lambda ()
|
||
;; Interrupt could fire outside running a cothread, or
|
||
;; recursively within an async; ignore in that case.
|
||
(when (suspendable-continuation? preempt-tag)
|
||
(abort-to-prompt preempt-tag)))
|
||
run-cothreads)
|
||
(equal? (atomic-box-ref box) 100))))
|
||
|
||
(when (provided? 'threads)
|
||
(pass-if "preemption via external thread"
|
||
;; Use an atomic box as a compiler barrier.
|
||
(let* ((box (make-atomic-box 0))
|
||
(preempt-tag (make-prompt-tag))
|
||
(runqueue (make-q)))
|
||
(define (run-cothreads)
|
||
(unless (q-empty? runqueue)
|
||
(let ((k (deq! runqueue)))
|
||
(call-with-prompt preempt-tag
|
||
k
|
||
(lambda (k) (enq! runqueue k))))
|
||
(run-cothreads)))
|
||
(enq! runqueue (lambda ()
|
||
(let lp ()
|
||
(let ((x (atomic-box-ref box)))
|
||
(unless (= x 100)
|
||
(when (even? x)
|
||
(atomic-box-set! box (1+ x)))
|
||
(lp))))))
|
||
(enq! runqueue (lambda ()
|
||
(let lp ()
|
||
(let ((x (atomic-box-ref box)))
|
||
(unless (= x 100)
|
||
(when (odd? x)
|
||
(atomic-box-set! box (1+ x)))
|
||
(lp))))))
|
||
(let* ((main-thread (current-thread))
|
||
(preempt-thread
|
||
(call-with-new-thread
|
||
(lambda ()
|
||
(let lp ()
|
||
(unless (= (atomic-box-ref box) 100)
|
||
(usleep 1000)
|
||
(system-async-mark
|
||
(lambda ()
|
||
;; Interrupt could fire outside running a
|
||
;; cothread, or recursively within an async;
|
||
;; ignore in that case.
|
||
(when (suspendable-continuation? preempt-tag)
|
||
(abort-to-prompt preempt-tag)))
|
||
main-thread)
|
||
(lp)))))))
|
||
(run-cothreads)
|
||
(join-thread preempt-thread)
|
||
(equal? (atomic-box-ref box) 100)))))
|