Cosmetic (and remove quasi-queue definitions)

This commit is contained in:
Tony Garnock-Jones 2012-03-24 19:23:27 -04:00
parent 97304006b8
commit df3d76ae26
1 changed files with 15 additions and 38 deletions

53
os2.rkt
View File

@ -103,6 +103,7 @@
(struct at-meta-level (preaction) #:prefab) (struct at-meta-level (preaction) #:prefab)
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
;; role macro
(require (for-syntax syntax/parse)) (require (for-syntax syntax/parse))
(require (for-syntax racket/base)) (require (for-syntax racket/base))
@ -152,6 +153,9 @@
(handlers presence-handler absence-handler message-handler) (handlers presence-handler absence-handler message-handler)
ready-handler)))]))) ready-handler)))])))
;;---------------------------------------------------------------------------
;; Smarter constructors for transitions and preactions.
(define (make-transition state . actions) (transition state actions)) (define (make-transition state . actions) (transition state actions))
(define (make-add-role topic handlers [k #f]) (add-role topic handlers k)) (define (make-add-role topic handlers [k #f]) (add-role topic handlers k))
(define (make-delete-role eid [reason #f]) (delete-role eid reason)) (define (make-delete-role eid [reason #f]) (delete-role eid reason))
@ -202,48 +206,25 @@
(not (topic-virtual? remote-topic)))) (not (topic-virtual? remote-topic))))
;;--------------------------------------------------------------------------- ;;---------------------------------------------------------------------------
;; Core virtualizable virtual machine.
;; QuasiQueue<X>
(define empty-quasi-queue '())
;; QuasiQueue<X> -> Boolean
(define quasi-queue-empty? null?)
;; X QuasiQueue<X> -> QuasiQueue<X>
(define (quasi-enqueue-one thing existing-quasi-queue)
(cons thing existing-quasi-queue))
;; List<X> QuasiQueue<X> -> QuasiQueue<X>
(define (quasi-enqueue-many many-things-in-order existing-quasi-queue)
(append (reverse many-things-in-order) existing-quasi-queue))
;; QuasiQueue<X> -> List<X>
(define (quasi-queue->list quasi-queue)
(reverse quasi-queue))
;; List<X> -> QuasiQueue<X>
(define (list->quasi-queue xs)
(reverse xs))
;;---------------------------------------------------------------------------
(define (make-vm boot) (define (make-vm boot)
(vm (hash) (vm (hash)
(hash) (hash)
0 0
(list->quasi-queue (list (cons -1 (spawn boot #f)))))) (list (cons -1 (spawn boot #f)))))
(define (run-vm state) (define (run-vm state)
(let loop ((remaining-actions (quasi-queue->list (vm-pending-actions state))) (let loop ((remaining-actions (reverse (vm-pending-actions state)))
(state (struct-copy vm state [pending-actions empty-quasi-queue])) (state (struct-copy vm state [pending-actions '()]))
(outbound-actions empty-quasi-queue)) (outbound-actions '()))
(match remaining-actions (match remaining-actions
['() (transition state (quasi-queue->list outbound-actions))] ['() (transition state (reverse outbound-actions))]
[(cons (cons pid action) rest) [(cons (cons pid action) rest)
(match action (match action
[(at-meta-level preaction) [(at-meta-level preaction)
(define transformed-preaction (transform-meta-action pid preaction)) (define transformed-preaction (transform-meta-action pid preaction))
(loop rest state (quasi-enqueue-one transformed-preaction outbound-actions))] (loop rest state (cons transformed-preaction outbound-actions))]
[preaction [preaction
(loop rest (perform-action pid preaction state) outbound-actions)])]))) (loop rest (perform-action pid preaction state) outbound-actions)])])))
@ -394,8 +375,8 @@
(define (enqueue-actions state pid actions) (define (enqueue-actions state pid actions)
(struct-copy vm state (struct-copy vm state
[pending-actions (quasi-enqueue-many (for/list ([a (flatten actions)]) (cons pid a)) [pending-actions (append (reverse (for/list ([a (flatten actions)]) (cons pid a)))
(vm-pending-actions state))])) (vm-pending-actions state))]))
(define (wrap-trapk pid trapk) (define (wrap-trapk pid trapk)
(lambda args (lambda args
@ -425,7 +406,7 @@
[(transition state actions) [(transition state actions)
(when (not (null? actions)) (when (not (null? actions))
(error 'ground-vm "No meta-actions available in ground-vm: ~v" actions)) (error 'ground-vm "No meta-actions available in ground-vm: ~v" actions))
(define waiting? (quasi-queue-empty? (vm-pending-actions state))) (define waiting? (null? (vm-pending-actions state)))
(define active-events (for/list ([(eid e) (in-hash (vm-endpoints state))] (define active-events (for/list ([(eid e) (in-hash (vm-endpoints state))]
#:when (and (evt? (topic-pattern (endpoint-topic e))) #:when (and (evt? (topic-pattern (endpoint-topic e)))
(eq? (topic-role (endpoint-topic e)) (eq? (topic-role (endpoint-topic e))
@ -437,14 +418,10 @@
message message
state)))))) state))))))
(if (and waiting? (null? active-events)) (if (and waiting? (null? active-events))
;; About to block, and nothing can wake us 'done ;; About to block, and nothing can wake us
'done
(let ((interruptk (apply sync (let ((interruptk (apply sync
(if waiting? (if waiting?
never-evt never-evt
(wrap-evt always-evt (lambda (dummy) values))) (wrap-evt always-evt (lambda (dummy) values)))
active-events))) active-events)))
(loop (interruptk state))))]))) (loop (interruptk state))))])))
;;(require racket/trace)
;;(trace perform-action)