From 4f51ac1246f9a9b2bd172e2d6957d95942d12d23 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Mon, 15 Dec 2008 10:02:21 +0000 Subject: [PATCH] Revert CorePrep part of "Completely new treatment of INLINE pragmas..." The original patch said: * I made some changes to the way in which eta expansion happens in CorePrep, mainly to ensure that *arguments* that become let-bound are also eta-expanded. I'm still not too happy with the clarity and robustness fo the result. Unfortunately this change apparently broke some invariants that were relied on elsewhere, and in particular lead to panics when compiling with profiling on. Will re-investigate in the new year. --- compiler/coreSyn/CorePrep.lhs | 111 +++++++++++++++++++++-------------------- configure.ac | 2 +- 2 files changed, 59 insertions(+), 54 deletions(-) diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index facffdf..4211dca 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -276,7 +276,8 @@ corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats) -- This one is used for *local* bindings corePrepBind env (NonRec bndr rhs) = do - (floats, rhs2) <- corePrepExprFloat env rhs + rhs1 <- etaExpandRhs bndr rhs + (floats, rhs2) <- corePrepExprFloat env rhs1 (_, bndr') <- cloneBndr env bndr (floats', bndr'') <- mkLocalNonRec bndr' (bdrDem bndr) floats rhs2 -- We want bndr'' in the envt, because it records @@ -309,7 +310,8 @@ corePrepRhs :: TopLevelFlag -> RecFlag -> UniqSM (Floats, CoreExpr) -- Used for top-level bindings, and local recursive bindings corePrepRhs top_lvl is_rec env (bndr, rhs) = do - floats_w_rhs <- corePrepExprFloat env rhs + rhs' <- etaExpandRhs bndr rhs + floats_w_rhs <- corePrepExprFloat env rhs' floatRhs top_lvl is_rec bndr floats_w_rhs @@ -320,15 +322,14 @@ corePrepRhs top_lvl is_rec env (bndr, rhs) = do -- This is where we arrange that a non-trivial argument is let-bound corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand -> UniqSM (Floats, CoreArg) -corePrepArg env arg dem - = do { (floats, arg') <- corePrepExprFloat env arg - ; if exprIsTrivial arg' && allLazy NotTopLevel NonRecursive floats - -- Note [Floating unlifted arguments] - then return (floats, arg') - else do { v <- newVar (exprType arg') - -- Note [Eta expand arguments] - ; (floats', v') <- mkLocalNonRec v dem floats arg' - ; return (floats', Var v') } } +corePrepArg env arg dem = do + (floats, arg') <- corePrepExprFloat env arg + if exprIsTrivial arg' && allLazy NotTopLevel NonRecursive floats + -- Note [Floating unlifted arguments] + then return (floats, arg') + else do v <- newVar (exprType arg') + (floats', v') <- mkLocalNonRec v dem floats arg' + return (floats', Var v') -- version that doesn't consider an scc annotation to be trivial. exprIsTrivial :: CoreExpr -> Bool @@ -587,60 +588,20 @@ floatRhs :: TopLevelFlag -> RecFlag -> UniqSM (Floats, -- Floats out of this bind CoreExpr) -- Final Rhs -floatRhs top_lvl is_rec bndr (floats, rhs) +floatRhs top_lvl is_rec _bndr (floats, rhs) | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or allLazy top_lvl is_rec floats -- at top level = -- Why the test for allLazy? -- v = f (x `divInt#` y) -- we don't want to float the case, even if f has arity 2, -- because floating the case would make it evaluated too early - do { us <- getUniquesM - ; let eta_rhs = etaExpand arity us rhs (idType bndr) - -- For a GlobalId, take the Arity from the Id. - -- It was set in CoreTidy and must not change - -- For all others, just expand at will - -- See Note [Eta expansion] - arity | isGlobalId bndr = idArity bndr - | otherwise = exprArity rhs - ; return (floats, eta_rhs) } + return (floats, rhs) | otherwise = do -- Don't float; the RHS isn't a value rhs' <- mkBinds floats rhs return (emptyFloats, rhs') -\end{code} - -Note [Eta expansion] -~~~~~~~~~~~~~~~~~~~~~ -Eta expand to match the arity claimed by the binder Remember, -CorePrep must not change arity - -Eta expansion might not have happened already, because it is done by -the simplifier only when there at least one lambda already. - -NB1:we could refrain when the RHS is trivial (which can happen - for exported things). This would reduce the amount of code - generated (a little) and make things a little words for - code compiled without -O. The case in point is data constructor - wrappers. - -NB2: we have to be careful that the result of etaExpand doesn't - invalidate any of the assumptions that CorePrep is attempting - to establish. One possible cause is eta expanding inside of - an SCC note - we're now careful in etaExpand to make sure the - SCC is pushed inside any new lambdas that are generated. - -NB3: It's important to do eta expansion, and *then* ANF-ising - f = /\a -> g (h 3) -- h has arity 2 -If we ANF first we get - f = /\a -> let s = h 3 in g s -and now eta expansion gives - f = /\a -> \ y -> (let s = h 3 in g s) y -which is horrible. -Eta expanding first gives - f = /\a -> \y -> let s = h 3 in g s y -\begin{code} -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand -> Floats -> CoreExpr -- Rhs: let binds in body @@ -686,6 +647,50 @@ mkBinds (Floats _ binds) body mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)] mk_bind (FloatLet bind) body = Let bind body +etaExpandRhs :: CoreBndr -> CoreExpr -> UniqSM CoreExpr +etaExpandRhs bndr rhs = do + -- Eta expand to match the arity claimed by the binder + -- Remember, CorePrep must not change arity + -- + -- Eta expansion might not have happened already, + -- because it is done by the simplifier only when + -- there at least one lambda already. + -- + -- NB1:we could refrain when the RHS is trivial (which can happen + -- for exported things). This would reduce the amount of code + -- generated (a little) and make things a little words for + -- code compiled without -O. The case in point is data constructor + -- wrappers. + -- + -- NB2: we have to be careful that the result of etaExpand doesn't + -- invalidate any of the assumptions that CorePrep is attempting + -- to establish. One possible cause is eta expanding inside of + -- an SCC note - we're now careful in etaExpand to make sure the + -- SCC is pushed inside any new lambdas that are generated. + -- + -- NB3: It's important to do eta expansion, and *then* ANF-ising + -- f = /\a -> g (h 3) -- h has arity 2 + -- If we ANF first we get + -- f = /\a -> let s = h 3 in g s + -- and now eta expansion gives + -- f = /\a -> \ y -> (let s = h 3 in g s) y + -- which is horrible. + -- Eta expanding first gives + -- f = /\a -> \y -> let s = h 3 in g s y + -- + us <- getUniquesM + let eta_rhs = etaExpand arity us rhs (idType bndr) + + ASSERT2( manifestArity eta_rhs == arity, (ppr bndr <+> ppr arity <+> ppr (exprArity rhs)) + $$ ppr rhs $$ ppr eta_rhs ) + -- Assertion checks that eta expansion was successful + return eta_rhs + where + -- For a GlobalId, take the Arity from the Id. + -- It was set in CoreTidy and must not change + -- For all others, just expand at will + arity | isGlobalId bndr = idArity bndr + | otherwise = exprArity rhs -- --------------------------------------------------------------------------- -- Eliminate Lam as a non-rhs (STG doesn't have such a thing) diff --git a/configure.ac b/configure.ac index 38ba4b7..31281c0 100644 --- a/configure.ac +++ b/configure.ac @@ -13,7 +13,7 @@ dnl # see what flags are available. (Better yet, read the documentation!) # -AC_INIT([The Glorious Glasgow Haskell Compilation System], [6.11], [glasgow-haskell-bugs@haskell.org], [ghc]) +AC_INIT([The Glorious Glasgow Haskell Compilation System], [6.11.20081214], [glasgow-haskell-bugs@haskell.org], [ghc]) # Set this to YES for a released version, otherwise NO : ${RELEASE=NO} -- 1.7.10.4