X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FLiberateCase.lhs;h=2b190621d658b75fc7507af77d85898001434f47;hb=491b818a4a9bd2160107178499e160d62933f58c;hp=4b1055bbede2a34b7f87543207a7939a5befe106;hpb=9bcd95bad83ee937c178970e8b729732e680fe1e;p=ghc-hetmet.git diff --git a/compiler/simplCore/LiberateCase.lhs b/compiler/simplCore/LiberateCase.lhs index 4b1055b..2b19062 100644 --- a/compiler/simplCore/LiberateCase.lhs +++ b/compiler/simplCore/LiberateCase.lhs @@ -144,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 [ (localiseId binder, libCase env_body rhs) - | (binder, rhs) <- pairs ] - - -- 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. - - 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!] && 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 ~~~~~~~~~~~ @@ -235,9 +246,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] @@ -262,6 +275,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 + %************************************************************************ %* * @@ -298,7 +327,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 @@ -346,13 +375,24 @@ 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 @@ -367,4 +407,3 @@ bombOutSize :: LibCaseEnv -> Maybe Int bombOutSize = lc_size \end{code} -