Split out effect-handling library.
This commit is contained in:
Tony Garnock-Jones
parent
e74f6ae7e5
commit
2a218dd0a6
|
|
@ -39,6 +39,7 @@
|
|||
(require "support/struct.rkt")
|
||||
(require "pretty.rkt")
|
||||
(require "treap.rkt")
|
||||
(require "effect.rkt")
|
||||
|
||||
(define&provide-dsl-helper-syntaxes "state/until/forever form"
|
||||
[on
|
||||
|
|
@ -82,10 +83,10 @@
|
|||
;; side-effects.
|
||||
|
||||
;; An Instruction is one of
|
||||
;; - (patch-instruction Patch (Void -> Instruction))
|
||||
;; - (action-instruction Action (Void -> Instruction))
|
||||
;; - (patch-instruction Patch)
|
||||
;; - (action-instruction Action)
|
||||
;; - (return-instruction (Option (Listof Any)))
|
||||
;; - (spawn-instruction LinkageKind (Symbol Symbol -> Spawn) (Void -> Instruction))
|
||||
;; - (spawn-instruction LinkageKind (Symbol Symbol -> Spawn))
|
||||
;; - (script-complete-instruction Variables)
|
||||
;; and represents a side-effect for an actor to take in its
|
||||
;; interactions with the outside world.
|
||||
|
|
@ -113,10 +114,10 @@
|
|||
;; (Background is done differently, with a new continuation for the
|
||||
;; background script, and a self-send to activate it. (TODO))
|
||||
;;
|
||||
(struct patch-instruction (patch k) #:transparent)
|
||||
(struct action-instruction (action k) #:transparent)
|
||||
(struct patch-instruction (patch) #:transparent)
|
||||
(struct action-instruction (action) #:transparent)
|
||||
(struct return-instruction (result-values) #:transparent)
|
||||
(struct spawn-instruction (linkage-kind action-fn k) #:transparent)
|
||||
(struct spawn-instruction (linkage-kind action-fn) #:transparent)
|
||||
(struct script-complete-instruction (variables) #:transparent)
|
||||
|
||||
;; An ActorState is an (actor-state ... as below), describing the
|
||||
|
|
@ -183,46 +184,25 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Producing Instruction side-effects
|
||||
|
||||
(define prompt (make-continuation-prompt-tag 'syndicate-hll))
|
||||
(define syndicate-tag (make-effect-tag 'syndicate))
|
||||
|
||||
(define (syndicate-actor-prompt-tag-installed?)
|
||||
(continuation-prompt-available? prompt))
|
||||
(effect-available? syndicate-tag))
|
||||
|
||||
;; (Any ... -> Nothing) -> (Any ... -> Instruction)
|
||||
(define (reply-to k)
|
||||
(lambda reply-values
|
||||
(call-with-continuation-prompt (lambda ()
|
||||
(apply k reply-values)
|
||||
(error 'reply-to "Script returned directly"))
|
||||
prompt)))
|
||||
|
||||
;; (-> Instruction) -> Nothing
|
||||
(define (call-in-raw-context/abort proc)
|
||||
(abort-current-continuation prompt proc))
|
||||
|
||||
;; ((Any ... -> Instruction) -> Instruction)
|
||||
(define (call-in-raw-context proc)
|
||||
(when (not (syndicate-actor-prompt-tag-installed?))
|
||||
(error 'call-in-raw-context
|
||||
"Attempt to invoke imperative Syndicate actor action outside actor context."))
|
||||
(call-with-composable-continuation
|
||||
(lambda (k) (abort-current-continuation prompt (lambda () (proc (reply-to k)))))
|
||||
prompt))
|
||||
(define do! (perform syndicate-tag))
|
||||
(define do/abort! (perform/abort syndicate-tag))
|
||||
|
||||
;; Returns void
|
||||
(define (assert! P #:meta-level [meta-level 0])
|
||||
(call-in-raw-context
|
||||
(lambda (k) (patch-instruction (core:assert P #:meta-level meta-level) k))))
|
||||
(do! (patch-instruction (core:assert P #:meta-level meta-level))))
|
||||
|
||||
;; Returns void
|
||||
(define (retract! P #:meta-level [meta-level 0])
|
||||
(call-in-raw-context
|
||||
(lambda (k) (patch-instruction (retract P #:meta-level meta-level) k))))
|
||||
(do! (patch-instruction (retract P #:meta-level meta-level))))
|
||||
|
||||
;; Returns void
|
||||
(define (patch! p)
|
||||
(call-in-raw-context
|
||||
(lambda (k) (patch-instruction p k))))
|
||||
(do! (patch-instruction p)))
|
||||
|
||||
;; Returns void
|
||||
(define (send! M #:meta-level [meta-level 0])
|
||||
|
|
@ -230,25 +210,21 @@
|
|||
|
||||
;; Returns void
|
||||
(define (perform-core-action! A)
|
||||
(call-in-raw-context
|
||||
(lambda (k) (action-instruction A k))))
|
||||
(do! (action-instruction A)))
|
||||
|
||||
;; Does not return to caller; instead, terminates the current actor
|
||||
;; after sending a link-result to the calling actor.
|
||||
(define (return! . result-values)
|
||||
(call-in-raw-context/abort
|
||||
(lambda () (return-instruction result-values))))
|
||||
(do/abort! (return-instruction result-values)))
|
||||
|
||||
;; Does not return to caller; instead, terminates the current actor
|
||||
;; without sending a link-result to the calling actor.
|
||||
(define (return/no-link-result!)
|
||||
(call-in-raw-context/abort
|
||||
(lambda () (return-instruction #f))))
|
||||
(do/abort! (return-instruction #f)))
|
||||
|
||||
;; Returns new variables, plus values from spawned actor if any.
|
||||
(define (spawn! linkage-kind action-fn)
|
||||
(call-in-raw-context
|
||||
(lambda (k) (spawn-instruction linkage-kind action-fn k))))
|
||||
(do! (spawn-instruction linkage-kind action-fn)))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-splicing-syntax-class name
|
||||
|
|
@ -388,10 +364,10 @@
|
|||
;; callee-id
|
||||
;; reply-values
|
||||
;; continuation)
|
||||
(handle-actor-syscall (transition (struct-copy actor-state s [continuation-table new-table])
|
||||
'())
|
||||
(apply continuation
|
||||
(append reply-values (vector->list (actor-state-variables s))))))
|
||||
(handle-effects (transition (struct-copy actor-state s [continuation-table new-table]) '())
|
||||
(lambda (_void)
|
||||
(apply continuation
|
||||
(append reply-values (vector->list (actor-state-variables s)))))))
|
||||
|
||||
;; ActorState -> Transition
|
||||
(define (perform-pending-patch s)
|
||||
|
|
@ -410,70 +386,65 @@
|
|||
|
||||
;; ActorState Script -> Transition
|
||||
(define (run-script s script)
|
||||
(handle-actor-syscall (transition s '())
|
||||
((reply-to (lambda (dummy)
|
||||
(define new-variables (script))
|
||||
(call-in-raw-context/abort
|
||||
(lambda ()
|
||||
(script-complete-instruction new-variables)))))
|
||||
(void))))
|
||||
(handle-effects (transition s '())
|
||||
(lambda (_void) (do/abort! (script-complete-instruction (script))))))
|
||||
|
||||
(define (actor-body->spawn-action thunk)
|
||||
(match ((reply-to (lambda (dummy)
|
||||
(actor (thunk))
|
||||
(error '%%boot "Reached end of boot thunk")))
|
||||
(void))
|
||||
[(spawn-instruction 'actor action-fn _get-next-instr)
|
||||
(action-fn (gensym 'root-actor) (gensym 'boot-actor))]))
|
||||
(with-effect #:shallow syndicate-tag k
|
||||
([(spawn-instruction 'actor action-fn)
|
||||
(action-fn (gensym 'root-actor) (gensym 'boot-actor))])
|
||||
(begin (actor (thunk))
|
||||
(error '%%boot "Reached end of boot thunk"))))
|
||||
|
||||
;; Transition Instruction -> Transition
|
||||
(define (handle-actor-syscall t instr)
|
||||
(match instr
|
||||
[(patch-instruction p get-next-instr)
|
||||
(handle-actor-syscall (sequence-transitions t
|
||||
(extend-pending-patch *adhoc-label* p))
|
||||
(get-next-instr (void)))]
|
||||
[(action-instruction a get-next-instr)
|
||||
(handle-actor-syscall (sequence-transitions t
|
||||
perform-pending-patch
|
||||
(lambda (s) (transition s a)))
|
||||
(get-next-instr (void)))]
|
||||
[(return-instruction result-values)
|
||||
(sequence-transitions t
|
||||
perform-pending-patch
|
||||
(lambda (s)
|
||||
(if result-values
|
||||
(quit (message (link-result (actor-state-caller-id s)
|
||||
(actor-state-self-id s)
|
||||
result-values)))
|
||||
(quit))))]
|
||||
[(spawn-instruction linkage-kind action-fn get-next-instr)
|
||||
(define blocking? (eq? linkage-kind 'call))
|
||||
(define next-t
|
||||
(sequence-transitions t
|
||||
perform-pending-patch
|
||||
(lambda (s)
|
||||
(define callee-id (gensym linkage-kind))
|
||||
(define spawn-action (action-fn callee-id (actor-state-self-id s)))
|
||||
(transition (if blocking?
|
||||
(store-continuation s callee-id get-next-instr)
|
||||
s)
|
||||
(if (eq? linkage-kind 'dataspace)
|
||||
(spawn-dataspace spawn-action)
|
||||
spawn-action)))))
|
||||
(if blocking?
|
||||
next-t
|
||||
(handle-actor-syscall next-t (get-next-instr (void))))]
|
||||
[(script-complete-instruction new-variables)
|
||||
(sequence-transitions t
|
||||
;; NB: Does not perform-pending-patch here.
|
||||
;; Instead, the script runner will now
|
||||
;; update ongoing subscriptions and
|
||||
;; incorporate the pending patch into that
|
||||
;; process.
|
||||
(lambda (s)
|
||||
(transition (struct-copy actor-state s [variables new-variables])
|
||||
'())))]))
|
||||
;; Transition (Void -> Instruction) -> Transition
|
||||
(define (handle-effects t get-this-instr)
|
||||
(with-effect #:shallow syndicate-tag get-next-instr
|
||||
([(patch-instruction p)
|
||||
(handle-effects (sequence-transitions t (extend-pending-patch *adhoc-label* p))
|
||||
get-next-instr)]
|
||||
[(action-instruction a)
|
||||
(handle-effects (sequence-transitions t
|
||||
perform-pending-patch
|
||||
(lambda (s) (transition s a)))
|
||||
get-next-instr)]
|
||||
[(return-instruction result-values)
|
||||
(sequence-transitions t
|
||||
perform-pending-patch
|
||||
(lambda (s)
|
||||
(if result-values
|
||||
(quit (message (link-result (actor-state-caller-id s)
|
||||
(actor-state-self-id s)
|
||||
result-values)))
|
||||
(quit))))]
|
||||
[(spawn-instruction linkage-kind action-fn)
|
||||
(define blocking? (eq? linkage-kind 'call))
|
||||
(define next-t
|
||||
(sequence-transitions t
|
||||
perform-pending-patch
|
||||
(lambda (s)
|
||||
(define callee-id (gensym linkage-kind))
|
||||
(define spawn-action
|
||||
(action-fn callee-id (actor-state-self-id s)))
|
||||
(transition (if blocking?
|
||||
(store-continuation s callee-id get-next-instr)
|
||||
s)
|
||||
(if (eq? linkage-kind 'dataspace)
|
||||
(spawn-dataspace spawn-action)
|
||||
spawn-action)))))
|
||||
(if blocking?
|
||||
next-t
|
||||
(handle-effects next-t get-next-instr))]
|
||||
[(script-complete-instruction new-variables)
|
||||
(sequence-transitions t
|
||||
;; NB: Does not perform-pending-patch here.
|
||||
;; Instead, the script runner will now
|
||||
;; update ongoing subscriptions and
|
||||
;; incorporate the pending patch into that
|
||||
;; process.
|
||||
(lambda (s)
|
||||
(transition (struct-copy actor-state s [variables new-variables])
|
||||
'())))])
|
||||
(get-this-instr (void))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Compilation of HLL actors
|
||||
|
|
|
|||
|
|
@ -0,0 +1,159 @@
|
|||
#lang racket/base
|
||||
;; Simple effect system.
|
||||
|
||||
;; Should `with-effect` be called `with-effect-handler` (or `with-effect-handlers`)?
|
||||
|
||||
(provide (except-out (struct-out effect-tag) effect-tag)
|
||||
make-effect-tag
|
||||
effect-available?
|
||||
perform
|
||||
perform/abort
|
||||
handle*
|
||||
with-effect)
|
||||
|
||||
(require racket/control)
|
||||
(require racket/match)
|
||||
|
||||
(struct effect-tag (name prompt) #:transparent)
|
||||
|
||||
(define (make-effect-tag name) (effect-tag name (make-continuation-prompt-tag name)))
|
||||
|
||||
(struct instruction (action k))
|
||||
(struct result (values))
|
||||
|
||||
(define (effect-available? tag)
|
||||
(continuation-prompt-available? (effect-tag-prompt tag)))
|
||||
|
||||
(define (ensure-effect-available! who tag action)
|
||||
(unless (effect-available? tag)
|
||||
(error who
|
||||
"Attempt to invoke action ~v in effect ~a with no handler installed."
|
||||
action
|
||||
(effect-tag-name tag))))
|
||||
|
||||
(define ((perform tag) action)
|
||||
(ensure-effect-available! 'perform tag action)
|
||||
(define p (effect-tag-prompt tag))
|
||||
(call-with-composable-continuation
|
||||
(lambda (k) (abort/cc p (lambda () (instruction action k))))
|
||||
p))
|
||||
|
||||
(define ((perform/abort tag) action)
|
||||
(ensure-effect-available! 'perform/abort tag action)
|
||||
(abort/cc (effect-tag-prompt tag) (lambda () (instruction action #f))))
|
||||
|
||||
(define (handle* shallow? tag body-thunk action-proc result-proc)
|
||||
(define p (effect-tag-prompt tag))
|
||||
(let run ((body-thunk body-thunk))
|
||||
(call-with-values (lambda ()
|
||||
(call-with-continuation-prompt
|
||||
(lambda () (call-with-values
|
||||
body-thunk
|
||||
(lambda results
|
||||
(abort/cc p (lambda () (result results))))))
|
||||
p))
|
||||
(match-lambda
|
||||
[(instruction action k)
|
||||
(action-proc action
|
||||
(if shallow?
|
||||
k
|
||||
(lambda vs
|
||||
(run (lambda () (apply k vs))))))]
|
||||
[(result vs)
|
||||
(apply result-proc vs)]))))
|
||||
|
||||
(define-syntax shallow-or-deep
|
||||
(syntax-rules ()
|
||||
((shallow-or-deep #:shallow) #t)
|
||||
((shallow-or-deep #:deep) #f)))
|
||||
|
||||
(define-syntax with-effect
|
||||
(syntax-rules ()
|
||||
((with-effect sd tag-exp k-var (clause ...) effectful-exp)
|
||||
(with-effect sd tag-exp k-var (clause ...) effectful-exp #:return values))
|
||||
((with-effect sd tag-exp k-var (clause ...) effectful-exp #:return result-proc)
|
||||
(handle* (shallow-or-deep sd)
|
||||
tag-exp
|
||||
(lambda () effectful-exp)
|
||||
(lambda (action k-var) (match action clause ...))
|
||||
result-proc))))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(struct get ())
|
||||
(struct set (v))
|
||||
|
||||
(define cell-effect (make-effect-tag 'cell))
|
||||
|
||||
(define do! (perform cell-effect))
|
||||
|
||||
(define (with-shallow-cell-effect initial-value thunk)
|
||||
(let loop ((value initial-value) (thunk thunk))
|
||||
(with-effect #:shallow cell-effect k
|
||||
([(get) (loop value (lambda () (k value)))]
|
||||
[(set v) (loop v (lambda () (k value)))])
|
||||
(thunk))))
|
||||
|
||||
(define (with-deep-cell-effect initial-value thunk)
|
||||
((with-effect #:deep cell-effect k
|
||||
([(get) (lambda (s) ((k s) s))]
|
||||
[(set v) (lambda (s) ((k s) v))])
|
||||
(thunk)
|
||||
#:return (lambda (v) (lambda (s) v)))
|
||||
initial-value))
|
||||
|
||||
(define (tracing-cell-effect initial-value thunk)
|
||||
(struct finish (v))
|
||||
(let loop ((trace '())
|
||||
(value initial-value)
|
||||
(thunk (lambda () ((perform cell-effect) (finish (thunk))))))
|
||||
(with-effect #:shallow cell-effect k
|
||||
([(get) (loop (cons `get trace) value (lambda () (k value)))]
|
||||
[(set v) (loop (cons `(set ,v) trace) v (lambda () (k value)))]
|
||||
[(finish v) (reverse (cons `(result ,v) trace))])
|
||||
(thunk))))
|
||||
|
||||
(define (tracing-cell-effect2 initial-value thunk)
|
||||
(let loop ((trace '())
|
||||
(value initial-value)
|
||||
(thunk thunk))
|
||||
(with-effect #:shallow cell-effect k
|
||||
([(get) (loop (cons `get trace) value (lambda () (k value)))]
|
||||
[(set v) (loop (cons `(set ,v) trace) v (lambda () (k value)))])
|
||||
(thunk)
|
||||
#:return (lambda (v) (reverse (cons `(result ,v) trace))))))
|
||||
|
||||
(define (tracing-cell-effect3 initial-value thunk)
|
||||
(with-shallow-cell-effect '()
|
||||
(lambda ()
|
||||
(define final
|
||||
(let loop ((value initial-value)
|
||||
(thunk thunk))
|
||||
(with-effect #:shallow cell-effect k
|
||||
([(get)
|
||||
(do! (set (cons `get (do! (get)))))
|
||||
(loop value (lambda () (k value)))]
|
||||
[(set v)
|
||||
(do! (set (cons `(set ,v) (do! (get)))))
|
||||
(loop v (lambda () (k value)))])
|
||||
(thunk))))
|
||||
(reverse (cons `(result ,final) (do! (get)))))))
|
||||
|
||||
(define (do-something)
|
||||
(do! (set (+ (do! (get)) 1)))
|
||||
(list (do! (get))
|
||||
(begin (do! (set (+ (do! (get)) 1)))
|
||||
(do! (get)))))
|
||||
|
||||
(check-equal? (with-shallow-cell-effect 0 do-something)
|
||||
(list 1 2))
|
||||
(check-equal? (tracing-cell-effect 0 do-something)
|
||||
`(get (set 1) get get (set 2) get (result ,(list 1 2))))
|
||||
(check-equal? (tracing-cell-effect2 0 do-something)
|
||||
`(get (set 1) get get (set 2) get (result ,(list 1 2))))
|
||||
(check-equal? (tracing-cell-effect3 0 do-something)
|
||||
`(get (set 1) get get (set 2) get (result ,(list 1 2))))
|
||||
|
||||
(check-equal? (with-deep-cell-effect 0 do-something)
|
||||
(list 1 2)))
|
||||
Loading…
Reference in New Issue