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