[commit: ghc] wip/tdammers/D4395-new: Discard reflexive casts during Simplify (dd26724)
git at git.haskell.org
git at git.haskell.org
Tue Mar 27 14:19:03 UTC 2018
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/tdammers/D4395-new
Link : http://ghc.haskell.org/trac/ghc/changeset/dd26724b23bfee3b9e18dc1dcaf519061ed6be65/ghc
>---------------------------------------------------------------
commit dd26724b23bfee3b9e18dc1dcaf519061ed6be65
Author: Richard Eisenberg <rae at cs.brynmawr.edu>
Date: Fri Jan 26 22:42:46 2018 -0500
Discard reflexive casts during Simplify
Previously, we went to great lengths to build just the right
reflexive casts, only to discard them shortly later. Now, just
skip creating reflexive casts altogether.
>---------------------------------------------------------------
dd26724b23bfee3b9e18dc1dcaf519061ed6be65
compiler/coreSyn/CoreOpt.hs | 48 ++++++++++++++++++++++++------------------
compiler/simplCore/Simplify.hs | 27 +++++++++++++++++++-----
2 files changed, 50 insertions(+), 25 deletions(-)
diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs
index 04e604e..e1eae8b 100644
--- a/compiler/coreSyn/CoreOpt.hs
+++ b/compiler/coreSyn/CoreOpt.hs
@@ -732,9 +732,11 @@ exprIsConApp_maybe (in_scope, id_unf) expr
go subst (Tick t expr) cont
| not (tickishIsCode t) = go subst expr cont
go subst (Cast expr co1) (CC args co2)
- | Just (args', co1') <- pushCoArgs (subst_co subst co1) args
+ | Just (args', m_co1') <- pushCoArgs (subst_co subst co1) args
-- See Note [Push coercions in exprIsConApp_maybe]
- = go subst expr (CC args' (co1' `mkTransCo` co2))
+ = case m_co1' of
+ Just co1' -> go subst expr (CC args' (co1' `mkTransCo` co2))
+ Nothing -> go subst expr (CC args' co2)
go subst (App fun arg) (CC args co)
= go subst fun (CC (subst_arg subst arg : args) co)
go subst (Lam var body) (CC (arg:args) co)
@@ -928,36 +930,40 @@ Here we implement the "push rules" from FC papers:
by pushing the coercion into the arguments
-}
-pushCoArgs :: Coercion -> [CoreArg] -> Maybe ([CoreArg], Coercion)
-pushCoArgs co [] = return ([], co)
-pushCoArgs co (arg:args) = do { (arg', co1) <- pushCoArg co arg
- ; (args', co2) <- pushCoArgs co1 args
- ; return (arg':args', co2) }
+pushCoArgs :: Coercion -> [CoreArg] -> Maybe ([CoreArg], Maybe Coercion)
+pushCoArgs co [] = return ([], Just co)
+pushCoArgs co (arg:args) = do { (arg', m_co1) <- pushCoArg co arg
+ ; case m_co1 of
+ Just co1 -> do { (args', m_co2) <- pushCoArgs co1 args
+ ; return (arg':args', m_co2) }
+ Nothing -> return (arg':args, Nothing) }
-pushCoArg :: Coercion -> CoreArg -> Maybe (CoreArg, Coercion)
+pushCoArg :: Coercion -> CoreArg -> Maybe (CoreArg, Maybe Coercion)
-- We have (fun |> co) arg, and we want to transform it to
-- (fun arg) |> co
-- This may fail, e.g. if (fun :: N) where N is a newtype
-- C.f. simplCast in Simplify.hs
-- 'co' is always Representational
+-- If the returned coercion is Nothing, then it would have been reflexive
+pushCoArg co (Type ty) = do { (ty', m_co') <- pushCoTyArg co ty
+ ; return (Type ty', m_co') }
+pushCoArg co val_arg = do { (arg_co, m_co') <- pushCoValArg co
+ ; return (val_arg `mkCast` arg_co, m_co') }
-pushCoArg co (Type ty) = do { (ty', co') <- pushCoTyArg co ty
- ; return (Type ty', co') }
-pushCoArg co val_arg = do { (arg_co, co') <- pushCoValArg co
- ; return (mkCast val_arg arg_co, co') }
-
-pushCoTyArg :: Coercion -> Type -> Maybe (Type, Coercion)
+pushCoTyArg :: CoercionR -> Type -> Maybe (Type, Maybe CoercionR)
-- We have (fun |> co) @ty
-- Push the coercion through to return
-- (fun @ty') |> co'
-- 'co' is always Representational
+-- If the returned coercion is Nothing, then it would have been reflexive;
+-- it's faster not to compute it, though.
pushCoTyArg co ty
| tyL `eqType` tyR
- = Just (ty, mkRepReflCo (piResultTy tyR ty))
+ = Just (ty, Nothing)
| isForAllTy tyL
= ASSERT2( isForAllTy tyR, ppr co $$ ppr ty )
- Just (ty `mkCastTy` mkSymCo co1, co2)
+ Just (ty `mkCastTy` mkSymCo co1, Just co2)
| otherwise
= Nothing
@@ -977,14 +983,16 @@ pushCoTyArg co ty
-- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ]
-- Arg of mkInstCo is always nominal, hence mkNomReflCo
-pushCoValArg :: Coercion -> Maybe (Coercion, Coercion)
+pushCoValArg :: Coercion -> Maybe (Coercion, Maybe Coercion)
-- We have (fun |> co) arg
-- Push the coercion through to return
-- (fun (arg |> co_arg)) |> co_res
-- 'co' is always Representational
+-- If the second returned Coercion is actually Nothing, then no cast is necessary;
+-- the returned coercion would have been reflexive.
pushCoValArg co
| tyL `eqType` tyR
- = Just (mkRepReflCo arg, mkRepReflCo res)
+ = Just (mkRepReflCo arg, Nothing)
| isFunTy tyL
, (co1, co2) <- decomposeFunCo co
@@ -992,12 +1000,12 @@ pushCoValArg co
-- then co1 :: tyL1 ~ tyR1
-- co2 :: tyL2 ~ tyR2
= ASSERT2( isFunTy tyR, ppr co $$ ppr arg )
- Just (mkSymCo co1, co2)
+ Just (mkSymCo co1, Just co2)
| otherwise
= Nothing
where
- (arg, res) = splitFunTy tyR
+ (arg, _) = splitFunTy tyR
Pair tyL tyR = coercionKind co
pushCoercionIntoLambda
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 53e3a21..bb7cd2c 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -1207,23 +1207,40 @@ simplCast env body co0 cont0
; cont1 <- addCoerce co1 cont0
; simplExprF env body cont1 }
where
+ -- If the first parameter is Nothing, then simplifying revealed a
+ -- reflexive coercion. Omit.
+ addCoerce0 :: Maybe OutCoercion -> SimplCont -> SimplM SimplCont
+ addCoerce0 Nothing cont = return cont
+ addCoerce0 (Just co) cont = addCoerce co cont
+
addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont
+ addCoerce co cont -- just skip reflexive casts
+ | isReflexiveCo co = {-#SCC "addCoerce-reflexive" #-}
+ return cont
+ -- It's worth checking isReflexiveCo.
+ -- For example, in the initial form of a worker
+ -- we may find (coerce T (coerce S (\x.e))) y
+ -- and we'd like it to simplify to e[y/x] in one round
+ -- of simplification
+
addCoerce co1 (CastIt co2 cont)
= addCoerce (mkTransCo co1 co2) cont
addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })
- | Just (arg_ty', co') <- pushCoTyArg co arg_ty
- = do { tail' <- addCoerce co' tail
- ; return (cont { sc_arg_ty = arg_ty', sc_cont = tail' }) }
+ | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty
+ = case m_co' of
+ Just co' -> do { tail' <- addCoerce co' tail
+ ; return (cont { sc_arg_ty = arg_ty', sc_cont = tail' }) }
+ Nothing -> return cont
addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_dup = dup, sc_cont = tail })
- | Just (co1, co2) <- pushCoValArg co
+ | Just (co1, m_co2) <- pushCoValArg co
, Pair _ new_ty <- coercionKind co1
, not (isTypeLevPoly new_ty) -- without this check, we get a lev-poly arg
-- See Note [Levity polymorphism invariants] in CoreSyn
-- test: typecheck/should_run/EtaExpandLevPoly
- = do { tail' <- addCoerce co2 tail
+ = do { tail' <- addCoerce0 m_co2 tail
; if isReflCo co1
then return (cont { sc_cont = tail' })
-- Avoid simplifying if possible;
More information about the ghc-commits
mailing list