X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSimplify.lhs;h=b3e6bf7cf4e4aabdb35f5f2fb2a67adb351ed2c1;hp=7c4a2ce86940982c912716a6006423a6840faecb;hb=d5934bbb856aa0aa620c9b2e0fa51c90a1a5a048;hpb=c248518fe81b6d2807d3bcbb8a09ae14facce1ad diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index 7c4a2ce..b3e6bf7 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -26,10 +26,8 @@ import Id ( Id, idType, idInfo, idArity, isDataConWorkId, idNewDemandInfo, setIdInfo, setIdOccInfo, zapLamIdInfo, setOneShotLambda ) -import IdInfo ( OccInfo(..), isLoopBreaker, - setArityInfo, zapDemandInfo, - setUnfoldingInfo, - occInfo +import IdInfo ( OccInfo(..), setArityInfo, zapDemandInfo, + setUnfoldingInfo, occInfo ) import NewDemand ( isStrictDmd ) import TcGadt ( dataConCanMatch ) @@ -58,7 +56,7 @@ import VarEnv ( elemVarEnv, emptyVarEnv ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) import BasicTypes ( TopLevelFlag(..), isTopLevel, - RecFlag(..), isNonRec + RecFlag(..), isNonRec, isNonRuleLoopBreaker ) import OrdList import List ( nub ) @@ -372,7 +370,6 @@ completeNonRecX env is_strict old_bndr new_bndr new_rhs thing_inside | otherwise = -- Make the arguments atomic if necessary, -- adding suitable bindings - -- pprTrace "completeNonRecX" (ppr new_bndr <+> ppr new_rhs) $ mkAtomicArgsE env is_strict new_rhs $ \ env new_rhs -> completeLazyBind env NotTopLevel old_bndr new_bndr new_rhs `thenSmpl` \ (floats, env) -> @@ -491,8 +488,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se else -- ANF-ise a constructor or PAP rhs - mkAtomicArgs False {- Not strict -} - ok_float_unlifted rhs1 `thenSmpl` \ (aux_binds, rhs2) -> + mkAtomicArgs ok_float_unlifted rhs1 `thenSmpl` \ (aux_binds, rhs2) -> -- If the result is a PAP, float the floats out, else wrap them -- By this time it's already been ANF-ised (if necessary) @@ -600,14 +596,17 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs | otherwise = let - -- Add arity info + -- Arity info new_bndr_info = idInfo new_bndr `setArityInfo` exprArity new_rhs + -- Unfolding info -- 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 + + -- Demand info -- If the unfolding is a value, the demand info may -- go pear-shaped, so we nuke it. Example: -- let x = (a,b) in @@ -618,7 +617,7 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs -- 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 + -- After inlining 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... info_w_unf = new_bndr_info `setUnfoldingInfo` unfolding @@ -635,7 +634,7 @@ completeLazyBind env top_lvl old_bndr new_bndr new_rhs returnSmpl (unitFloat env final_id new_rhs, env) where unfolding = mkUnfolding (isTopLevel top_lvl) new_rhs - loop_breaker = isLoopBreaker occ_info + loop_breaker = isNonRuleLoopBreaker occ_info old_info = idInfo old_bndr occ_info = occInfo old_info \end{code} @@ -912,6 +911,14 @@ simplNote env InlineMe e cont simplNote env (CoreNote s) e cont = simplExpr env e `thenSmpl` \ e' -> rebuild env (Note (CoreNote s) e') cont + +simplNote env note@(TickBox {}) e cont + = simplExpr env e `thenSmpl` \ e' -> + rebuild env (Note note e') cont + +simplNote env note@(BinaryTickBox {}) e cont + = simplExpr env e `thenSmpl` \ e' -> + rebuild env (Note note e') cont \end{code} @@ -926,7 +933,7 @@ simplVar env var cont = case substId env var of DoneEx e -> simplExprF (zapSubstEnv env) e cont ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont - DoneId var1 occ -> completeCall (zapSubstEnv env) var1 occ cont + DoneId var1 -> completeCall (zapSubstEnv env) var1 cont -- Note [zapSubstEnv] -- The template is already simplified, so don't re-substitute. -- This is VITAL. Consider @@ -940,7 +947,7 @@ simplVar env var cont --------------------------------------------------------- -- Dealing with a call site -completeCall env var occ_info cont +completeCall env var cont = -- Simplify the arguments getDOptsSmpl `thenSmpl` \ dflags -> let @@ -1005,8 +1012,8 @@ completeCall env var occ_info cont interesting_cont = interestingCallContext (notNull args) (notNull arg_infos) call_cont - active_inline = activeInline env var occ_info - maybe_inline = callSiteInline dflags active_inline occ_info + active_inline = activeInline env var + maybe_inline = callSiteInline dflags active_inline var arg_infos interesting_cont in case maybe_inline of { @@ -1015,7 +1022,7 @@ completeCall env var occ_info cont (if dopt Opt_D_dump_inlinings dflags then pprTrace "Inlining done" (vcat [ text "Before:" <+> ppr var <+> sep (map pprParendExpr args), - text "Inlined fn: " <+> ppr unfolding, + text "Inlined fn: " $$ nest 2 (ppr unfolding), text "Cont: " <+> ppr call_cont]) else id) $ @@ -1153,7 +1160,6 @@ N Y Non-top-level and non-recursive, Bind args of lifted type, or Y Y Non-top-level, non-recursive, Bind all args and strict (demanded) - For example, given x = MkC (y div# z) @@ -1166,13 +1172,44 @@ because the (y div# z) can't float out of the let. But if it was a *strict* let, then it would be a good thing to do. Hence the context information. +Note [Float coercions] +~~~~~~~~~~~~~~~~~~~~~~ +When we find the binding + x = e `cast` co +we'd like to transform it to + x' = e + x = x `cast` co -- A trivial binding +There's a chance that e will be a constructor application or function, or something +like that, so moving the coerion to the usage site may well cancel the coersions +and lead to further optimisation. Example: + + data family T a :: * + data instance T Int = T Int + + foo :: Int -> Int -> Int + foo m n = ... + where + x = T m + go 0 = 0 + go n = case x of { T m -> go (n-m) } + -- This case should optimise + \begin{code} mkAtomicArgsE :: SimplEnv - -> Bool -- A strict binding - -> OutExpr -- The rhs + -> Bool -- A strict binding + -> OutExpr -- The rhs -> (SimplEnv -> OutExpr -> SimplM FloatsWithExpr) + -- Consumer for the simpler rhs -> SimplM FloatsWithExpr +mkAtomicArgsE env is_strict (Cast rhs co) thing_inside + | not (exprIsTrivial rhs) + -- Note [Float coersions] + -- See also Note [Take care] below + = do { id <- newId FSLIT("a") (exprType rhs) + ; completeNonRecX env False id id rhs $ \ env -> + thing_inside env (Cast (substExpr env (Var id)) co) } + mkAtomicArgsE env is_strict rhs thing_inside | (Var fun, args) <- collectArgs rhs, -- It's an application isDataConWorkId fun || valArgCount args < idArity fun -- And it's a constructor or PAP @@ -1191,7 +1228,18 @@ mkAtomicArgsE env is_strict rhs thing_inside | otherwise = do { arg_id <- newId FSLIT("a") arg_ty ; completeNonRecX env False {- pessimistic -} arg_id arg_id arg $ \env -> - go env (App fun (Var arg_id)) args } + go env (App fun (substExpr env (Var arg_id))) args } + -- Note [Take care]: + -- If completeNonRecX was to do a postInlineUnconditionally + -- (undoing the effect of introducing the let-binding), we'd find arg_id had + -- no binding; hence the substExpr. This happens if we see + -- C (D x `cast` g) + -- Then we start by making a variable a1, thus + -- let a1 = D x `cast` g in C a1 + -- But then we deal with the rhs of a1, getting + -- let a2 = D x, a1 = a1 `cast` g in C a1 + -- And now the preInlineUnconditionally kicks in, and we substitute for a1 + where arg_ty = exprType arg no_float_arg = not is_strict && (isUnLiftedType arg_ty) && not (exprOkForSpeculation arg) @@ -1199,14 +1247,20 @@ mkAtomicArgsE env is_strict rhs thing_inside -- Old code: consider rewriting to be more like mkAtomicArgsE -mkAtomicArgs :: Bool -- A strict binding - -> Bool -- OK to float unlifted args +mkAtomicArgs :: Bool -- OK to float unlifted args -> OutExpr -> SimplM (OrdList (OutId,OutExpr), -- The floats (unusually) may include OutExpr) -- things that need case-binding, -- if the strict-binding flag is on -mkAtomicArgs is_strict ok_float_unlifted rhs +mkAtomicArgs ok_float_unlifted (Cast rhs co) + | not (exprIsTrivial rhs) + -- Note [Float coersions] + = do { id <- newId FSLIT("a") (exprType rhs) + ; (binds, rhs') <- mkAtomicArgs ok_float_unlifted rhs + ; return (binds `snocOL` (id, rhs'), Cast (Var id) co) } + +mkAtomicArgs ok_float_unlifted rhs | (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 @@ -1228,14 +1282,13 @@ 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 FSLIT("a") arg_ty `thenSmpl` \ arg_id -> + = mkAtomicArgs ok_float_unlifted arg `thenSmpl` \ (arg_binds, arg') -> + 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 arg_ty = exprType arg - can_float_arg = is_strict - || not (isUnLiftedType arg_ty) + can_float_arg = not (isUnLiftedType arg_ty) || (ok_float_unlifted && exprOkForSpeculation arg) @@ -1341,8 +1394,8 @@ try to eliminate uses of v in the RHSs in favour of case_bndr; that way, there's a chance that v will now only be used once, and hence inlined. -Note 1 -~~~~~~ +Note [no-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~ There is a time we *don't* want to do that, namely when -fno-case-of-case is on. This happens in the first simplifier pass, and enhances full laziness. Here's the bad case: @@ -1353,6 +1406,15 @@ in action in spectral/cichelli/Prog.hs: [(m,n) | m <- [1..max], n <- [1..max]] Hence the check for NoCaseOfCase. +Note [Case of cast] +~~~~~~~~~~~~~~~~~~~ +Consider case (v `cast` co) of x { I# -> + ... (case (v `cast` co) of {...}) ... +We'd like to eliminate the inner case. We can get this neatly by +arranging that inside the outer case we add the unfolding + v |-> x `cast` (sym co) +to v. Then we should inline v at the inner case, cancel the casts, and away we go + Note 2 ~~~~~~ There is another situation when we don't want to do it. If we have @@ -1391,8 +1453,8 @@ eliminate the last case, we must either make sure that x (as well as x1) has unfolding MkT y1. THe straightforward thing to do is to do the binder-swap. So this whole note is a no-op. -Note 3 -~~~~~~ +Note [zapOccInfo] +~~~~~~~~~~~~~~~~~ If we replace the scrutinee, v, by tbe case binder, then we have to nuke any occurrence info (eg IAmDead) in the case binder, because the case-binder now effectively occurs whenever v does. AND we have to do @@ -1418,23 +1480,31 @@ after the outer case, and that makes (a,b) alive. At least we do unless the case binder is guaranteed dead. \begin{code} -simplCaseBinder env (Var v) case_bndr - | not (switchIsOn (getSwitchChecker env) NoCaseOfCase) +simplCaseBinder env scrut case_bndr + | switchIsOn (getSwitchChecker env) NoCaseOfCase + -- See Note [no-case-of-case] + = do { (env, case_bndr') <- simplBinder env case_bndr + ; return (env, case_bndr') } +simplCaseBinder env (Var v) case_bndr -- Failed try [see Note 2 above] -- not (isEvaldUnfolding (idUnfolding v)) - - = simplBinder env (zapOccInfo case_bndr) `thenSmpl` \ (env, case_bndr') -> - returnSmpl (modifyInScope env v case_bndr', case_bndr') + = do { (env, case_bndr') <- simplBinder env (zapOccInfo case_bndr) + ; return (modifyInScope env v case_bndr', case_bndr') } -- We could extend the substitution instead, but it would be -- a hack because then the substitution wouldn't be idempotent -- any more (v is an OutId). And this does just as well. +simplCaseBinder env (Cast (Var v) co) case_bndr -- Note [Case of cast] + = do { (env, case_bndr') <- simplBinder env (zapOccInfo case_bndr) + ; let rhs = Cast (Var case_bndr') (mkSymCoercion co) + ; return (addBinderUnfolding env v rhs, case_bndr') } + simplCaseBinder env other_scrut case_bndr - = simplBinder env case_bndr `thenSmpl` \ (env, case_bndr') -> - returnSmpl (env, case_bndr') + = do { (env, case_bndr') <- simplBinder env case_bndr + ; return (env, case_bndr') } -zapOccInfo :: InId -> InId +zapOccInfo :: InId -> InId -- See Note [zapOccInfo] zapOccInfo b = b `setIdOccInfo` NoOccInfo \end{code} @@ -1565,7 +1635,7 @@ simplDefault env case_bndr' imposs_cons cont (Just rhs) cant_match tys data_con = not (dataConCanMatch data_con tys) simplify_default imposs_cons - = do { let env' = mk_rhs_env env case_bndr' (mkOtherCon imposs_cons) + = do { let env' = addBinderOtherCon env case_bndr' imposs_cons -- Record the constructors that the case-binder *can't* be. ; rhs' <- simplExprC env' rhs cont ; return [(DEFAULT, [], rhs')] } @@ -1593,7 +1663,7 @@ simplAlt env handled_cons case_bndr' cont' (DEFAULT, bndrs, rhs) simplExprC env' rhs cont' `thenSmpl` \ rhs' -> returnSmpl (Just (emptyVarEnv, (DEFAULT, [], rhs'))) where - env' = mk_rhs_env env case_bndr' (mkOtherCon handled_cons) + env' = addBinderOtherCon env case_bndr' handled_cons -- Record the constructors that the case-binder *can't* be. simplAlt env handled_cons case_bndr' cont' (LitAlt lit, bndrs, rhs) @@ -1601,7 +1671,7 @@ simplAlt env handled_cons case_bndr' cont' (LitAlt lit, bndrs, rhs) simplExprC env' rhs cont' `thenSmpl` \ rhs' -> returnSmpl (Just (emptyVarEnv, (LitAlt lit, [], rhs'))) where - env' = mk_rhs_env env case_bndr' (mkUnfolding False (Lit lit)) + env' = addBinderUnfolding env case_bndr' (Lit lit) simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs) = -- Deal with the pattern-bound variables @@ -1613,10 +1683,9 @@ simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs) simplBinders env (add_evals con vs) `thenSmpl` \ (env, vs') -> -- Bind the case-binder to (con args) - let unf = mkUnfolding False (mkConApp con con_args) - inst_tys' = tyConAppArgs (idType case_bndr') + let inst_tys' = tyConAppArgs (idType case_bndr') con_args = map Type inst_tys' ++ varsToCoreExprs vs' - env' = mk_rhs_env env case_bndr' unf + env' = addBinderUnfolding env case_bndr' (mkConApp con con_args) in simplExprC env' rhs cont' `thenSmpl` \ rhs' -> returnSmpl (Just (emptyVarEnv, (DataAlt con, vs', rhs'))) @@ -1651,8 +1720,13 @@ simplAlt env handled_cons case_bndr' cont' (DataAlt con, vs, rhs) zap_occ_info | isDeadBinder case_bndr' = \id -> id | otherwise = zapOccInfo -mk_rhs_env env case_bndr' case_bndr_unf - = modifyInScope env case_bndr' (case_bndr' `setIdUnfolding` case_bndr_unf) +addBinderUnfolding :: SimplEnv -> Id -> CoreExpr -> SimplEnv +addBinderUnfolding env bndr rhs + = modifyInScope env bndr (bndr `setIdUnfolding` mkUnfolding False rhs) + +addBinderOtherCon :: SimplEnv -> Id -> [AltCon] -> SimplEnv +addBinderOtherCon env bndr cons + = modifyInScope env bndr (bndr `setIdUnfolding` mkOtherCon cons) \end{code} @@ -1732,7 +1806,7 @@ bind_args env dead_bndr (b:bs) (arg : args) thing_inside -- Note that the binder might be "dead", because it doesn't occur -- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally -- Nevertheless we must keep it if the case-binder is alive, because it may - -- be used in teh con_app + -- be used in the con_app. See Note [zapOccInfo] in simplNonRecX env b' arg $ \ env -> bind_args env dead_bndr bs args thing_inside