X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FLiberateCase.lhs;h=fe1f7585516d7548e2e85cf5a701048ea1b9e1c8;hp=a7b613dbb5d51cbd99c0b8c900ea3d955cf61f91;hb=f8f0e76ad302fda30196ebc9230e5fcbc97be537;hpb=8edeb9dbe5ec9bdf7e9bf1efa3962351efaf5cdb diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs index a7b613d..fe1f758 100644 --- a/compiler/simplCore/LiberateCase.lhs +++ b/compiler/simplCore/LiberateCase.lhs @@ -9,22 +9,11 @@ module LiberateCase ( liberateCase ) where #include "HsVersions.h" import DynFlags -import HscTypes -import CoreLint ( showPass, endPass ) import CoreSyn import CoreUnfold ( couldBeSmallEnoughToInline ) -import Rules ( RuleBase ) -import UniqSupply ( UniqSupply ) -import SimplMonad ( SimplCount, zeroSimplCount ) import Id -import FamInstEnv -import Type -import Coercion -import TyCon import VarEnv -import Name ( localiseName ) import Util ( notNull ) -import Data.IORef ( readIORef ) \end{code} The liberate-case transformation @@ -58,30 +47,13 @@ Example Better code, because 'a' is free inside the inner letrec, rather than needing projection from v. -Other examples we'd like to catch with this kind of transformation +Note that this deals with *free variables*. SpecConstr deals with +*arguments* that are of known form. E.g. last [] = error last (x:[]) = x last (x:xs) = last xs -We'd like to avoid the redundant pattern match, transforming to - - last [] = error - last (x:[]) = x - last (x:(y:ys)) = last' y ys - where - last' y [] = y - last' _ (y:ys) = last' y ys - - (is this necessarily an improvement) - -Similarly drop: - - drop n [] = [] - drop 0 xs = xs - drop n (x:xs) = drop (n-1) xs - -Would like to pass n along unboxed. Note [Scrutinee with cast] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -93,9 +65,26 @@ Exactly the same optimisation (unrolling one call to f) will work here, despite the cast. See mk_alt_env in the Case branch of libCase. +Note [Only functions!] +~~~~~~~~~~~~~~~~~~~~~~ +Consider the following code + + f = g (case v of V a b -> a : t f) + +where g is expensive. If we aren't careful, liberate case will turn this into + + f = g (case v of + V a b -> a : t (letrec f = g (case v of V a b -> a : f t) + in f) + ) + +Yikes! We evaluate g twice. This leads to a O(2^n) explosion +if g calls back to the same code recursively. + +Solution: make sure that we only do the liberate-case thing on *functions* + To think about (Apr 94) ~~~~~~~~~~~~~~ - Main worry: duplicating code excessively. At the moment we duplicate the entire binding group once at each recursive call. But there may be a group of recursive calls which share a common set of evaluated @@ -120,43 +109,6 @@ scope. For example: Here, the level of @f@ is zero, the level of @g@ is one, and the level of @h@ is zero (NB not one). -Note [Indexed data types] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data family T :: * -> * - data T Int = TI Int - - f :: T Int -> Bool - f x = case x of { DEFAULT -> } - -We would like to change this to - f x = case x `cast` co of { TI p -> } - -so that can make use of the fact that x is already evaluated to -a TI; and a case on a known data type may be more efficient than a -polymorphic one (not sure this is true any longer). Anyway the former -showed up in Roman's experiments. Example: - foo :: FooT Int -> Int -> Int - foo t n = t `seq` bar n - where - bar 0 = 0 - bar n = bar (n - case t of TI i -> i) -Here we'd like to avoid repeated evaluating t inside the loop, by -taking advantage of the `seq`. - -We implement this as part of the liberate-case transformation by -spotting - case of (x::T) tys { DEFAULT -> } -where x :: T tys, and T is a indexed family tycon. Find the -representation type (T77 tys'), and coercion co, and transform to - case `cast` co of (y::T77 tys') - DEFAULT -> let x = y `cast` sym co in - -The "find the representation type" part is done by looking up in the -family-instance environment. - -NB: in fact we re-use x (changing its type) to avoid making a fresh y; -this entails shadowing, but that's ok. %************************************************************************ %* * @@ -165,21 +117,10 @@ this entails shadowing, but that's ok. %************************************************************************ \begin{code} -liberateCase :: HscEnv -> UniqSupply -> RuleBase -> ModGuts - -> IO (SimplCount, ModGuts) -liberateCase hsc_env _ _ guts - = do { let dflags = hsc_dflags hsc_env - ; eps <- readIORef (hsc_EPS hsc_env) - ; let fam_envs = (eps_fam_inst_env eps, mg_fam_inst_env guts) - - ; showPass dflags "Liberate case" - ; let { env = initEnv dflags fam_envs - ; binds' = do_prog env (mg_binds guts) } - ; endPass dflags "Liberate case" Opt_D_verbose_core2core binds' - {- no specific flag for dumping -} - ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) } +liberateCase :: DynFlags -> [CoreBind] -> [CoreBind] +liberateCase dflags binds = do_prog (initEnv dflags) binds where - do_prog env [] = [] + do_prog _ [] = [] do_prog env (bind:binds) = bind' : do_prog env' binds where (env', bind') = libCaseBind env bind @@ -203,37 +144,49 @@ libCaseBind env (NonRec binder rhs) libCaseBind env (Rec pairs) = (env_body, Rec pairs') where - (binders, rhss) = unzip pairs + binders = map fst pairs env_body = addBinders env binders pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs] - env_rhs = if all rhs_small_enough rhss then extended_env else env - -- We extend the rec-env by binding each Id to its rhs, first -- processing the rhs with an *un-extended* environment, so -- that the same process doesn't occur for ever! - -- - extended_env = addRecBinds env [ (adjust binder, libCase env_body rhs) - | (binder, rhs) <- pairs ] - - -- Two subtle things: - -- (a) Reset the export flags on the binders so - -- that we don't get name clashes on exported things if the - -- local binding floats out to top level. This is most unlikely - -- to happen, since the whole point concerns free variables. - -- But resetting the export flag is right regardless. - -- - -- (b) Make the name an Internal one. External Names should never be - -- nested; if it were floated to the top level, we'd get a name - -- clash at code generation time. - adjust bndr = setIdNotExported (setIdName bndr (localiseName (idName bndr))) - - rhs_small_enough rhs = couldBeSmallEnoughToInline lIBERATE_BOMB_SIZE rhs - lIBERATE_BOMB_SIZE = bombOutSize env + env_rhs = addRecBinds env [ (localiseId binder, libCase env_body rhs) + | (binder, rhs) <- pairs + , rhs_small_enough binder rhs ] + -- localiseID : see Note [Need to localiseId in libCaseBind] + + + rhs_small_enough id rhs -- Note [Small enough] + = idArity id > 0 -- Note [Only functions!] + && maybe True (\size -> couldBeSmallEnoughToInline size rhs) + (bombOutSize env) \end{code} +Note [Need to localiseId in libCaseBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The call to localiseId is needed for two subtle reasons +(a) Reset the export flags on the binders so + that we don't get name clashes on exported things if the + local binding floats out to top level. This is most unlikely + to happen, since the whole point concerns free variables. + But resetting the export flag is right regardless. + +(b) Make the name an Internal one. External Names should never be + nested; if it were floated to the top level, we'd get a name + clash at code generation time. + +Note [Small enough] +~~~~~~~~~~~~~~~~~~~ +Consider + \fv. letrec + f = \x. BIG...(case fv of { (a,b) -> ...g.. })... + g = \y. SMALL...f... +Then we *can* do liberate-case on g (small RHS) but not for f (too big). +But we can choose on a item-by-item basis, and that's what the +rhs_small_enough call in the comprehension for env_rhs does. Expressions ~~~~~~~~~~~ @@ -243,9 +196,10 @@ libCase :: LibCaseEnv -> CoreExpr -> CoreExpr -libCase env (Var v) = libCaseId env v -libCase env (Lit lit) = Lit lit -libCase env (Type ty) = Type ty +libCase env (Var v) = libCaseId env v +libCase _ (Lit lit) = Lit lit +libCase _ (Type ty) = Type ty +libCase _ (Coercion co) = Coercion co libCase env (App fun arg) = App (libCase env fun) (libCase env arg) libCase env (Note note body) = Note note (libCase env body) libCase env (Cast e co) = Cast (libCase env e) co @@ -259,33 +213,18 @@ libCase env (Let bind body) (env_body, bind') = libCaseBind env bind libCase env (Case scrut bndr ty alts) - = mkCase env (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts) + = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts) where env_alts = addBinders (mk_alt_env scrut) [bndr] mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var mk_alt_env (Cast scrut _) = mk_alt_env scrut -- Note [Scrutinee with cast] - mk_alt_env otehr = env + mk_alt_env _ = env +libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr) + -> (AltCon, [CoreBndr], CoreExpr) libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs) \end{code} -\begin{code} -mkCase :: LibCaseEnv -> CoreExpr -> Id -> Type -> [CoreAlt] -> CoreExpr --- See Note [Indexed data types] -mkCase env scrut bndr ty [(DEFAULT,_,rhs)] - | Just (tycon, tys) <- splitTyConApp_maybe (idType bndr) - , [(subst, fam_inst)] <- lookupFamInstEnv (lc_fams env) tycon tys - = let - rep_tc = famInstTyCon fam_inst - rep_tys = map (substTyVar subst) (tyConTyVars rep_tc) - bndr' = setIdType bndr (mkTyConApp rep_tc rep_tys) - Just co_tc = tyConFamilyCoercion_maybe rep_tc - co = mkTyConApp co_tc rep_tys - bind = NonRec bndr (Cast (Var bndr') (mkSymCoercion co)) - in mkCase env (Cast scrut co) bndr' ty [(DEFAULT,[],Let bind rhs)] -mkCase env scrut bndr ty alts - = Case scrut bndr ty alts -\end{code} Ids ~~~ @@ -302,8 +241,57 @@ libCaseId env v where rec_id_level = lookupLevel env v free_scruts = freeScruts env rec_id_level + +freeScruts :: LibCaseEnv + -> LibCaseLevel -- Level of the recursive Id + -> [Id] -- Ids that are scrutinised between the binding + -- of the recursive Id and here +freeScruts env rec_bind_lvl + = [v | (v, scrut_bind_lvl, scrut_at_lvl) <- lc_scruts env + , scrut_bind_lvl <= rec_bind_lvl + , scrut_at_lvl > rec_bind_lvl] + -- Note [When to specialise] + -- Note [Avoiding fruitless liberate-case] \end{code} +Note [When to specialise] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f = \x. letrec g = \y. case x of + True -> ... (f a) ... + False -> ... (g b) ... + +We get the following levels + f 0 + x 1 + g 1 + y 2 + +Then 'x' is being scrutinised at a deeper level than its binding, so +it's added to lc_sruts: [(x,1)] + +We do *not* want to specialise the call to 'f', becuase 'x' is not free +in 'f'. So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0). + +We *do* want to specialise the call to 'g', because 'x' is free in g. +Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1). + +Note [Avoiding fruitless liberate-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider also: + f = \x. case top_lvl_thing of + I# _ -> let g = \y. ... g ... + in ... + +Here, top_lvl_thing is scrutinised at a level (1) deeper than its +binding site (0). Nevertheless, we do NOT want to specialise the call +to 'g' because all the structure in its free variables is already +visible at the definition site for g. Hence, when considering specialising +an occurrence of 'g', we want to check that there's a scruted-var v st + + a) v's binding site is *outside* g + b) v's scrutinisation site is *inside* g + %************************************************************************ %* * @@ -340,7 +328,7 @@ addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env, | otherwise = env where - scruts' = (scrut_var, lvl) : scruts + scruts' = (scrut_var, bind_lvl, lvl) : scruts bind_lvl = case lookupVarEnv lvl_env scrut_var of Just lvl -> lvl Nothing -> topLevel @@ -353,13 +341,6 @@ lookupLevel env id = case lookupVarEnv (lc_lvl_env env) id of Just lvl -> lvl Nothing -> topLevel - -freeScruts :: LibCaseEnv - -> LibCaseLevel -- Level of the recursive Id - -> [Id] -- Ids that are scrutinised between the binding - -- of the recursive Id and here -freeScruts env rec_bind_lvl - = [v | (v,scrut_lvl) <- lc_scruts env, scrut_lvl > rec_bind_lvl] \end{code} %************************************************************************ @@ -378,45 +359,52 @@ topLevel = 0 \begin{code} data LibCaseEnv = LibCaseEnv { - lc_size :: Int, -- Bomb-out size for deciding if + lc_size :: Maybe Int, -- Bomb-out size for deciding if -- potential liberatees are too big. -- (passed in from cmd-line args) lc_lvl :: LibCaseLevel, -- Current level + -- The level is incremented when (and only when) going + -- inside the RHS of a (sufficiently small) recursive + -- function. lc_lvl_env :: IdEnv LibCaseLevel, - -- Binds all non-top-level in-scope Ids - -- (top-level and imported things have - -- a level of zero) + -- Binds all non-top-level in-scope Ids (top-level and + -- imported things have a level of zero) lc_rec_env :: IdEnv CoreBind, - -- Binds *only* recursively defined ids, - -- to their own binding group, - -- and *only* in their own RHSs - - lc_scruts :: [(Id,LibCaseLevel)], - -- Each of these Ids was scrutinised by an - -- enclosing case expression, with the - -- specified number of enclosing - -- recursive bindings; furthermore, - -- the Id is bound at a lower level - -- than the case expression. The order is - -- insignificant; it's a bag really - - lc_fams :: FamInstEnvs - -- Instance env for indexed data types + -- Binds *only* recursively defined ids, to their own + -- binding group, and *only* in their own RHSs + + lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)] + -- Each of these Ids was scrutinised by an enclosing + -- case expression, at a level deeper than its binding + -- level. + -- + -- The first LibCaseLevel is the *binding level* of + -- the scrutinised Id, + -- The second is the level *at which it was scrutinised*. + -- (see Note [Avoiding fruitless liberate-case]) + -- The former is a bit redundant, since you could always + -- look it up in lc_lvl_env, but it's just cached here + -- + -- The order is insignificant; it's a bag really + -- + -- There's one element per scrutinisation; + -- in principle the same Id may appear multiple times, + -- although that'd be unusual: + -- case x of { (a,b) -> ....(case x of ...) .. } } -initEnv :: DynFlags -> FamInstEnvs -> LibCaseEnv -initEnv dflags fams - = LibCaseEnv { lc_size = specThreshold dflags, +initEnv :: DynFlags -> LibCaseEnv +initEnv dflags + = LibCaseEnv { lc_size = liberateCaseThreshold dflags, lc_lvl = 0, lc_lvl_env = emptyVarEnv, lc_rec_env = emptyVarEnv, - lc_scruts = [], - lc_fams = fams } + lc_scruts = [] } +bombOutSize :: LibCaseEnv -> Maybe Int bombOutSize = lc_size \end{code} -