X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=7dc3cfced2228ed6d831de00bc4e8937edeb8fcf;hb=911a9fad0e04c6df6e895bab8e169a90766dc483;hp=f5af0d1693c72f86ce38f443d007cda23f0b90ac;hpb=0171936c9092666692c69a7f93fa75af976330cb;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index f5af0d1..7dc3cfc 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -21,14 +21,14 @@ 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, ) import OccName ( encodeFS ) import IdInfo ( OccInfo(..), isLoopBreaker, - setArityInfo, + setArityInfo, zapDemandInfo, setUnfoldingInfo, occInfo ) @@ -41,7 +41,7 @@ import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding, exprIsConApp_maybe, mkPiTypes, findAlt, exprType, exprIsValue, exprOkForSpeculation, exprArity, - mkCoerce, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg + mkCoerce, mkCoerce2, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg ) import Rules ( lookupRule ) import BasicTypes ( isMarkedStrict ) @@ -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 ) @@ -59,7 +59,9 @@ import BasicTypes ( TopLevelFlag(..), isTopLevel, ) import OrdList import Maybe ( Maybe ) +import Maybes ( orElse ) import Outputable +import Util ( notNull ) \end{code} @@ -247,8 +249,15 @@ simplTopBinds env binds drop_bs (NonRec _ _) (_ : bs) = bs drop_bs (Rec prs) bs = drop (length prs) bs - simpl_bind env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r - simpl_bind env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs' + simpl_bind env bind bs + = getDOptsSmpl `thenSmpl` \ dflags -> + if dopt Opt_D_dump_inlinings dflags then + pprTrace "SimplBind" (ppr (bindersOf bind)) $ simpl_bind1 env bind bs + else + simpl_bind1 env bind bs + + simpl_bind1 env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r + simpl_bind1 env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs' \end{code} @@ -296,17 +305,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 @@ -443,24 +452,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. @@ -469,7 +497,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 @@ -480,38 +508,53 @@ 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 ... - -- Here we definitely want to float the y=E defn. - -- exprIsValue definitely isn't right for that. - -- - -- BUT we can't use "exprIsCheap", because that causes a strictness bug. + else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then + -- WARNING: long dodgy argument coming up + -- WANTED: a better way to do this + -- + -- We can't use "exprIsCheap" instead of exprIsValue, + -- because that causes a strictness bug. -- x = let y* = E in case (scc y) of { T -> F; F -> T} -- The case expression is 'cheap', but it's wrong to transform to -- y* = E; x = case (scc y) of {...} -- Either we must be careful not to float demanded non-values, or -- we must use exprIsValue for the test, which ensures that the - -- thing is non-strict. I think. The WARN below tests for this. - else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then + -- thing is non-strict. So exprIsValue => bindings are non-strict + -- I think. The WARN below tests for this. + -- + -- We use exprIsTrivial here because we want to reveal lone variables. + -- E.g. let { x = letrec { y = E } in y } in ... + -- Here we definitely want to float the y=E defn. + -- exprIsValue definitely isn't right for that. + -- + -- Again, the floated binding can't be strict; if it's recursive it'll + -- be non-strict; if it's non-recursive it'd be inlined. + -- + -- Note [SCC-and-exprIsTrivial] + -- If we have + -- y = let { x* = E } in scc "foo" x + -- then we do *not* want to float out the x binding, because + -- it's strict! Fortunately, exprIsTrivial replies False to + -- (scc "foo" x). -- There's a subtlety here. There may be a binding (x* = e) in the -- floats, where the '*' means 'will be demanded'. So is it safe -- to float it out? Answer no, but it won't matter because - -- we only float if arg' is a WHNF, + -- we only float if (a) arg' is a WHNF, or (b) it's going to top level -- and so there can't be any 'will be demanded' bindings in the floats. - -- Hence the assert - WARN( any demanded_float (floatBinds floats), - ppr (filter demanded_float (floatBinds floats)) ) + -- Hence the warning + ASSERT2( is_top_level || not (any demanded_float (floatBinds floats)), + ppr (filter demanded_float (floatBinds floats)) ) 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)) @@ -570,16 +613,32 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs -- Add arity info new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs - -- Add the unfolding *only* for non-loop-breakers - -- Making loop breakers not have an unfolding at all - -- means that we can avoid tests in exprIsConApp, for example. - -- This is important: if exprIsConApp says 'yes' for a recursive - -- thing, then we can get into an infinite loop - info_w_unf | loop_breaker = new_bndr_info - | otherwise = new_bndr_info `setUnfoldingInfo` unfolding - unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs - - final_id = new_bndr `setIdInfo` info_w_unf + -- Add the unfolding *only* for non-loop-breakers + -- Making loop breakers not have an unfolding at all + -- means that we can avoid tests in exprIsConApp, for example. + -- This is important: if exprIsConApp says 'yes' for a recursive + -- thing, then we can get into an infinite loop + + -- If the unfolding is a value, the demand info may + -- go pear-shaped, so we nuke it. Example: + -- let x = (a,b) in + -- case x of (p,q) -> h p q x + -- Here x is certainly demanded. But after we've nuked + -- the case, we'll get just + -- let x = (a,b) in h a b x + -- and now x is not demanded (I'm assuming h is lazy) + -- This really happens. Similarly + -- let f = \x -> e in ...f..f... + -- After inling f at some of its call sites the original binding may + -- (for example) be no longer strictly demanded. + -- The solution here is a bit ad hoc... + unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs + info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding + final_info | loop_breaker = new_bndr_info + | isEvaldUnfolding unfolding = zapDemandInfo info_w_unf `orElse` info_w_unf + | otherwise = info_w_unf + + final_id = new_bndr `setIdInfo` final_info in -- These seqs forces the Id, and hence its IdInfo, -- and hence any inner substitutions @@ -684,8 +743,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 -> @@ -787,12 +846,14 @@ simplNote env (Coerce to from) body cont -- the inner one is redundant addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont) - | Just (s1, s2) <- splitFunTy_maybe s1s2 + | not (isTypeArg arg), -- This whole case only works for value args + -- Could upgrade to have equiv thing for type apps too + Just (s1, s2) <- splitFunTy_maybe s1s2 -- (coerce (T1->T2) (S1->S2) F) E -- ===> -- coerce T2 S2 (F (coerce S1 T1 E)) -- - -- t1t2 must be a function type, T1->T2 + -- t1t2 must be a function type, T1->T2, because it's applied to something -- but s1s2 might conceivably not be -- -- When we build the ApplyTo we can't mix the out-types @@ -801,7 +862,7 @@ simplNote env (Coerce to from) body cont -- But it isn't a common case. = let (t1,t2) = splitFunTy t1t2 - new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg) + new_arg = mkCoerce2 s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg) in ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont) @@ -832,6 +893,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} @@ -908,7 +973,7 @@ completeCall env var occ_info cont tick (RuleFired rule_name) `thenSmpl_` (if dopt Opt_D_dump_inlinings dflags then pprTrace "Rule fired" (vcat [ - text "Rule:" <+> ptext rule_name, + text "Rule:" <+> ftext rule_name, text "Before:" <+> ppr var <+> sep (map pprParendExpr args), text "After: " <+> pprCoreExpr rule_rhs, text "Cont: " <+> ppr call_cont]) @@ -922,8 +987,8 @@ completeCall env var occ_info cont let arg_infos = [ interestingArg arg | arg <- args, isValArg arg] - interesting_cont = interestingCallContext (not (null args)) - (not (null arg_infos)) + interesting_cont = interestingCallContext (notNull args) + (notNull arg_infos) call_cont active_inline = activeInline env var occ_info @@ -1037,11 +1102,14 @@ simplifyArg env fn_ty (val_arg, arg_se, is_strict) cont_ty thing_inside | is_strict = simplStrictArg AnArg env val_arg arg_se arg_ty cont_ty thing_inside - | otherwise - = simplExprF (setInScope arg_se env) val_arg - (mkStop arg_ty AnArg) `thenSmpl` \ (floats, arg1) -> - addFloats env floats $ \ env -> - thing_inside env arg1 + | otherwise -- Lazy argument + -- DO NOT float anything outside, hence simplExprC + -- There is no benefit (unlike in a let-binding), and we'd + -- have to be very careful about bogus strictness through + -- floating a demanded let. + = simplExprC (setInScope arg_se env) val_arg + (mkStop arg_ty AnArg) `thenSmpl` \ arg1 -> + thing_inside env arg1 where arg_ty = funArgTy fn_ty @@ -1118,8 +1186,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 @@ -1188,7 +1256,7 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM FloatsWithExpr rebuild env expr (Stop _ _ _) = rebuildDone env expr rebuild env expr (ArgOf _ _ _ cont_fn) = cont_fn env expr -rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty (exprType expr) expr) cont +rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty expr) cont rebuild env expr (InlinePlease cont) = rebuild env (Note InlineCall expr) cont rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont rebuild env expr (ApplyTo _ arg se cont) = rebuildApp (setInScope se env) expr arg cont @@ -1232,7 +1300,7 @@ rebuildCase env scrut case_bndr alts cont | otherwise = prepareAlts scrut case_bndr alts `thenSmpl` \ (better_alts, handled_cons) -> - + -- Deal with the case binder, and prepare the continuation; -- The new subst_env is in place prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> @@ -1399,17 +1467,21 @@ simplAlts env zap_occ_info handled_cons case_bndr' alts cont' -- We really must record that b is already evaluated so that we don't -- go and re-evaluate it when constructing the result. - add_evals (DataAlt dc) vs = cat_evals vs (dataConRepStrictness dc) + add_evals (DataAlt dc) vs = cat_evals dc vs (dataConRepStrictness dc) add_evals other_con vs = vs - cat_evals [] [] = [] - cat_evals (v:vs) (str:strs) - | isTyVar v = v : cat_evals vs (str:strs) - | isMarkedStrict str = evald_v : cat_evals vs strs - | otherwise = zapped_v : cat_evals vs strs + cat_evals dc vs strs + = go vs strs where - zapped_v = zap_occ_info v - evald_v = zapped_v `setIdUnfolding` mkOtherCon [] + go [] [] = [] + go (v:vs) (str:strs) + | isTyVar v = v : go vs (str:strs) + | isMarkedStrict str = evald_v : go vs strs + | otherwise = zapped_v : go vs strs + where + zapped_v = zap_occ_info v + evald_v = zapped_v `setIdUnfolding` mkOtherCon [] + go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs) \end{code} @@ -1679,7 +1751,7 @@ mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs) ) `thenSmpl` \ (final_bndrs', final_args) -> -- See comment about "$j" name above - newId (encodeFS SLIT("$j")) (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr -> + newId (encodeFS FSLIT("$j")) (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr -> -- Notice the funky mkPiTypes. If the contructor has existentials -- it's possible that the join point will be abstracted over -- type varaibles as well as term variables.