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

   1 \begin{code}
   2 module Types where
   3 import SBP
   4 import Util
   5
   6 class FromTree a where
   7  fromTree  :: Tree   -> a
   8 class FromTrees a where
   9  fromTrees :: [Tree] -> a
  10 instance FromTree a => FromTree [a] where
  11  fromTree (Tree _ c _) = map fromTree c
  12
  13 data Def = Def String [String] [String] Expr
  14   deriving Eq
  15 instance Show Def where
  16  show (Def name inp outp exprs) =
  17      name ++ "(" ++ (commify inp) ++ " -> " ++ (commify outp) ++ ") =\n   " ++ (indent (show exprs))
  18   where
  19    commify x = join "," x
  20
  21 instance FromTree Def where
  22   fromTree (Tree "Def" [name,inp,outp,es] _) =
  23      Def (fromTree name) (fromTree inp) (fromTree outp) (Par (fromTree es))
  24   fromTree (Tree "Def" q _) = error $ show q
  25
  26 data Port = ShipPort String String
  27           | IdPort   String
  28  deriving Eq
  29 instance Show Port where
  30  show (ShipPort a b) = a++"."++b
  31  show (IdPort a)     = a
  32 instance FromTree Port where
  33  fromTree (Tree "Port" [s] _)   = IdPort (fromTree s)
  34  fromTree (Tree "Port" [a,b] _) = ShipPort (fromTree a) (fromTree b)
  35  fromTree t = error (show t)
  36
  37 data Expr = Decl     String  String
  38           | Seq      [Expr]
  39           | Par      [Expr]
  40           | Move     Int Port    [Port]
  41           | Literal  Int Int     [Port]
  42   deriving Eq
  43
  44 instance Show Expr where
  45  show (Decl shipName shipType) = shipName ++ " :: " ++ shipType
  46  show (Seq  exprs)             = join " ;; " $ map (\x -> "{ "++x++" }") $ map show exprs
  47  show (Par  [expr])            = show expr
  48  show (Par  exprs)             = "{ " ++ (join "\n   " $ map show exprs) ++ " }"
  49  show (Move 0 source dests)      = (show source) ++ " -[*]-> " ++ (join "," $ map show dests)
  50  show (Move 1 source dests)      = (show source) ++ " --> " ++ (join "," $ map show dests)
  51  show (Move count source dests)      = (show source) ++ " -["++(show count)++"]-> " ++ (join "," $ map show dests)
  52  show (Literal 0 i dest)   = (show i) ++ " -[*]-> " ++ (show dest)
  53  show (Literal 1 i dest)   = (show i) ++ " --> " ++ (show dest)
  54  show (Literal count i dest)   = (show i) ++ " -["++(show count)++"]-> " ++ (show dest)
  55
  56 instance FromTree Expr where
  57   fromTree (Tree "::"     [shipName,shipType] _)                = Decl    (fromTree shipName) (fromTree shipType)
  58   fromTree (Tree "-->"    [(Tree i [] _),dest] _)               = Literal 1        (read i)          (fromTree dest)
  59   fromTree (Tree "-->"    [source,dest] _)                      = Move    1        (fromTree source) (fromTree dest)
  60   fromTree (Tree "-["     [(Tree i [] _),(Tree c [] _),dest] _) = Literal (read c) (read i)            (fromTree dest)
  61   fromTree (Tree "-["     [source,(Tree c [] _),dest] _)        = Move    (read c) (fromTree source)   (fromTree dest)
  62   fromTree (Tree "-[*]->" [(Tree i [] _),dest] _)               = Literal 0        (read i)            (fromTree dest)
  63   fromTree (Tree "-[*]->" [source,dest] _)                      = Move    0        (fromTree source)   (fromTree dest)
  64   fromTree t@(Tree "{"    [(Tree _ e _)] _)                     = Par     (map fromTree e)
  65   fromTree t@(Tree ";;"   [a,b] _)                              = Seq    [(fromTree a), (fromTree b)]
  66   fromTree other = error  (show other)
  67
  68 instance FromTree  String where
  69   fromTree  (Tree h c _) = h++(concatMap fromTree c)
  70 instance FromTrees String where
  71   fromTrees ts           = concatMap (fromTree :: Tree -> String) ts
  72
  73 type BenkoBox = Port
  74 data Inst =
  75     IKill     BenkoBox Int
  76   | ILiteral  Int                 BenkoBox
  77   | IMove   { m_benkobox   :: BenkoBox ,
  78               m_dest     :: Maybe BenkoBox ,
  79               m_count    :: Int ,
  80               m_recycle  :: Bool ,
  81               m_tokenIn  :: Bool ,
  82               m_dataIn   :: Bool ,
  83               m_latch    :: Bool ,
  84               m_dataOut  :: Bool ,
  85               m_tokenOut :: Bool }
  86
  87 showCount 0 True  = "[*r] "
  88 showCount 0 False = "[*] "
  89 showCount 1 _     = ""
  90 showCount n True  = "["++(show n)++"r] "
  91 showCount n False = "["++(show n)++"] "
  92
  93 instance Show Inst where
  94  show (IKill bb count)  = (show bb)++": "++(showCount count False)++" kill;"
  95  show (ILiteral lit bb) = (show lit)++": sendto "++(show bb)++";"
  96  show m@(_)             = (show $ m_benkobox m) ++
  97                          ": "++
  98                          (showCount (m_count m) $ m_recycle m) ++
  99                          (join ", " $ showrest m)++
 100                          ";"
 101                            where
 102                              showrest m = wait++takelatch++out++ack
 103                               where
 104                                wait = if m_tokenIn m then ["wait"] else []
 105                                takelatch = if m_dataIn m then (if m_latch m then ["take"] else ["drop"]) else []
 106                                out = if m_dataOut m then (case m_dest m of { Nothing -> ["deliver"]; (Just j) -> ["sendto "++(show j)] }) else []
 107                                ack = if m_tokenOut m then (case m_dest m of (Just j) -> ["ack "++(show j)]) else []
 108
 109 \end{code}