X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FLiberateCase.lhs;h=fe1f7585516d7548e2e85cf5a701048ea1b9e1c8;hp=c29d217b00a794a4596b98f46cdc0b21ce4d1790;hb=c1c2c25355bc462e521b2c5fb41ac79307da22ff;hpb=ebd091d5cd703b249838baaa125e6c0fa0fe0e45 diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs index c29d217..fe1f758 100644 --- a/compiler/simplCore/LiberateCase.lhs +++ b/compiler/simplCore/LiberateCase.lhs @@ -4,28 +4,15 @@ \section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - 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 VarEnv -import Name ( localiseName ) import Util ( notNull ) \end{code} @@ -130,19 +117,10 @@ and the level of @h@ is zero (NB not one). %************************************************************************ \begin{code} -liberateCase :: HscEnv -> UniqSupply -> RuleBase -> ModGuts - -> IO (SimplCount, ModGuts) -liberateCase hsc_env _ _ guts - = do { let dflags = hsc_dflags hsc_env - - ; showPass dflags "Liberate case" - ; let { env = initEnv dflags - ; 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 @@ -166,38 +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 pairs 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 (id,rhs) + 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!] - && couldBeSmallEnoughToInline (bombOutSize env) rhs + && 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 ~~~~~~~~~~~ @@ -207,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 @@ -228,8 +218,10 @@ libCase env (Case scrut bndr ty alts) 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} @@ -255,9 +247,11 @@ freeScruts :: LibCaseEnv -> [Id] -- Ids that are scrutinised between the binding -- of the recursive Id and here freeScruts env rec_bind_lvl - = [v | (v,scrut_bind_lvl) <- lc_scruts env - , scrut_bind_lvl <= 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] @@ -282,6 +276,22 @@ 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 + %************************************************************************ %* * @@ -318,7 +328,7 @@ addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env, | otherwise = env where - scruts' = (scrut_var, bind_lvl) : scruts + scruts' = (scrut_var, bind_lvl, lvl) : scruts bind_lvl = case lookupVarEnv lvl_env scrut_var of Just lvl -> lvl Nothing -> topLevel @@ -349,7 +359,7 @@ 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) @@ -366,24 +376,35 @@ data LibCaseEnv -- Binds *only* recursively defined ids, to their own -- binding group, and *only* in their own RHSs - lc_scruts :: [(Id,LibCaseLevel)] + 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 LibCaseLevel recorded here is the *binding - -- level* of the scrutinised Id. + -- 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 -> LibCaseEnv initEnv dflags - = LibCaseEnv { lc_size = specThreshold dflags, + = LibCaseEnv { lc_size = liberateCaseThreshold dflags, lc_lvl = 0, lc_lvl_env = emptyVarEnv, lc_rec_env = emptyVarEnv, lc_scruts = [] } +bombOutSize :: LibCaseEnv -> Maybe Int bombOutSize = lc_size \end{code} -