From: adam Date: Mon, 26 Feb 2007 16:23:34 +0000 (+0100) Subject: initial import of f0 code X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=083a4fbc4cd98a5a4e7edc94356a416efaa86304;p=fleet.git initial import of f0 code --- diff --git a/Makefile b/Makefile index 0b6239b..8d18f5d 100644 --- a/Makefile +++ b/Makefile @@ -143,4 +143,15 @@ dist: @echo +# you'll probably want to change this line +ghc = /usr/local/brian/ghc/compiler/ghc-inplace + +ghc += -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -cpp +ghc += -i$(shell pwd)/build/hi/ -hidir $(shell pwd)/build/hi/ -odir $(shell pwd)/build/class/ + +f0: fleet.jar + mkdir -p build/hi build/class + cd lib; $(ghc) -c -java SBP.lhs + cd src/edu/berkeley/fleet/f0/; $(ghc) -fglasgow-exts -cpp $(hflags) -java Main.lhs + $(java) -cp build/class:lib/HSbase.jar:lib/HSrts.jar:lib/HSstm.jar:fleet.jar Main diff --git a/lib/HSbase.jar b/lib/HSbase.jar new file mode 100644 index 0000000..9bf683e Binary files /dev/null and b/lib/HSbase.jar differ diff --git a/lib/HSrts.jar b/lib/HSrts.jar new file mode 100644 index 0000000..29cd392 Binary files /dev/null and b/lib/HSrts.jar differ diff --git a/lib/HSstm.jar b/lib/HSstm.jar new file mode 100644 index 0000000..6c86870 Binary files /dev/null and b/lib/HSstm.jar differ diff --git a/lib/SBP.lhs b/lib/SBP.lhs new file mode 100644 index 0000000..bab70a6 --- /dev/null +++ b/lib/SBP.lhs @@ -0,0 +1,149 @@ +\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} diff --git a/src/edu/berkeley/fleet/f0/Main.lhs b/src/edu/berkeley/fleet/f0/Main.lhs new file mode 100644 index 0000000..7b50707 --- /dev/null +++ b/src/edu/berkeley/fleet/f0/Main.lhs @@ -0,0 +1,178 @@ +\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} + + + + diff --git a/src/edu/berkeley/fleet/f0/f0.g b/src/edu/berkeley/fleet/f0/f0.g new file mode 100644 index 0000000..b0e3963 --- /dev/null +++ b/src/edu/berkeley/fleet/f0/f0.g @@ -0,0 +1,30 @@ +s = ws! (Def+/ws) ws! + +Def = Id "(" (Id+/comma) "->" (Id+/comma) ")" "=" Exprs /ws + +Exprs = Expr +/ ws + +Expr = Id ^"::" ShipName /ws + | Expr ^";;" Expr /ws + | ^"{" Exprs "}" /ws + | (Int|Port) ^"-->" Ports /ws + | (Int|Port) ws! ^"-[" Int "]->" ws! Ports + | (Int|Port) ^"-[*]->" Ports /ws +// | "if" "then" "else" +// | "while" + +Ports = Port +/ comma +Port = "Port":: Id + | "Port":: Id "." Id + +Int = [\-0-9]++ +ShipName = "":: [A-Z] [a-zA-Z0-9_]* +Id = "":: [a-z] [a-zA-Z0-9_]* + +Comment = "//" ~eol* eol! + | "/*" (any* &~ any*! "*/" any*!) "*/" +ws = (wsc | Comment)* -> ~wsc +eol = [\r\n] +wsc = [\r\n ] | \{ | \} +comma = ws! "," ws! +any = ~[]