X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplify.lhs;h=3eed86af2d8a36131b72b369fb6ec498c6e51690;hb=c389ab20bbfd0ea98953d630502a43fe44050f2c;hp=b69e2b22e6a2be426a280fb2adea8a8a391852d9;hpb=772ffb22872ea6b3c8c6973c32389080b17229f1;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index b69e2b2..3eed86a 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -12,7 +12,7 @@ import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings), SimplifierSwitch(..) ) import SimplMonad -import SimplUtils ( mkCase, mkLam, newId, +import SimplUtils ( mkCase, mkLam, newId, prepareAlts, simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr, SimplCont(..), DupFlag(..), LetRhsFlag(..), mkStop, mkBoringStop, pushContArgs, @@ -21,11 +21,12 @@ import SimplUtils ( mkCase, mkLam, newId, ) import Var ( mustHaveLocalBinding ) import VarEnv -import Id ( Id, idType, idInfo, idArity, isDataConId, - idUnfolding, setIdUnfolding, isDeadBinder, +import Id ( Id, idType, idInfo, idArity, isDataConWorkId, + setIdUnfolding, isDeadBinder, idNewDemandInfo, setIdInfo, setIdOccInfo, zapLamIdInfo, setOneShotLambda, ) +import OccName ( encodeFS ) import IdInfo ( OccInfo(..), isLoopBreaker, setArityInfo, setUnfoldingInfo, @@ -35,20 +36,20 @@ import NewDemand ( isStrictDmd ) import DataCon ( dataConNumInstArgs, dataConRepStrictness ) import CoreSyn import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, callSiteInline ) +import CoreUnfold ( mkOtherCon, mkUnfolding, callSiteInline ) import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding, exprIsConApp_maybe, mkPiTypes, findAlt, - exprType, coreAltsType, exprIsValue, - exprOkForSpeculation, exprArity, findDefault, - mkCoerce, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg + exprType, exprIsValue, + exprOkForSpeculation, exprArity, + mkCoerce, mkCoerce2, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg ) import Rules ( lookupRule ) import BasicTypes ( isMarkedStrict ) import CostCentre ( currentCCS ) -import Type ( isUnLiftedType, seqType, mkFunTy, tyConAppArgs, funArgTy, - funResultTy, splitFunTy_maybe, splitFunTy, eqType +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,6 +60,7 @@ import BasicTypes ( TopLevelFlag(..), isTopLevel, import OrdList import Maybe ( Maybe ) import Outputable +import Util ( notNull ) \end{code} @@ -246,8 +248,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} @@ -294,16 +303,22 @@ 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 in the substitution - simplLetBndr env bndr `thenSmpl` \ (env, bndr') -> - simplStrictArg AnRhs env rhs rhs_se (idType bndr') cont_ty $ \ env rhs1 -> + -- fragile occurrence info in the substitution + 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 - completeNonRecX env True {- strict -} bndr bndr' rhs1 thing_inside + let + -- simplLetBndr doesn't deal with the IdInfo, so we must + -- do so here (c.f. simplLazyBind) + bndr2 = bndr1 `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr) + env2 = modifyInScope env1 bndr2 bndr2 + in + completeNonRecX env2 True {- strict -} bndr bndr2 rhs1 thing_inside | otherwise -- Normal, lazy case = -- Don't use simplBinder because that doesn't keep - -- fragile occurrence in the substitution + -- fragile occurrence info in the substitution simplLetBndr env bndr `thenSmpl` \ (env, bndr') -> simplLazyBind env NotTopLevel NonRecursive bndr bndr' rhs rhs_se `thenSmpl` \ (floats, env) -> @@ -321,6 +336,18 @@ simplNonRecX :: SimplEnv -> SimplM FloatsWithExpr simplNonRecX env bndr new_rhs thing_inside + | needsCaseBinding (idType bndr) new_rhs + -- Make this test *before* the preInlineUnconditionally + -- Consider case I# (quotInt# x y) of + -- I# v -> let w = J# v in ... + -- If we gaily inline (quotInt# x y) for v, we end up building an + -- extra thunk: + -- let w = J# (quotInt# x y) in ... + -- because quotInt# can fail. + = simplBinder env bndr `thenSmpl` \ (env, bndr') -> + thing_inside env `thenSmpl` \ (floats, body) -> + returnSmpl (emptyFloats env, Case new_rhs bndr' [(DEFAULT, [], wrapFloats floats body)]) + | preInlineUnconditionally env NotTopLevel bndr -- This happens; for example, the case_bndr during case of -- known constructor: case (a,b) of x { (p,q) -> ... } @@ -338,11 +365,6 @@ simplNonRecX env bndr new_rhs thing_inside bndr bndr' new_rhs thing_inside completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside - | needsCaseBinding (idType new_bndr) new_rhs - = thing_inside env `thenSmpl` \ (floats, body) -> - returnSmpl (emptyFloats env, Case new_rhs new_bndr [(DEFAULT, [], wrapFloats floats body)]) - - | otherwise = mkAtomicArgs is_strict True {- OK to float unlifted -} new_rhs `thenSmpl` \ (aux_binds, rhs2) -> @@ -429,25 +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 - is_top_level = isTopLevel top_lvl - bndr_ty' = idType bndr' - bndr'' = simplIdInfo (getSubst rhs_se) (idInfo bndr) 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 bndr_ty' 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. @@ -456,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 @@ -467,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 ... @@ -486,19 +526,19 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se -- 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), + -- Hence the warning + WARN( not is_top_level && 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)) @@ -545,7 +585,7 @@ completeLazyBind :: SimplEnv -- (as usual) use the in-scope-env from the floats completeLazyBind env top_lvl old_bndr new_bndr new_rhs - | postInlineUnconditionally env new_bndr loop_breaker new_rhs + | postInlineUnconditionally env new_bndr occ_info new_rhs = -- Drop the binding tick (PostInlineUnconditionally old_bndr) `thenSmpl_` returnSmpl (emptyFloats env, extendSubst env old_bndr (DoneEx new_rhs)) @@ -671,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 -> @@ -774,12 +814,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 @@ -788,7 +830,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) @@ -819,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} @@ -895,9 +941,10 @@ 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 "After: " <+> pprCoreExpr rule_rhs, + text "Cont: " <+> ppr call_cont]) else id) $ simplExprF env rule_rhs call_cont ; @@ -908,8 +955,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 @@ -1023,11 +1070,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 @@ -1104,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 @@ -1126,7 +1176,7 @@ mkAtomicArgs is_strict ok_float_unlifted rhs | otherwise -- Don't forget to do it recursively -- E.g. x = a:b:c:[] = mkAtomicArgs is_strict ok_float_unlifted arg `thenSmpl` \ (arg_binds, arg') -> - newId SLIT("a") arg_ty `thenSmpl` \ arg_id -> + newId FSLIT("a") arg_ty `thenSmpl` \ arg_id -> go fun ((arg_binds `snocOL` (arg_id,arg')) `appOL` binds) (Var arg_id : rev_args) args where @@ -1174,7 +1224,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 @@ -1217,38 +1267,22 @@ rebuildCase env scrut case_bndr alts cont = knownCon env (LitAlt lit) [] case_bndr alts cont | otherwise - = -- Prepare case alternatives - -- Filter out alternatives that can't possibly match - let - impossible_cons = case scrut of - Var v -> otherCons (idUnfolding v) - other -> [] - better_alts = case impossible_cons of - [] -> alts - other -> [alt | alt@(con,_,_) <- alts, - not (con `elem` impossible_cons)] - - -- "handled_cons" are handled either by the context, - -- or by a branch in this case expression - -- Don't add DEFAULT to the handled_cons!! - (alts_wo_default, _) = findDefault better_alts - handled_cons = impossible_cons ++ [con | (con,_,_) <- alts_wo_default] - in - + = 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)) -> - addFloats env floats $ \ env -> + prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) -> + addFloats env floats $ \ env -> -- Deal with variable scrutinee - simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) -> + simplCaseBinder env scrut case_bndr `thenSmpl` \ (alt_env, case_bndr', zap_occ_info) -> -- Deal with the case alternatives simplAlts alt_env zap_occ_info handled_cons - case_bndr' better_alts dup_cont `thenSmpl` \ alts' -> + case_bndr' better_alts dup_cont `thenSmpl` \ alts' -> -- Put the case back together - mkCase scrut handled_cons case_bndr' alts' `thenSmpl` \ case_expr -> + mkCase scrut case_bndr' alts' `thenSmpl` \ case_expr -> -- Notice that rebuildDone returns the in-scope set from env, not alt_env -- The case binder *not* scope over the whole returned case-expression @@ -1284,10 +1318,10 @@ We'll perform the binder-swap for the outer case, giving case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } ...other cases .... } -But there is no point in doing it for the inner case, -because w1 can't be inlined anyway. Furthermore, doing the case-swapping -involves zapping w2's occurrence info (see paragraphs that follow), -and that forces us to bind w2 when doing case merging. So we get +But there is no point in doing it for the inner case, because w1 can't +be inlined anyway. Furthermore, doing the case-swapping involves +zapping w2's occurrence info (see paragraphs that follow), and that +forces us to bind w2 when doing case merging. So we get case x of w1 { A -> let w2 = w1 in e1 B -> let w2 = w1 in e2 @@ -1555,7 +1589,7 @@ mkDupableCont env (ApplyTo _ arg se cont) if exprIsDupable arg' then returnSmpl (emptyFloats env, (ApplyTo OkToDup arg' (zapSubstEnv se) dup_cont, nondup_cont)) else - newId SLIT("a") (exprType arg') `thenSmpl` \ arg_id -> + newId FSLIT("a") (exprType arg') `thenSmpl` \ arg_id -> tick (CaseOfCase arg_id) `thenSmpl_` -- Want to tick here so that we go round again, @@ -1674,14 +1708,14 @@ mkDupableAlt env case_bndr' cont alt@(con, bndrs, rhs) -- (the \v alone is enough to make CPR happy) but I think it's rare ( if null used_bndrs' - then newId SLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id -> + then newId FSLIT("w") realWorldStatePrimTy `thenSmpl` \ rw_id -> returnSmpl ([rw_id], [Var realWorldPrimId]) else returnSmpl (used_bndrs', map varToCoreExpr used_bndrs') ) `thenSmpl` \ (final_bndrs', final_args) -> -- See comment about "$j" name above - newId 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.