module Main
where
import SBP
+import Types
+import Util
+
main = do t <- parseFile "src/edu/berkeley/fleet/f0/f0.g" "contrib/demo.f0"
putStrLn ""
putStrLn $ show $ coalesceFlatHeadlessNodes t
writeFile "compiled.fleet" ("// compiled with f0\n\n"++compiled++"\n")
putStrLn ""
-class FromTree a where
- fromTree :: Tree -> a
-class FromTrees a where
- fromTrees :: [Tree] -> a
-instance FromTree a => FromTree [a] where
- fromTree (Tree _ c _) = map fromTree c
-
-indent [] = []
-indent ('\n':q) = "\n "++(indent q)
-indent (a:b) = a:(indent b)
-
-join c [] = ""
-join c [x] = x
-join c (x:y) = x++c++(join c y)
-
-data Def = Def String [String] [String] Expr
- deriving Eq
-instance Show Def where
- show (Def name inp outp exprs) =
- name ++ "(" ++ (commify inp) ++ " -> " ++ (commify outp) ++ ") =\n " ++ (indent (show exprs))
- 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))
- fromTree (Tree "Def" q _) = error $ show q
-
-data Port = ShipPort String String
- | IdPort String
- deriving Eq
-instance Show Port where
- show (ShipPort a b) = a++"."++b
- show (IdPort a) = a
-instance FromTree Port where
- fromTree (Tree "Port" [s] _) = IdPort (fromTree s)
- fromTree (Tree "Port" [a,b] _) = ShipPort (fromTree a) (fromTree b)
- fromTree t = error (show t)
-
-data Expr = Decl String String
- | Seq [Expr]
- | Par [Expr]
- | Move Int Port [Port]
- | Literal Int Int [Port]
- deriving 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 (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 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)
-
-instance FromTree String where
- fromTree (Tree h c _) = h++(concatMap fromTree c)
-instance FromTrees String where
- fromTrees ts = concatMap (fromTree :: Tree -> String) ts
-
-
compile :: Expr -> [Inst]
compile (Decl _ _) = []
compile (Seq s) = error "bleh"
compile (Par e) = concatMap compile e
-compile (Move 1 s [d]) = [ move { m_benkobox=s, m_dest=(Just d) },
- accept { m_benkobox=d } ]
-compile (Move 1 s d) = [itake { m_benkobox=s }]++sends++recvs
+compile (Move 1 s [d]) = [ (move s) { m_dest=(Just d) }, (accept d) ]
+compile (Move 1 s d) = [itake s]++sends++recvs
where
- sends = map (\x -> (send { m_benkobox=s, m_dest=(Just x) })) d
- recvs = map (\x -> (accept { m_benkobox=x })) d
-compile (Literal 0 lit ds) = concatMap (\d -> [ ILiteral lit d,
- accept { m_benkobox=d, m_count=0 } ]) ds
-compile (Literal 1 lit ds) = concatMap (\d -> [ ILiteral lit d,
- accept { m_benkobox=d } ]) ds
-compile (Literal n lit ds) = concatMap (\d -> [ ILiteral lit d,
- accept { m_benkobox=d, m_count=n } ]) ds
+ 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
getdecls (Decl n t) = ["#ship " ++ n ++ " : " ++ t]
getdecls (Seq es) = concatMap getdecls es
(join "\n" $ getdecls e)++"\n"++
(join "\n" $ map show (compile e))
-itake = IMove { m_count=1, m_recycle=False, m_tokenIn=False, m_dataIn=True,
- m_latch=True, m_dataOut=False, m_tokenOut=False, m_dest=Nothing }
-move = itake { m_dataOut=True }
-send = move { m_dataIn=False, m_latch=False }
-accept = move
-
-type BenkoBox = Port
-data Inst =
- IKill BenkoBox Int
- | ILiteral Int BenkoBox
- | IMove { m_benkobox :: BenkoBox ,
- m_dest :: Maybe BenkoBox ,
- m_count :: Int ,
- m_recycle :: Bool ,
- m_tokenIn :: Bool ,
- m_dataIn :: Bool ,
- m_latch :: Bool ,
- m_dataOut :: Bool ,
- m_tokenOut :: Bool }
-
-showCount 0 True = "[*r] "
-showCount 0 False = "[*] "
-showCount 1 _ = ""
-showCount 1 r = ""
-showCount n True = "["++(show n)++"r] "
-showCount n False = "["++(show n)++"] "
-
-instance Show Inst where
- show (IKill bb count) = (show bb)++": "++(showCount count False)++" kill;"
- show (ILiteral lit bb) = (show lit)++": sendto "++(show bb)++";"
- show m@(_) = (show $ m_benkobox m) ++
- ": "++
- (showCount (m_count m) $ m_recycle m) ++
- (join ", " $ showrest m)++
- ";"
- where
- showrest m = wait++takelatch++out++ack
- where
- 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 []
+itake box = IMove { m_count=1, m_recycle=False, m_tokenIn=False, m_dataIn=True,
+ m_latch=True, m_dataOut=False, m_tokenOut=False, m_dest=Nothing,
+ m_benkobox=box }
+move box = (itake box){ m_dataOut=True }
+send box = (move box){ m_dataIn=False, m_latch=False }
+accept box = move box
+
\end{code}
projects / fleet.git / blobdiff