--- /dev/null
+\begin{code}
+--
+-- These bindings are highly experimental and subject to change
+-- without notice. You've been warned.
+--
+module SBP(Tree(Tree),Location(Location),Region(Region),parseFile,prettyPrintTree,coalesceFlatHeadlessNodes)
+where
+
+#if defined(java_HOST_OS)
+import Foreign
+import Foreign.Java
+import Text.PrettyPrint.HughesPJ
+#define CONCAT(x,y) x/**/y
+#define DEFINE_OBJECT(s,name) \
+data CONCAT(name,_); \
+type name = Object CONCAT(name,_); \
+foreign import jvm s CONCAT(_,name) :: JClass; \
+instance JType_ CONCAT(name,_) where jClass_ _ = CONCAT(_,name);
+#else
+import Header_Java;
+import Class_edu_berkeley_sbp_misc_HaskellHelper;
+import Class_java_lang_Object;
+import Class_java_lang_Class;
+import Class_java_lang_String;
+import Class_edu_berkeley_sbp_Tree;
+import Header_edu_berkeley_sbp_Tree;
+import JVM_edu_berkeley_sbp_misc_HaskellHelper;
+import Header_edu_berkeley_sbp_misc_HaskellHelper;
+import TypedString;
+import JVMBridge;
+import JavaText;
+import JavaTypes;
+import Data.Int;
+import Invocation;
+import Text.PrettyPrint.HughesPJ
+#endif
+
+data Location = Location Int Int
+data Region = Region Location Location
+
+data Tree = Tree String [Tree] Region
+instance Show Tree
+ where
+ show t@(Tree _ _ _) = show $ prettyPrintTree $ t
+
+coalesceFlatHeadlessNodes t@(Tree s children r)
+ | s==[], flat t = Tree (concat $ map (\(Tree s _ _) -> s) children) [] r
+ | otherwise = Tree s (map coalesceFlatHeadlessNodes children) r
+ where
+ flat (Tree _ children _) = not (any id $ map notFlatComponent children)
+ notFlatComponent (Tree _ [] _) = False
+ notFlatComponent (Tree _ _ _) = True
+
+prettyPrintTree (Tree "" [] _) = empty
+prettyPrintTree (Tree s [] _) = text s
+prettyPrintTree (Tree [] children _) = prettyPrintTreeList children
+prettyPrintTree (Tree s children _) = (text (s++":")) <+> (nest 4 $ prettyPrintTreeList children)
+prettyPrintTreeList [] = text "{}"
+prettyPrintTreeList children = (text "{") <+> ((fsep $ map prettyPrintTree children) <+> (text "}"))
+
+nullRegion = (Region (Location 0 0) (Location 0 0))
+
+
+
+------------------------------------------------------------------------------
+#if defined(java_HOST_OS)
+foreign import jvm type "edu.berkeley.sbp.Tree" JTree#
+data JTree = JTree JTree#
+foreign import jvm safe "edu.berkeley.sbp.misc.RegressionTests.main" regressionTests :: IO ()
+foreign import jvm safe "edu.berkeley.sbp.misc.HaskellHelper.help0" haskellHelper :: JString -> JString -> IO JTree
+foreign import jvm safe "edu.berkeley.sbp.misc.HaskellHelper.isNull" isNull :: (Object a) -> IO Bool
+foreign import jvm safe "getHead" getHead :: JTree -> IO (Object a)
+foreign import jvm safe "child" getChild :: JTree -> Int32 -> IO JTree
+foreign import jvm safe "size" size :: JTree -> IO Int32
+foreign import jvm safe "toString" jtoString :: (Object a) -> IO JString
+
+toString o = do isn <- isNull o
+ if isn then return ""
+ else do str <- jtoString o
+ return (unpackJString str)
+
+
+haskify :: JTree -> IO Tree
+haskify t =
+ do head <- getHead t
+ str <- toString head
+ numChildren <- size t
+ children <- if numChildren == 0
+ then do return []
+ else do children <- mapM (\i -> getChild t i)
+ $ take (fromIntegral numChildren)
+ $ iterate (+1) 0
+ h <- mapM haskify children
+ return h
+ return $ Tree str children nullRegion
+
+parseFile ::
+ String -> -- grammar *.g file
+ String -> -- file to be parsed
+ IO Tree
+
+parseFile g f = do g' <- packJString g
+ f' <- packJString f
+ tree <- haskellHelper g' f'
+ x <- haskify tree
+ return x
+
+------------------------------------------------------------------------------
+#else
+ -- Why do I need this?
+ instance SubJavaClassMarker
+ Header_edu_berkeley_sbp_Tree.Class_Jedu_berkeley_sbp_Tree
+ Header_edu_berkeley_sbp_misc_HaskellHelper.Class_Jedu_berkeley_sbp_Tree
+
+ parseFile ::
+ [String] -> -- class path
+ String -> -- grammar *.g file
+ String -> -- file to be parsed
+ IO Tree
+
+ parseFile classPath grammarFile inputFile =
+ runJVM classPath
+ ((do class_JHaskellHelper
+ s1 <- new_JString_ArrayJchar $ toJavaString grammarFile
+ s2 <- new_JString_ArrayJchar $ toJavaString inputFile
+ tree <- main_JHaskellHelper_JString_JString (s1, s2)
+ t <- haskifyTree tree
+ return t
+ ) :: JVM Tree)
+
+ haskifyTree t =
+ ((do class_JHaskellHelper
+ class_JTree
+ head <- getHead_JTree t ()
+ isNull <- getIsNothing head
+ str <- if isNull then (return "") else (toString_JObject ((castTLRef head) :: Jjava_lang_Object) () >>= getStringUTF >>= \x -> return (showUTF8 x))
+ numChildren <- size_JTree t()
+ children <- if numChildren == 0
+ then do return []
+ else do children <- mapM (\i -> child_JTree_Jint t ((fromIntegral i)::Int32))
+ $ take (fromIntegral numChildren)
+ $ iterate (+1) 0
+ h <- mapM (\c -> haskifyTree (castTLRef c)) children
+ return h
+ return $ Tree str children nullRegion
+ ) :: JVM Tree)
+
+#endif
+\end{code}
--- /dev/null
+\begin{code}
+
+{-
+ next step:
+
+ - Transform code involving standing moves into two sequential
+ blocks: setup and teardown. Then establish proper sequencing
+ between them. The teardown block consists only of kills.
+
+ - Implement sequencing.
+-}
+
+module Main
+where
+import SBP
+main = do t <- parseFile "src/edu/berkeley/fleet/f0/f0.g" "contrib/demo.f0"
+ putStrLn ""
+ putStrLn $ show $ coalesceFlatHeadlessNodes t
+ putStrLn ""
+ putStrLn $ join "\n\n" $ map show $ ((fromTree $ coalesceFlatHeadlessNodes t) :: [Def])
+ putStrLn ""
+ compiled <- return $ join "\n\n" $ map compileDef $ ((fromTree $ coalesceFlatHeadlessNodes t) :: [Def])
+ putStrLn $ compiled
+ 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
+ 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
+
+getdecls (Decl n t) = ["#ship " ++ n ++ " : " ++ t]
+getdecls (Seq es) = concatMap getdecls es
+getdecls (Par es) = concatMap getdecls es
+getdecls _ = []
+
+compileDef (Def s _ _ e) =
+ "// " ++ s ++ "\n" ++
+ (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 []
+
+
+\end{code}
+
+
+
+
projects / fleet.git / commitdiff