contrib/f0/Compile.lhs

   1 \begin{code}
   2 module Compile where
   3 import SBP
   4 import Types
   5 import Util
   6 import Fleet
   7
   8 -- assumption:
   9 --   within a block that has data going both to and from a ship,
  10 --   the last datum leaving the ship must leave after all arriving
  11 --   datums have arrived
  12
  13 getBoxes :: Bool -> Expr -> [Port]
  14 getBoxes True  (Move 1 s d)    = [s]
  15 getBoxes True  (Copy 1 s d)    = [s]
  16 getBoxes inb   (Decl d e)      = getBoxes inb e
  17 getBoxes inb   (Par es)        = concatMap (getBoxes inb) es
  18 getBoxes True  (Seq es)        = getBoxes True  $ last es
  19 getBoxes False (Seq es)        = getBoxes False $ head es
  20 getBoxes True  (While p o i e) = [cbdPort] -- FIXME
  21 getBoxes False (While p o i e) = [] -- FIXME
  22 getBoxes _ _                   = []
  23
  24 cbdPort = ShipPort "mem" "inCBD"
  25
  26
  27 compile :: Expr -> [Inst]
  28 compile (Literal 0 lit d)  = [ ILiteral lit d, (accept d) {m_count=0} ]
  29 compile (Literal 1 lit d)  = [ ILiteral lit d, (accept d)             ]
  30 compile (Literal n lit d)  = [ ILiteral lit d, (accept d) {m_count=n} ]
  31 compile (Decl d e)         = compile e
  32 compile (Par e)            = concatMap compile e
  33 compile (Move 1 s d)       = [ (move s) { m_dest=(Just d) }, (accept d) ]
  34 compile (Copy 1 s d)       = [ (copy s) { m_dest=(Just d) }, (accept d) ]
  35 compile (While p op i e)   = think ++ [IBagDef "WHILECODEBAG" $ think ++ (compile e) ]
  36  where
  37   think        = [
  38                    ILiteralBag "WHILECODEBAG" (ShipPort "choice" "in2"),
  39                    (move p) { m_dataIn=False, m_dest=(Just (ShipPort "ifalu" "in1")) },
  40                    (move (ShipPort "ifalu" "out")) { m_dest = (Just (ShipPort "choice" ("in."++(swapPort op)))) },
  41                    ILiteral    i       (ShipPort "ifalu"  "in2"),
  42                    ILiteral    1       (ShipPort "ifalu"  "inOp"),
  43                    ILiteral    0       (ShipPort "choice" "in1"),  -- FIXME
  44                    accept (ShipPort "ifalu" "in1"),
  45                    accept (ShipPort "ifalu" "in2"),
  46                    accept (ShipPort "ifalu" "inOp"),
  47                    accept (ShipPort "choice" "in1"),
  48                    accept (ShipPort "choice" "in2"),
  49                    accept (ShipPort "choice" "in"),
  50                    (move (ShipPort "choice" "out1")) { m_dest = Just cbdPort },
  51                    (dismiss (ShipPort "choice" "out2")),
  52                    (accept cbdPort)
  53                  ]
  54   swapPort Lt  = "swapIfNegative"
  55   swapPort Gt  = "swapIfPositive"
  56   swapPort Leq = "swapIfNonPositive"
  57   swapPort Geq = "swapIfNonNegative"
  58   swapPort Eq  = "swapIfZero"
  59   swapPort Neq = "swapIfNonZero"
  60 compile (Seq [a])          = compile a
  61 compile (Seq (a:b:rest))   = (compile a)++(bridge (getBoxes True a) (uniq (getBoxes False b)))++(compile $ Seq (b:rest))
  62  where
  63   bridge :: [Port] -> [Port] -> [Inst]
  64   bridge [] _         = []
  65   bridge _  []        = []
  66   bridge obs (ib:ibs) = notifyFromOutboxes ++ waitForOutboxNotifications ++ notifyInboxes ++ waitForInboxNotifications
  67    where
  68     notifyFromOutboxes         = map (\ob -> notify ob ib) obs
  69     waitForOutboxNotifications = [ (wait ib) { m_count=(length obs) } ]
  70     notifyInboxes              = map (notify ib) ibs
  71     waitForInboxNotifications  = map wait ibs
  72
  73 getdecls (Decl d e) = ["#ship mem : Memory", "#ship choice : Choice", "#ship ifalu : Alu2" ] ++
  74                       map (\(n,t) -> ("#ship " ++ n ++ " : " ++ t)) d
  75 getdecls (Seq es)   = concatMap getdecls es
  76 getdecls (Par es)   = concatMap getdecls es
  77 getdecls _          = []
  78
  79 compileDef (Def s _ _ e) =
  80     "// " ++ s ++ "\n" ++
  81     (join "\n" $ getdecls e)++"\n"++
  82     (join "\n" $ map show (compile e))
  83 \end{code}