From 32b0b3682f7e4f94419da2115aef8b286e23f51d Mon Sep 17 00:00:00 2001 From: adam Date: Thu, 1 Mar 2007 13:17:01 +0100 Subject: [PATCH] checkpoint --- contrib/demo.f0 | 36 +++++++++++++++++++ src/edu/berkeley/fleet/f0/Compile.lhs | 47 ++++++++++++++++++------ src/edu/berkeley/fleet/f0/Fleet.lhs | 16 ++++++--- src/edu/berkeley/fleet/f0/Types.lhs | 63 +++++++++++++++++++++------------ src/edu/berkeley/fleet/f0/Util.lhs | 8 +++++ src/edu/berkeley/fleet/f0/f0.g | 21 ++++++----- 6 files changed, 145 insertions(+), 46 deletions(-) create mode 100644 contrib/demo.f0 diff --git a/contrib/demo.f0 b/contrib/demo.f0 new file mode 100644 index 0000000..2c4785c --- /dev/null +++ b/contrib/demo.f0 @@ -0,0 +1,36 @@ + +main(x -> out) = + alu :: Alu2 + debug :: Debug + fifo1 :: Fifo + fifo2 :: Fifo + { 0, 1, 2 } --> fifo1.in + { 0, 3, 4 } --> fifo2.in + fifo1.out --> alu.inOp, alu.in1, alu.in2 + alu.out --> debug.in + ;; + fifo2.out --> alu.inOp, alu.in1, alu.in2 + alu.out --> debug.in + +/* +double(a -> out) = + alu :: Alu2 + a --> alu.in1, alu.in2 + 0 --> alu.inOp + alu.out --> out + + +half(a -> out) = + shift :: Shift + a --> shift.in + 1 --> shift.inAmount + shift.out --> out + +thrice(a -> out) = + alu :: Alu2 + a --> alu.in1, alu.in2, alu.in2 + 0 -[2]-> alu.inOp + { alu.out --> alu.in2 + alu.out --> alu.out + } +*/ diff --git a/src/edu/berkeley/fleet/f0/Compile.lhs b/src/edu/berkeley/fleet/f0/Compile.lhs index cdbf292..a505eec 100644 --- a/src/edu/berkeley/fleet/f0/Compile.lhs +++ b/src/edu/berkeley/fleet/f0/Compile.lhs @@ -5,20 +5,45 @@ import Types import Util import Fleet +-- assumption: +-- within a block that has data going both to and from a ship, +-- the last datum leaving the ship must leave after all arriving +-- datums have arrived + +getInboxes :: Expr -> [Port] +getInboxes (Move 1 s d) = [d] +getInboxes (Exprs d e) = getInboxes e +getInboxes (Par e) = concatMap getInboxes e +getInboxes (Seq [a,b]) = getInboxes a +getInboxes _ = [] + +getOutboxes :: Expr -> [Port] +getOutboxes (Move 1 s d) = [s] +getOutboxes (Exprs d e) = getOutboxes e +getOutboxes (Par e) = concatMap getOutboxes e +getOutboxes (Seq [a,b]) = getOutboxes b +getOutboxes _ = [] + compile :: Expr -> [Inst] -compile (Decl _ _) = [] -compile (Seq s) = error "bleh" -compile (Par e) = concatMap compile e -compile (Move 1 s [d]) = [ (move s) { m_dest=(Just d) }, (accept d) ] -compile (Move 1 s d) = [itake s]++sends++recvs +compile (Literal 0 lit d) = [ ILiteral lit d, (accept d) {m_count=0} ] +compile (Literal 1 lit d) = [ ILiteral lit d, (accept d) ] +compile (Literal n lit d) = [ ILiteral lit d, (accept d) {m_count=n} ] +compile (Exprs d e) = compile e +compile (Seq [a,b]) = (compile a)++(bridge (getInboxes a) (uniq (getOutboxes b)))++(compile b) +compile (Par e) = concatMap compile e +compile (Move 1 s d) = [ (move s) { m_dest=(Just d) }, (accept d) ] + +bridge :: [Port] -> [Port] -> [Inst] +bridge [] _ = [] +bridge _ [] = [] +bridge obs (ib:ibs) = notifyFromOutboxes ++ waitForOutboxNotifications ++ notifyInboxes ++ waitForInboxNotifications where - sends = map (\x -> ((send s) { m_dest=(Just x) })) d - recvs = map (\x -> ((accept x) )) d -compile (Literal 0 lit ds) = concatMap (\d -> [ ILiteral lit d, (accept d) {m_count=0} ]) ds -compile (Literal 1 lit ds) = concatMap (\d -> [ ILiteral lit d, (accept d) ]) ds -compile (Literal n lit ds) = concatMap (\d -> [ ILiteral lit d, (accept d) {m_count=n} ]) ds + notifyFromOutboxes = map (\ob -> notify ob ib) obs + waitForOutboxNotifications = [(wait ib){m_count=(length obs)}] + notifyInboxes = map (notify ib) ibs + waitForInboxNotifications = map wait ibs -getdecls (Decl n t) = ["#ship " ++ n ++ " : " ++ t] +getdecls (Exprs d e) = map (\(Decl n t) -> ("#ship " ++ n ++ " : " ++ t)) d getdecls (Seq es) = concatMap getdecls es getdecls (Par es) = concatMap getdecls es getdecls _ = [] diff --git a/src/edu/berkeley/fleet/f0/Fleet.lhs b/src/edu/berkeley/fleet/f0/Fleet.lhs index 0cad15f..0b2206d 100644 --- a/src/edu/berkeley/fleet/f0/Fleet.lhs +++ b/src/edu/berkeley/fleet/f0/Fleet.lhs @@ -8,13 +8,19 @@ itake box = IMove { m_count=1, m_recycle=False, m_tokenIn=False, m_dataIn=True, m_benkobox=box } move box = (itake box){ m_dataOut=True } send box = (move box){ m_dataIn=False, m_latch=False } +notify box dest = IMove { m_count=1, m_recycle=False, m_tokenIn=False, m_dataIn=False, + m_latch=False, m_dataOut=False, m_tokenOut=True, m_dest=(Just dest), + m_benkobox=box } +wait box = IMove { m_count=1, m_recycle=False, m_tokenIn=True, m_dataIn=False, + m_latch=False, m_dataOut=False, m_tokenOut=False, m_dest=Nothing, + m_benkobox=box } accept box = move box type BenkoBox = Port data Inst = IKill BenkoBox Int - | ILiteral Int BenkoBox - | IMove { m_benkobox :: BenkoBox , + | ILiteral Int BenkoBox + | IMove { m_benkobox :: BenkoBox , m_dest :: Maybe BenkoBox , m_count :: Int , m_recycle :: Bool , @@ -41,8 +47,8 @@ instance Show Inst where where showrest m = wait++takelatch++out++ack where - wait = if m_tokenIn m then ["wait"] else [] + wait = if m_tokenIn m then ["wait"] else [] takelatch = if m_dataIn m then (if m_latch m then ["take"] else ["drop"]) else [] - out = if m_dataOut m then (case m_dest m of { Nothing -> ["deliver"]; (Just j) -> ["sendto "++(show j)] }) else [] - ack = if m_tokenOut m then (case m_dest m of (Just j) -> ["ack "++(show j)]) else [] + out = if m_dataOut m then (case m_dest m of { Nothing -> ["deliver"]; (Just j) -> ["sendto "++(show j)] }) else [] + ack = if m_tokenOut m then (case m_dest m of (Just j) -> ["notify "++(show j)]) else [] \end{code} \ No newline at end of file diff --git a/src/edu/berkeley/fleet/f0/Types.lhs b/src/edu/berkeley/fleet/f0/Types.lhs index eb955e8..f82c411 100644 --- a/src/edu/berkeley/fleet/f0/Types.lhs +++ b/src/edu/berkeley/fleet/f0/Types.lhs @@ -13,13 +13,13 @@ instance Show Def where commify x = join "," x instance FromTree Def where fromTree (Tree "Def" [name,inp,outp,es] _) = - Def (fromTree name) (fromTree inp) (fromTree outp) (Par (fromTree es)) + Def (fromTree name) (fromTree inp) (fromTree outp) (fromTree es) fromTree (Tree "Def" q _) = error $ show q -- Port ------------------------------------------------------------------------------ data Port = ShipPort String String | IdPort String - deriving Eq + deriving (Eq, Ord) instance Show Port where show (ShipPort a b) = a++"."++b @@ -32,35 +32,54 @@ instance FromTree Port where -- Expr ------------------------------------------------------------------------------ -data Expr = Decl String String - | Seq [Expr] - | Par [Expr] - | Move Int Port [Port] - | Literal Int Int [Port] - deriving Eq - +data Decl = Decl String String + deriving (Show,Eq) +data Expr = Seq [Expr] + | Par [Expr] + | Exprs [Decl] Expr + | Move Int Port Port + | Literal Int Int Port + | Nop + deriving (Show,Eq) +{- instance Show Expr where show (Decl shipName shipType) = shipName ++ " :: " ++ shipType show (Seq exprs) = join " ;; " $ map (\x -> "{ "++x++" }") $ map show exprs show (Par [expr]) = show expr show (Par exprs) = "{ " ++ (join "\n " $ map show exprs) ++ " }" - show (Move 0 source dests) = (show source) ++ " -[*]-> " ++ (join "," $ map show dests) - show (Move 1 source dests) = (show source) ++ " --> " ++ (join "," $ map show dests) - show (Move count source dests) = (show source) ++ " -["++(show count)++"]-> " ++ (join "," $ map show dests) + show (Move 0 source dest) = (show source) ++ " -[*]-> " ++ (show dest) + show (Move 1 source dest) = (show source) ++ " --> " ++ (show dest) + show (Move count source dest) = (show source) ++ " -["++(show count)++"]-> " ++ (show dest) show (Literal 0 i dest) = (show i) ++ " -[*]-> " ++ (show dest) show (Literal 1 i dest) = (show i) ++ " --> " ++ (show dest) show (Literal count i dest) = (show i) ++ " -["++(show count)++"]-> " ++ (show dest) +-} + +instance FromTree Decl where + fromTree (Tree "::" [shipName,shipType] _) = Decl (fromTree shipName) (fromTree shipType) instance FromTree Expr where - fromTree (Tree "::" [shipName,shipType] _) = Decl (fromTree shipName) (fromTree shipType) - fromTree (Tree "-->" [(Tree i [] _),dest] _) = Literal 1 (read i) (fromTree dest) - fromTree (Tree "-->" [source,dest] _) = Move 1 (fromTree source) (fromTree dest) - fromTree (Tree "-[" [(Tree i [] _),(Tree c [] _),dest] _) = Literal (read c) (read i) (fromTree dest) - fromTree (Tree "-[" [source,(Tree c [] _),dest] _) = Move (read c) (fromTree source) (fromTree dest) - fromTree (Tree "-[*]->" [(Tree i [] _),dest] _) = Literal 0 (read i) (fromTree dest) - fromTree (Tree "-[*]->" [source,dest] _) = Move 0 (fromTree source) (fromTree dest) - fromTree t@(Tree "{" [(Tree _ e _)] _) = Par (map fromTree e) - fromTree t@(Tree ";;" [a,b] _) = Seq [(fromTree a), (fromTree b)] - fromTree other = error (show other) + fromTree (Tree "Exprs" [decls, sequents] _) = Exprs (fromTree decls) (seq $ map par $ fromTree sequents) + where seq [] = Nop + seq [x] = x + seq x = Seq x + par [] = Nop + par [x] = x + par x = Par x + fromTree (Tree "-->" es _) = + case es of + [(Tree i [] _),dest] -> rep (fromTree dest) $ \d -> Literal 1 (read i) d + [(Tree "{" [Tree _ is _] _),dest] -> Par $ concatMap (\d -> map (\(Tree i _ _) -> Literal 1 (read i) d) is) (fromTree dest) + [source,dest] -> rep (fromTree dest) $ \d -> Move 1 (fromTree source) d +-- fromTree (Tree "-[" [(Tree i [] _),(Tree c [] _),dest] _) = Literal (read c) (read i) (fromTree dest) +-- fromTree (Tree "-[" [source,(Tree c [] _),dest] _) = Move (read c) (fromTree source) (fromTree dest) +-- fromTree (Tree "-[*]->" [(Tree i [] _),dest] _) = Literal 0 (read i) (fromTree dest) +-- fromTree (Tree "-[*]->" [source,dest] _) = Move 0 (fromTree source) (fromTree dest) + fromTree other = error $ (show other) + +rep :: [Port] -> (Port -> Expr) -> Expr +rep [] _ = error "nop" +rep [x] f = f x +rep list f = Par $ map f list \end{code} \ No newline at end of file diff --git a/src/edu/berkeley/fleet/f0/Util.lhs b/src/edu/berkeley/fleet/f0/Util.lhs index 6f27ee9..f178fc5 100644 --- a/src/edu/berkeley/fleet/f0/Util.lhs +++ b/src/edu/berkeley/fleet/f0/Util.lhs @@ -1,6 +1,7 @@ \begin{code} module Util where import SBP +import List(sort) indent [] = [] indent ('\n':q) = "\n "++(indent q) @@ -21,4 +22,11 @@ instance FromTree String where instance FromTrees String where fromTrees ts = concatMap (fromTree :: Tree -> String) ts +uniq l = rmdups $ sort l + where + rmdups [] = [] + rmdups [x] = [x] + rmdups (x:y:rest) | x==y = rmdups (x:rest) + | otherwise = x:(rmdups (y:rest)) + \end{code} \ No newline at end of file diff --git a/src/edu/berkeley/fleet/f0/f0.g b/src/edu/berkeley/fleet/f0/f0.g index 462afca..dbd10dd 100644 --- a/src/edu/berkeley/fleet/f0/f0.g +++ b/src/edu/berkeley/fleet/f0/f0.g @@ -2,14 +2,17 @@ s = ws! (Def+/ws) ws! Def = Id "(" (Id+/comma) "->" (Id+/comma) ")" "=" Exprs /ws -Exprs = Expr +/ ws +Exprs = + Exprs:: Decl */ ws + ws! + ((Expr +/ ws) +/ semicolons) -Expr = Id ^"::" ShipName /ws - | Expr ^";;" Expr /ws - | ^"{" Exprs "}" /ws - | (Int|Port) ^"-->" Ports /ws - | (Int|Port) ws! ^"-[" Int "]->" ws! Ports - | (Int|Port) ^"-[*]->" Ports /ws +Decl = Id ^"::" ShipName /ws + +Expr = "{" Exprs "}" /ws + | (Literal|Port) ^"-->" Ports /ws + | (Literal|Port) ws! ^"-[" Int "]->" ws! Ports + | (Literal|Port) ^"-[*]->" Ports /ws // | "if" "then" "else" // | "while" @@ -17,6 +20,7 @@ Ports = Port +/ comma Port = "Port":: Id | "Port":: Id "." Id +Literal = Int | ^"{" Int +/ comma "}" /ws Int = [\-0-9]++ ShipName = "":: [A-Z] [a-zA-Z0-9_]* Id = "":: [a-z] [a-zA-Z0-9_]* @@ -26,5 +30,6 @@ Comment = "//" (~eol)* eol! ws = (wsc | Comment)* -> ~wsc eol = [\r\n] wsc = [\r\n ] | \{ | \} -comma = ws! "," ws! +comma = ws! "," ws! +semicolons = ws! ";;" ws! any = ~[] -- 1.7.10.4