This commit is contained in:
Tony Garnock-Jones 2012-03-24 19:31:30 -04:00
parent 859fb5a929
commit 1696971366
1 changed files with 10 additions and 17 deletions

27
os2.rkt
View File

@ -229,8 +229,6 @@
(loop rest (perform-action pid preaction state) outbound-actions)])]))) (loop rest (perform-action pid preaction state) outbound-actions)])])))
(define (send-to-user failure-proc f . args) (define (send-to-user failure-proc f . args)
;; TODO: use this hook to find all the bits of code that will need
;; with-handlers and crash compensation.
(with-handlers ([exn:fail? failure-proc]) (with-handlers ([exn:fail? failure-proc])
(apply f args))) (apply f args)))
@ -333,12 +331,10 @@
(define (run-trapk state pid trap-k . args) (define (run-trapk state pid trap-k . args)
(if trap-k (if trap-k
(run-ready state pid (apply send-to-user (let ((failure-proc (lambda (e) (lambda (process-state)
(lambda (e) (lambda (process-state) (transition process-state
(transition process-state (kill #f e))))))
(kill #f e)))) (run-ready state pid (apply send-to-user failure-proc trap-k args)))
trap-k
args))
state)) state))
(define (maybe-transition->transition t) (define (maybe-transition->transition t)
@ -349,21 +345,18 @@
(define (run-ready state pid interrupt-k) (define (run-ready state pid interrupt-k)
(define old-process (hash-ref (vm-processes state) pid)) (define old-process (hash-ref (vm-processes state) pid))
(match-define (transition new-process-state actions) (match-define (transition new-process-state actions)
(maybe-transition->transition (send-to-user (lambda (e) (maybe-transition->transition
(transition (process-state old-process) (send-to-user (lambda (e) (transition (process-state old-process) (kill #f e)))
(kill #f e))) interrupt-k
interrupt-k (process-state old-process))))
(process-state old-process))))
(struct-copy vm (enqueue-actions state pid actions) (struct-copy vm (enqueue-actions state pid actions)
[processes (hash-set (vm-processes state) pid [processes (hash-set (vm-processes state) pid
(struct-copy process old-process (struct-copy process old-process
[state new-process-state]))])) [state new-process-state]))]))
(define (do-spawn spawning-pid thunk k state) (define (do-spawn spawning-pid thunk k state)
(match-define (transition initial-state initial-actions) (send-to-user (lambda (e) (match-define (transition initial-state initial-actions)
(transition #f (send-to-user (lambda (e) (transition #f (kill #f e))) thunk))
(kill #f e)))
thunk))
(define new-pid (vm-next-process-id state)) (define new-pid (vm-next-process-id state))
(run-trapk (struct-copy vm (enqueue-actions state new-pid initial-actions) (run-trapk (struct-copy vm (enqueue-actions state new-pid initial-actions)
[processes (hash-set (vm-processes state) new-pid (process new-pid [processes (hash-set (vm-processes state) new-pid (process new-pid