Skip to content

Commit

Permalink
Enhanced actor example to support multi-buffers
Browse files Browse the repository at this point in the history
  • Loading branch information
Lukas Convent committed Jun 24, 2017
1 parent 104ae03 commit 93f2559
Show file tree
Hide file tree
Showing 3 changed files with 196 additions and 20 deletions.
1 change: 1 addition & 0 deletions Syntax.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -313,6 +313,7 @@ substOpenAbPort ab (MkPort adj ty) =
MkPort (substOpenAbAdj ab adj) (substOpenAb ab ty)
-}

-- ability might be overridden by adjustment
plus :: Ab a -> Adj a -> Ab a
plus (MkAb v m) (MkAdj m') = MkAb v (M.union m' m)

Expand Down
30 changes: 10 additions & 20 deletions Unification.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -80,7 +80,8 @@ unify t s =
unifyAb :: Ab Desugared -> Ab Desugared -> Contextual ()
unifyAb ab0@(MkAb v0 m0) ab1@(MkAb v1 m1) =
-- [v0 | m0_1, ..., m0_m] [v1 | m1_1, ... m1_n]
do ma0 <- findAbVar v0 -- find ability bound to flex. eff var v0
do logBeginUnifyAb ab0 ab1
ma0 <- findAbVar v0 -- find ability bound to flex. eff var v0
ma1 <- findAbVar v1 -- find ability bound to flex. eff var v1
-- 1a) If v0 is flex. eff var: v0 = [v0' | m0'_1, ..., m0'_k]
-- Consider only merged: [v0' | m0_1, ..., m0_m, m0'_1, ..., m0'_n]
Expand All @@ -91,27 +92,16 @@ unifyAb ab0@(MkAb v0 m0) ab1@(MkAb v1 m1) =
(Just (MkAb v0 m0'), Just (MkAb v1 m1')) ->
let m0'' = M.union m0 m0' in
let m1'' = M.union m1 m1' in
do logBeginUnifyAb ab0 ab1
res <- unifyAb' (MkAb v0 m0'') (MkAb v1 m1'')
logEndUnifyAb ab0 ab1
return res
unifyAb' (MkAb v0 m0'') (MkAb v1 m1'')
(Just (MkAb v0 m0'), Nothing) ->
let m0'' = M.union m0 m0' in do
logBeginUnifyAb ab0 ab1
res <- unifyAb' (MkAb v0 m0'') ab1
logEndUnifyAb ab0 ab1
return res
let m0'' = M.union m0 m0' in
unifyAb' (MkAb v0 m0'') ab1
(Nothing, Just (MkAb v1 m1')) ->
let m1'' = M.union m1 m1' in do
logBeginUnifyAb ab0 ab1
res <- unifyAb' ab0 (MkAb v1 m1'')
logEndUnifyAb ab0 ab1
return res
(Nothing, Nothing) -> do
logBeginUnifyAb ab0 ab1
res <- unifyAb' ab0 ab1
logEndUnifyAb ab0 ab1
return res
let m1'' = M.union m1 m1' in
unifyAb' ab0 (MkAb v1 m1'')
(Nothing, Nothing) ->
unifyAb' ab0 ab1
logEndUnifyAb ab0 ab1
where -- Same eff ty vars leaves nothing to unify but instantiat's m0, m1
unifyAb' ab0@(MkAb v0 m0) ab1@(MkAb v1 m1) | v0 == v1 =
catchError (unifyItfMap m0 m1) (unifyAbError ab0 ab1)
Expand Down
185 changes: 185 additions & 0 deletions examples/actorMultiMailbox.fk
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,185 @@
--- start of standard stuff ---
data Maybe X = nothing | just X
data Pair X Y = pair X Y

reverse' : {List X -> List X -> List X}
reverse' [] ys = ys
reverse' (x :: xs) ys = reverse' xs (x :: ys)

reverse : {List X -> List X}
reverse xs = reverse' xs []

map : {{X -> Y} -> List X -> List Y}
map f [] = []
map f (x :: xs) = f x :: map f xs

print : {String -> [Console]Unit}
print s = map ouch s; unit
--- end of standard stuff ---

--------------------------------------------------------------------------------
-- Queue interface and fast queue implementation
--------------------------------------------------------------------------------

interface Queue S = enqueue : S -> Unit
| dequeue : Maybe S

-- Execute a computation along with a queue as state (generalisation of
-- zipQueue from coop-factored.fk)
data ZipQueue S = zipq (List S) (List S)

runZipQueue: {{[Queue S]X} -> ZipQueue S -> Pair X (ZipQueue S)}
runZipQueue t q = runZipQueue' t! q

runZipQueue': {<Queue S>X -> ZipQueue S -> Pair X (ZipQueue S)}
runZipQueue' <enqueue q -> k> (zipq ps qs) = runZipQueue' (k unit) (zipq ps (q :: qs))
runZipQueue' <dequeue -> k> (zipq [] []) = runZipQueue' (k nothing) (zipq [] [])
runZipQueue' <dequeue -> k> (zipq [] qs) = runZipQueue' (k dequeue!) (zipq (reverse qs) [])
runZipQueue' <dequeue -> k> (zipq (p :: ps) qs) = runZipQueue' (k (just p)) (zipq ps qs)
runZipQueue' x (zipq ps qs) = pair x (zipq ps qs)

evalZipQueue: {{[Queue S]X} -> ZipQueue S -> X}
evalZipQueue t q = case (runZipQueue t q) { (pair x _) -> x }

execZipQueue: {{[Queue S]X} -> ZipQueue S -> ZipQueue S}
execZipQueue t q = case (runZipQueue t q) { (pair _ q) -> q }

--------------------------------------------------------------------------------
-- Definitions of interfaces, data types
--------------------------------------------------------------------------------

-- interface Co [C] = fork : {[C | Co [C|]]Unit} -> Unit
interface Co = fork : {[Co]Unit} -> Unit
| yield : Unit

-- Single item mailbox
data Mailbox X = mbox (Ref (ZipQueue X))

-- interface Actor X [A] = spawn Y: {[A | Actor Y [A|]]Unit} -> Mailbox Y
interface Actor X = spawn Y: {[Actor Y]Unit} -> Mailbox Y
| self: Mailbox X
| recv: X
| send Y: Mailbox Y -> Y -> Unit

data WithSender X Y = withSender (Mailbox X) Y

--------------------------------------------------------------------------------
-- Simple example actors
--------------------------------------------------------------------------------

doubleActor: {[Actor (WithSender Int Int)]Unit}
doubleActor! = case recv! { (withSender sender inp) -> send sender (inp + inp) }

doubleSpawningActor: {[Actor Int [Console], Console]Unit}
doubleSpawningActor! = let doubler = spawn doubleActor in
send doubler (withSender self! 3);
case recv! { 6 -> print "you truly know how to double"
| _ -> print "naw" }

-- This one would only work with a multi-buffer, not our single-Mailbox.
divConqActor: {[Actor Int [Console], Console]Unit}
divConqActor! = let doublerA = spawn doubleActor in
let doublerB = spawn doubleActor in
send doublerA (withSender self! 1);
send doublerB (withSender self! 2);
print "calculating (1+1) + (2+2)\n";
case (recv! + recv!) { 6 -> print "yay got 6"
| _ -> print "naw" }

soliloquistActor: {[Actor Int [Console], Console]Unit}
soliloquistActor! = let me = self! in
send me 42;
case recv! { 42 -> print "ouh how unexpected"
| _ -> print "what did I send again?" }

nicePrintActor: {[Actor String [Console], Console]Unit}
nicePrintActor! = let inp = recv! in
print "Hey, a message came in: "; print inp

writingActor: {[Actor Int [Console], Console]Unit}
writingActor! = let you = spawn nicePrintActor in
send you "important msg"

--------------------------------------------------------------------------------
-- Turn an actor step into a process step
--------------------------------------------------------------------------------

-- step: {Mailbox X -> <Actor X [E|RefState, Co[E|RefState]]>Z -> [E|RefState, Co[E|RefState]]Z}
step: {Mailbox X -> <Actor X [RefState, Co[RefState]]>Unit -> [RefState, Co [RefState]]Unit}
step me <self -> k> = step me (k me)
step (mbox me') <recv -> k> = case (runZipQueue {dequeue!} (read me'))
{ (pair nothing _) -> yield!;
step (mbox me') (k recv!)
| (pair (just x) q) -> write me' q;
step (mbox me') (k x) }
step me <send (mbox you') x -> k> = let q = read you' in
case (execZipQueue {enqueue x} q)
{ q' -> write you' q';
step me (k unit) }
step me <spawn other -> k> = let you = mbox (new (zipq [] [])) in
fork {step you other!};
step me (k you)
step me x = x

--------------------------------------------------------------------------------
-- Two simple process-executers for up to two processes
--------------------------------------------------------------------------------

-- Execute up to two processes. If the 1st one forks, replace the 2nd by fork
duoCoExec: {<Co>Unit -> <Co>Unit -> Unit}
duoCoExec <fork e -> k> _ = duoCoExec (k unit) e!
duoCoExec <fork e -> k> <_> = duoCoExec (k unit) e!
duoCoExec <yield -> _> <fork e' -> k'> = duoCoExec (k' unit) e'!
duoCoExec <yield -> k> <yield -> k'> = duoCoExec (k unit) (k' unit) -- possibly deadlock
duoCoExec <yield -> k> unit = duoCoExec (k unit) unit -- possibly deadlock
duoCoExec unit <fork e' -> k'> = duoCoExec (k' unit) e'!
duoCoExec unit <yield -> k'> = duoCoExec (k' unit) unit -- possibly deadlock
duoCoExec unit unit = unit -- done

-- Same as duoCoExec, but only the 1st process is executed, the 2nd is frozen
duoSuspCoExec: {<Co>Unit -> Unit}
duoSuspCoExec <fork e -> k> = duoSuspCoExec' (k unit) e
duoSuspCoExec <yield -> k> = unit
duoSuspCoExec _ = unit

duoSuspCoExec': {<Co>Unit -> {[Co]Unit} -> Unit}
duoSuspCoExec' <fork e -> k> _ = duoSuspCoExec' (k unit) e
duoSuspCoExec' <yield -> k> e' = duoSuspCoExec' e'! {k unit}
duoSuspCoExec' unit e' = duoSuspCoExec e'!

--------------------------------------------------------------------------------
-- This is the process executer from coop-factored.fk, using a queue to handle
-- multiple processes
--------------------------------------------------------------------------------

data Proc = proc {[Queue Proc]Unit}

pushProc : {{[Queue Proc]Unit} -> [Queue Proc]Unit}
pushProc p = enqueue (proc p)

popProc : {[Queue Proc]Maybe Unit}
popProc! = case dequeue! { (just (proc x)) -> just x!
| nothing -> nothing }

popProcs : {[Queue Proc]Unit}
popProcs! = case popProc! { (just unit) -> popProcs!
| nothing -> unit }

-- Serialise a queue-tree and return a "queue-manager" in the following way:
-- Given a forkable computation,
-- 1) yield ==translate==> push continuation into queue, pop rest of list
-- 2) fork ==translate==> push fork into queue, then carry on
-- 3) unit ==translate==> pop rest of list
-- roundRobin : {<Co [R | Queue Proc]>Unit -> [R | Queue Proc]Unit}
roundRobin : {<Co [Queue Proc]>Unit -> [Queue Proc]Unit}
roundRobin <yield -> k> = pushProc {roundRobin (k unit)}; popProcs!
roundRobin <fork p -> k> = pushProc {roundRobin p!}; roundRobin (k unit)
roundRobin unit = popProcs!

--------------------------------------------------------------------------------
-- Test doubleSpawningActor example
--------------------------------------------------------------------------------

main: {[Console, RefState]Unit}
main! = let me = mbox (new (zipq [] [])) in
runZipQueue' (roundRobin (step me divConqActor!)) (zipq [] []); unit

0 comments on commit 93f2559

Please sign in to comment.