diff options
| -rw-r--r-- | compiler/coreSyn/CoreOpt.hs | 48 | ||||
| -rw-r--r-- | compiler/simplCore/Simplify.hs | 89 |
2 files changed, 76 insertions, 61 deletions
diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs index 04e604eb06..42cc706bff 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 = funArgTy tyR Pair tyL tyR = coercionKind co pushCoercionIntoLambda diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index 53e3a210de..eb5b6721ab 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -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) |