Cosmetic (and remove quasi-queue definitions)
This commit is contained in:
parent
97304006b8
commit
df3d76ae26
53
os2.rkt
53
os2.rkt
|
@ -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)
|
|
Loading…
Reference in New Issue