final pass to update instruction encoding; should now match the spec

[fleet.git] / contrib / f0 / Fleet.lhs

diff --git a/contrib/f0/Fleet.lhs b/contrib/f0/Fleet.lhs
new file mode 100644 (file)
index 0000000..2432f80
--- /dev/null
+++ b/contrib/f0/Fleet.lhs
@@ -0,0 +1,76 @@
+\begin{code}
+module Fleet where
+import SBP
+import Util
+
+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_pump=box }
+move   box = (itake box){ m_dataOut=True }
+copy   box = (move box){ m_dataIn=False }
+send   box = (move box){ m_dataIn=False, m_latch=False }
+notify box dest = IMove { m_count=1, m_recycle=False, m_tokenIn=False, m_dataIn=False,
+                          m_latch=False, m_dataOut=False, m_tokenOut=True, m_dest=(Just dest),
+                          m_pump=box }
+wait box = IMove { m_count=1, m_recycle=False, m_tokenIn=True, m_dataIn=False,
+                   m_latch=False, m_dataOut=False, m_tokenOut=False, m_dest=Nothing,
+                   m_pump=box }
+dismiss box = IMove { m_count=1, m_recycle=False, m_tokenIn=False, m_dataIn=True,
+                      m_latch=False, m_dataOut=False, m_tokenOut=False, m_dest=Nothing,
+                      m_pump=box }
+accept box = move box
+
+-- Port ------------------------------------------------------------------------------
+data Port = ShipPort String String
+          | IdPort   String
+ deriving (Eq, Ord)
+
+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)
+
+type PortBox = Port
+data Inst =
+    IKill        PortBox Int
+  | ILiteral     Int           PortBox
+  | ILiteralBag  String        PortBox
+  | IBagDef      String        [Inst]
+  | IMove   { m_pump :: PortBox ,
+              m_dest     :: Maybe PortBox ,
+              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 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 (ILiteralBag bagname bb) = bagname++": sendto "++(show bb)++";"
+ show (IBagDef bagname is) = bagname++": {\n  "++(join "" $ map (\i -> (show i)++"\n  ") is)++"}\n"
+ show m@(_)             = (show $ m_pump 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 ["dismiss"]) 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) -> ["notify "++(show j)]) else []
+\end{code}
\ No newline at end of file