Commit 181516bc authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Marge Bot

Fix a buglet in Simplify.simplCast

This bug, revealed by #18347, is just a missing update to
sc_hole_ty in simplCast.  I'd missed a code path when I
made the recentchanges in

    commit 6d49d5be
    Author: Simon Peyton Jones <simonpj@microsoft.com>
    Date:   Thu May 21 12:53:35 2020 +0100

    Implement cast worker/wrapper properly

The fix is very easy.

Two other minor changes

* Tidy up in SimpleOpt.simple_opt_expr. In fact I think this is an
  outright bug, introduced in the fix to #18112: we were simplifying
  the same coercion twice *with the same substitution*, which is just
  wrong.  It'd be a hard bug to trigger, so I just fixed it; less code
  too.

* Better debug printing of ApplyToVal
parent a2a9006b
Pipeline #21358 passed with stages
in 454 minutes and 43 seconds
......@@ -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
......
......@@ -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 })
......
......@@ -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)
......@@ -266,6 +260,9 @@ simple_opt_expr env expr
e' = go e
(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)
......@@ -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
......
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
......@@ -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'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment