Commit 7bb7f991 authored by Richard Eisenberg's avatar Richard Eisenberg Committed by Ben Gamari

Discard reflexive casts during Simplify

Trac #14735 (derived from Trac #11735) found that 75% of compile
time was being spent in simplCast. This patch is the first in a series
to deal with that problem.

This particular patch actually has very little effect on performance; it
just refactors simplCast so that it builds Refl coercions less often.
Refl coercions require us to compute the type to put inside them, and
even if that's done lazily it is still work and code. Instead we use
Maybe Coercion with Nothing for Refl. This change also percolates to
pushCoTyArg and pushValArg.

Reviewers: goldfire, bgamari, simonpj

Reviewed By: simonpj

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #14737

Differential Revision: https://phabricator.haskell.org/D4395
parent c054162a
......@@ -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 = funArgTy tyR
Pair tyL tyR = coercionKind co
pushCoercionIntoLambda
......
......@@ -1207,47 +1207,54 @@ simplCast env body co0 cont0
; cont1 <- addCoerce co1 cont0
; simplExprF env body cont1 }
where
addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont
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' }) }
addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_dup = dup, sc_cont = tail })
| Just (co1, 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
; if isReflCo co1
then return (cont { sc_cont = tail' })
-- Avoid simplifying if possible;
-- See Note [Avoiding exponential behaviour]
else 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.
-- But it isn't a common case.
-- Example of use: Trac #995
; return (ApplyToVal { sc_arg = mkCast arg' co1
, sc_env = arg_se'
, sc_dup = dup'
, sc_cont = tail' }) } }
addCoerce co cont
| isReflexiveCo co = return cont
| otherwise = 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
-- 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 co1 (CastIt co2 cont)
= addCoerce (mkTransCo co1 co2) cont
addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })
| Just (arg_ty', m_co') <- pushCoTyArg co arg_ty
= do { tail' <- addCoerce0 m_co' tail
; return (cont { sc_arg_ty = arg_ty', sc_cont = tail' }) }
addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_dup = dup, sc_cont = tail })
| 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' <- addCoerce0 m_co2 tail
; if isReflCo co1
then return (cont { sc_cont = tail' })
-- Avoid simplifying if possible;
-- See Note [Avoiding exponential behaviour]
else 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.
-- But it isn't a common case.
-- Example of use: Trac #995
; return (ApplyToVal { sc_arg = mkCast arg' co1
, sc_env = arg_se'
, sc_dup = dup'
, sc_cont = tail' }) } }
addCoerce co cont
| isReflexiveCo co = return cont
| otherwise = 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
simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr
-> SimplM (DupFlag, StaticEnv, OutExpr)
......
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