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

More concision.

This commit is contained in:
Tony Garnock-Jones 2012-01-10 13:29:25 -05:00
parent 6c66e632f4
commit b16d723450
1 changed files with 25 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
os.rkt
View File

@ -160,8 +160,15 @@
(define (run-vm state)
(let* ((state (requeue-pollers state))
(state (run-runnables state))
(state (dispatch-messages state)))
(trap-to-metalevel 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 '())
meta-messages
'()
'())))
(define (requeue-pollers state)
(foldl (lambda (susp state)
@ -183,6 +190,22 @@
(struct-copy vm state [pending-messages (make-queue)])
(queue->list (vm-pending-messages state))))
(define (extract-downward-meta-message-handlers susp)
(for/list ([(hid mmh) (in-hash (suspension-meta-message-handlers susp))])
(message-handler (message-handler-pattern mmh) (dispatch-meta-message hid))))
(define (extract-upward-meta-message-handlers susp)
(for/list ([(hid mmh) (in-hash (suspension-meta-message-handlers susp))])
(message-handler hid (message-handler-k mmh))))
(define (((dispatch-meta-message hid) message) state)
(run-vm
(foldl (match-suspension message
(lambda (handler-hid message) (equal? hid handler-hid))
extract-upward-meta-message-handlers)
(struct-copy vm state [suspensions '()])
(vm-suspensions state))))
;; KernelModeTransition VM -> VM
(define (perform-transition transition state)
(match transition
@ -251,37 +274,6 @@
(not (queue-empty? (vm-pending-messages state)))
(ormap suspension-polling? (vm-suspensions state))))
(define (trap-to-metalevel state)
(define meta-messages (queue->list (vm-pending-meta-messages state)))
(define meta-handlers (append-map extract-downward-meta-message-handlers
(vm-suspensions state)))
(define final-state (struct-copy vm state [pending-meta-messages (make-queue)]))
(kernel-mode-transition (subscription final-state
(and (should-poll? final-state)
;; only block if there's nothing left to do
run-vm)
meta-handlers
'())
meta-messages
'()
'()))
(define (extract-downward-meta-message-handlers susp)
(for/list ([(hid mmh) (in-hash (suspension-meta-message-handlers susp))])
(message-handler (message-handler-pattern mmh) (dispatch-meta-message hid))))
(define (extract-upward-meta-message-handlers susp)
(for/list ([(hid mmh) (in-hash (suspension-meta-message-handlers susp))])
(message-handler hid (message-handler-k mmh))))
(define (((dispatch-meta-message hid) message) state)
(run-vm
(foldl (match-suspension message
(lambda (handler-hid message) (equal? hid handler-hid))
extract-upward-meta-message-handlers)
(struct-copy vm state [suspensions '()])
(vm-suspensions state))))
;;---------------------------------------------------------------------------
(define (nested-vm-inert? sub)