module Language.KansasLava.Optimization
( optimizeCircuit
, OptimizationOpts(..)
) where
import Language.KansasLava.Types
import Data.Reify
import Control.Applicative
import Control.Monad
import Prelude
import Data.List
import Data.Default
import Data.Maybe(fromMaybe)
optimizeEntity :: (Unique -> Entity Unique) -> Entity Unique -> Maybe (Entity Unique)
optimizeEntity env (Entity (Prim "fst") [(o0,_)] [(_,_,Port o0' u)]) =
case env u of
Entity (Prim "pair") [(o0'',_)] [(i1',t1,p1),(_,_,_)]
| o0' == o0'' -> return $ replaceWith o0 (i1',t1,p1)
_ -> Nothing
optimizeEntity env (Entity (Prim "snd") [(o0,_)] [(_,_,Port o0' u)]) =
case env u of
Entity (Prim "pair") [(o0'',_)] [(_,_,_),(i2',t2,p2)]
| o0' == o0'' -> return $ replaceWith o0 (i2',t2,p2)
_ -> Nothing
optimizeEntity env (Entity (Prim "pair") [(o0,tO)] [(_,_,Port o0' u0),(_,_,Port o1' u1)]) =
case (env u0,env u1) of
( Entity (Prim "fst") [(o0'',_)] [(_,_,p2)]
, Entity (Prim "snd") [(o1'',_)] [(_,_,p1)]
) | o0' == o0'' && o1' == o1'' && p1 == p2 ->
return $ replaceWith o0 ("o0",tO,p1)
_ -> Nothing
optimizeEntity _ (Entity (Prim "mux") [(o0,_)] [(_,_,_),(i1 ,tTy,t),(_,_,f)])
| t == f = return $ replaceWith o0 (i1,tTy,t)
| otherwise = Nothing
optimizeEntity _ (Entity (BlackBox _) [(o0,_)] [(i0, ti, di)]) =
return $ replaceWith o0 (i0,ti,di)
optimizeEntity _ _ = Nothing
replaceWith :: String -> (String, Type, Driver s) -> Entity s
replaceWith o (i,t,other) = Entity (Prim "id") [(o,t)] [(i,t,other)]
data Opt a = Opt a Int
instance Functor Opt where
fmap f (Opt x n) = Opt (f x) n
instance Applicative Opt where
pure x = Opt x 0
(Opt f n) <*> (Opt x m) = Opt (f x) (n + m)
instance Monad Opt where
return a = Opt a 0
(Opt a n) >>= k = case k a of
Opt r m -> Opt r (n + m)
copyElimCircuit :: KLEG -> Opt KLEG
copyElimCircuit rCir = Opt rCir' (length renamings)
where
env0 = theCircuit rCir
rCir' = rCir
{ theSinks =
[ ( v,t,
case d of
Port p u -> fromMaybe (Port p u) (lookup (u, p) renamings)
Pad v' -> Pad v'
Lit i -> Lit i
Error i -> error $ "Found Error : " ++ show (i,v,t,d)
c -> error $ "copyElimCircuit: " ++ show c
)
| (v,t,d) <- theSinks rCir
]
, theCircuit =
[ (u,case e of
Entity nm outs ins -> Entity nm outs (map fixInPort ins)
)
| (u,e) <- env0
]
}
renamings = [ ((u,o),other)
| (u,Entity (Prim "id") [(o,tO)] [(_,tI,other)]) <- env0
, tO == tI
]
fixInPort (i,t,Port p u) =
(i,t,fromMaybe (Port p u) (lookup (u, p) renamings))
fixInPort (i,t,o) = (i,t,o)
cseCircuit :: KLEG -> Opt KLEG
cseCircuit rCir = Opt (rCir { theCircuit = concat rCirX }) cseCount
where
cseCount = length (theCircuit rCir) - length rCirX
rCirX :: [[(Unique, Entity Unique)]]
rCirX = map canonicalize
$ groupBy (\ (_,b) (_,b') -> (b `mycompare` b') == EQ && not (isId b))
$ sortBy (\ (_,b) (_,b') -> b `mycompare` b')
$ theCircuit rCir
isId (Entity (Prim "id") _ _) = True
isId _ = False
mycompare (Entity nm _ ins)
(Entity nm' _ ins') =
chain
[ nm `compare` nm'
, ins `compare` ins'
]
chain (LT:_ ) = LT
chain (GT:_ ) = GT
chain (EQ:xs) = chain xs
chain [] = EQ
canonicalize [] = []
canonicalize ((u0,e0@(Entity _ outs _)):rest) =
(u0,e0) : [ ( uX,
Entity (Prim "id") outs'
[ (n,t, Port n u0) | (n,t) <- outs ]
)
| (uX,Entity _ outs' _) <- rest, length outs == length outs'
]
dceCircuit :: KLEG -> Opt KLEG
dceCircuit rCir = if optCount == 0
then return rCir
else Opt rCir' optCount
where
optCount = length (theCircuit rCir) - length optCir
outFrees (_,_,Port _ u) = [u]
outFrees _ = []
allNames :: [Unique]
allNames = nub (concat
[ case e of
Entity _ _ outs -> concatMap outFrees outs
| (_,e) <- theCircuit rCir
] ++ concatMap outFrees (theSinks rCir)
)
optCir = [ (uq,orig)
| (uq,orig) <- theCircuit rCir
, uq `elem` allNames
]
rCir' = rCir { theCircuit = optCir }
patternMatchCircuit :: KLEG -> Opt KLEG
patternMatchCircuit rCir = if optCount == 0
then return rCir
else Opt rCir' optCount
where
env0 = theCircuit rCir
env1 v = fromMaybe (error $ "oops, can not find " ++ show v) (lookup v env0)
attemptOpt = [ optimizeEntity env1 e | (_,e) <- theCircuit rCir ]
optCount = length [ () | (Just _) <- attemptOpt ]
optCir = [ (uq,fromMaybe orig mOpt)
| ((uq,orig),mOpt) <- zip (theCircuit rCir) attemptOpt
]
rCir' = rCir { theCircuit = optCir }
optimizeCircuits :: [(String,KLEG -> Opt KLEG)] -> KLEG -> [(String,Opt KLEG)]
optimizeCircuits [] _ = []
optimizeCircuits ((nm,fn):fns) c = (nm,opt) : optimizeCircuits fns c'
where opt@(Opt c' _) = case fn c of
Opt _ 0 -> Opt c 0
res@(Opt _ _) -> res
data OptimizationOpts = OptimizationOpts
{ optDebugLevel :: Int
}
instance Default OptimizationOpts
where
def = OptimizationOpts
{ optDebugLevel = 0
}
optimizeCircuit :: OptimizationOpts -> KLEG -> IO KLEG
optimizeCircuit options rCir = do
when debug $ print rCir
loop (optimizeCircuits (cycle opts) rCir)
where
debug = optDebugLevel options > 0
loop [] = error "optimizeCircuit: loop []"
loop cs@((nm,Opt code n):_) = do
when debug $ do
putStrLn $ "##[" ++ nm ++ "](" ++ show n ++ ")###################################"
when (n > 0) $ print code
case cs of
((_,Opt c _):_) | and [ num == 0 | (_,Opt _ num) <- take (length opts) cs ] -> return c
((_,Opt _ _):rest) -> loop rest
[] -> error "optimizeCircuit: no optimizations"
opts = [ ("opt",patternMatchCircuit)
, ("cse",cseCircuit)
, ("copy",copyElimCircuit)
, ("dce",dceCircuit)
]