diff --git a/scheme/interfaces.scm b/scheme/interfaces.scm index 855f73f..45c2c26 100644 --- a/scheme/interfaces.scm +++ b/scheme/interfaces.scm @@ -655,7 +655,7 @@ (define-interface rts-sigevents-internal-interface (export waiting-for-sigevent? - initialize-sigevents!)) + with-sigevents)) (define-interface writing-interface (export write diff --git a/scheme/rts-packages.scm b/scheme/rts-packages.scm index 4fb954d..68ba38a 100644 --- a/scheme/rts-packages.scm +++ b/scheme/rts-packages.scm @@ -226,6 +226,7 @@ (rts-sigevents-internal rts-sigevents-internal-interface)) (open scheme-level-1 define-record-types queues threads threads-internal + wind interrupts architecture) (files (rts sigevents)) @@ -329,7 +330,7 @@ fluids-internal ;initialize-dynamic-state! exceptions ;initialize-exceptions! interrupts ;initialize-interrupts! - rts-sigevents-internal ;initialize-sigevents! + rts-sigevents-internal ;with-sigevents records-internal ;initialize-records! export-the-record-type ;just what it says threads-internal ;start threads diff --git a/scheme/rts/init.scm b/scheme/rts/init.scm index 5b8d562..e66dec4 100644 --- a/scheme/rts/init.scm +++ b/scheme/rts/init.scm @@ -13,7 +13,9 @@ (initialize-rts in out error (lambda () (initialize-records! records) - (entry-point (vector->list resume-arg)))))) + (with-sigevents + (lambda () + (entry-point (vector->list resume-arg)))))))) (define (initialize-rts in out error thunk) (initialize-session-data!) @@ -30,7 +32,6 @@ (lambda () (with-threads (lambda () - (initialize-sigevents!) (root-scheduler thunk 200 ; thread quantum, in msec 300)))))))))) ; port-flushing quantum diff --git a/scheme/rts/sigevents.scm b/scheme/rts/sigevents.scm index 82ec67e..40073fc 100644 --- a/scheme/rts/sigevents.scm +++ b/scheme/rts/sigevents.scm @@ -58,21 +58,34 @@ waiters)))))) (for-each make-ready waiters))) + +;;; Records whether the sigevent system is running. +;;; If set to #f we ignore threads waiting for a sigevent. +(define sigevents-running? #f) + ;;; has to be called with interrupts disabled (define (waiting-for-sigevent?) - (not (thread-queue-empty? sigevent-thread-queue))) + (if sigevents-running? + (not (thread-queue-empty? sigevent-thread-queue)) + #f)) -(define (initialize-sigevents!) +(define (with-sigevents thunk) (set! sigevent-thread-queue (make-queue)) (set-interrupt-handler! (enum interrupt os-signal) (lambda (type enabled-interrupts) - ; type is already set in the unix signal handler + ; type is already set in the unix signal handler (register-interrupt type))) (set-interrupt-handler! (enum interrupt keyboard) (lambda (enabled-interrupts) (register-interrupt (enum interrupt keyboard)))) -; (call-after-gc! (lambda () (register-interrupt (enum interrupt post-gc)))) -) + (dynamic-wind + (lambda () + (set! sigevents-running? #t)) + thunk + (lambda () + (set! sigevents-running? #f)))) + + ;;; the vm uses the timer for the scheduler (define (schedule-timer-interrupt! msec) (spawn (lambda ()