module Language.ImProve.Narrow (narrow) where
import Data.List
import Data.Maybe
import Language.ImProve.Core
narrow :: Statement -> Statement
narrow stmt = assumes
where
assumes = foldl Sequence Null [ Label lab $ Assume assume | (lab, opt) <- optimizations, assume <- opt stmt ]
optimizations =
[ ("constantAssigns", constantAssigns)
, ("timerRanges", timerRanges)
]
constantAssigns :: Statement -> [E Bool]
constantAssigns stmt = mapMaybe f1 $ stmtVars stmt
where
f1 :: UV -> Maybe (E Bool)
f1 uv
| input = Nothing
| otherwise = do
assigns <- lastConstAssign uv stmt
case (init, nub $ init : assigns) of
(Bool _, [_, _]) -> Nothing
(_, a) -> return $ foldl1 Or $ map f2 a
where
f2 :: Const -> E Bool
f2 assign = case (init, assign) of
(Bool a, Bool b) -> Eq (Ref (V input path a)) (Const b)
(Int a, Int b) -> Eq (Ref (V input path a)) (Const b)
(Float a, Float b) -> Eq (Ref (V input path a)) (Const b)
_ -> undefined
(input, path, init) = varInfo uv
lastConstAssign :: UV -> Statement -> Maybe [Const]
lastConstAssign uv a = do
(_, a) <- lastConstAssign a
return $ nub a
where
lastConstAssign :: Statement -> Maybe (Bool, [Const])
lastConstAssign a = case a of
Assign v (Const a) | untype v == uv -> Just (True, [const' a])
Assign v _ | untype v == uv -> Nothing
Branch _ a b -> do
(aDone, a) <- lastConstAssign a
(bDone, b) <- lastConstAssign b
return (aDone && bDone, a ++ b)
Sequence a b -> do
(bDone, b) <- lastConstAssign b
if bDone
then return (True, b)
else do
(aDone, a) <- lastConstAssign a
return (aDone, a ++ b)
Label _ a -> lastConstAssign a
_ -> Just (False, [])
timerRanges :: Statement -> [E Bool]
timerRanges stmt = [] --XXX
where
intCode :: [(VarInfo, Statement)]
intCode = [ (varInfo a, assignedVar a stmt) | a@(UVInt _) <- stmtVars stmt ]
assignedVar :: UV -> Statement -> Statement
assignedVar v a = case a of
Assign v' _ | v == untype v' -> a
Branch cond a b -> case (assignedVar v a, assignedVar v b) of
(Null, Null) -> Null
(a, b) -> Branch cond a b
Sequence a b -> case (assignedVar v a, assignedVar v b) of
(Null, Null) -> Null
(a, b) -> Sequence a b
Label a b -> Label a $ assignedVar v b
_ -> Null