syndicate-lang
/
marketplace-2014
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Safety: wrap spawn intermediate step in send-to-user to blame appropriate process

This commit is contained in:
Tony Garnock-Jones 2013-04-11 19:20:33 -04:00
parent 52750cf67f
commit cd7da75504
1 changed files with 19 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
marketplace/action-spawn.rkt
View File

@ -27,24 +27,23 @@
(: co-quit : Reason -> CoTransition) (: co-quit : Reason -> CoTransition)
(define ((co-quit e) k) (define ((co-quit e) k)
((inst k False) (transition #f (quit #f e)))) ((inst k False) (transition #f (quit #f e))))
(: transition-accepter : (All (NewState) (Transition NewState) -> (: transition-accepter : (All (NewState) (Transition NewState) -> Process))
(List (process OldState) vm)))
(define (transition-accepter t) (define (transition-accepter t)
(match t (match-define (transition initial-state initial-actions) t)
[(transition initial-state initial-actions) (mkProcess ((inst process NewState)
;;(matrix-log 'info "PID ~v (~a) started" new-pid debug-name) debug-name
(list (if parent-k new-pid
(run-ready p (send-to-user p (e) (quit-interruptk e) initial-state
(parent-k new-pid))) '()
p) #hash()
(inject-process (struct-copy vm state [next-process-id (+ new-pid 1)]) #hash()
(mkProcess ((inst process NewState) (action-tree->quasiqueue initial-actions))))
debug-name (let ((new-process
new-pid (send-to-user* debug-name new-pid (e) (transition-accepter (transition #f (quit #f e)))
initial-state ((inst new-cotransition Process) transition-accepter))))
'() (values (if parent-k
#hash() (run-ready p (send-to-user p (e) (quit-interruptk e)
#hash() (parent-k new-pid)))
(action-tree->quasiqueue initial-actions)))))])) p)
(apply values ((inst new-cotransition (List (process OldState) vm)) (inject-process (struct-copy vm state [next-process-id (+ new-pid 1)])
transition-accepter))) new-process))))