50 lines
1.6 KiB
Racket
50 lines
1.6 KiB
Racket
#lang typed/racket/base
|
|
|
|
(require racket/match)
|
|
(require "types.rkt")
|
|
(require "roles.rkt")
|
|
(require "vm.rkt")
|
|
(require "log-typed.rkt")
|
|
(require "process.rkt")
|
|
(require (rename-in "tr-struct-copy.rkt" [tr-struct-copy struct-copy])) ;; PR13149 workaround
|
|
|
|
(provide do-spawn)
|
|
|
|
(: do-spawn : (All (OldState)
|
|
process-spec
|
|
(Option (PID -> (InterruptK OldState)))
|
|
(process OldState)
|
|
Any
|
|
vm
|
|
-> (Values (Option (process OldState)) vm)))
|
|
(define (do-spawn spec parent-k p debug-name state)
|
|
(define new-pid (vm-next-process-id state))
|
|
(marketplace-log 'info "PID ~v (~a) starting" new-pid debug-name)
|
|
(: new-cotransition : CoTransition)
|
|
(define new-cotransition
|
|
(send-to-user* debug-name new-pid (e) (co-quit e)
|
|
((process-spec-boot spec) new-pid)))
|
|
(: co-quit : Reason -> CoTransition)
|
|
(define ((co-quit e) k)
|
|
((inst k False) (transition #f (quit #f e))))
|
|
(: transition-accepter : (All (NewState) (Transition NewState) -> Process))
|
|
(define (transition-accepter t)
|
|
(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))))
|