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

Remove dependency on functional-queue.rkt

This commit is contained in:
Tony Garnock-Jones 2012-01-19 13:38:11 -05:00
parent 9ef1165c9a
commit fd64c460a4
1 changed files with 15 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
os.rkt
View File

@ -4,7 +4,6 @@
(require racket/match)
(require racket/list)
(require "functional-queue.rkt")
(provide
;; Waiting for messages
@ -148,9 +147,9 @@
;; BootK -> VM
(define (make-vm boot #:pattern-predicate [pattern-predicate default-pattern-predicate])
(vm (list)
(make-queue)
(make-queue)
(enqueue (make-queue) boot)
(list)
(list)
(cons boot (list))
pattern-predicate))
;; VM -> KernelModeTransition
@ -159,10 +158,10 @@
(let* ((state (requeue-pollers state))
(state (run-runnables state))
(state (dispatch-messages state))
(meta-messages (queue->list (vm-pending-meta-messages state)))
(meta-messages (reverse (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)])))
(state (struct-copy vm state [pending-meta-messages (list)])))
(kernel-mode-transition (subscription state poller-k meta-handlers '())
meta-messages
'()
@ -178,13 +177,13 @@
(define (run-runnables state)
(foldl (lambda (r state) (perform-transition (r) state))
(struct-copy vm state [pending-processes (make-queue)])
(queue->list (vm-pending-processes state))))
(struct-copy vm state [pending-processes (list)])
(reverse (vm-pending-processes state))))
(define (dispatch-messages state)
(foldl dispatch-message
(struct-copy vm state [pending-messages (make-queue)])
(queue->list (vm-pending-messages state))))
(struct-copy vm state [pending-messages (list)])
(reverse (vm-pending-messages state))))
(define (extract-downward-meta-message-handlers susp)
(for/list ([(hid mmh) (in-hash (suspension-meta-message-handlers susp))])
@ -222,10 +221,10 @@
(suspension ps k 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)]))
(struct-copy vm state [pending-messages (cons message (vm-pending-messages state))]))
(define (enqueue-runnable r state)
(struct-copy vm state [pending-processes (enqueue (vm-pending-processes state) r)]))
(struct-copy vm state [pending-processes (cons r (vm-pending-processes state))]))
(define (enqueue-suspension susp state)
(match susp
@ -236,7 +235,7 @@
(struct-copy vm state [suspensions (cons susp (vm-suspensions state))])]))
(define (enqueue-meta-message message state)
(struct-copy vm state [pending-meta-messages (enqueue (vm-pending-meta-messages state) message)]))
(struct-copy vm state [pending-meta-messages (cons message (vm-pending-meta-messages state))]))
(define (dispatch-message message state)
(foldl (match-suspension message
@ -266,8 +265,8 @@
;; When should a VM block? When it has no runnables, no pending
;; messages, and no polling suspensions. Otherwise, it should poll.
(define (should-poll? state)
(or (not (queue-empty? (vm-pending-processes state)))
(not (queue-empty? (vm-pending-messages state)))
(or (not (null? (vm-pending-processes state)))
(not (null? (vm-pending-messages state)))
(ormap suspension-polling? (vm-suspensions state))))
(define (nested-vm boot #:pattern-predicate [pattern-predicate default-pattern-predicate])
@ -277,7 +276,7 @@
(define (nested-vm-inert? sub)
(match sub
[(subscription (vm _ (? queue-empty?) (? queue-empty?) (? queue-empty?) _) #f '() '())
[(subscription (vm _ '() '() '() _) #f '() '())
;; Inert iff not waiting for any messages or metamessages, and
;; with no internal work left to do.
#t]