From a92bb87ab1f74e628980af01b88cdb7936c8c4ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?= Date: Fri, 21 Dec 2018 14:36:06 +0100 Subject: [PATCH] Forward interrupts to dedicated thread when scheduler is loaded. This is a tentative change proposal; not in final shape. Currently interrupt handlers are run within the current thread. This is required, even if occationally hard to reason about, when there is only the primordial thread. It becomes a nightmare within a multi threaded environment, especially when interrupt handlers raise exceptions or attempt to use synchronization primitives. The text book solution is to forward interrupt handling to a (possibly high priority) thread. That's what this change does to scheduler.scm. Furthermore is cleans up after itself: - remove the dependency on scheduler from posixunix and posixwin I could not figure out why these where there. However loading scheduler defeats testing the single thread version. - Modify signal-test to load srfi-18 late in the game in order to actually test the single thread case too. - Add a now-required ##sys#dispatch-interrupts to posix's sleep. That's weird: How did this actually work before? Plus: It contains a tentative test case and a cleanup which really do not belong here. --- posixunix.scm | 6 ++++-- posixwin.scm | 2 +- scheduler.scm | 48 +++++++++++++++++++++++++++++++----------------- srfi-18.scm | 7 +------ tests/mutex-test.scm | 13 +++++++++++++ tests/signal-tests.scm | 10 ++++++++-- 6 files changed, 58 insertions(+), 28 deletions(-) diff --git a/posixunix.scm b/posixunix.scm index 11a00e07..431a0503 100644 --- a/posixunix.scm +++ b/posixunix.scm @@ -27,7 +27,7 @@ (declare (unit posix) - (uses scheduler irregex extras files ports lolevel) + (uses irregex extras files ports lolevel) (disable-interrupts) (hide group-member _get-groups _ensure-groups posix-error ##sys#terminal-check) (not inline ##sys#interrupt-hook ##sys#user-interrupt-hook)) @@ -1599,7 +1599,9 @@ EOF (define parent-process-id (foreign-lambda int "C_getppid")) -(define sleep (foreign-lambda int "C_sleep" int)) +(define (sleep x) + (let ((r ((foreign-lambda int "C_sleep" int) x))) + (if (zero? r) r (##sys#dispatch-interrupt (lambda () r))))) (define process-signal (lambda (id . sig) diff --git a/posixwin.scm b/posixwin.scm index 9f696e03..61cdfc29 100644 --- a/posixwin.scm +++ b/posixwin.scm @@ -63,7 +63,7 @@ (declare (unit posix) - (uses scheduler irregex extras files ports lolevel) + (uses irregex extras files ports lolevel) (disable-interrupts) (hide quote-arg-string) (not inline ##sys#interrupt-hook ##sys#user-interrupt-hook) diff --git a/scheduler.scm b/scheduler.scm index e8b48efd..81ea092b 100644 --- a/scheduler.scm +++ b/scheduler.scm @@ -230,14 +230,30 @@ EOF (##sys#make-thread (lambda () (let loop () - ;; inline from (thread-suspend! (current-thread)) - (##sys#setslot thread 3 'suspended) - (##sys#call-with-current-continuation - (lambda (return) - (##sys#setslot thread 1 (lambda () (return (##core#undefined)))) - (##sys#schedule) ) ) - (loop))) - 'suspended 'signal-handler 10))))) + (let ((ct ##sys#current-thread)) + (##sys#setslot ct 3 'suspended) + (##sys#setslot ct 1 loop)) + (##sys#schedule))) + 'suspended 'signal-handler ##sys#default-thread-quantum))))) + (set! ##sys#interrupt-hook + (let ((oldhook ##sys#interrupt-hook)) + (lambda (reason state) + (cond + ((fx= reason 255) ; C_TIMER_INTERRUPT_NUMBER + (let ((ct ##sys#current-thread)) + (##sys#setslot ct 1 (lambda () (oldhook reason state))) + (##sys#schedule) ) ) ; expected not to return! + ((eq? thread ##sys#current-thread) + (oldhook reason state)) + (else + (let ((old (##sys#slot thread 1))) + (##sys#setslot thread 1 (lambda () (oldhook reason old))) + (##sys#setslot thread 3 'ready) + (##sys#add-in-front-of-ready-queue thread) + (cond #;((fx> (##sys#slot ##sys#pending-finalizers 0) 0) + (##sys#run-pending-finalizers state) ) + ((procedure? state) (##sys#thread-yield!) (state)) + (else (##sys#context-switch state) ) )))) ) ) ) (install!) (lambda () (dbg "signal thread forced due to interrupt") @@ -259,6 +275,13 @@ EOF (else (set-cdr! ready-queue-tail new-pair)) ) (set! ready-queue-tail new-pair) ) ) +(define (##sys#add-in-front-of-ready-queue thread) + (##sys#setslot thread 3 'ready) + (let ((new-pair (cons thread ready-queue-head))) + (cond ((eq? '() ready-queue-head) + (set! ready-queue-tail new-pair)) ) + (set! ready-queue-head new-pair) ) ) + (define (remove-from-ready-queue) (let ((first-pair ready-queue-head)) (and (not (null? first-pair)) @@ -285,15 +308,6 @@ EOF (set! ##sys#current-exception-handler (##sys#slot buf 4)) (set! ##sys#current-parameter-vector (##sys#slot buf 5)) ) ) -(set! ##sys#interrupt-hook - (let ([oldhook ##sys#interrupt-hook]) - (lambda (reason state) - (when (fx= reason 255) ; C_TIMER_INTERRUPT_NUMBER - (let ([ct ##sys#current-thread]) - (##sys#setslot ct 1 (lambda () (oldhook reason state))) - (##sys#schedule) ) ) ; expected not to return! - (oldhook reason state) ) ) ) - (define ##sys#timeout-list '()) (define (##sys#remove-from-timeout-list t) diff --git a/srfi-18.scm b/srfi-18.scm index 5f06798f..00c3498d 100644 --- a/srfi-18.scm +++ b/srfi-18.scm @@ -384,12 +384,7 @@ (define (condition-variable-broadcast! cvar) (##sys#check-structure cvar 'condition-variable 'condition-variable-broadcast!) (dbg "broadcasting " cvar) - (##sys#for-each - (lambda (ti) - (let ((tis (##sys#slot ti 3))) - (when (or (eq? tis 'blocked) (eq? tis 'sleeping)) - (##sys#thread-unblock! ti) ) ) ) - (##sys#slot cvar 2) ) ) + (##sys#for-each ##sys#thread-unblock! (##sys#slot cvar 2) ) ) ;;; Change continuation of thread to signal an exception: diff --git a/tests/mutex-test.scm b/tests/mutex-test.scm index ee7c2de1..ec64b1f0 100644 --- a/tests/mutex-test.scm +++ b/tests/mutex-test.scm @@ -225,6 +225,19 @@ Slot Type Meaning (print "Forcing primordial broke mutex-unlock! result: " r (mutex-specific mux)) (test-exit 1))) +;; XXX TBD: It is not yet clear what the semantics should be. +#;(let* ((mux (let ((m (make-mutex 'done))) (mutex-lock! m) m)) + (t (thread-start! + (lambda () + (print "Waiting for mutex " mux " in " (current-thread)) + (let ((r (mutex-lock! mux))) + (print "mutex-lock! succeeded on locked mutex " mux " result " r) + (if r (test-exit 1))))))) + (thread-yield!) + (thread-suspend! t) + (thread-resume! t) + (print "Thread " t " now in state " (thread-state t))) + (cond-expand (dribble (define-for-syntax count 0) (define-syntax trail diff --git a/tests/signal-tests.scm b/tests/signal-tests.scm index 0289fdc9..b0f88c7b 100644 --- a/tests/signal-tests.scm +++ b/tests/signal-tests.scm @@ -7,9 +7,13 @@ (exit)) -(use posix srfi-18 extras) +(use posix extras) -(define all-go? (make-parameter #f)) +(define all-go? + (let ((v #f)) + (case-lambda + (() v) + ((x) (set! v x))))) ;; This is set before starting the child to avoid the race condition ;; from #877. The child itself overwrites these signal handlers @@ -41,6 +45,7 @@ (define (child) (print "child started") + (use srfi-18) (thread-start! (lambda () (do () (#f) @@ -59,6 +64,7 @@ (sent2 0)) (print "Sleeping until child wakes us up") ; signal *should* interrupt the sleep (print "would have slept for " (sleep 5) " more seconds") + (use srfi-18) (cond ((all-go?) (print "sending signals to " pid) (do ((i 1000 (sub1 i))) -- 2.11.0