[commit: ghc] wip/tdammers/T11735: Discard reflexive casts during Simplify (b595f99)
git at git.haskell.org
git at git.haskell.org
Sat Jan 27 03:58:18 UTC 2018
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/tdammers/T11735
Link : http://ghc.haskell.org/trac/ghc/changeset/b595f99b64c8c505d4b68bd408daf3e6ccf558b6/ghc
>---------------------------------------------------------------
commit b595f99b64c8c505d4b68bd408daf3e6ccf558b6
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.
>---------------------------------------------------------------
b595f99b64c8c505d4b68bd408daf3e6ccf558b6
compiler/coreSyn/CoreOpt.hs | 44 +++++++++++++++++++++++++-----------------
compiler/simplCore/Simplify.hs | 39 +++++++++++++++++++++++--------------
2 files changed, 50 insertions(+), 33 deletions(-)
diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs
index 440d7c5..d4ddd84 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 :: CoercionR -> [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 :: CoercionR -> [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 :: CoercionR -> CoreArg -> Maybe (CoreArg, Coercion)
+pushCoArg :: CoercionR -> 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 :: CoercionR -> Maybe (Coercion, Coercion)
+pushCoValArg :: CoercionR -> 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 Representational co
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 19cbe2e..3d94dae 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -1225,26 +1225,43 @@ simplCast env body co0 cont0
; cont1 <- {-#SCC "simplCast-addCoerce" #-} addCoerce co1 cont0
; {-#SCC "simplCast-simplExprF" #-} 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 = 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)
= {-#SCC "addCoerce-simple-recursion" #-}
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
+ | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty
= {-#SCC "addCoerce-pushCoTyArg" #-}
- do { tail' <- addCoerce co' tail
- ; return (cont { sc_arg_ty = arg_ty', sc_cont = tail' }) }
+ 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
= {-#SCC "addCoerce-pushCoValArg" #-}
- do { tail' <- addCoerce co2 tail
+ do { tail' <- addCoerce0 m_co2 tail
; if isReflCo co1
then return (cont { sc_cont = tail' })
-- Avoid simplifying if possible;
@@ -1261,16 +1278,8 @@ simplCast env body co0 cont0
, sc_dup = dup'
, sc_cont = tail' }) } }
- addCoerce co cont
- | isReflexiveCo co = {-#SCC "addCoerce-reflexive" #-}
- return cont
- | otherwise = {-#SCC "addCoerce-other" #-}
- return (CastIt co 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 co cont = {-#SCC "addCoerce-other" #-}
+ return (CastIt co cont)
simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr
-> SimplM (DupFlag, StaticEnv, OutExpr)
More information about the ghc-commits
mailing list