-- the last datum leaving the ship must leave after all arriving
-- datums have arrived
-getInboxes :: Expr -> [Port]
-getInboxes (Move 1 s d) = [d]
-getInboxes (Decl d e) = getInboxes e
-getInboxes (Par e) = concatMap getInboxes e
-getInboxes (Seq [a,b]) = getInboxes a
-getInboxes _ = []
+getBoxes :: Bool -> Expr -> [Port]
+getBoxes True (Move 1 s d) = [s]
+getBoxes True (Copy 1 s d) = [s]
+getBoxes inb (Decl d e) = getBoxes inb e
+getBoxes inb (Par es) = concatMap (getBoxes inb) es
+getBoxes True (Seq es) = getBoxes True $ last es
+getBoxes False (Seq es) = getBoxes False $ head es
+getBoxes True (While p o i e) = [cbdPort] -- FIXME
+getBoxes False (While p o i e) = [] -- FIXME
+getBoxes _ _ = []
-getOutboxes :: Expr -> [Port]
-getOutboxes (Move 1 s d) = [s]
-getOutboxes (Decl d e) = getOutboxes e
-getOutboxes (Par e) = concatMap getOutboxes e
-getOutboxes (Seq [a,b]) = getOutboxes b
-getOutboxes _ = []
+cbdPort = ShipPort "mem" "inCBD"
+
compile :: Expr -> [Inst]
-compile (Literal 0 lit d) = [ ILiteral lit d, (accept d) {m_count=0} ]
-compile (Literal 1 lit d) = [ ILiteral lit d, (accept d) ]
-compile (Literal n lit d) = [ ILiteral lit d, (accept d) {m_count=n} ]
-compile (Decl d e) = compile e
-compile (Seq [a,b]) = (compile a)++(bridge (getInboxes a) (uniq (getOutboxes b)))++(compile b)
-compile (Par e) = concatMap compile e
-compile (Move 1 s d) = [ (move s) { m_dest=(Just d) }, (accept d) ]
-
-bridge :: [Port] -> [Port] -> [Inst]
-bridge [] _ = []
-bridge _ [] = []
-bridge obs (ib:ibs) = notifyFromOutboxes ++ waitForOutboxNotifications ++ notifyInboxes ++ waitForInboxNotifications
+compile (Literal 0 lit d) = [ ILiteral lit d, (accept d) {m_count=0} ]
+compile (Literal 1 lit d) = [ ILiteral lit d, (accept d) ]
+compile (Literal n lit d) = [ ILiteral lit d, (accept d) {m_count=n} ]
+compile (Decl d e) = compile e
+compile (Par e) = concatMap compile e
+compile (Move 1 s d) = [ (move s) { m_dest=(Just d) }, (accept d) ]
+compile (Copy 1 s d) = [ (copy s) { m_dest=(Just d) }, (accept d) ]
+compile (While p op i e) = think ++ [IBagDef "WHILECODEBAG" $ think ++ (compile e) ]
+ where
+ think = [
+ ILiteralBag "WHILECODEBAG" (ShipPort "choice" "in2"),
+ (move p) { m_dataIn=False, m_dest=(Just (ShipPort "ifalu" "in1")) },
+ (move (ShipPort "ifalu" "out")) { m_dest = (Just (ShipPort "choice" ("in."++(swapPort op)))) },
+ ILiteral i (ShipPort "ifalu" "in2"),
+ ILiteral 1 (ShipPort "ifalu" "inOp"),
+ ILiteral 0 (ShipPort "choice" "in1"), -- FIXME
+ accept (ShipPort "ifalu" "in1"),
+ accept (ShipPort "ifalu" "in2"),
+ accept (ShipPort "ifalu" "inOp"),
+ accept (ShipPort "choice" "in1"),
+ accept (ShipPort "choice" "in2"),
+ accept (ShipPort "choice" "in"),
+ (move (ShipPort "choice" "out1")) { m_dest = Just cbdPort },
+ (dismiss (ShipPort "choice" "out2")),
+ (accept cbdPort)
+ ]
+ swapPort Lt = "swapIfNegative"
+ swapPort Gt = "swapIfPositive"
+ swapPort Leq = "swapIfNonPositive"
+ swapPort Geq = "swapIfNonNegative"
+ swapPort Eq = "swapIfZero"
+ swapPort Neq = "swapIfNonZero"
+compile (Seq [a]) = compile a
+compile (Seq (a:b:rest)) = (compile a)++(bridge (getBoxes True a) (uniq (getBoxes False b)))++(compile $ Seq (b:rest))
where
- notifyFromOutboxes = map (\ob -> notify ob ib) obs
- waitForOutboxNotifications = [(wait ib){m_count=(length obs)}]
- notifyInboxes = map (notify ib) ibs
- waitForInboxNotifications = map wait ibs
+ bridge :: [Port] -> [Port] -> [Inst]
+ bridge [] _ = []
+ bridge _ [] = []
+ bridge obs (ib:ibs) = notifyFromOutboxes ++ waitForOutboxNotifications ++ notifyInboxes ++ waitForInboxNotifications
+ where
+ notifyFromOutboxes = map (\ob -> notify ob ib) obs
+ waitForOutboxNotifications = [ (wait ib) { m_count=(length obs) } ]
+ notifyInboxes = map (notify ib) ibs
+ waitForInboxNotifications = map wait ibs
-getdecls (Decl d e) = map (\(n,t) -> ("#ship " ++ n ++ " : " ++ t)) d
+getdecls (Decl d e) = ["#ship mem : Memory", "#ship choice : Choice", "#ship ifalu : Alu2" ] ++
+ map (\(n,t) -> ("#ship " ++ n ++ " : " ++ t)) d
getdecls (Seq es) = concatMap getdecls es
getdecls (Par es) = concatMap getdecls es
getdecls _ = []
\begin{code}
module Fleet where
+import SBP
import Util
-import Types
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_benkobox=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),
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_benkobox=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_benkobox=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 BenkoBox = Port
data Inst =
- IKill BenkoBox Int
- | ILiteral Int BenkoBox
+ IKill BenkoBox Int
+ | ILiteral Int BenkoBox
+ | ILiteralBag String BenkoBox
+ | IBagDef String [Inst]
| IMove { m_benkobox :: BenkoBox ,
m_dest :: Maybe BenkoBox ,
m_count :: Int ,
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_benkobox m) ++
": "++
(showCount (m_count m) $ m_recycle m) ++
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 []
+ 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
module Types where
import SBP
import Util
+import Fleet
-- Def ------------------------------------------------------------------------------
data Def = Def String [String] [String] Expr
fromTree (Tree "Def" q _) = error $ show q
--- 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)
-
-- Expr ------------------------------------------------------------------------------
+data Op = Lt | Gt | Leq | Geq | Eq | Neq
+ deriving (Show,Eq)
+instance FromTree Op where
+ fromTree (Tree s _ _) =
+ case s of
+ "==" -> Eq
+ "!=" -> Neq
+ ">=" -> Geq
+ "<=" -> Leq
+ ">" -> Gt
+ "<" -> Lt
+
data Expr = Seq [Expr]
| Par [Expr]
| Decl [(String,String)] Expr
- | Move Int Port Port
- | Literal Int Int Port
+ | Move Int Port Port
+ | Copy Int Port Port
+ | Literal Int Int Port
+ | While Port Op Int Expr
| Nop
deriving (Show,Eq)
{-
par [] = Nop
par [x] = x
par x = Par x
- fromTree (Tree "-->" es _) =
- case es of
- [(Tree i [] _),dest] -> rep (fromTree dest) $ \d -> Literal 1 (read i) d
- [(Tree "{" [Tree _ is _] _),dest] -> Par $ concatMap (\d -> map (\(Tree i _ _) -> Literal 1 (read i) d) is) (fromTree dest)
- [source,dest] -> rep (fromTree dest) $ \d -> Move 1 (fromTree source) d
+ fromTree (Tree arrow [source,dests] _) | (arrow=="-->" || arrow=="+->") =
+ case source of
+ (Tree "{" [Tree _ is _] _) -> Par $ concatMap (\d -> map (\(Tree i _ _) -> Literal 1 (read i) d) is) dest
+ (Tree i [] _) -> rep' dest $ \d -> Literal 1 (read i) d
+ source -> case dests of
+ (Tree ";" [Tree _ d _] _) -> rep' dest $ \d -> mc 1 (fromTree source) d
+ (Tree "," [Tree _ (d:ds) _] _) ->
+ Par $
+ ((mc 1 (fromTree source) (fromTree d)):
+ (map (\d' -> Copy 1 (fromTree source) d') (map fromTree ds)))
+ where
+ mc = if arrow=="-->" then Move else Copy
+ dest = case dests of
+ (Tree ";" [Tree _ d _] _) -> map fromTree d
+ rep' [] _ = error "nop"
+ rep' [x] f = f x
+ rep' list f = Par $ map f list
+
-- 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 (Tree "while" [(Tree "Cond" [port, op, (Tree i _ _)] _), e] _) =
+ While (fromTree port) (fromTree op) (read i) (fromTree e)
fromTree other = error $ (show other)
-rep :: [Port] -> (Port -> Expr) -> Expr
-rep [] _ = error "nop"
-rep [x] f = f x
-rep list f = Par $ map f list
\end{code}
\ No newline at end of file
Expr = "{" Exprs "}" /ws
| (Literal|Port) ^"-->" Ports /ws
+ | (Literal|Port) ^"+->" Ports /ws
| (Literal|Port) ws! ^"-[" Int "]->" ws! Ports
| (Literal|Port) ^"-[*]->" Ports /ws
+ | ^"while" Cond Expr /ws
// | "if" "then" "else"
-// | "while"
-Ports = Port +/ comma
+CondOp = ^"==" | ^"!=" | ^">" | ^">=" | ^"<" | ^"<="
+Cond = Cond:: Port CondOp Int /ws
+
+Ports = ";":: Port +/ semicolon
+ > ",":: Port +/ comma
Port = "Port":: Id
| "Port":: Id "." Id
ShipName = "":: [A-Z] [a-zA-Z0-9_]*
Id = "":: [a-z] [a-zA-Z0-9_]*
-Comment = "//" (~eol)* eol!
+Comment = "//" (~eol)* eol!
| "/*" (any* &~ (any*! "*/" any*!)) "*/"
-ws = (wsc | Comment)* -> ~wsc
-eol = [\r\n]
-wsc = [\r\n ] | \{ | \}
+ws = (wsc | Comment)* -> ~wsc
+eol = [\r\n]
+wsc = [\r\n ] | \{ | \}
comma = ws! "," ws!
+semicolon = ws! ";" ws!
semicolons = ws! ";;" ws!
-any = ~[]
+any = ~[]
projects / fleet.git / commitdiff