diff options
Diffstat (limited to 'compiler/GHC/Core/Opt/Simplify.hs')
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 38 |
1 files changed, 22 insertions, 16 deletions
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index e219a0dba9..6c207766bd 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -51,9 +51,9 @@ import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Utils import GHC.Core.Opt.Arity ( ArityType(..), arityTypeArity, isBotArityType + , pushCoTyArg, pushCoValArg , idArityType, etaExpandAT ) -import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg - , joinPointBinding_maybe, joinPointBindings_maybe ) +import GHC.Core.SimpleOpt ( joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs ( mkRuleInfo ) import GHC.Core.Rules ( lookupRule, getRules, initRuleOpts ) import GHC.Types.Basic @@ -318,7 +318,7 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont - -- Never float join-floats out of a non-join let-binding + -- Never float join-floats out of a non-join let-binding (which this is) -- So wrap the body in the join-floats right now -- Hence: body_floats1 consists only of let-floats ; let (body_floats1, body1) = wrapJoinFloatsX body_floats0 body0 @@ -1414,25 +1414,23 @@ simplCast env body co0 cont0 -- type of the hole changes (#16312) -- (f |> co) e ===> (f (e |> co1)) |> co2 - -- where co :: (s1->s2) ~ (t1~t2) + -- where co :: (s1->s2) ~ (t1->t2) -- co1 :: t1 ~ s1 -- co2 :: s2 ~ t2 addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_dup = dup, sc_cont = tail }) - | Just (co1, m_co2) <- pushCoValArg co - , let new_ty = coercionRKind co1 - , not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg - -- See Note [Levity polymorphism invariants] in GHC.Core - -- test: typecheck/should_run/EtaExpandLevPoly + | Just (m_co1, m_co2) <- pushCoValArg co + , levity_ok m_co1 = {-#SCC "addCoerce-pushCoValArg" #-} do { tail' <- addCoerceM m_co2 tail - ; if isReflCo co1 - then return (cont { sc_cont = tail' - , sc_hole_ty = coercionLKind co }) + ; case m_co1 of { + MRefl -> return (cont { sc_cont = tail' + , sc_hole_ty = coercionLKind co }) ; -- Avoid simplifying if possible; -- See Note [Avoiding exponential behaviour] - else do - { (dup', arg_se', arg') <- simplArg env dup arg_se arg + + MCo co1 -> + do { (dup', arg_se', arg') <- simplArg env dup arg_se arg -- When we build the ApplyTo we can't mix the OutCoercion -- 'co' with the InExpr 'arg', so we simplify -- to make it all consistent. It's a bit messy. @@ -1442,7 +1440,7 @@ simplCast env body co0 cont0 , sc_env = arg_se' , sc_dup = dup' , sc_cont = tail' - , sc_hole_ty = coercionLKind co }) } } + , sc_hole_ty = coercionLKind co }) } } } addCoerce co cont | isReflexiveCo co = return cont -- Having this at the end makes a huge @@ -1450,6 +1448,13 @@ simplCast env body co0 cont0 -- See Note [Optimising reflexivity] | otherwise = return (CastIt co cont) + levity_ok :: MCoercionR -> Bool + levity_ok MRefl = True + levity_ok (MCo co) = not $ isTypeLevPoly $ coercionRKind co + -- Without this check, we get a lev-poly arg + -- See Note [Levity polymorphism invariants] in GHC.Core + -- test: typecheck/should_run/EtaExpandLevPoly + simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr -> SimplM (DupFlag, StaticEnv, OutExpr) simplArg env dup_flag arg_env arg @@ -3114,7 +3119,7 @@ knownCon :: SimplEnv knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont = do { (floats1, env1) <- bind_args env bs dc_args - ; (floats2, env2) <- bind_case_bndr env1 + ; (floats2, env2) <- bind_case_bndr env1 ; (floats3, expr') <- simplExprF env2 rhs cont ; case dc_floats of [] -> @@ -3240,6 +3245,7 @@ altsWouldDup [_] = False altsWouldDup (alt:alts) | is_bot_alt alt = altsWouldDup alts | otherwise = not (all is_bot_alt alts) + -- otherwise case: first alt is non-bot, so all the rest must be bot where is_bot_alt (_,_,rhs) = exprIsDeadEnd rhs |