diff options
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 3 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Utils.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Core/SimpleOpt.hs | 24 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T18347.hs | 10 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 1 |
5 files changed, 32 insertions, 13 deletions
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 81cf962d91..dba4362a81 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -1456,7 +1456,8 @@ simplCast env body co0 cont0 = {-#SCC "addCoerce-pushCoValArg" #-} do { tail' <- addCoerceM m_co2 tail ; if isReflCo co1 - then return (cont { sc_cont = tail' }) + then return (cont { sc_cont = tail' + , sc_hole_ty = coercionLKind co }) -- Avoid simplifying if possible; -- See Note [Avoiding exponential behaviour] else do diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 5f2db4508d..eca8f0a474 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -221,9 +221,10 @@ instance Outputable SimplCont where ppr (TickIt t cont) = (text "TickIt" <+> ppr t) $$ ppr cont ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont }) = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont - ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont }) - = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg) - $$ ppr cont + ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty }) + = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole" <+> ppr hole_ty) + 2 (pprParendExpr arg)) + $$ ppr cont ppr (StrictBind { sc_bndr = b, sc_cont = cont }) = (text "StrictBind" <+> ppr b) $$ ppr cont ppr (StrictArg { sc_fun = ai, sc_cont = cont }) diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 87ad9e69c5..9901f752b1 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -213,6 +213,7 @@ simple_opt_expr env expr in_scope = substInScope subst in_scope_env = (in_scope, simpleUnfoldingFun) + --------------- go (Var v) | Just clo <- lookupVarEnv (soe_inl env) v = simple_opt_clo env clo @@ -221,17 +222,10 @@ simple_opt_expr env expr go (App e1 e2) = simple_app env e1 [(env,e2)] go (Type ty) = Type (substTy subst ty) - go (Coercion co) = Coercion (optCoercion (soe_dflags env) (getTCvSubst subst) co) + go (Coercion co) = Coercion (go_co co) go (Lit lit) = Lit lit go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) - go (Cast e co) = case go e of - -- flatten nested casts before calling the coercion optimizer; - -- see #18112 (note that mkCast handles dropping Refl coercions) - Cast e' co' -> mkCast e' (opt_co (mkTransCo co' co)) - e' -> mkCast e' (opt_co co) - where - opt_co = optCoercion (soe_dflags env) (getTCvSubst subst) - + go (Cast e co) = mk_cast (go e) (go_co co) go (Let bind body) = case simple_opt_bind env bind NotTopLevel of (env', Nothing) -> simple_opt_expr env' body (env', Just bind) -> Let bind (simple_opt_expr env' body) @@ -267,6 +261,9 @@ simple_opt_expr env expr (env', b') = subst_opt_bndr env b ---------------------- + go_co co = optCoercion (soe_dflags env) (getTCvSubst subst) co + + ---------------------- go_alt env (con, bndrs, rhs) = (con, bndrs', simple_opt_expr env' rhs) where @@ -285,6 +282,15 @@ simple_opt_expr env expr bs = reverse bs' e' = simple_opt_expr env e +mk_cast :: CoreExpr -> CoercionR -> CoreExpr +-- Like GHC.Core.Utils.mkCast, but does a full reflexivity check. +-- mkCast doesn't do that because the Simplifier does (in simplCast) +-- But in SimpleOpt it's nice to kill those nested casts (#18112) +mk_cast (Cast e co1) co2 = mk_cast e (co1 `mkTransCo` co2) +mk_cast (Tick t e) co = Tick t (mk_cast e co) +mk_cast e co | isReflexiveCo co = e + | otherwise = Cast e co + ---------------------- -- simple_app collects arguments for beta reduction simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr diff --git a/testsuite/tests/simplCore/should_compile/T18347.hs b/testsuite/tests/simplCore/should_compile/T18347.hs new file mode 100644 index 0000000000..50ecf461fa --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T18347.hs @@ -0,0 +1,10 @@ +module T18347 (function) where + +import Data.Coerce + +newtype All = All Bool + +data Encoding = Encoding (Char -> Bool) + +function :: Encoding -> Char -> All +function enc v = coerce (case enc of Encoding x -> x) v diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 4c301cd6f2..ea77a92c36 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -328,3 +328,4 @@ test('T18231', [ only_ways(['optasm']), grep_errmsg(r'^[\w\.]+ ::.*->.*') ], com # Cast WW test('T17673', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999']) test('T18078', [ only_ways(['optasm']), grep_errmsg(r'^\w+\.\$wf') ], compile, ['-ddump-simpl -dsuppress-uniques -dppr-cols=9999']) +test('T18347', normal, compile, ['-dcore-lint -O']) |