Simon Peyton Jones pushed to branch wip/26543 at Glasgow Haskell Compiler / GHC
Commits:
-
1dd5d86a
by Simon Peyton Jones at 2025-12-11T13:49:57+00:00
2 changed files:
Changes:
| ... | ... | @@ -26,8 +26,8 @@ import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBind |
| 26 | 26 | import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr )
|
| 27 | 27 | import qualified GHC.Core.Make
|
| 28 | 28 | import GHC.Core.Coercion hiding ( substCo, substCoVar )
|
| 29 | -import GHC.Core.Reduction
|
|
| 30 | 29 | import GHC.Core.Coercion.Opt ( optCoercion )
|
| 30 | +import GHC.Core.Reduction
|
|
| 31 | 31 | import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe )
|
| 32 | 32 | import GHC.Core.DataCon
|
| 33 | 33 | import GHC.Core.Opt.Stats ( Tick(..) )
|
| ... | ... | @@ -35,8 +35,7 @@ import GHC.Core.Unfold |
| 35 | 35 | import GHC.Core.Unfold.Make
|
| 36 | 36 | import GHC.Core.Utils
|
| 37 | 37 | import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe
|
| 38 | - , pushCoTyArg, pushCoValArg, exprIsDeadEnd
|
|
| 39 | - , typeArity, arityTypeArity, etaExpandAT )
|
|
| 38 | + , exprIsDeadEnd, typeArity, arityTypeArity, etaExpandAT )
|
|
| 40 | 39 | import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )
|
| 41 | 40 | import GHC.Core.FVs ( mkRuleInfo {- exprsFreeIds -} )
|
| 42 | 41 | import GHC.Core.Rules ( lookupRule, getRules )
|
| ... | ... | @@ -1676,70 +1675,12 @@ optOutCoercion env co already_optimised |
| 1676 | 1675 | simplCast :: SimplEnv -> InExpr -> InCoercion -> SimplCont
|
| 1677 | 1676 | -> SimplM (SimplFloats, OutExpr)
|
| 1678 | 1677 | simplCast env body co0 cont0
|
| 1679 | - = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0
|
|
| 1680 | - ; cont1 <- {-#SCC "simplCast-addCoerce" #-}
|
|
| 1681 | - if isReflCo co1
|
|
| 1682 | - then return cont0 -- See Note [Optimising reflexivity]
|
|
| 1683 | - else addCoerce co1 True cont0
|
|
| 1678 | + = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0
|
|
| 1679 | + ; let cont1 = {-#SCC "simplCast-addCoerce" #-}
|
|
| 1680 | + pushCastCont env co1 True cont0
|
|
| 1684 | 1681 | -- True <=> co1 is optimised
|
| 1685 | - ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }
|
|
| 1686 | - where
|
|
| 1687 | - |
|
| 1688 | - -- If the first parameter is MRefl, then simplifying revealed a
|
|
| 1689 | - -- reflexive coercion. Omit.
|
|
| 1690 | - addCoerceM :: MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont
|
|
| 1691 | - addCoerceM MRefl _ cont = return cont
|
|
| 1692 | - addCoerceM (MCo co) opt cont = addCoerce co opt cont
|
|
| 1693 | - |
|
| 1694 | - addCoerce :: OutCoercion -> Bool -> SimplCont -> SimplM SimplCont
|
|
| 1695 | - addCoerce co1 _ (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity]
|
|
| 1696 | - = addCoerce (mkTransCo co1 co2) False cont
|
|
| 1697 | - -- False: (mkTransCo co1 co2) is not fully optimised
|
|
| 1698 | - -- See Note [Avoid re-simplifying coercions]
|
|
| 1699 | - |
|
| 1700 | - addCoerce co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })
|
|
| 1701 | - | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty
|
|
| 1702 | - = {-#SCC "addCoerce-pushCoTyArg" #-}
|
|
| 1703 | - do { tail' <- addCoerceM m_co' co_is_opt tail
|
|
| 1704 | - ; return (ApplyToTy { sc_arg_ty = arg_ty'
|
|
| 1705 | - , sc_cont = tail'
|
|
| 1706 | - , sc_hole_ty = coercionLKind co }) }
|
|
| 1707 | - -- NB! As the cast goes past, the
|
|
| 1708 | - -- type of the hole changes (#16312)
|
|
| 1709 | - -- (f |> co) e ===> (f (e |> co1)) |> co2
|
|
| 1710 | - -- where co :: (s1->s2) ~ (t1->t2)
|
|
| 1711 | - -- co1 :: t1 ~ s1
|
|
| 1712 | - -- co2 :: s2 ~ t2
|
|
| 1713 | - addCoerce co co_is_opt cont@(ApplyToVal { sc_arg = arg_clo
|
|
| 1714 | - , sc_dup = dup, sc_cont = tail })
|
|
| 1715 | - | not co_is_opt -- pushCoValArg duplicates the coercion, so optimise first
|
|
| 1716 | - = addCoerce (optOutCoercion (zapSubstEnv env) co co_is_opt) True cont
|
|
| 1717 | - |
|
| 1718 | - | Just (m_co1, m_co2) <- pushCoValArg co
|
|
| 1719 | - = {-#SCC "addCoerce-pushCoValArg" #-}
|
|
| 1720 | - do { tail' <- addCoerceM m_co2 co_is_opt tail
|
|
| 1721 | - ; case m_co1 of {
|
|
| 1722 | - MRefl -> return (cont { sc_cont = tail'
|
|
| 1723 | - , sc_hole_ty = coercionLKind co }) ;
|
|
| 1724 | - -- See Note [Avoiding simplifying repeatedly]
|
|
| 1725 | - |
|
| 1726 | - MCo co1 ->
|
|
| 1727 | - do { let arg_clo' = case arg_clo of
|
|
| 1728 | - DoneId v -> DoneEx (Cast (Var v) co1) NotJoinPoint
|
|
| 1729 | - DoneEx e _jp -> DoneEx (Cast e co1) NotJoinPoint
|
|
| 1730 | - ContEx se e mco -> ContEx se e (mkTransMCoL mco co1)
|
|
| 1731 | - |
|
| 1732 | - ; return (ApplyToVal { sc_arg = arg_clo'
|
|
| 1733 | - , sc_dup = dup
|
|
| 1734 | - , sc_cont = tail'
|
|
| 1735 | - , sc_hole_ty = coercionLKind co }) } } }
|
|
| 1736 | - |
|
| 1737 | - addCoerce co co_is_opt cont
|
|
| 1738 | - | isReflCo co = return cont -- Having this at the end makes a huge
|
|
| 1739 | - -- difference in T12227, for some reason
|
|
| 1740 | - -- See Note [Optimising reflexivity]
|
|
| 1741 | - | otherwise = return (CastIt { sc_co = co, sc_opt = co_is_opt, sc_cont = cont })
|
|
| 1742 | 1682 | |
| 1683 | + ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }
|
|
| 1743 | 1684 | |
| 1744 | 1685 | {-
|
| 1745 | 1686 | ************************************************************************
|
| ... | ... | @@ -1870,7 +1811,7 @@ simplNonRecE env from_what bndr (ContEx rhs_se rhs mco) body cont |
| 1870 | 1811 | is_strict_bind
|
| 1871 | 1812 | = -- Evaluate RHS strictly
|
| 1872 | 1813 | simplExprF (rhs_se `setInScopeFromE` env) rhs
|
| 1873 | - (pushCastCont mco $
|
|
| 1814 | + (pushCastMCont env mco True $
|
|
| 1874 | 1815 | StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what
|
| 1875 | 1816 | , sc_env = env, sc_cont = cont, sc_dup = NoDup })
|
| 1876 | 1817 | |
| ... | ... | @@ -2226,7 +2167,7 @@ simplClo :: SimplEnv |
| 2226 | 2167 | simplClo env clo cont
|
| 2227 | 2168 | = case clo of
|
| 2228 | 2169 | ContEx se e mco -> simplExprF (se `setInScopeFromE` env) e $
|
| 2229 | - pushCastCont mco cont
|
|
| 2170 | + pushCastMCont env mco True cont
|
|
| 2230 | 2171 | -- Don't trimJoinCont; we haven't already simplified e,
|
| 2231 | 2172 | -- so the cont is not embodied in e
|
| 2232 | 2173 | |
| ... | ... | @@ -2247,7 +2188,7 @@ simplCloArg :: SimplEnvIS -- ^ Used only for its InScopeSet |
| 2247 | 2188 | -> SimplClo
|
| 2248 | 2189 | -> SimplM OutExpr
|
| 2249 | 2190 | simplCloArg env fun_ty mb_arg_info (ContEx arg_se arg mco)
|
| 2250 | - = simplExprC arg_env arg (pushCastCont mco stop)
|
|
| 2191 | + = simplExprC arg_env arg (pushCastMCont env mco True stop)
|
|
| 2251 | 2192 | where
|
| 2252 | 2193 | arg_env = arg_se `setInScopeFromE` env
|
| 2253 | 2194 | arg_ty = funArgTy fun_ty
|
| ... | ... | @@ -2393,7 +2334,7 @@ rebuildCall env fun_info |
| 2393 | 2334 | , seCaseCase env -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify
|
| 2394 | 2335 | -- Note [Case-of-case and full laziness]
|
| 2395 | 2336 | -> simplExprF (arg_se `setInScopeFromE` env) in_arg
|
| 2396 | - (pushCastCont mco $
|
|
| 2337 | + (pushCastMCont env mco True $
|
|
| 2397 | 2338 | StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty
|
| 2398 | 2339 | , sc_dup = NoDup, sc_cont = cont })
|
| 2399 | 2340 | -- Note [Shadowing in the Simplifier]
|
| ... | ... | @@ -29,7 +29,7 @@ module GHC.Core.Opt.Simplify.Utils ( |
| 29 | 29 | contIsTrivial, contArgs, contIsRhs,
|
| 30 | 30 | countArgs, contOutArgs, dropContArgs,
|
| 31 | 31 | mkBoringStop, mkRhsStop, mkLazyArgStop,
|
| 32 | - interestingCallContext, pushCastCont,
|
|
| 32 | + interestingCallContext, pushCastCont, pushCastMCont,
|
|
| 33 | 33 | |
| 34 | 34 | -- ArgInfo
|
| 35 | 35 | ArgInfo(..), ArgSpec(..), mkArgInfo,
|
| ... | ... | @@ -63,6 +63,7 @@ import GHC.Core.Unfold.Make |
| 63 | 63 | import GHC.Core.Opt.Simplify.Monad
|
| 64 | 64 | import GHC.Core.Type hiding( substTy )
|
| 65 | 65 | import GHC.Core.Coercion hiding( substCo )
|
| 66 | +import GHC.Core.Coercion.Opt ( optCoercion )
|
|
| 66 | 67 | import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon )
|
| 67 | 68 | import GHC.Core.Multiplicity
|
| 68 | 69 | import GHC.Core.Opt.ConstantFold
|
| ... | ... | @@ -415,11 +416,6 @@ mkLazyArgStop ty fun_info = Stop ty (lazyArgContext fun_info) arg_sd |
| 415 | 416 | where
|
| 416 | 417 | arg_sd = subDemandIfEvaluated (Partial.head (ai_dmds fun_info))
|
| 417 | 418 | |
| 418 | -pushCastCont :: MOutCoercion -> SimplCont -> SimplCont
|
|
| 419 | --- Assumes the MOutCoercion is optimised
|
|
| 420 | -pushCastCont MRefl cont = cont
|
|
| 421 | -pushCastCont (MCo co) cont = CastIt { sc_co = co, sc_opt = True, sc_cont = cont }
|
|
| 422 | - |
|
| 423 | 419 | -------------------
|
| 424 | 420 | contIsRhs :: SimplCont -> Maybe RecFlag
|
| 425 | 421 | contIsRhs (Stop _ (RhsCtxt is_rec) _) = Just is_rec
|
| ... | ... | @@ -704,6 +700,63 @@ make use of the strictness info for the function. |
| 704 | 700 | -}
|
| 705 | 701 | |
| 706 | 702 | |
| 703 | +{- *********************************************************************
|
|
| 704 | +* *
|
|
| 705 | + Pushing a cast onto a continuation
|
|
| 706 | +* *
|
|
| 707 | +********************************************************************* -}
|
|
| 708 | + |
|
| 709 | +pushCastMCont :: SimplEnvIS -> MOutCoercion -> Bool -> SimplCont -> SimplCont
|
|
| 710 | +-- Bool = True <=> the coercion is already optimised
|
|
| 711 | +pushCastMCont _ MRefl _ cont = cont
|
|
| 712 | +pushCastMCont env (MCo co) opt cont = pushCastCont env co opt cont
|
|
| 713 | + |
|
| 714 | +pushCastCont :: SimplEnvIS -> OutCoercion -> Bool -> SimplCont -> SimplCont
|
|
| 715 | +pushCastCont _env co _opt cont
|
|
| 716 | + | isReflCo co -- isReflCo is cheap
|
|
| 717 | + = cont -- Having this test made a huge difference in T12227, for some reason
|
|
| 718 | + -- See Note [Optimising reflexivity]
|
|
| 719 | + |
|
| 720 | +pushCastCont env co _opt (CastIt { sc_co = co2, sc_cont = cont }) -- See Note [Optimising reflexivity]
|
|
| 721 | + = pushCastCont env (mkTransCo co co2) False cont
|
|
| 722 | + -- False: (mkTransCo co co2) is not fully optimised
|
|
| 723 | + -- See Note [Avoid re-simplifying coercions]
|
|
| 724 | + |
|
| 725 | +pushCastCont env co opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })
|
|
| 726 | + | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty
|
|
| 727 | + = {-#SCC "addCoerce-pushCoTyArg" #-}
|
|
| 728 | + ApplyToTy { sc_arg_ty = arg_ty'
|
|
| 729 | + , sc_hole_ty = coercionLKind co
|
|
| 730 | + , sc_cont = pushCastMCont env m_co' opt tail }
|
|
| 731 | + -- sc_hole_ty: As the cast goes past, the hole type changes (#16312)
|
|
| 732 | + |
|
| 733 | +pushCastCont env co opt cont@(ApplyToVal {})
|
|
| 734 | + | not opt -- pushCoValArg duplicates the coercion, so optimise first
|
|
| 735 | + = pushCastCont env (optCoercion opts empty_subst co) True cont
|
|
| 736 | + where
|
|
| 737 | + empty_subst = mkEmptySubst (seInScope env)
|
|
| 738 | + opts = seOptCoercionOpts env
|
|
| 739 | + |
|
| 740 | +pushCastCont env co _opt (ApplyToVal { sc_arg = clo, sc_dup = dup, sc_cont = tail })
|
|
| 741 | + | Just (m_co1, m_co2) <- pushCoValArg co
|
|
| 742 | + = -- (f |> co) e ===> (f (e |> co1)) |> co2
|
|
| 743 | + -- where co :: (s1->s2) ~ (t1->t2)
|
|
| 744 | + -- co1 :: t1 ~ s1
|
|
| 745 | + -- co2 :: s2 ~ t2
|
|
| 746 | + ApplyToVal { sc_arg = mkCloCastMCo clo m_co1
|
|
| 747 | + , sc_dup = dup
|
|
| 748 | + , sc_hole_ty = coercionLKind co
|
|
| 749 | + , sc_cont = pushCastMCont env m_co2 True tail }
|
|
| 750 | + |
|
| 751 | +pushCastCont _env co opt cont
|
|
| 752 | + = CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }
|
|
| 753 | + |
|
| 754 | +mkCloCastMCo :: SimplClo -> MOutCoercion -> SimplClo
|
|
| 755 | +mkCloCastMCo clo MRefl = clo
|
|
| 756 | +mkCloCastMCo (DoneId v) (MCo co) = DoneEx (Cast (Var v) co) NotJoinPoint
|
|
| 757 | +mkCloCastMCo (DoneEx e _jp) (MCo co) = DoneEx (Cast e co) NotJoinPoint
|
|
| 758 | +mkCloCastMCo (ContEx se e mco) (MCo co) = ContEx se e (mkTransMCoL mco co)
|
|
| 759 | + |
|
| 707 | 760 | {-
|
| 708 | 761 | ************************************************************************
|
| 709 | 762 | * *
|
| ... | ... | @@ -1859,7 +1912,9 @@ rebuildLam _env [] body _cont |
| 1859 | 1912 | = return body
|
| 1860 | 1913 | |
| 1861 | 1914 | rebuildLam env bndrs@(bndr:_) body cont
|
| 1862 | - = {-# SCC "rebuildLam" #-} try_eta bndrs body
|
|
| 1915 | + = {-# SCC "rebuildLam" #-}
|
|
| 1916 | + do { traceSmpl "rebuildLam" (ppr bndrs $$ ppr cont)
|
|
| 1917 | + ; try_eta bndrs body }
|
|
| 1863 | 1918 | where
|
| 1864 | 1919 | rec_ids = seRecIds env
|
| 1865 | 1920 | in_scope = getInScope env -- Includes 'bndrs'
|