marketplace-2014/actions.rkt

215 lines
7.0 KiB
Racket

#lang racket/base
(require racket/match)
(require "structs.rkt")
(require "roles.rkt")
(require "vm.rkt")
(require "log.rkt")
(require "process.rkt")
(require "action-add-endpoint.rkt")
(require "action-delete-endpoint.rkt")
(require "action-send-message.rkt")
(require "action-spawn.rkt")
(require "action-quit.rkt")
(require "list-utils.rkt")
(require "quasiqueue.rkt")
(provide run-vm)
;; dump-state : vm -> Any
(define (dump-state state)
`(vm (next-pid ,(vm-next-process-id state))
(processes ,@(for/fold ([acc '()])
([pid (in-hash-keys (vm-processes state))])
(cons (list pid (let ((wp (hash-ref (vm-processes state) pid)))
(let ((p wp))
(list (match (process-state p)
[(? vm? v) (dump-state v)]
[v v])
(process-spawn-ks p)
(process-endpoints p)
(process-meta-endpoints p)
(process-pending-actions p))))) acc)))))
;; run-vm : vm -> (Transition vm)
(define (run-vm state)
;; for each pid,
;; extract the corresponding process.
;; run through its work items, collecting external actions.
;; put the process back.
;; return the new state and the external actions
(let next-process ((remaining-pids (hash-keys (vm-processes state)))
(state state)
(external-actions (empty-quasiqueue)))
(match remaining-pids
['()
(let ((state (collect-dead-processes state))
(action-tree (quasiqueue->cons-tree external-actions)))
(transition state
(if (vm-idle? state)
action-tree
(cons (yield run-vm) action-tree))))]
[(cons pid remaining-pids)
(let-values (((state wp) (extract-process state pid)))
(if (not wp)
(next-process remaining-pids state external-actions)
(let ((p wp))
(let next-action
([remaining-actions (quasiqueue->list (process-pending-actions p))]
[p (reset-pending-actions p)]
[state state]
[external-actions external-actions])
(match remaining-actions
['()
(next-process remaining-pids
(inject-process state p)
external-actions)]
[(cons action remaining-actions)
(marketplace-log 'debug
"PID ~v (~a) Action: ~v"
pid
(process-debug-name p)
action)
(let-values (((p state new-external-actions)
(perform-action action p state)))
(if p
(next-action remaining-actions
p
state
(quasiqueue-append external-actions
new-external-actions))
(next-process remaining-pids
state
(quasiqueue-append external-actions
new-external-actions))))])))))])))
;; collect-dead-processes : vm -> vm
(define (collect-dead-processes state)
;; process-alive? : (All (State) (process State) -> Boolean)
(define (process-alive? p)
(or (not (null? (process-spawn-ks p)))
(positive? (hash-count (process-endpoints p)))
(positive? (hash-count (process-meta-endpoints p)))
(not (quasiqueue-empty? (process-pending-actions p)))))
(struct-copy vm state
[processes (for/fold ([processes #hash()])
([pid (in-hash-keys (vm-processes state))])
(define wp (hash-ref (vm-processes state) pid))
(let ((p wp))
(if (process-alive? p)
(hash-set processes pid wp)
(begin (marketplace-log 'info
"PID ~v (~a) garbage-collected"
pid
(process-debug-name p))
processes))))]))
;; vm-idle? : vm -> Boolean
;; TODO: simplify
(define (vm-idle? state)
(andmap (lambda (pid)
(define wp (hash-ref (vm-processes state) pid))
(let ((p wp))
(quasiqueue-empty? (process-pending-actions p))))
(hash-keys (vm-processes state))))
;; perform-action : (All (State) (Action State) (process State) vm
;; -> (Values (Option (process State)) vm (QuasiQueue (Action vm))))
(define (perform-action action p state)
(match action
[(at-meta-level preaction)
(transform-meta-action preaction p state)]
[(yield k)
(let ((p (run-ready p k)))
(values p state (empty-quasiqueue)))]
[(quit maybe-pid reason)
(do-quit (or maybe-pid (process-pid p)) reason p state)]
[_
(define-values (new-p new-state)
(match action
[(add-endpoint pre-eid role handler)
(do-add-endpoint pre-eid role handler p state)]
[(delete-endpoint pre-eid reason)
(do-delete-endpoint pre-eid reason p state)]
[(send-message body orientation)
(do-send-message orientation body p state)]
[(spawn spec k debug-name)
(do-spawn spec k p debug-name state)]))
(values new-p
new-state
(empty-quasiqueue))]))
;; wrap-trapk : eid -> (Handler vm)
(define (((wrap-trapk target-eid) event) state)
(match-define (eid pid pre-eid) target-eid)
(run-vm
(let-values (((state wp) (extract-process state pid)))
(if (not wp)
state
(let ((p wp))
(define ep (hash-ref (process-meta-endpoints p) pre-eid always-false))
(if (not ep)
(inject-process state p)
(let ((p (run-ready p (send-to-user p (e) (quit-interruptk e)
((endpoint-handler ep) event)))))
(inject-process state p))))))))
;; dispatch-spawn-k : PID Integer -> (TrapK PID vm)
(define (((dispatch-spawn-k pid spawn-k-id) new-pid) state)
(run-vm
(let-values (((state wp) (extract-process state pid)))
(if (not wp)
state
(let ((p wp))
(match (assoc spawn-k-id (process-spawn-ks p))
[#f
(inject-process state p)]
[(and entry (cons _ k))
(define interruptk (send-to-user p (e) (quit-interruptk e)
(k new-pid)))
(define p1 (struct-copy process p [spawn-ks (remq entry (process-spawn-ks p))]))
(inject-process state (run-ready p1 interruptk))]))))))
;; transform-meta-action : (All (State) (PreAction State) (process State) vm ->
;; (Values (Option (process State)) vm (QuasiQueue (Action vm))))
(define (transform-meta-action pa p state)
(match pa
[(add-endpoint pre-eid role unwrapped-handler)
(define new-eid (eid (process-pid p) pre-eid))
(values (struct-copy process p
[meta-endpoints (hash-set (process-meta-endpoints p)
pre-eid
(endpoint new-eid
role
unwrapped-handler))])
state
(quasiqueue
(add-endpoint new-eid
role
(wrap-trapk new-eid))))]
[(delete-endpoint pre-eid reason)
(define old-eid (eid (process-pid p) pre-eid))
(values (struct-copy process p
[meta-endpoints (hash-remove (process-meta-endpoints p) pre-eid)])
state
(quasiqueue (delete-endpoint old-eid reason)))]
[(send-message body orientation)
(values p
state
(quasiqueue (send-message body orientation)))]
[(spawn spec k debug-name)
(define pid (process-pid p))
(if k
(let ((spawn-k-id (+ 1 (list-max (map car (process-spawn-ks p))))))
(values (struct-copy process p
[spawn-ks (cons (cons spawn-k-id k) (process-spawn-ks p))])
state
(quasiqueue (spawn spec (dispatch-spawn-k pid spawn-k-id) debug-name))))
(values p
state
(quasiqueue (spawn spec #f debug-name))))]
[(quit maybe-pid reason)
(values p
state
(quasiqueue (quit maybe-pid reason)))]))