X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=3eed86af2d8a36131b72b369fb6ec498c6e51690;hb=a38fed411ee18754cede5c410ec94f33001c0af3;hp=588f71d57e24d52b96262950e8af79bdae8ed7a2;hpb=0316a9e603115e6d3f04bd03824a1ca9430b0f0f;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 588f71d..3eed86a 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -21,7 +21,7 @@ import SimplUtils ( mkCase, mkLam, newId, prepareAlts, ) import Var ( mustHaveLocalBinding ) import VarEnv -import Id ( Id, idType, idInfo, idArity, isDataConId, +import Id ( Id, idType, idInfo, idArity, isDataConWorkId, setIdUnfolding, isDeadBinder, idNewDemandInfo, setIdInfo, setIdOccInfo, zapLamIdInfo, setOneShotLambda, @@ -49,7 +49,7 @@ import CostCentre ( currentCCS ) import Type ( isUnLiftedType, seqType, tyConAppArgs, funArgTy, splitFunTy_maybe, splitFunTy, eqType ) -import Subst ( mkSubst, substTy, substExpr, +import Subst ( mkSubst, substTy, substExpr, isInScope, lookupIdSubst, simplIdInfo ) import TysPrim ( realWorldStatePrimTy ) @@ -304,17 +304,17 @@ simplNonRecBind env bndr rhs rhs_se cont_ty thing_inside | isStrictDmd (idNewDemandInfo bndr) || isStrictType (idType bndr) -- A strict let = -- Don't use simplBinder because that doesn't keep -- fragile occurrence info in the substitution - simplLetBndr env bndr `thenSmpl` \ (env, bndr') -> + simplLetBndr env bndr `thenSmpl` \ (env, bndr1) -> + simplStrictArg AnRhs env rhs rhs_se (idType bndr1) cont_ty $ \ env1 rhs1 -> + + -- Now complete the binding and simplify the body let -- simplLetBndr doesn't deal with the IdInfo, so we must -- do so here (c.f. simplLazyBind) - bndr'' = bndr' `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr) - env1 = modifyInScope env bndr'' bndr'' + bndr2 = bndr1 `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr) + env2 = modifyInScope env1 bndr2 bndr2 in - simplStrictArg AnRhs env1 rhs rhs_se (idType bndr') cont_ty $ \ env rhs1 -> - - -- Now complete the binding and simplify the body - completeNonRecX env True {- strict -} bndr bndr'' rhs1 thing_inside + completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside | otherwise -- Normal, lazy case = -- Don't use simplBinder because that doesn't keep @@ -451,24 +451,43 @@ simplLazyBind :: SimplEnv -> InExpr -> SimplEnv -- The RHS and its environment -> SimplM (FloatsWith SimplEnv) -simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se - = -- Substitute IdInfo on binder, in the light of earlier - -- substitutions in this very letrec, and extend the - -- in-scope env, so that the IdInfo for this binder extends - -- over the RHS for the binder itself. +simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se + = let -- Transfer the IdInfo of the original binder to the new binder + -- This is crucial: we must preserve + -- strictness + -- rules + -- worker info + -- etc. To do this we must apply the current substitution, + -- which incorporates earlier substitutions in this very letrec group. -- + -- NB 1. We do this *before* processing the RHS of the binder, so that + -- its substituted rules are visible in its own RHS. -- This is important. Manuel found cases where he really, really -- wanted a RULE for a recursive function to apply in that function's - -- own right-hand side. + -- own right-hand side. -- - -- NB: does no harm for non-recursive bindings - let - bndr'' = bndr' `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr) - env1 = modifyInScope env bndr'' bndr'' + -- NB 2: We do not transfer the arity (see Subst.substIdInfo) + -- The arity of an Id should not be visible + -- in its own RHS, else we eta-reduce + -- f = \x -> f x + -- to + -- f = f + -- which isn't sound. And it makes the arity in f's IdInfo greater than + -- the manifest arity, which isn't good. + -- The arity will get added later. + -- + -- NB 3: It's important that we *do* transer the loop-breaker OccInfo, + -- because that's what stops the Id getting inlined infinitely, in the body + -- of the letrec. + + -- NB 4: does no harm for non-recursive bindings + + bndr2 = bndr1 `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr) + env1 = modifyInScope env bndr2 bndr2 rhs_env = setInScope rhs_se env1 is_top_level = isTopLevel top_lvl ok_float_unlifted = not is_top_level && isNonRec is_rec - rhs_cont = mkStop (idType bndr') AnRhs + rhs_cont = mkStop (idType bndr1) AnRhs in -- Simplify the RHS; note the mkStop, which tells -- the simplifier that this is the RHS of a let. @@ -477,7 +496,7 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se -- If any of the floats can't be floated, give up now -- (The allLifted predicate says True for empty floats.) if (not ok_float_unlifted && not (allLifted floats)) then - completeLazyBind env1 top_lvl bndr bndr'' + completeLazyBind env1 top_lvl bndr bndr2 (wrapFloats floats rhs1) else @@ -488,7 +507,7 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se -- If the result is a PAP, float the floats out, else wrap them -- By this time it's already been ANF-ised (if necessary) if isEmptyFloats floats && isNilOL aux_binds then -- Shortcut a common case - completeLazyBind env1 top_lvl bndr bndr'' rhs2 + completeLazyBind env1 top_lvl bndr bndr2 rhs2 -- We use exprIsTrivial here because we want to reveal lone variables. -- E.g. let { x = letrec { y = E } in y } in ... @@ -516,10 +535,10 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se tick LetFloatFromLet `thenSmpl_` ( addFloats env1 floats $ \ env2 -> addAtomicBinds env2 (fromOL aux_binds) $ \ env3 -> - completeLazyBind env3 top_lvl bndr bndr'' rhs2) + completeLazyBind env3 top_lvl bndr bndr2 rhs2) else - completeLazyBind env1 top_lvl bndr bndr'' (wrapFloats floats rhs1) + completeLazyBind env1 top_lvl bndr bndr2 (wrapFloats floats rhs1) #ifdef DEBUG demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b)) @@ -692,8 +711,8 @@ simplExprF env (Case scrut bndr alts) cont simplExprF env (Let (Rec pairs) body) cont = simplRecBndrs env (map fst pairs) `thenSmpl` \ (env, bndrs') -> - -- NB: bndrs' don't have unfoldings or spec-envs - -- We add them as we go down, using simplPrags + -- NB: bndrs' don't have unfoldings or rules + -- We add them as we go down simplRecBind env NotTopLevel pairs bndrs' `thenSmpl` \ (floats, env) -> addFloats env floats $ \ env -> @@ -842,6 +861,10 @@ simplNote env InlineMe e cont -- an interesting context of any kind to combine with -- (even a type application -- anything except Stop) = simplExprF env e cont + +simplNote env (CoreNote s) e cont + = simplExpr env e `thenSmpl` \ e' -> + rebuild env (Note (CoreNote s) e') cont \end{code} @@ -1131,8 +1154,8 @@ mkAtomicArgs :: Bool -- A strict binding -- if the strict-binding flag is on mkAtomicArgs is_strict ok_float_unlifted rhs - | (Var fun, args) <- collectArgs rhs, -- It's an application - isDataConId fun || valArgCount args < idArity fun -- And it's a constructor or PAP + | (Var fun, args) <- collectArgs rhs, -- It's an application + isDataConWorkId fun || valArgCount args < idArity fun -- And it's a constructor or PAP = go fun nilOL [] args -- Have a go | otherwise = bale_out -- Give up