-- GRIN-like backend for Yhc Core. -- Eval inlining/elimination. module Yhc.Core.GRIN.OptEvals where import Yhc.Core.GRIN.Type import Yhc.Core.GRIN.FindType import Yhc.Core.GRIN.HeapPointsTo import Yhc.Core.GRIN.SubstVars import Yhc.Core.GRIN.OptApply import Yhc.Core.GRIN.OptCases import Yhc.Core.GRIN.FlatInline import Yhc.Core.GRIN.Sharing import Yhc.Core.GRIN.GGMonad import Yhc.Core.GRIN.ElimDead import Data.List import Data.Maybe import qualified Data.Set as S import qualified Data.Map as M -- Create a central eval function out of the heap map. Brute-force approach: -- consider all F- and K-tags for building central eval. buildEval :: HeapMap -> GGM GFunc buildEval hm = do arg <- newVar ftvar <- newGVar let fetch = GBind (GFetch arg "" (Just 0)) ftvar fkargs n = map (val2sval . gVar . ('a':) . show) [1 .. n] ftags = concat $ map ftag $ concat $ M.elems hm ftag (HasValue (GTagged t args)) = [HasValue (GTagged t (fkargs $ length args))] ftag t@(HasValue (GTag _)) = [t] ftag _ = [] tas = nub ftags pat (HasValue (GTag t@('K':'@':caf))) = do rtvarp <- newGVar return (GPatTag t, [GBind (GCall caf []) rtvarp, GSimple (GUnit rtvarp)]) pat (HasValue (GTagged t@('F':'@':fun) gvs)) = do let nargs = length gvs rtvarp <- newGVar argvs <- replicateM nargs newGVar let aftch = zipWith (\a b -> GBind (GFetch arg t (Just a)) b) [1 .. ] argvs fcall = [GBind (GCall fun argvs) rtvarp] fret = [GSimple (GUnit rtvarp)] return (GPatTag t, concat [aftch, fcall, fret]) pat (HasValue (GTag t)) = return (GPatTag t, [GSimple (GUnit $ gVar arg)]) pat (HasValue (GTagged t as)) = return (GPatTag t, [GSimple (GUnit $ gVar arg)]) pat (_) = return (GPatDefault, [GSimple (GUnit $ gVar arg)]) body <- case tas of [] -> return $ GSimple (GUnit GEmpty) _ -> mapM pat (sort tas) >>= return . GCase ftvar . sort . nub return $ GFunc {gFuncName = "GRIN;eval" ,gFuncArgs = [arg] ,gFuncBody = [fetch, body]} -- Given a heap map, find values (where possible, not running type analysis) of -- eval's arguments. Where these values are single K- tags, replace -- calls to eval with calls to functions themselves. Where these values -- are constants (tagged other than F-tags, or simple values), replace -- eval with return. Where these values are returned from other functions, -- replace evals with returns because functions return only WHNFs. elimWhnfEvalsLoc :: HeapMap -> GRIN -> (GRIN, Bool) elimWhnfEvalsLoc hm g = let evalv = concat $ map cvar $ M.keys $ M.filter (== [CallTo "GRIN;eval"]) hm applyv = concat $ map cvar $ M.keys $ M.filter (== [CallTo "GRIN;apply"]) hm cvar (HCall _ (EquivTo v:_)) = [v] cvar _ = [] applys = M.fromList $ filter trivial $ zip applyv $ map ((flip (M.findWithDefault []) hm) . HVar) applyv trivial (_, [HasValue (GTagged ('P':'@':_) _)]) = True trivial _ = False isapf1 v = case apcall v of [] -> False [(HCall _ [EquivTo v1, EquivTo v2], _)] -> case M.findWithDefault [] (HVar v1) hm of [] -> False [HasValue (GTagged ('P':'@':missfun) _)] -> let (miss, _:fun) = break (== ':') missfun mnarg = (read miss) :: Int in mnarg > 1 _ -> False _ -> False apcall v = M.toList $ M.filterWithKey (apc v) $ M.filter (== [CallTo "GRIN;apply"])hm apc v (HCall (_, rv) _) _ = v == rv apc _ _ _ = False evals = M.fromList $ filter oneval $ zip evalv $ map ((flip (M.findWithDefault []) hm) . HVar) evalv oneval (v, [ReturnOf "GRIN;apply"]) = isapf1 v oneval (_, [HasValue _]) = True oneval (_, [ReturnOf _]) = True oneval (_, [EquivTo _]) = True oneval _ = False mfun ex@(GBind (GCall "GRIN;eval" [GVal (GVar ev)]) bv) = case M.lookup ev evals of Nothing -> ex Just [HasValue (GTag ('K':'@':caf))] -> GBind (GCall caf []) bv Just [HasValue (GTagged t@('F':'@':fun) vs)] -> let nums = [1 .. length vs] ftvar n = gVar (ev ++ "'" ++ show n) rtvar = gVar (ev ++ "'r") mkfetch n = GBind (GFetch ev t (Just n)) (ftvar n) fcall = GBind (GCall fun (map ftvar nums)) rtvar ret = GSimple (GUnit rtvar) in GBind (GInline (map mkfetch nums ++ [fcall, ret])) bv Just [HasValue hv] -> GBind (GUnit hv) bv Just [ReturnOf _] -> GBind (GUnit $ gVar ev) bv Just [EquivTo nv] -> GBind (GCall "GRIN;eval" [GVal (GVar nv)]) bv Just _ -> ex mfun ex@(GBind (GCall "GRIN;apply" [GVal (GVar tv), av]) bv) = case M.lookup tv applys of Nothing -> ex Just [HasValue (GTagged tag@('P':'@':missfun) gsvs)] -> let (miss, _:fun) = break (== ':') missfun nflds = [1 .. length gsvs] rtvarp = gVar (tv ++ "'rt") fldvars = map (\n -> tv ++ "'fl'" ++ show n) nflds flftchs = zipWith (\vv n -> GBind (GFetch tv tag (Just n)) vv) xxargs nflds xxargs = map gVar fldvars mnarg = (read miss) :: Int cot = case mnarg of 1 -> GStore $ GTagged ("F@" ++ fun) (map val2sval (xxargs ++ [av])) _ -> GStore $ GTagged ("P@" ++ show (mnarg - 1) ++ ":" ++ fun) (map val2sval (xxargs ++ [av])) bl = flftchs ++ [GBind cot rtvarp, GSimple (GUnit rtvarp)] in GBind (GInline bl) bv _ -> ex mfun ex = ex mg f | gFuncName f `elem` ["GRIN;eval", "GRIN;apply"] = f mg f = f {gFuncBody = mapOverBlock mfun (gFuncBody f)} in case (M.null evals && M.null applys) of True -> (g, False) False -> (g {gFuncs = map mg (gFuncs g)}, True) elimWhnfEvals :: HeapMap -> GRIN -> (GRIN, Bool) elimWhnfEvals hm g = let evalv = concat $ map cvar $ M.keys $ M.filter (== [CallTo "GRIN;eval"]) hm cvar (HCall _ [EquivTo v]) = [v] cvar _ = [] nds = Deps {complete = M.empty, pending = M.empty, newdeps = evalv} cds = iterBRDeps hm (\old new -> sort (newdeps old) == sort (newdeps new)) nds evalc = M.map S.toList $ M.filterWithKey (\k a -> k `elem` evalv) (complete cds) evals = M.filter oneval $ evalc oneval [] = False oneval [GTagged ('F':'@':_) _] = True oneval [GTag ('K':'@':_)] = True oneval z = all whnf z whnf (GTagged ('F':'@':_) _) = False whnf (GTag ('K':'@':_)) = False whnf (GTagged _ _) = True whnf (GTag _) = True whnf (GVal (GVar _)) = False whnf _ = True mfun ex@(GBind (GCall "GRIN;eval" [GVal (GVar v)]) bv) = case M.lookup v evals of Nothing -> ex Just [GTag ('K':'@':caf)] -> GBind (GCall caf []) bv Just [GTagged t@('F':'@':fun) vs] -> let nums = [1 .. length vs] ftvar n = gVar (unGVar bv ++ "'" ++ show n) rtvar = gVar (unGVar bv ++ "'r") mkfetch n = GBind (GFetch v t (Just n)) (ftvar n) fcall = GBind (GCall fun (map ftvar nums)) rtvar ret = GSimple (GUnit rtvar) in GBind (GInline (map mkfetch nums ++ [fcall, ret])) bv Just _ -> GBind (GUnit $ gVar v) bv mfun ex = ex mg f | gFuncName f `elem` ["GRIN;eval", "GRIN;apply"] = f mg f = f {gFuncBody = mapOverBlock mfun (gFuncBody f)} in case M.null evals of True -> (g, False) False -> (g {gFuncs = map mg (gFuncs g)}, True)