> module Epic.Simplify(simplifyAll) where
> import Epic.Language
> import Data.Maybe
> import Debug.Trace
> simplifyAll :: (Context, [Decl]) -> (Context, [Decl])
> simplifyAll (ctxt, xs) = let sctxt = mapMaybe mkEntry xs in
> simpl sctxt ctxt xs
> where mkEntry d@(Decl n _ fn _ fl) = Just (n, (d, (length (fun_args fn)), fl))
> mkEntry _ = Nothing
For each supercombinator, evaluate it as far as we believe sensible - basically just inlining
definitions marked as such, constant folding, case on constants, etc.
Also consider creating specialised versions of functions?
> type SCtxt = [(Name, (Decl, Int, [CGFlag]))]
> simpl :: SCtxt -> Context -> [Decl] -> (Context, [Decl])
> simpl sctxt ctxt ds = (ctxt, map simplD ds)
> where simplD (Decl fn fr fd fe fl) = let simpled = simplFun fd in
> diff fn simpled fd $
> Decl fn fr (simplFun fd) fe fl
> simplD d = d
> simplFun (Bind args locs def fl)
> = Bind args locs (simplify sctxt (map (\x -> Nothing) args) (length args) def) fl
> diff fn simpled fd x | defn simpled == defn fd = x
> | otherwise = x
> inlinable = elem Inline
> simplify :: SCtxt -> [Maybe Expr] -> Int -> Expr -> Expr
> simplify sctxt args arity exp = s' args arity exp
> where
> s' args depth (V i) = if i<length args then
> case args!!i of
> Nothing -> V i
> Just v -> v
> else error "Can't happen - simplify - No such arg"
> s' args d (R fn)
> = case lookup fn sctxt of
> Just (decl, 0, fl) ->
> if (inlinable fl) then s' args d (inline d decl [])
> else R fn
> _ -> R fn
> s' args d (App f a) = apply d (s' args d f) (map (s' args d) a) args
> s' args d (Lazy e) = Lazy $ s' args d e
> s' args d (Effect e) = Effect $ s' args d e
> s' args d (While t e) = While (s' args d t) (s' args d e)
> s' args d (WhileAcc t a e) = WhileAcc (s' args d t) (s' args d a) (s' args d e)
> s' args d (Con t a) = Con t (map (s' args d) a)
> s' args d (Proj e i) = project (s' args d e) i
> s' args d (Case e alts) = runCase (s' args d e) (map (salt args d) alts)
> s' args d (If x t e) = runIf (s' args d x) (s' args d t) (s' args d e)
> s' args d (Op op l r) = runOp op (s' args d l) (s' args d r)
> s' args d (Let n ty v sc)
> = simplFLet $ runLet n ty (s' args d v)
> (s' (args++[Just (V d)]) (d+1) sc)
> s' args d (ForeignCall ty nm a)
> = ForeignCall ty nm (map (\ (x,y) -> (s' args d x, y)) a)
> s' args d (LazyForeignCall ty nm a)
> = LazyForeignCall ty nm (map (\ (x,y) -> (s' args d x, y)) a)
> s' args d x = x
> salt args d (Alt t bargs e)
> = Alt t bargs (s' newargs (d+length bargs) e)
> where newargs = args ++ (map (Just . V) (take (length bargs) [d..]))
> salt args d (ConstAlt c e) = ConstAlt c (s' args d e)
> salt args d (DefaultCase e) = DefaultCase (s' args d e)
> project e i = Proj e i
> runCase e alts = Case e alts
> runIf x t e = If x t e
> runOp op l r = Op op l r
> runLet n ty v sc = Let n ty v sc
> apply d f@(R fn) as args
> = case lookup fn sctxt of
> Just (decl, ar, fl) ->
> if (inlinable fl && ar == length as) then inline d decl (map Just as)
> else App f as
> _ -> App f as
> apply d f as args = App f as
> inline :: Int -> Decl -> [Maybe Expr] -> Expr
> inline d (Decl fn _ (Bind _ _ exp _) _ _) args
> = simplify (remove fn sctxt) args d exp
> where remove fn [] = []
> remove fn (f@(x,_):xs) | x == fn = xs
> | otherwise = f:(remove fn xs)
If we do this, we can chop out some pointless assignments to Unit
> simplFLet :: Expr -> Expr
> simplFLet (Let n _ (ForeignCall ty f args) s) =
> Let n ty (ForeignCall ty f args) s
> simplFLet (Let n _ (Effect (ForeignCall ty f args)) s) =
> Let n ty (Effect (ForeignCall ty f args)) s
> simplFLet x = x