X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=2cdc44a30e9dbf2d71c3d476bcfb861f95fdc465;hp=89c5fb188d2511dec2128f9de2c594a15032fbb8;hb=fa1c8a7e7013b1e9a37326b80abadec737c9347e;hpb=be7bf80fec1f471ceccbbe06885c265411baf25e diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 89c5fb1..2cdc44a 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -29,7 +29,7 @@ import DataCon ( dataConRepStrictness, dataConUnivTyVars ) import CoreSyn import NewDemand ( isStrictDmd ) import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkUnfolding, callSiteInline ) +import CoreUnfold ( mkUnfolding, callSiteInline, CallCtxt(..) ) import CoreUtils import Rules ( lookupRule ) import BasicTypes ( isMarkedStrict ) @@ -264,7 +264,7 @@ simplRecBind env top_lvl pairs where add_rules :: SimplEnv -> (InBndr,InExpr) -> (SimplEnv, (InBndr, OutBndr, InExpr)) -- Add the (substituted) rules to the binder - add_rules env (bndr, rhs) = (env, (bndr, bndr', rhs)) + add_rules env (bndr, rhs) = (env', (bndr, bndr', rhs)) where (env', bndr') = addBndrRules env bndr (lookupRecBndr env bndr) @@ -742,7 +742,7 @@ simplType :: SimplEnv -> InType -> SimplM OutType -- Kept monadic just so we can do the seqType simplType env ty = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $ - seqType new_ty `seq` returnSmpl new_ty + seqType new_ty `seq` return new_ty where new_ty = substTy env ty \end{code} @@ -764,7 +764,7 @@ rebuild env expr cont Stop {} -> return (env, expr) CoerceIt co cont -> rebuild env (mkCoerce co expr) cont Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont - StrictArg fun ty info cont -> rebuildCall env (fun `App` expr) (funResultTy ty) info cont + StrictArg fun ty _ info cont -> rebuildCall env (fun `App` expr) (funResultTy ty) info cont StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr ; simplLam env' bs body cont } ApplyTo _ arg se cont -> do { arg' <- simplExpr (se `setInScope` env) arg @@ -939,8 +939,8 @@ simplNote env InlineMe e cont -- (even a type application -- anything except Stop) = simplExprF env e cont -simplNote env (CoreNote s) e cont - = simplExpr env e `thenSmpl` \ e' -> +simplNote env (CoreNote s) e cont = do + e' <- simplExpr env e rebuild env (Note (CoreNote s) e') cont \end{code} @@ -1009,8 +1009,8 @@ completeCall env var cont Just act_fn -> lookupRule act_fn in_scope rules var args ; case maybe_rule of { - Just (rule, rule_rhs) -> - tick (RuleFired (ru_name rule)) `thenSmpl_` + Just (rule, rule_rhs) -> do + tick (RuleFired (ru_name rule)) (if dopt Opt_D_dump_rule_firings dflags then pprTrace "Rule fired" (vcat [ text "Rule:" <+> ftext (ru_name rule), @@ -1019,20 +1019,18 @@ completeCall env var cont text "Cont: " <+> ppr call_cont]) else id) $ - simplExprF env rule_rhs (dropArgs (ruleArity rule) cont) - -- The ruleArity says how many args the rule consumed + simplExprF env rule_rhs (dropArgs (ruleArity rule) cont) + -- The ruleArity says how many args the rule consumed ; Nothing -> do -- No rules ------------- Next try inlining ---------------- { let arg_infos = [interestingArg arg | arg <- args, isValArg arg] n_val_args = length arg_infos - interesting_cont = interestingCallContext (notNull args) - (notNull arg_infos) - call_cont + interesting_cont = interestingCallContext call_cont active_inline = activeInline env var - maybe_inline = callSiteInline dflags active_inline - var arg_infos interesting_cont + maybe_inline = callSiteInline dflags active_inline var + (null args) arg_infos interesting_cont ; case maybe_inline of { Just unfolding -- There is an inlining! -> do { tick (UnfoldingDone var) @@ -1056,10 +1054,10 @@ completeCall env var cont rebuildCall :: SimplEnv -> OutExpr -> OutType -- Function and its type - -> (Bool, [Bool]) -- See SimplUtils.mkArgInfo + -> ArgInfo -> SimplCont -> SimplM (SimplEnv, OutExpr) -rebuildCall env fun fun_ty (has_rules, []) cont +rebuildCall env fun fun_ty (ArgInfo { ai_strs = [] }) cont -- When we run out of strictness args, it means -- that the call is definitely bottom; see SimplUtils.mkArgInfo -- Then we want to discard the entire strict continuation. E.g. @@ -1082,11 +1080,13 @@ rebuildCall env fun fun_ty info (ApplyTo _ (Type arg_ty) se cont) = do { ty' <- simplType (se `setInScope` env) arg_ty ; rebuildCall env (fun `App` Type ty') (applyTy fun_ty ty') info cont } -rebuildCall env fun fun_ty (has_rules, str:strs) (ApplyTo _ arg arg_se cont) +rebuildCall env fun fun_ty + (ArgInfo { ai_rules = has_rules, ai_strs = str:strs, ai_discs = disc:discs }) + (ApplyTo _ arg arg_se cont) | str || isStrictType arg_ty -- Strict argument = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setFloats` env) arg - (StrictArg fun fun_ty (has_rules, strs) cont) + (StrictArg fun fun_ty cci arg_info' cont) -- Note [Shadowing] | otherwise -- Lazy argument @@ -1095,10 +1095,13 @@ rebuildCall env fun fun_ty (has_rules, str:strs) (ApplyTo _ arg arg_se cont) -- have to be very careful about bogus strictness through -- floating a demanded let. = do { arg' <- simplExprC (arg_se `setInScope` env) arg - (mkLazyArgStop arg_ty has_rules) - ; rebuildCall env (fun `App` arg') res_ty (has_rules, strs) cont } + (mkLazyArgStop arg_ty cci) + ; rebuildCall env (fun `App` arg') res_ty arg_info' cont } where (arg_ty, res_ty) = splitFunTy fun_ty + arg_info' = ArgInfo { ai_rules = has_rules, ai_strs = strs, ai_discs = discs } + cci | has_rules || disc > 0 = ArgCtxt has_rules disc -- Be keener here + | otherwise = BoringCtxt -- Nothing interesting rebuildCall env fun fun_ty info cont = rebuild env fun cont @@ -1331,7 +1334,7 @@ where x::F Int. Then we'd like to rewrite (F Int) to Int, getting I# x# -> let x = x' `cast` sym co in rhs -so that 'rhs' can take advantage of hte form of x'. Notice that Note +so that 'rhs' can take advantage of the form of x'. Notice that Note [Case of cast] may then apply to the result. This showed up in Roman's experiments. Example: @@ -1467,7 +1470,7 @@ simplCaseBinder env scrut case_bndr alts -- See Note [no-case-of-case] = (env, case_bndr) - | otherwise -- Failed try [see Note 2 above] + | otherwise -- Failed try; see Note [Suppressing the case binder-swap] -- not (isEvaldUnfolding (idUnfolding v)) = case scrut of Var v -> (modifyInScope env1 v case_bndr', case_bndr') @@ -1545,7 +1548,7 @@ simplAlts env scrut case_bndr alts cont' do { let alt_env = zapFloats env ; (alt_env, scrut', case_bndr') <- simplCaseBinder alt_env scrut case_bndr alts - ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut case_bndr' alts + ; (imposs_deflt_cons, in_alts) <- prepareAlts alt_env scrut case_bndr' alts ; alts' <- mapM (simplAlt alt_env imposs_deflt_cons case_bndr' cont') in_alts ; return (scrut', case_bndr', alts') } @@ -1574,19 +1577,19 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (LitAlt lit, bndrs, rhs) simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs) = do { -- Deal with the pattern-bound variables - (env, vs') <- simplBinders env (add_evals con vs) - -- Mark the ones that are in ! positions in the -- data constructor as certainly-evaluated. - ; let vs'' = add_evals con vs' + -- NB: simplLamBinders preserves this eval info + let vs_with_evals = add_evals vs (dataConRepStrictness con) + ; (env, vs') <- simplLamBndrs env vs_with_evals -- Bind the case-binder to (con args) ; let inst_tys' = tyConAppArgs (idType case_bndr') - con_args = map Type inst_tys' ++ varsToCoreExprs vs'' + con_args = map Type inst_tys' ++ varsToCoreExprs vs' env' = addBinderUnfolding env case_bndr' (mkConApp con con_args) ; rhs' <- simplExprC env' rhs cont' - ; return (DataAlt con, vs'', rhs') } + ; return (DataAlt con, vs', rhs') } where -- add_evals records the evaluated-ness of the bound variables of -- a case pattern. This is *important*. Consider @@ -1597,9 +1600,7 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs) -- We really must record that b is already evaluated so that we don't -- go and re-evaluate it when constructing the result. -- See Note [Data-con worker strictness] in MkId.lhs - add_evals dc vs = cat_evals dc vs (dataConRepStrictness dc) - - cat_evals dc vs strs + add_evals vs strs = go vs strs where go [] [] = [] @@ -1610,12 +1611,15 @@ simplAlt env imposs_deflt_cons case_bndr' cont' (DataAlt con, vs, rhs) where zapped_v = zap_occ_info v evald_v = zapped_v `setIdUnfolding` evaldUnfolding - go _ _ = pprPanic "cat_evals" (ppr dc $$ ppr vs $$ ppr strs) + go _ _ = pprPanic "cat_evals" (ppr con $$ ppr vs $$ ppr strs) - -- If the case binder is alive, then we add the unfolding + -- zap_occ_info: if the case binder is alive, then we add the unfolding -- case_bndr = C vs -- to the envt; so vs are now very much alive - -- Note [Aug06] I can't see why this actually matters + -- Note [Aug06] I can't see why this actually matters, but it's neater + -- case e of t { (a,b) -> ...(case t of (p,q) -> p)... } + -- ==> case e of t { (a,b) -> ...(a)... } + -- Look, Ma, a is alive now. zap_occ_info | isDeadBinder case_bndr' = \id -> id | otherwise = zapOccInfo @@ -1741,7 +1745,7 @@ mkDupableCont :: SimplEnv -> SimplCont mkDupableCont env cont | contIsDupable cont - = returnSmpl (env, cont, mkBoringStop (contResultType cont)) + = return (env, cont, mkBoringStop (contResultType cont)) mkDupableCont env (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn @@ -1753,7 +1757,7 @@ mkDupableCont env cont@(StrictBind bndr _ _ se _) = return (env, mkBoringStop (substTy se (idType bndr)), cont) -- See Note [Duplicating strict continuations] -mkDupableCont env cont@(StrictArg _ fun_ty _ _) +mkDupableCont env cont@(StrictArg _ fun_ty _ _ _) = return (env, mkBoringStop (funArgTy fun_ty), cont) -- See Note [Duplicating strict continuations]