syndicate-lang
/
racket-dns-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Remove polling support.

This commit is contained in:
Tony Garnock-Jones 2012-01-10 13:40:36 -05:00
parent b16d723450
commit d67e258e7a
1 changed files with 22 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
os.rkt
View File

@ -97,22 +97,17 @@
;; A Subscription is a
;; (subscription ProcessState
;; Maybe<InterruptK>
;; ListBagOf<MessageHandler>
;; ListBagOf<MetaMessageHandler>).
;; To poll the kernel, include a non-#f InterruptK.
(struct subscription (state
k
message-handlers
meta-message-handlers) #:transparent)
;; A Suspension is a
;; (suspension ProcessState
;; Maybe<InterruptK>
;; ListBagOf<MessageHandler>
;; Map<HID,MetaMessageHandler>).
(struct suspension (state
k
message-handlers
meta-message-handlers) #:transparent)
@ -158,28 +153,16 @@
;; VM -> KernelModeTransition
;; (A kind of Meta-InterruptK)
(define (run-vm state)
(let* ((state (requeue-pollers state))
(state (run-runnables state))
(let* ((state (run-runnables state))
(state (dispatch-messages state))
(meta-messages (queue->list (vm-pending-meta-messages 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)])))
(kernel-mode-transition (subscription state poller-k meta-handlers '())
(kernel-mode-transition (subscription state meta-handlers '())
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)
(foldl (lambda (r state) (perform-transition ((runnable-k r) (runnable-state r)) state))
(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)]))
(define (subscription->suspension sub)
(match-define (subscription ps k mhs mmhs) sub)
(suspension ps k mhs (for/hash ([mmh mmhs]) (values (gensym 'hid) mmh))))
(match-define (subscription ps mhs mmhs) sub)
(suspension ps mhs (for/hash ([mmh mmhs]) (values (gensym 'hid) mmh))))
(define (enqueue-message message state)
(struct-copy vm state [pending-messages (enqueue (vm-pending-messages state) message)]))
@ -233,10 +216,10 @@
(define (enqueue-suspension susp state)
(match susp
[(suspension _ #f '() (? (lambda (h) (zero? (hash-count h)))))
[(suspension _ '() (? (lambda (h) (zero? (hash-count h)))))
;; dead process because no continuations offered
state]
[(suspension _ _ _ _)
[(suspension _ _ _)
(struct-copy vm state [suspensions (cons susp (vm-suspensions state))])]))
(define (enqueue-meta-message message state)
@ -263,22 +246,18 @@
[else
(search-handlers (cdr message-handlers))])))
(define (suspension-polling? susp)
(not (eq? (suspension-k susp) #f)))
;; VM -> Boolean
;; When should a VM block? When it has no runnables, no pending
;; messages, and no polling suspensions. Otherwise, it should poll.
;; When should a VM block? When it has no runnables and no pending
;; messages. Otherwise, it should poll.
(define (should-poll? state)
(or (not (queue-empty? (vm-pending-processes state)))
(not (queue-empty? (vm-pending-messages state)))
(ormap suspension-polling? (vm-suspensions state))))
(not (queue-empty? (vm-pending-messages state)))))
;;---------------------------------------------------------------------------
(define (nested-vm-inert? 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
;; with no internal work left to do.
#t]
@ -294,23 +273,14 @@
(let loop ((transition (run-vm (make-vm pattern-predicate boot))))
(when (not (nested-vm-inert? (kernel-mode-transition-subscription transition)))
(match transition
[(kernel-mode-transition (subscription new-state
polling-k
message-handlers
'())
outbound-messages
'()
'())
[(kernel-mode-transition (subscription new-state message-handlers '())
outbound-messages '() '())
(for-each (lambda (thunk) (thunk)) outbound-messages)
(define inbound-messages
(map (match-lambda [(message-handler e k) (wrap-evt e (lambda (v) (cons v k)))])
message-handlers))
(match-define (cons inbound-value inbound-continuation)
(apply sync
(wrap-evt (if polling-k always-evt never-evt)
(lambda (v) (cons (void)
(lambda (dummy) polling-k))))
inbound-messages))
(apply sync inbound-messages))
(loop ((inbound-continuation inbound-value) new-state))]
[_
(error 'ground-vm
@ -320,35 +290,29 @@
(require racket/pretty)
(define (yield k)
(kernel-mode-transition (subscription 'none (lambda (_) (k)) '() '())
'()
'()
'()))
(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)
(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
#f
'()
(list (message-handler
(super-alarm (+ (current-inexact-milliseconds) n))
(lambda (_message)
(lambda (_state)
(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))
(lambda ()
(print "SLEEPING"