src/edu/berkeley/fleet/f0/Main.lhs

   1 \begin{code}
   2
   3 {-
   4  next step:
   5
   6   - Transform code involving standing moves into two sequential
   7     blocks: setup and teardown.  Then establish proper sequencing
   8     between them.  The teardown block consists only of kills.
   9
  10   - Implement sequencing.
  11 -}
  12
  13 module Main
  14 where
  15 import SBP
  16 main = do t <- parseFile "src/edu/berkeley/fleet/f0/f0.g" "contrib/demo.f0"
  17           putStrLn ""
  18           putStrLn $ show $ coalesceFlatHeadlessNodes t
  19           putStrLn ""
  20           putStrLn $ join "\n\n" $ map show $ ((fromTree $ coalesceFlatHeadlessNodes t) :: [Def])
  21           putStrLn ""
  22           compiled <- return $ join "\n\n" $ map compileDef $ ((fromTree $ coalesceFlatHeadlessNodes t) :: [Def])
  23           putStrLn $ compiled
  24           writeFile "compiled.fleet" ("// compiled with f0\n\n"++compiled++"\n")
  25           putStrLn ""
  26
  27 class FromTree a where
  28  fromTree  :: Tree   -> a
  29 class FromTrees a where
  30  fromTrees :: [Tree] -> a
  31 instance FromTree a => FromTree [a] where
  32  fromTree (Tree _ c _) = map fromTree c
  33
  34 indent []       = []
  35 indent ('\n':q) = "\n  "++(indent q)
  36 indent (a:b)    = a:(indent b)
  37
  38 join c []    = ""
  39 join c [x]   = x
  40 join c (x:y) = x++c++(join c y)
  41
  42 data Def = Def String [String] [String] Expr
  43   deriving Eq
  44 instance Show Def where
  45  show (Def name inp outp exprs) =
  46      name ++ "(" ++ (commify inp) ++ " -> " ++ (commify outp) ++ ") =\n   " ++ (indent (show exprs))
  47   where
  48    commify x = join "," x
  49
  50 instance FromTree Def where
  51   fromTree (Tree "Def" [name,inp,outp,es] _) =
  52      Def (fromTree name) (fromTree inp) (fromTree outp) (Par (fromTree es))
  53   fromTree (Tree "Def" q _) = error $ show q
  54
  55 data Port = ShipPort String String
  56           | IdPort   String
  57  deriving Eq
  58 instance Show Port where
  59  show (ShipPort a b) = a++"."++b
  60  show (IdPort a)     = a
  61 instance FromTree Port where
  62  fromTree (Tree "Port" [s] _)   = IdPort (fromTree s)
  63  fromTree (Tree "Port" [a,b] _) = ShipPort (fromTree a) (fromTree b)
  64  fromTree t = error (show t)
  65
  66 data Expr = Decl     String  String
  67           | Seq      [Expr]
  68           | Par      [Expr]
  69           | Move     Int Port    [Port]
  70           | Literal  Int Int     [Port]
  71   deriving Eq
  72
  73 instance Show Expr where
  74  show (Decl shipName shipType) = shipName ++ " :: " ++ shipType
  75  show (Seq  exprs)             = join " ;; " $ map (\x -> "{ "++x++" }") $ map show exprs
  76  show (Par  [expr])            = show expr
  77  show (Par  exprs)             = "{ " ++ (join "\n   " $ map show exprs) ++ " }"
  78  show (Move 0 source dests)      = (show source) ++ " -[*]-> " ++ (join "," $ map show dests)
  79  show (Move 1 source dests)      = (show source) ++ " --> " ++ (join "," $ map show dests)
  80  show (Move count source dests)      = (show source) ++ " -["++(show count)++"]-> " ++ (join "," $ map show dests)
  81  show (Literal 0 i dest)   = (show i) ++ " -[*]-> " ++ (show dest)
  82  show (Literal 1 i dest)   = (show i) ++ " --> " ++ (show dest)
  83  show (Literal count i dest)   = (show i) ++ " -["++(show count)++"]-> " ++ (show dest)
  84
  85 instance FromTree Expr where
  86   fromTree (Tree "::"     [shipName,shipType] _)                = Decl    (fromTree shipName) (fromTree shipType)
  87   fromTree (Tree "-->"    [(Tree i [] _),dest] _)               = Literal 1        (read i)          (fromTree dest)
  88   fromTree (Tree "-->"    [source,dest] _)                      = Move    1        (fromTree source) (fromTree dest)
  89   fromTree (Tree "-["     [(Tree i [] _),(Tree c [] _),dest] _) = Literal (read c) (read i)            (fromTree dest)
  90   fromTree (Tree "-["     [source,(Tree c [] _),dest] _)        = Move    (read c) (fromTree source)   (fromTree dest)
  91   fromTree (Tree "-[*]->" [(Tree i [] _),dest] _)               = Literal 0        (read i)            (fromTree dest)
  92   fromTree (Tree "-[*]->" [source,dest] _)                      = Move    0        (fromTree source)   (fromTree dest)
  93   fromTree t@(Tree "{"    [(Tree _ e _)] _)                     = Par     (map fromTree e)
  94   fromTree t@(Tree ";;"   [a,b] _)                              = Seq    [(fromTree a), (fromTree b)]
  95   fromTree other = error  (show other)
  96
  97 instance FromTree  String where
  98   fromTree  (Tree h c _) = h++(concatMap fromTree c)
  99 instance FromTrees String where
 100   fromTrees ts           = concatMap (fromTree :: Tree -> String) ts
 101
 102
 103 compile :: Expr -> [Inst]
 104 compile (Decl _ _)      = []
 105 compile (Seq s)         = error "bleh"
 106 compile (Par e)         = concatMap compile e
 107 compile (Move 1 s [d])    = [ move { m_benkobox=s, m_dest=(Just d) },
 108                               accept { m_benkobox=d } ]
 109 compile (Move 1 s d)      = [itake { m_benkobox=s }]++sends++recvs
 110  where
 111    sends = map (\x -> (send   { m_benkobox=s, m_dest=(Just x) })) d
 112    recvs = map (\x -> (accept { m_benkobox=x })) d
 113 compile (Literal 0 lit ds) =  concatMap (\d -> [ ILiteral lit d,
 114                                                  accept { m_benkobox=d, m_count=0 } ]) ds
 115 compile (Literal 1 lit ds) =  concatMap (\d -> [ ILiteral lit d,
 116                                                  accept { m_benkobox=d } ]) ds
 117 compile (Literal n lit ds) =  concatMap (\d -> [ ILiteral lit d,
 118                                                  accept { m_benkobox=d, m_count=n } ]) ds
 119
 120 getdecls (Decl n t) = ["#ship " ++ n ++ " : " ++ t]
 121 getdecls (Seq es)   = concatMap getdecls es
 122 getdecls (Par es)   = concatMap getdecls es
 123 getdecls _          = []
 124
 125 compileDef (Def s _ _ e) =
 126     "// " ++ s ++ "\n" ++
 127     (join "\n" $ getdecls e)++"\n"++
 128     (join "\n" $ map show (compile e))
 129
 130 itake  = IMove { m_count=1, m_recycle=False, m_tokenIn=False, m_dataIn=True,
 131                  m_latch=True, m_dataOut=False, m_tokenOut=False, m_dest=Nothing }
 132 move   = itake { m_dataOut=True }
 133 send   = move { m_dataIn=False, m_latch=False }
 134 accept = move
 135
 136 type BenkoBox = Port
 137 data Inst =
 138     IKill     BenkoBox Int
 139   | ILiteral  Int                 BenkoBox
 140   | IMove   { m_benkobox   :: BenkoBox ,
 141               m_dest     :: Maybe BenkoBox ,
 142               m_count    :: Int ,
 143               m_recycle  :: Bool ,
 144               m_tokenIn  :: Bool ,
 145               m_dataIn   :: Bool ,
 146               m_latch    :: Bool ,
 147               m_dataOut  :: Bool ,
 148               m_tokenOut :: Bool }
 149
 150 showCount 0 True  = "[*r] "
 151 showCount 0 False = "[*] "
 152 showCount 1 _     = ""
 153 showCount 1 r     = ""
 154 showCount n True  = "["++(show n)++"r] "
 155 showCount n False = "["++(show n)++"] "
 156
 157 instance Show Inst where
 158  show (IKill bb count)  = (show bb)++": "++(showCount count False)++" kill;"
 159  show (ILiteral lit bb) = (show lit)++": sendto "++(show bb)++";"
 160  show m@(_)             = (show $ m_benkobox m) ++
 161                          ": "++
 162                          (showCount (m_count m) $ m_recycle m) ++
 163                          (join ", " $ showrest m)++
 164                          ";"
 165                            where
 166                              showrest m = wait++takelatch++out++ack
 167                               where
 168                                wait = if m_tokenIn m then ["wait"] else []
 169                                takelatch = if m_dataIn m then (if m_latch m then ["take"] else ["drop"]) else []
 170                                out = if m_dataOut m then (case m_dest m of { Nothing -> ["deliver"]; (Just j) -> ["sendto "++(show j)] }) else []
 171                                ack = if m_tokenOut m then (case m_dest m of (Just j) -> ["ack "++(show j)]) else []
 172
 173
 174 \end{code}
 175
 176
 177
 178