Compare commits
1 Commits
main
...
no-polling
Author | SHA1 | Date |
---|---|---|
Tony Garnock-Jones | d67e258e7a |
80
os.rkt
80
os.rkt
|
@ -97,22 +97,17 @@
|
||||||
|
|
||||||
;; A Subscription is a
|
;; A Subscription is a
|
||||||
;; (subscription ProcessState
|
;; (subscription ProcessState
|
||||||
;; Maybe<InterruptK>
|
|
||||||
;; ListBagOf<MessageHandler>
|
;; ListBagOf<MessageHandler>
|
||||||
;; ListBagOf<MetaMessageHandler>).
|
;; ListBagOf<MetaMessageHandler>).
|
||||||
;; To poll the kernel, include a non-#f InterruptK.
|
|
||||||
(struct subscription (state
|
(struct subscription (state
|
||||||
k
|
|
||||||
message-handlers
|
message-handlers
|
||||||
meta-message-handlers) #:transparent)
|
meta-message-handlers) #:transparent)
|
||||||
|
|
||||||
;; A Suspension is a
|
;; A Suspension is a
|
||||||
;; (suspension ProcessState
|
;; (suspension ProcessState
|
||||||
;; Maybe<InterruptK>
|
|
||||||
;; ListBagOf<MessageHandler>
|
;; ListBagOf<MessageHandler>
|
||||||
;; Map<HID,MetaMessageHandler>).
|
;; Map<HID,MetaMessageHandler>).
|
||||||
(struct suspension (state
|
(struct suspension (state
|
||||||
k
|
|
||||||
message-handlers
|
message-handlers
|
||||||
meta-message-handlers) #:transparent)
|
meta-message-handlers) #:transparent)
|
||||||
|
|
||||||
|
@ -158,28 +153,16 @@
|
||||||
;; VM -> KernelModeTransition
|
;; VM -> KernelModeTransition
|
||||||
;; (A kind of Meta-InterruptK)
|
;; (A kind of Meta-InterruptK)
|
||||||
(define (run-vm state)
|
(define (run-vm state)
|
||||||
(let* ((state (requeue-pollers state))
|
(let* ((state (run-runnables state))
|
||||||
(state (run-runnables state))
|
|
||||||
(state (dispatch-messages state))
|
(state (dispatch-messages state))
|
||||||
(meta-messages (queue->list (vm-pending-meta-messages state)))
|
(meta-messages (queue->list (vm-pending-meta-messages state)))
|
||||||
(meta-handlers (append-map extract-downward-meta-message-handlers (vm-suspensions state)))
|
(meta-handlers (append-map extract-downward-meta-message-handlers (vm-suspensions state)))
|
||||||
(poller-k (and (should-poll? state) run-vm)) ;; only block if there's nothing left to do
|
|
||||||
(state (struct-copy vm state [pending-meta-messages (make-queue)])))
|
(state (struct-copy vm state [pending-meta-messages (make-queue)])))
|
||||||
(kernel-mode-transition (subscription state poller-k meta-handlers '())
|
(kernel-mode-transition (subscription state meta-handlers '())
|
||||||
meta-messages
|
meta-messages
|
||||||
'()
|
'()
|
||||||
'())))
|
'())))
|
||||||
|
|
||||||
(define (requeue-pollers state)
|
|
||||||
(foldl (lambda (susp state)
|
|
||||||
(if (suspension-polling? susp)
|
|
||||||
(enqueue-runnable (runnable (suspension-state susp)
|
|
||||||
(suspension-k susp))
|
|
||||||
state)
|
|
||||||
(enqueue-suspension susp state)))
|
|
||||||
(struct-copy vm state [suspensions '()])
|
|
||||||
(vm-suspensions state)))
|
|
||||||
|
|
||||||
(define (run-runnables state)
|
(define (run-runnables state)
|
||||||
(foldl (lambda (r state) (perform-transition ((runnable-k r) (runnable-state r)) state))
|
(foldl (lambda (r state) (perform-transition ((runnable-k r) (runnable-state r)) state))
|
||||||
(struct-copy vm state [pending-processes (make-queue)])
|
(struct-copy vm state [pending-processes (make-queue)])
|
||||||
|
@ -222,8 +205,8 @@
|
||||||
(error 'vm "Processes must return a kernel-mode-transition struct; got ~v" other)]))
|
(error 'vm "Processes must return a kernel-mode-transition struct; got ~v" other)]))
|
||||||
|
|
||||||
(define (subscription->suspension sub)
|
(define (subscription->suspension sub)
|
||||||
(match-define (subscription ps k mhs mmhs) sub)
|
(match-define (subscription ps mhs mmhs) sub)
|
||||||
(suspension ps k mhs (for/hash ([mmh mmhs]) (values (gensym 'hid) mmh))))
|
(suspension ps mhs (for/hash ([mmh mmhs]) (values (gensym 'hid) mmh))))
|
||||||
|
|
||||||
(define (enqueue-message message state)
|
(define (enqueue-message message state)
|
||||||
(struct-copy vm state [pending-messages (enqueue (vm-pending-messages state) message)]))
|
(struct-copy vm state [pending-messages (enqueue (vm-pending-messages state) message)]))
|
||||||
|
@ -233,10 +216,10 @@
|
||||||
|
|
||||||
(define (enqueue-suspension susp state)
|
(define (enqueue-suspension susp state)
|
||||||
(match susp
|
(match susp
|
||||||
[(suspension _ #f '() (? (lambda (h) (zero? (hash-count h)))))
|
[(suspension _ '() (? (lambda (h) (zero? (hash-count h)))))
|
||||||
;; dead process because no continuations offered
|
;; dead process because no continuations offered
|
||||||
state]
|
state]
|
||||||
[(suspension _ _ _ _)
|
[(suspension _ _ _)
|
||||||
(struct-copy vm state [suspensions (cons susp (vm-suspensions state))])]))
|
(struct-copy vm state [suspensions (cons susp (vm-suspensions state))])]))
|
||||||
|
|
||||||
(define (enqueue-meta-message message state)
|
(define (enqueue-meta-message message state)
|
||||||
|
@ -263,22 +246,18 @@
|
||||||
[else
|
[else
|
||||||
(search-handlers (cdr message-handlers))])))
|
(search-handlers (cdr message-handlers))])))
|
||||||
|
|
||||||
(define (suspension-polling? susp)
|
|
||||||
(not (eq? (suspension-k susp) #f)))
|
|
||||||
|
|
||||||
;; VM -> Boolean
|
;; VM -> Boolean
|
||||||
;; When should a VM block? When it has no runnables, no pending
|
;; When should a VM block? When it has no runnables and no pending
|
||||||
;; messages, and no polling suspensions. Otherwise, it should poll.
|
;; messages. Otherwise, it should poll.
|
||||||
(define (should-poll? state)
|
(define (should-poll? state)
|
||||||
(or (not (queue-empty? (vm-pending-processes state)))
|
(or (not (queue-empty? (vm-pending-processes state)))
|
||||||
(not (queue-empty? (vm-pending-messages state)))
|
(not (queue-empty? (vm-pending-messages state)))))
|
||||||
(ormap suspension-polling? (vm-suspensions state))))
|
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
;;---------------------------------------------------------------------------
|
||||||
|
|
||||||
(define (nested-vm-inert? sub)
|
(define (nested-vm-inert? sub)
|
||||||
(match sub
|
(match sub
|
||||||
[(subscription (vm _ (? queue-empty?) (? queue-empty?) (? queue-empty?) _) #f '() '())
|
[(subscription (vm _ (? queue-empty?) (? queue-empty?) (? queue-empty?) _) '() '())
|
||||||
;; Inert iff not waiting for any messages or metamessages, and
|
;; Inert iff not waiting for any messages or metamessages, and
|
||||||
;; with no internal work left to do.
|
;; with no internal work left to do.
|
||||||
#t]
|
#t]
|
||||||
|
@ -294,23 +273,14 @@
|
||||||
(let loop ((transition (run-vm (make-vm pattern-predicate boot))))
|
(let loop ((transition (run-vm (make-vm pattern-predicate boot))))
|
||||||
(when (not (nested-vm-inert? (kernel-mode-transition-subscription transition)))
|
(when (not (nested-vm-inert? (kernel-mode-transition-subscription transition)))
|
||||||
(match transition
|
(match transition
|
||||||
[(kernel-mode-transition (subscription new-state
|
[(kernel-mode-transition (subscription new-state message-handlers '())
|
||||||
polling-k
|
outbound-messages '() '())
|
||||||
message-handlers
|
|
||||||
'())
|
|
||||||
outbound-messages
|
|
||||||
'()
|
|
||||||
'())
|
|
||||||
(for-each (lambda (thunk) (thunk)) outbound-messages)
|
(for-each (lambda (thunk) (thunk)) outbound-messages)
|
||||||
(define inbound-messages
|
(define inbound-messages
|
||||||
(map (match-lambda [(message-handler e k) (wrap-evt e (lambda (v) (cons v k)))])
|
(map (match-lambda [(message-handler e k) (wrap-evt e (lambda (v) (cons v k)))])
|
||||||
message-handlers))
|
message-handlers))
|
||||||
(match-define (cons inbound-value inbound-continuation)
|
(match-define (cons inbound-value inbound-continuation)
|
||||||
(apply sync
|
(apply sync inbound-messages))
|
||||||
(wrap-evt (if polling-k always-evt never-evt)
|
|
||||||
(lambda (v) (cons (void)
|
|
||||||
(lambda (dummy) polling-k))))
|
|
||||||
inbound-messages))
|
|
||||||
(loop ((inbound-continuation inbound-value) new-state))]
|
(loop ((inbound-continuation inbound-value) new-state))]
|
||||||
[_
|
[_
|
||||||
(error 'ground-vm
|
(error 'ground-vm
|
||||||
|
@ -320,35 +290,29 @@
|
||||||
|
|
||||||
(require racket/pretty)
|
(require racket/pretty)
|
||||||
|
|
||||||
(define (yield k)
|
|
||||||
(kernel-mode-transition (subscription 'none (lambda (_) (k)) '() '())
|
|
||||||
'()
|
|
||||||
'()
|
|
||||||
'()))
|
|
||||||
(define (quit)
|
(define (quit)
|
||||||
(kernel-mode-transition (subscription 'none #f '() '())
|
(kernel-mode-transition (subscription 'none '() '())
|
||||||
'()
|
'()
|
||||||
'()
|
'()
|
||||||
'()))
|
'()))
|
||||||
(define (print x k)
|
|
||||||
(kernel-mode-transition (subscription 'none (lambda (_) (k)) '() '())
|
|
||||||
'()
|
|
||||||
(list (lambda () (pretty-print x)))
|
|
||||||
'()))
|
|
||||||
(define (super-alarm msecs)
|
(define (super-alarm msecs)
|
||||||
(wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds))))
|
(wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds))))
|
||||||
(define (sleep n k)
|
(define (sleep-after-sending ms mms n k)
|
||||||
(kernel-mode-transition (subscription 'none
|
(kernel-mode-transition (subscription 'none
|
||||||
#f
|
|
||||||
'()
|
'()
|
||||||
(list (message-handler
|
(list (message-handler
|
||||||
(super-alarm (+ (current-inexact-milliseconds) n))
|
(super-alarm (+ (current-inexact-milliseconds) n))
|
||||||
(lambda (_message)
|
(lambda (_message)
|
||||||
(lambda (_state)
|
(lambda (_state)
|
||||||
(k))))))
|
(k))))))
|
||||||
'()
|
ms
|
||||||
'()
|
mms
|
||||||
'()))
|
'()))
|
||||||
|
(define (sleep n k) (sleep-after-sending '() '() n k))
|
||||||
|
(define (yield k) (sleep 0 k))
|
||||||
|
(define (print x k) (sleep-after-sending '()
|
||||||
|
(list (lambda () (pretty-print x)))
|
||||||
|
0 k))
|
||||||
(ground-vm (lambda (p m) (p m))
|
(ground-vm (lambda (p m) (p m))
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(print "SLEEPING"
|
(print "SLEEPING"
|
||||||
|
|
Loading…
Reference in New Issue