[Git][ghc/ghc][wip/simplifier-tweaks] More changes
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Mar 28 12:09:12 UTC 2024
Simon Peyton Jones pushed to branch wip/simplifier-tweaks at Glasgow Haskell Compiler / GHC
Commits:
b63dc6bb by Simon Peyton Jones at 2024-03-28T12:08:54+00:00
More changes
- - - - -
8 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Utils.hs
- testsuite/tests/simplCore/should_compile/T12877.hs
- testsuite/tests/simplCore/should_compile/T18013.stderr
- testsuite/tests/simplCore/should_compile/T20040.stderr
- testsuite/tests/simplStg/should_compile/T15226b.stderr
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -1641,21 +1641,31 @@ canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
canUnfold _ = False
isBetterUnfoldingThan :: Unfolding -> Unfolding -> Bool
--- Used in inlining checks
+-- See Note [Better unfolding]
isBetterUnfoldingThan NoUnfolding _ = False
isBetterUnfoldingThan BootUnfolding _ = False
-isBetterUnfoldingThan (CoreUnfolding {}) (CoreUnfolding {}) = False
-isBetterUnfoldingThan (CoreUnfolding {}) _ = True
+isBetterUnfoldingThan (CoreUnfolding {uf_cache = uc1}) unf2
+ = case unf2 of
+ CoreUnfolding {uf_cache = uc2} -> uf_is_value uc1 && not (uf_is_value uc2)
+ OtherCon _ -> uf_is_value uc1
+ _ -> True
+ -- Default case: CoreUnfolding better than NoUnfolding etc
+ -- Better than DFunUnfolding? I don't care.
-isBetterUnfoldingThan (DFunUnfolding {}) (DFunUnfolding {}) = False
-isBetterUnfoldingThan (DFunUnfolding {}) _ = True
+isBetterUnfoldingThan (DFunUnfolding {}) unf2
+ | DFunUnfolding {} <- unf2 = False
+ | otherwise = True
-isBetterUnfoldingThan (OtherCon cs) (OtherCon cs') = not (null cs) && null cs' -- A bit crude
-isBetterUnfoldingThan (OtherCon {}) (CoreUnfolding {}) = False
-isBetterUnfoldingThan (OtherCon {}) (DFunUnfolding {}) = False
-isBetterUnfoldingThan (OtherCon {}) NoUnfolding = True
-isBetterUnfoldingThan (OtherCon {}) BootUnfolding = True
+isBetterUnfoldingThan (OtherCon cs1) unf2
+ = case unf2 of
+ CoreUnfolding {uf_cache = uc} -- If unf1 is OtherCon and unf2 is
+ -> not (uf_is_value uc) -- just a thunk, unf1 is better
+
+ OtherCon cs2 -> not (null cs1) && null cs2 -- A bit crude
+ DFunUnfolding {} -> False
+ NoUnfolding -> True
+ BootUnfolding -> True
{- Note [Fragile unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1671,6 +1681,20 @@ ones are
We consider even a StableUnfolding as fragile, because it needs substitution.
+Note [Better unfolding]
+~~~~~~~~~~~~~~~~~~~~~~~
+(unf1 `isBetterUnfoldingThan` unf2) is used when we have
+ let x = <rhs> in -- unf2
+ let $j y = ...x...
+ in case x of
+ K a -> ...$j v....
+
+At the /call site/ of $j, `x` has a better unfolding than it does at the
+/defnition site/ of $j; so we are keener to inline $j. See
+Note [Inlining join points] in GHC.Core.Opt.Simplify.Inline for discussion.
+
+The notion of "better" is encapsulated here.
+
Note [Stable unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~
When you say
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -3342,7 +3342,7 @@ simplAlts env0 scrut case_bndr alts cont'
; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut
case_bndr case_bndr2 alts
- ; (imposs_deflt_cons, in_alts) <- prepareAlts (seMode env0) scrut' case_bndr alts
+ ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr alts
-- NB: it's possible that the returned in_alts is empty: this is handled
-- by the caller (rebuildCase) in the missingAlt function
-- NB: pass case_bndr::InId, not case_bndr' :: OutId, to prepareAlts
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -2404,17 +2404,15 @@ OutId. Test simplCore/should_compile/simpl013 apparently shows this
up, although I'm not sure exactly how..
-}
-prepareAlts :: SimplMode -> OutExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt])
+prepareAlts :: OutExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt])
-- The returned alternatives can be empty, none are possible
--
-- Note that case_bndr is an InId; see Note [Shadowing in prepareAlts]
-prepareAlts mode scrut case_bndr alts
+prepareAlts scrut case_bndr alts
| Just (tc, tys) <- splitTyConApp_maybe (idType case_bndr)
= do { us <- getUniquesM
- ; let (yes1, alts1) | sm_case_merge mode = mergeCaseAlts case_bndr alts
- | otherwise = (False, alts)
- -- See Note [Merging nested cases]
- (idcs2, alts2) = filterAlts tc tys imposs_cons alts1
+ ; let -- See Note [Merging nested cases]
+ (idcs2, alts2) = filterAlts tc tys imposs_cons alts
(yes3, alts3) = refineDefaultAlt us (idMult case_bndr) tc tys idcs2 alts2
-- The multiplicity on case_bndr's is the multiplicity of the
-- case expression The newly introduced patterns in
@@ -2422,7 +2420,6 @@ prepareAlts mode scrut case_bndr alts
(yes4, idcs4, alts4) = combineIdenticalAlts idcs2 alts3
-- "idcs" stands for "impossible default data constructors"
-- i.e. the constructors that can't match the default case
- ; when yes1 $ tick (CaseMerge case_bndr)
; when yes3 $ tick (FillInCaseDefault case_bndr)
; when yes4 $ tick (AltMerge case_bndr)
; return (idcs4, alts4) }
@@ -2633,7 +2630,7 @@ and now we can do case-merge again, getting the desired
-}
-mkCase, mkCase2, mkCase3
+mkCase, mkCase1, mkCase2, mkCase3
:: SimplMode
-> OutExpr -> OutId
-> OutType -> [OutAlt] -- Alternatives in standard (increasing) order
@@ -2646,12 +2643,26 @@ mkCase, mkCase2, mkCase3
-- Note [Cascading case merge]
--------------------------------------------------
+mkCase mode scrut outer_bndr alts_ty alts
+ | sm_case_merge mode
+ , Just (joins, alts') <- mergeCaseAlts outer_bndr alts
+ = do { tick (CaseMerge outer_bndr)
+ ; case_expr <- mkCase1 mode scrut outer_bndr alts_ty alts'
+ ; return (mkLets joins case_expr) }
+ -- mkCase1: don't call mkCase recursively!
+ -- Firstly, there's no point, because inner alts have already had
+ -- mkCase applied to them, so they won't have a case in their default
+ -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr
+ -- in munge_rhs may put a case into the DEFAULT branch!
+ | otherwise
+ = mkCase1 mode scrut outer_bndr alts_ty alts
+
--------------------------------------------------
-- 2. Eliminate Identity Case
-- See Note [Eliminate Identity Case]
--------------------------------------------------
-mkCase _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : alts') -- Identity case
+mkCase1 _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : alts') -- Identity case
| all identity_alt alts
= do { tick (CaseIdentity case_bndr)
; return (mkTicks ticks $ re_cast scrut rhs1) }
@@ -2690,7 +2701,8 @@ mkCase _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : alts') -- Identity case
re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co
re_cast scrut _ = scrut
-mkCase mode scrut bndr alts_ty alts = mkCase2 mode scrut bndr alts_ty alts
+mkCase1 mode scrut bndr alts_ty alts = mkCase2 mode scrut bndr alts_ty alts
+
--------------------------------------------------
-- 2. Scrutinee Constant Folding
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -71,6 +71,7 @@ import GHC.Platform
import GHC.Core
import GHC.Core.Ppr
+import GHC.Core.FVs( bindFreeVars )
import GHC.Core.DataCon
import GHC.Core.Type as Type
import GHC.Core.FamInstEnv
@@ -643,13 +644,70 @@ filters down the matching alternatives in GHC.Core.Opt.Simplify.rebuildCase.
-}
---------------------------------
-mergeCaseAlts :: Id -> [CoreAlt] -> (Bool, [CoreAlt])
--- Result: (yes, alts'); if 'yes' then something actually happened
+mergeCaseAlts :: Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt])
-- See Note [Merge Nested Cases]
+mergeCaseAlts outer_bndr alts
+ | (Alt DEFAULT _ deflt_rhs : outer_alts) <- alts
+ , Just (joins, inner_alts) <- go deflt_rhs
+ = Just (joins, mergeAlts outer_alts inner_alts)
+ -- NB: mergeAlts gives priority to the left
+ -- case x of
+ -- A -> e1
+ -- DEFAULT -> case x of
+ -- A -> e2
+ -- B -> e3
+ -- When we merge, we must ensure that e1 takes
+ -- precedence over e2 as the value for A!
+
+ | otherwise
+ = Nothing
+
+ where
+ go :: CoreExpr -> Maybe ([CoreBind], [CoreAlt])
+ go (Let bind body)
+ | any (== outer_bndr) (bindersOf bind)
+ = Nothing
+ | isJoinBind bind
+ , not (outer_bndr `elemVarSet` bindFreeVars bind)
+ = do { (joins, alts) <- go body
+ ; return (bind:joins, alts ) }
+ | otherwise
+ = Nothing
+
+ -- Whizzo: we can merge!
+ go (Case (Var inner_scrut_var) inner_bndr _ inner_alts)
+ | inner_scrut_var == outer_bndr
+ , not (inner_bndr == outer_bndr) -- Avoid shadowing
+ , let wrap_let rhs' = Let (NonRec inner_bndr (Var outer_bndr)) rhs'
+ -- inner_bndr is never dead! It's the scrutinee!
+ -- The let is OK even for unboxed binders,
+ do_one (Alt con bndrs rhs)
+ | any (== outer_bndr) bndrs = Nothing
+ | otherwise = Just (Alt con bndrs (wrap_let rhs))
+ = do { alts' <- mapM do_one inner_alts
+ ; return ([], alts') }
+
+ -- Deal with tagToEnum# See See Note [Merge Nested Cases] wrinkle (MNC1)
+ go (App (App (Var f) (Type type_arg)) (Var v))
+ | v == outer_bndr
+ , Just TagToEnumOp <- isPrimOpId_maybe f
+ , Just tc <- tyConAppTyCon_maybe type_arg
+ , Just (dc1:dcs) <- tyConDataCons_maybe tc -- At least one data constructor
+ , dcs `lengthAtMost` 3 -- Arbitrary
+ = return ( [], mk_alts dc1 dcs)
+ where
+ mk_lit dc = mkLitIntUnchecked $ toInteger $ dataConTagZ dc
+ mk_rhs dc = Var (dataConWorkId dc)
+ mk_alts dc1 dcs = Alt DEFAULT [] (mk_rhs dc1)
+ : [Alt (LitAlt (mk_lit dc)) [] (mk_rhs dc) | dc <- dcs]
+
+ go _ = Nothing
+
+{-
mergeCaseAlts outer_bndr alts
| (Alt DEFAULT _ deflt_rhs : outer_alts) <- alts
, Just inner_alts <- go 5 (\e -> e) emptyVarSet deflt_rhs
- = (True, mergeAlts outer_alts inner_alts)
+ = Just (mergeAlts outer_alts inner_alts)
-- NB: mergeAlts gives priority to the left
-- case x of
-- A -> e1
@@ -660,7 +718,7 @@ mergeCaseAlts outer_bndr alts
-- precedence over e2 as the value for A!
| otherwise
- = (False, alts)
+ = Nothing
where
go :: Int -> (OutExpr -> OutExpr) -> VarSet -> OutExpr -> Maybe [OutAlt]
-- In the call (go wrap free_bndrs rhs), the `wrap` function has free `free_bndrs`;
@@ -714,7 +772,7 @@ mergeCaseAlts outer_bndr alts
= go (n-1) (wrap . wrap_case) (free_bndrs `extendVarSet` inner_scrut) rhs
go _ _ _ _ = Nothing
-
+-}
---------------------------------
mergeAlts :: [Alt a] -> [Alt a] -> [Alt a]
@@ -851,7 +909,7 @@ variable is scrutinised multiple times.
Wrinkles
-(MC1) `tryMergeCase` "looks though" an inner single-alternative case-on-variable.
+(MC1) `mergeCaseAlts` "looks though" an inner single-alternative case-on-variable.
For example
case x of {
...outer-alts...
@@ -880,7 +938,7 @@ Wrinkles
IS y2 -> tagToEnum# @Bool (==# x2 y2) };
IP x2 -> ...
IN x2 -> ...
- We want to merge the outer `case x` with thea inner `case x1`.
+ We want to merge the outer `case x` with the inner `case x1`.
This story is not fully robust; it will be defeated by a let-binding,
whih we don't want to duplicate. But accounting for single-alternative
=====================================
testsuite/tests/simplCore/should_compile/T12877.hs
=====================================
@@ -21,7 +21,7 @@ test x = case x of
t -> case t + 1 of
3 -> "0"
4 -> "1"
- t -> case t + 1 of
+ t -> "n" {- case t + 1 of
4 -> "0"
5 -> "1"
t -> case t + 1 of
@@ -112,3 +112,4 @@ test x = case x of
34 -> "0"
35 -> "1"
_ -> "n"
+-}
=====================================
testsuite/tests/simplCore/should_compile/T18013.stderr
=====================================
@@ -165,9 +165,9 @@ mapMaybeRule [InlPrag=[2]]
Result s b #)))
s1
of
- { (# ipv [Occ=Once1], ipv1 [Occ=Once1!] #) ->
- case ipv1 of { Result t2 [Occ=Once1] c1 [Occ=Once1] ->
- (# ipv,
+ { (# new_s [Occ=Once1], a2 [Occ=Once1!] #) ->
+ case a2 of { Result t2 [Occ=Once1] c1 [Occ=Once1] ->
+ (# new_s,
T18013a.Result @s @(Maybe b) t2 (GHC.Internal.Maybe.Just @b c1) #)
}
}
@@ -207,9 +207,9 @@ mapMaybeRule
Result s b #)))
s1
of
- { (# ipv, ipv1 #) ->
- case ipv1 of { Result t2 c1 ->
- (# ipv,
+ { (# new_s, a2 #) ->
+ case a2 of { Result t2 c1 ->
+ (# new_s,
T18013a.Result @s @(Maybe b) t2 (GHC.Internal.Maybe.Just @b c1) #)
}
}
=====================================
testsuite/tests/simplCore/should_compile/T20040.stderr
=====================================
@@ -1,8 +1,8 @@
==================== Final STG: ====================
-$WNil = CCS_DONT_CARE Nil! [];
+$WNil = Nil! [];
-$WCons = \r [conrep conrep] Cons [conrep conrep];
+$WCons = \r [conrep conrep1] Cons [conrep conrep1];
unSucc1 = \r [ds] ds;
@@ -11,12 +11,11 @@ unSucc = \r [eta] unSucc1 eta;
Rec {
ifoldl' =
\r [f z ds]
- case ds of {
+ case ds of wild {
Nil -> z;
- Cons ipv2 ipv3 ->
+ Cons x xs ->
case z of z1 {
- __DEFAULT ->
- case f z1 ipv2 of sat { __DEFAULT -> ifoldl' f sat ipv3; };
+ __DEFAULT -> case f z1 x of sat { __DEFAULT -> ifoldl' f sat xs; };
};
};
end Rec }
@@ -25,7 +24,7 @@ Nil = \r [void] Nil [];
Cons = \r [void eta eta] Cons [eta eta];
-Z = CCS_DONT_CARE Z! [];
+Z = Z! [];
S = \r [eta] S [eta];
=====================================
testsuite/tests/simplStg/should_compile/T15226b.stderr
=====================================
@@ -20,13 +20,13 @@ T15226b.testFun1
[GblId, Arity=3, Str=<L><ML><L>, Unf=OtherCon []] =
{} \r [x y void]
case seq# [x GHC.Prim.void#] of ds1 {
- (# #) ipv1 [Occ=Once1] ->
+ (# #) a1 [Occ=Once1] ->
let {
sat [Occ=Once1] :: T15226b.StrictPair a b
[LclId] =
- {ipv1, y} \u []
+ {a1, y} \u []
case y of conrep {
- __DEFAULT -> T15226b.MkStrictPair [ipv1 conrep];
+ __DEFAULT -> T15226b.MkStrictPair [a1 conrep];
};
} in seq# [sat GHC.Prim.void#];
};
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b63dc6bbb1de5f63b6d88253ea42cdf9cea1ce3e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b63dc6bbb1de5f63b6d88253ea42cdf9cea1ce3e
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240328/9b24a99b/attachment-0001.html>
More information about the ghc-commits
mailing list