[Git][ghc/ghc][wip/T22404] 7 commits: Bump submodule bytestring to 0.11.4.0
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Jan 13 16:42:57 UTC 2023
Simon Peyton Jones pushed to branch wip/T22404 at Glasgow Haskell Compiler / GHC
Commits:
9a3d6add by Bodigrim at 2023-01-13T00:46:36-05:00
Bump submodule bytestring to 0.11.4.0
Metric Decrease:
T21839c
T21839r
- - - - -
df33c13c by Ben Gamari at 2023-01-13T00:47:12-05:00
gitlab-ci: Bump Darwin bootstrap toolchain
This updates the bootstrap compiler on Darwin from 8.10.7 to 9.2.5,
ensuring that we have the fix for #21964.
- - - - -
756a66ec by Ben Gamari at 2023-01-13T00:47:12-05:00
gitlab-ci: Pass -w to cabal update
Due to cabal#8447, cabal-install 3.8.1.0 requires a compiler to run
`cabal update`.
- - - - -
b01d8df6 by Simon Peyton Jones at 2023-01-13T15:21:15+00:00
Work in progress on #22404
Very much not ready!
- - - - -
a66a5639 by Sebastian Graf at 2023-01-13T15:21:15+00:00
Partition into OneOccs and ManyOccs
- - - - -
fe3bee43 by Simon Peyton Jones at 2023-01-13T15:21:15+00:00
Wibbles
- - - - -
614e35ac by Simon Peyton Jones at 2023-01-13T16:42:01+00:00
Refactor WithTailJoinDetails
- - - - -
7 changed files:
- .gitlab/ci.sh
- .gitlab/darwin/nix/sources.json
- .gitlab/darwin/toolchain.nix
- compiler/GHC/Core/Opt/OccurAnal.hs
- libraries/bytestring
- testsuite/tests/ghci/scripts/T9881.stdout
- testsuite/tests/ghci/scripts/ghci025.stdout
Changes:
=====================================
.gitlab/ci.sh
=====================================
@@ -236,7 +236,9 @@ function set_toolchain_paths() {
}
function cabal_update() {
- run "$CABAL" update --index="$HACKAGE_INDEX_STATE"
+ # In principle -w shouldn't be necessary here but with
+ # cabal-install 3.8.1.0 it is, due to cabal#8447.
+ run "$CABAL" update -w "$GHC" --index="$HACKAGE_INDEX_STATE"
}
=====================================
.gitlab/darwin/nix/sources.json
=====================================
@@ -12,15 +12,15 @@
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
},
"nixpkgs": {
- "branch": "wip/ghc-8.10.7-darwin",
+ "branch": "master",
"description": "Nix Packages collection",
"homepage": "",
- "owner": "bgamari",
+ "owner": "nixos",
"repo": "nixpkgs",
- "rev": "37c60356e3f83c708a78a96fdd914b5ffc1f551c",
- "sha256": "0i5j7nwk4ky0fg4agla3aznadpxz0jyrdwp2q92hyxidra987syn",
+ "rev": "ce1aa29621356706746c53e2d480da7c68f6c972",
+ "sha256": "sha256:1sbs3gi1nf4rcbmnw69fw0fpvb3qvlsa84hqimv78vkpd6xb0bgg",
"type": "tarball",
- "url": "https://github.com/bgamari/nixpkgs/archive/37c60356e3f83c708a78a96fdd914b5ffc1f551c.tar.gz",
+ "url": "https://github.com/nixos/nixpkgs/archive/ce1aa29621356706746c53e2d480da7c68f6c972.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
}
}
=====================================
.gitlab/darwin/toolchain.nix
=====================================
@@ -15,16 +15,16 @@ let
ghcBindists = let version = ghc.version; in {
aarch64-darwin = pkgs.fetchurl {
url = "https://downloads.haskell.org/ghc/${version}/ghc-${version}-aarch64-apple-darwin.tar.xz";
- sha256 = "sha256:10pby1idpxhkjqsi56jivkymhnabsdr8m2x8gdqchnv5113hl72k";
+ sha256 = "sha256-tQUHsingxBizLktswGAoi6lJf92RKWLjsHB9CisANlg=";
};
x86_64-darwin = pkgs.fetchurl {
url = "https://downloads.haskell.org/ghc/${version}/ghc-${version}-x86_64-apple-darwin.tar.xz";
- sha256 = "sha256:012yzyangk26sdapnz4226prgb8jgpf6k5bd9qxsdykk5x7jc7ah";
+ sha256 = "sha256-OjXjVe+ZODDCc/hqtihqqz6CX25TKI0ZgORzkR5O3pQ=";
};
};
ghc = pkgs.stdenv.mkDerivation rec {
- version = "9.4.3";
+ version = "9.4.4";
name = "ghc";
src = ghcBindists.${pkgs.stdenv.hostPlatform.system};
configureFlags = [
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -58,7 +58,7 @@ import GHC.Utils.Misc
import GHC.Builtin.Names( runRWKey )
import GHC.Unit.Module( Module )
-import Data.List (mapAccumL, mapAccumR)
+import Data.List (mapAccumL)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
@@ -94,8 +94,8 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds
init_env = initOccEnv { occ_rule_act = active_rule
, occ_unf_act = active_unf }
- (WithUsageDetails final_usage occ_anald_binds) = go init_env binds
- (WithUsageDetails _ occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel
+ WithUsageDetails final_usage occ_anald_binds = go binds init_env
+ WithUsageDetails _ occ_anald_glommed_binds = occAnalRecBind init_env TopLevel
imp_rule_edges
(flattenBinds binds)
initial_uds
@@ -127,14 +127,10 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds
-- Not BuiltinRules; see Note [Plugin rules]
, let rhs_fvs = exprFreeIds rhs `delVarSetList` bndrs ]
- go :: OccEnv -> [CoreBind] -> WithUsageDetails [CoreBind]
- go !_ []
- = WithUsageDetails initial_uds []
- go env (bind:binds)
- = WithUsageDetails final_usage (bind' ++ binds')
- where
- (WithUsageDetails bs_usage binds') = go env binds
- (WithUsageDetails final_usage bind') = occAnalBind env TopLevel imp_rule_edges bind bs_usage
+ go :: [CoreBind] -> OccEnv -> WithUsageDetails [CoreBind]
+ go [] _ = WithUsageDetails initial_uds []
+ go (bind:binds) env = occAnalBind env TopLevel
+ imp_rule_edges bind (go binds) (++)
{- *********************************************************************
* *
@@ -600,6 +596,10 @@ Hence the transitive rule_fv_env stuff described in
Note [Rules and loop breakers].
------------------------------------------------------------
+Note [Occurrence analysis for join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ToDo: addresses #22404.
+
Note [Finding join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~
It's the occurrence analyser's job to find bindings that we can turn into join
@@ -819,39 +819,106 @@ of both functions, serving as a specification:
data WithUsageDetails a = WithUsageDetails !UsageDetails !a
-data WithTailUsageDetails a = WithTailUsageDetails !TailUsageDetails !a
+-- | Captures the result of applying 'occAnalLamTail' to a function `\xyz.body`.
+-- The TailUsageDetails records
+-- * the number of lambdas (including type lambdas: a JoinArity)
+-- * UsageDetails for the `body`, unadjusted by `adjustTailUsage`.
+-- If the binding turns out to be a join point with the indicated join
+-- arity, this unadjusted usage details is just what we need; otherwise we
+-- need to discard tail calls. That's what `adjustTailUsage` does.
+data Tail a = TE !JoinArity !a
+
+instance Outputable a => Outputable (Tail a) where
+ ppr (TE ja rhs) = text "TE" <> braces(ppr ja) <+> ppr rhs
+
------------------------------------------------------------------
-- occAnalBind
------------------------------------------------------------------
-occAnalBind :: OccEnv -- The incoming OccEnv
- -> TopLevelFlag
- -> ImpRuleEdges
- -> CoreBind
- -> UsageDetails -- Usage details of scope
- -> WithUsageDetails [CoreBind] -- Of the whole let(rec)
+occAnalBind
+ :: OccEnv
+ -> TopLevelFlag
+ -> ImpRuleEdges
+ -> CoreBind
+ -> (OccEnv -> WithUsageDetails r) -- Scope of the bind
+ -> ([CoreBind] -> r -> r) -- How to combine the scope with new binds
+ -> WithUsageDetails r -- Of the whole let(rec)
+
+occAnalBind env lvl ire (Rec pairs) thing_inside combine
+ = addInScope env (map fst pairs) $ \env ->
+ let WithUsageDetails body_uds body' = thing_inside env
+ WithUsageDetails bind_uds binds' = occAnalRecBind env lvl ire pairs body_uds
+ in WithUsageDetails bind_uds (combine binds' body')
+
+occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine
+ | isTyVar bndr -- A type let; we don't gather usage info
+ = let !(WithUsageDetails body_uds res) = addInScope env [bndr] thing_inside
+ in WithUsageDetails body_uds (combine [NonRec bndr rhs] res)
+
+ -- Non-recursive join points
+ | NotTopLevel <- lvl
+ , mb_join@(Just {}) <- isJoinId_maybe bndr
+ , not (isStableUnfolding (realIdUnfolding bndr))
+ , not (idHasRules bndr)
+ = let -- Analyse the rhs first, generating rhs_uds
+ rhs_env = setRhsCtxt OccVanilla env
+ WithUsageDetails rhs_uds rhs' = adjustNonRecRhs mb_join $
+ occAnalLamTail rhs_env rhs
+
+ !(!one_uds, !many_uds) = partitionOneOccUDs rhs_uds
+
+ -- Now analyse the body, adding the
+ -- join-point into the environment with addJoinPoint
+ (tagged_bndr, body_wuds)
+ = occAnalNonRecBody env lvl bndr $ \env ->
+ thing_inside (addJoinPoint env bndr one_uds)
+
+ -- Build the WithUsageDetails for the join-point binding
+ bind_wuds = WithUsageDetails many_uds [NonRec tagged_bndr rhs']
+ in
+ finishNonRec combine tagged_bndr bind_wuds body_wuds
+
+ -- The normal case
+ | otherwise
+ = let -- Analyse the body first, generating tagged_bndr
+ (tagged_bndr, body_wuds) = occAnalNonRecBody env lvl bndr thing_inside
-occAnalBind !env lvl top_env (NonRec binder rhs) body_usage
- = occAnalNonRecBind env lvl top_env binder rhs body_usage
-occAnalBind env lvl top_env (Rec pairs) body_usage
- = occAnalRecBind env lvl top_env pairs body_usage
+ -- Analyse the binding itself
+ bind_wuds = occAnalNonRecIdBind env ire tagged_bndr rhs
+ in
+ finishNonRec combine tagged_bndr bind_wuds body_wuds
-----------------
-occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr
- -> UsageDetails -> WithUsageDetails [CoreBind]
-occAnalNonRecBind !env lvl imp_rule_edges bndr rhs body_usage
- | isTyVar bndr -- A type let; we don't gather usage info
- = WithUsageDetails body_usage [NonRec bndr rhs]
+occAnalNonRecBody :: OccEnv -> TopLevelFlag -> Id
+ -> (OccEnv -> WithUsageDetails r) -- Scope of the bind
+ -> (Id, WithUsageDetails r)
+occAnalNonRecBody env lvl bndr thing_inside
+ = let !(WithUsageDetails uds (tagged_bndr, res))
+ = addInScope env [bndr] $ \env ->
+ let !(WithUsageDetails inner_uds res) = thing_inside env
+ tagged_bndr = tagNonRecBinder lvl inner_uds bndr
+ in WithUsageDetails inner_uds (tagged_bndr, res)
+ in (tagged_bndr, WithUsageDetails uds res)
- | not (bndr `usedIn` body_usage)
- = WithUsageDetails body_usage [] -- See Note [Dead code]
+-----------------
+finishNonRec :: ([CoreBind] -> r -> r) -- How to combine the scope with new binds
+ -> Id -> WithUsageDetails [CoreBind] -> WithUsageDetails r
+ -> WithUsageDetails r
+finishNonRec combine tagged_bndr
+ (WithUsageDetails bind_uds binds)
+ (WithUsageDetails body_uds body)
+ | isDeadBinder tagged_bndr
+ = WithUsageDetails body_uds body -- Drop dead code; see Note [Dead code]
+ | otherwise
+ = WithUsageDetails (bind_uds `andUDs` body_uds) (combine binds body)
- | otherwise -- It's mentioned in the body
- = WithUsageDetails (body_usage' `andUDs` rhs_usage) [NonRec final_bndr final_rhs]
+-----------------
+occAnalNonRecIdBind :: OccEnv -> ImpRuleEdges -> Id -> CoreExpr
+ -> WithUsageDetails [CoreBind]
+occAnalNonRecIdBind !env imp_rule_edges tagged_bndr rhs
+ = WithUsageDetails rhs_usage [NonRec final_bndr final_rhs]
where
- WithUsageDetails body_usage' tagged_bndr = tagNonRecBinder lvl body_usage bndr
-
-- Get the join info from the *new* decision
-- See Note [Join points and unfoldings/rules]
-- => join arity O of Note [Join arity prediction based on joinRhsArity]
@@ -859,9 +926,10 @@ occAnalNonRecBind !env lvl imp_rule_edges bndr rhs body_usage
is_join_point = isJust mb_join_arity
--------- Right hand side ---------
- env1 | is_join_point = env -- See Note [Join point RHSs]
- | certainly_inline = env -- See Note [Cascading inlines]
- | otherwise = rhsCtxt env
+ env1 = setRhsCtxt rhs_ctxt env
+ rhs_ctxt | certainly_inline = OccVanilla -- See Note [Cascading inlines]
+ | is_join_point = OccVanilla -- See Note [Join point RHSs]
+ | otherwise = OccRhs
-- See Note [Sources of one-shot information]
rhs_env = env1 { occ_one_shots = argOneShots dmd }
@@ -869,26 +937,25 @@ occAnalNonRecBind !env lvl imp_rule_edges bndr rhs body_usage
-- Match join arity O from mb_join_arity with manifest join arity M as
-- returned by of occAnalLamTail. It's totally OK for them to mismatch;
-- hence adjust the UDs from the RHS
- WithUsageDetails adj_rhs_uds final_rhs
- = adjustNonRecRhs mb_join_arity $ occAnalLamTail rhs_env rhs
+ WithUsageDetails adj_rhs_uds final_rhs = adjustNonRecRhs mb_join_arity $
+ occAnalLamTail rhs_env rhs
rhs_usage = adj_rhs_uds `andUDs` adj_unf_uds `andUDs` adj_rule_uds
final_bndr = tagged_bndr `setIdSpecialisation` mkRuleInfo rules'
`setIdUnfolding` unf2
--------- Unfolding ---------
-- See Note [Join points and unfoldings/rules]
- unf | isId bndr = idUnfolding bndr
- | otherwise = NoUnfolding
- WithTailUsageDetails unf_uds unf1 = occAnalUnfolding rhs_env unf
+ unf = idUnfolding tagged_bndr
+ unf_wuds@(WithUsageDetails _ (TE _ unf1)) = occAnalUnfolding rhs_env unf
unf2 = markNonRecUnfoldingOneShots mb_join_arity unf1
- adj_unf_uds = adjustTailArity mb_join_arity unf_uds
+ adj_unf_uds = adjustTailArity mb_join_arity unf_wuds
--------- Rules ---------
-- See Note [Rules are extra RHSs] and Note [Rule dependency info]
-- and Note [Join points and unfoldings/rules]
- rules_w_uds = occAnalRules rhs_env bndr
+ rules_w_uds = occAnalRules rhs_env tagged_bndr
rules' = map fstOf3 rules_w_uds
- imp_rule_uds = impRulesScopeUsage (lookupImpRules imp_rule_edges bndr)
+ imp_rule_uds = impRulesScopeUsage (lookupImpRules imp_rule_edges tagged_bndr)
-- imp_rule_uds: consider
-- h = ...
-- g = ...
@@ -909,9 +976,9 @@ occAnalNonRecBind !env lvl imp_rule_edges bndr rhs body_usage
-> active && not_stable
_ -> False
- dmd = idDemandInfo bndr
- active = isAlwaysActive (idInlineActivation bndr)
- not_stable = not (isStableUnfolding (idUnfolding bndr))
+ dmd = idDemandInfo tagged_bndr
+ active = isAlwaysActive (idInlineActivation tagged_bndr)
+ not_stable = not (isStableUnfolding unf)
-----------------
occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]
@@ -921,7 +988,7 @@ occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]
-- * compute strongly-connected components
-- * feed those components to occAnalRec
-- See Note [Recursive bindings: the grand plan]
-occAnalRecBind !env lvl imp_rule_edges pairs body_usage
+occAnalRecBind !rhs_env lvl imp_rule_edges pairs body_usage
= foldr (occAnalRec rhs_env lvl) (WithUsageDetails body_usage []) sccs
where
sccs :: [SCC NodeDetails]
@@ -934,21 +1001,23 @@ occAnalRecBind !env lvl imp_rule_edges pairs body_usage
bndrs = map fst pairs
bndr_set = mkVarSet bndrs
- rhs_env = env `addInScope` bndrs
-adjustNonRecRhs :: Maybe JoinArity -> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr
+adjustNonRecRhs :: Maybe JoinArity -> WithUsageDetails (Tail CoreExpr)
+ -> WithUsageDetails CoreExpr
-- ^ This function concentrates shared logic between occAnalNonRecBind and the
-- AcyclicSCC case of occAnalRec.
-- * It applies 'markNonRecJoinOneShots' to the RHS
-- * and returns the adjusted rhs UsageDetails combined with the body usage
-adjustNonRecRhs mb_join_arity (WithTailUsageDetails rhs_tuds rhs)
+adjustNonRecRhs mb_join_arity (WithUsageDetails rhs_usage (TE ja rhs))
= WithUsageDetails rhs_uds' rhs'
where
--------- Marking (non-rec) join binders one-shot ---------
!rhs' | Just ja <- mb_join_arity = markNonRecJoinOneShots ja rhs
| otherwise = rhs
+
--------- Adjusting right-hand side usage ---------
- rhs_uds' = adjustTailUsage mb_join_arity rhs' rhs_tuds
+ rhs_uds' = adjustTailUsage mb_join_arity $
+ WithUsageDetails rhs_usage (TE ja rhs')
bindersOfSCC :: SCC NodeDetails -> [Var]
bindersOfSCC (AcyclicSCC nd) = [nd_bndr nd]
@@ -970,9 +1039,10 @@ occAnalRec !_ _ scc (WithUsageDetails body_uds binds)
occAnalRec !_ lvl
(AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds }))
(WithUsageDetails body_uds binds)
- = WithUsageDetails (body_uds' `andUDs` rhs_uds') (NonRec bndr' rhs' : binds)
+ = WithUsageDetails (body_uds `andUDs` rhs_uds')
+ (NonRec bndr' rhs' : binds)
where
- WithUsageDetails body_uds' tagged_bndr = tagNonRecBinder lvl body_uds bndr
+ tagged_bndr = tagNonRecBinder lvl body_uds bndr
mb_join_arity = willBeJoinId_maybe tagged_bndr
WithUsageDetails rhs_uds' rhs' = adjustNonRecRhs mb_join_arity wtuds
!unf' = markNonRecUnfoldingOneShots mb_join_arity (idUnfolding tagged_bndr)
@@ -1448,7 +1518,7 @@ type LetrecNode = Node Unique NodeDetails
data NodeDetails
= ND { nd_bndr :: Id -- Binder
- , nd_rhs :: !(WithTailUsageDetails CoreExpr)
+ , nd_rhs :: !(WithUsageDetails (Tail CoreExpr))
-- ^ RHS, already occ-analysed
-- With TailUsageDetails from RHS, and RULES, and stable unfoldings,
-- ignoring phase (ie assuming all are active).
@@ -1481,7 +1551,8 @@ instance Outputable NodeDetails where
, text "simple =" <+> ppr (nd_simple nd)
, text "active_rule_fvs =" <+> ppr (nd_active_rule_fvs nd)
])
- where WithTailUsageDetails uds _ = nd_rhs nd
+ where
+ WithUsageDetails uds _ = nd_rhs nd
-- | Digraph with simplified and completely occurrence analysed
-- 'SimpleNodeDetails', retaining just the info we need for breaking loops.
@@ -1525,7 +1596,7 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs)
-- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.
where
details = ND { nd_bndr = bndr'
- , nd_rhs = WithTailUsageDetails scope_uds rhs'
+ , nd_rhs = WithUsageDetails unadj_scope_uds rhs_te
, nd_inl = inl_fvs
, nd_simple = null rules_w_uds && null imp_rule_info
, nd_weak_fvs = weak_fvs
@@ -1538,7 +1609,6 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs)
-- JoinArity rhs_ja of unadj_rhs_uds.
unadj_inl_uds = unadj_rhs_uds `andUDs` adj_unf_uds
unadj_scope_uds = unadj_inl_uds `andUDs` adj_rule_uds
- scope_uds = TUD rhs_ja unadj_scope_uds
-- Note [Rules are extra RHSs]
-- Note [Rule dependency info]
scope_fvs = udFreeVars bndr_set unadj_scope_uds
@@ -1566,16 +1636,16 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs)
-- Instead, do the occAnalLamTail call here and postpone adjustTailUsage
-- until occAnalRec. In effect, we pretend that the RHS becomes a
-- non-recursive join point and fix up later with adjustTailUsage.
- rhs_env = rhsCtxt env
- WithTailUsageDetails (TUD rhs_ja unadj_rhs_uds) rhs' = occAnalLamTail rhs_env rhs
+ rhs_env = setRhsCtxt OccRhs env
+ WithUsageDetails unadj_rhs_uds rhs_te@(TE rhs_ja _) = occAnalLamTail rhs_env rhs
-- corresponding call to adjustTailUsage in occAnalRec and tagRecBinders
--------- Unfolding ---------
-- See Note [Join points and unfoldings/rules]
unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness
-- here because that is what we are setting!
- WithTailUsageDetails unf_tuds unf' = occAnalUnfolding rhs_env unf
- adj_unf_uds = adjustTailArity (Just rhs_ja) unf_tuds
+ unf_wuds@(WithUsageDetails _ (TE _ unf')) = occAnalUnfolding rhs_env unf
+ adj_unf_uds = adjustTailArity (Just rhs_ja) unf_wuds
-- `rhs_ja` is `joinRhsArity rhs` and is the prediction for source M
-- of Note [Join arity prediction based on joinRhsArity]
@@ -1590,8 +1660,8 @@ makeNode !env imp_rule_edges bndr_set (bndr, rhs)
-- `rhs_ja` is `joinRhsArity rhs'` and is the prediction for source M
-- of Note [Join arity prediction based on joinRhsArity]
rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]
- rules_w_uds = [ (r,l,adjustTailArity (Just rhs_ja) rhs_tuds)
- | (r,l,rhs_tuds) <- occAnalRules rhs_env bndr ]
+ rules_w_uds = [ (r,l,adjustTailArity (Just rhs_ja) rhs_wuds)
+ | (r,l,rhs_wuds) <- occAnalRules rhs_env bndr ]
rules' = map fstOf3 rules_w_uds
adj_rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds
@@ -1637,7 +1707,7 @@ mkLoopBreakerNodes !env lvl body_uds details_s
-- in nondeterministic order as explained in
-- Note [Deterministic SCC] in GHC.Data.Graph.Directed.
where
- WithTailUsageDetails _ rhs = nd_rhs nd
+ WithUsageDetails _ (TE _ rhs) = nd_rhs nd
simple_nd = SND { snd_bndr = new_bndr, snd_rhs = rhs, snd_score = score }
score = nodeScore env new_bndr lb_deps nd
lb_deps = extendFvs_ rule_fv_env inl_fvs
@@ -1677,7 +1747,7 @@ nodeScore :: OccEnv
-> NodeDetails
-> NodeScore
nodeScore !env new_bndr lb_deps
- (ND { nd_bndr = old_bndr, nd_rhs = WithTailUsageDetails _ bind_rhs })
+ (ND { nd_bndr = old_bndr, nd_rhs = WithUsageDetails _ (TE _ bind_rhs) })
| not (isId old_bndr) -- A type or coercion variable is never a loop breaker
= (100, 0, False)
@@ -1954,7 +2024,7 @@ zapLambdaBndrs fun arg_count
zap_bndr b | isTyVar b = b
| otherwise = zapLamIdInfo b
-occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
+occAnalLamTail :: OccEnv -> CoreExpr -> WithUsageDetails (Tail CoreExpr)
-- ^ See Note [Occurrence analysis for lambda binders].
-- It does the following:
-- * Sets one-shot info on the lambda binder from the OccEnv, and
@@ -1976,16 +2046,17 @@ occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
-- See Note [Adjusting right-hand sides]
occAnalLamTail env (Lam bndr expr)
| isTyVar bndr
- , let env1 = addOneInScope env bndr
- , WithTailUsageDetails (TUD ja usage) expr' <- occAnalLamTail env1 expr
- = WithTailUsageDetails (TUD (ja+1) usage) (Lam bndr expr')
- -- Important: Keep the 'env' unchanged so that with a RHS like
+ = addInScope env [bndr] $ \env ->
+ let WithUsageDetails usage (TE ja expr') = occAnalLamTail env expr
+ in WithUsageDetails usage (TE (ja+1) (Lam bndr expr'))
+ -- Important: Do not modify occ_encl, so that with a RHS like
-- \(@ x) -> K @x (f @x)
-- we'll see that (K @x (f @x)) is in a OccRhs, and hence refrain
-- from inlining f. See the beginning of Note [Cascading inlines].
| otherwise -- So 'bndr' is an Id
- = let (env_one_shots', bndr1)
+ = addInScope env [bndr] $ \env ->
+ let (env_one_shots', bndr1)
= case occ_one_shots env of
[] -> ([], bndr)
(os : oss) -> (oss, updOneShotInfo bndr os)
@@ -1995,15 +2066,14 @@ occAnalLamTail env (Lam bndr expr)
-- See Note [The oneShot function]
env1 = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }
- env2 = addOneInScope env1 bndr
- WithTailUsageDetails (TUD ja usage) expr' = occAnalLamTail env2 expr
- (usage', bndr2) = tagLamBinder usage bndr1
- in WithTailUsageDetails (TUD (ja+1) usage') (Lam bndr2 expr')
+ WithUsageDetails usage (TE ja expr') = occAnalLamTail env1 expr
+ bndr2 = tagLamBinder usage bndr1
+ in WithUsageDetails usage (TE (ja+1) (Lam bndr2 expr'))
-- For casts, keep going in the same lambda-group
-- See Note [Occurrence analysis for lambda binders]
occAnalLamTail env (Cast expr co)
- = let WithTailUsageDetails (TUD ja usage) expr' = occAnalLamTail env expr
+ = let WithUsageDetails usage (TE ja expr') = occAnalLamTail env expr
-- usage1: see Note [Gather occurrences of coercion variables]
usage1 = addManyOccs usage (coVarsOfCo co)
@@ -2019,10 +2089,10 @@ occAnalLamTail env (Cast expr co)
-- GHC.Core.Lint: Note Note [Join points and casts]
usage3 = markAllNonTail usage2
- in WithTailUsageDetails (TUD ja usage3) (Cast expr' co)
+ in WithUsageDetails usage3 (TE ja (Cast expr' co))
occAnalLamTail env expr = case occAnal env expr of
- WithUsageDetails usage expr' -> WithTailUsageDetails (TUD 0 usage) expr'
+ WithUsageDetails usage expr' -> WithUsageDetails usage (TE 0 expr')
{- Note [Occ-anal and cast worker/wrapper]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2055,7 +2125,7 @@ of a right hand side is handled by occAnalLamTail.
occAnalUnfolding :: OccEnv
-> Unfolding
- -> WithTailUsageDetails Unfolding
+ -> WithUsageDetails (Tail Unfolding)
-- Occurrence-analyse a stable unfolding;
-- discard a non-stable one altogether and return empty usage details.
occAnalUnfolding !env unf
@@ -2063,13 +2133,14 @@ occAnalUnfolding !env unf
unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src })
| isStableSource src ->
let
- WithTailUsageDetails (TUD rhs_ja usage) rhs' = occAnalLamTail env rhs
+ WithUsageDetails usage (TE rhs_ja rhs') = occAnalLamTail env rhs
unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules]
| otherwise = unf { uf_tmpl = rhs' }
- in WithTailUsageDetails (TUD rhs_ja (markAllMany usage)) unf'
+ in WithUsageDetails (markAllMany usage) (TE rhs_ja unf')
-- markAllMany: see Note [Occurrences in stable unfoldings]
- | otherwise -> WithTailUsageDetails (TUD 0 emptyDetails) unf
+
+ | otherwise -> WithUsageDetails emptyDetails (TE 0 unf)
-- For non-Stable unfoldings we leave them undisturbed, but
-- don't count their usage because the simplifier will discard them.
-- We leave them undisturbed because nodeScore uses their size info
@@ -2078,43 +2149,41 @@ occAnalUnfolding !env unf
-- scope remain in scope; there is no cloning etc.
unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
- -> WithTailUsageDetails (TUD 0 final_usage) (unf { df_args = args' })
- where
- env' = env `addInScope` bndrs
- (WithUsageDetails usage args') = occAnalList env' args
- final_usage = usage `addLamCoVarOccs` bndrs `delDetailsList` bndrs
- -- delDetailsList; no need to use tagLamBinders because we
+ -> let WithUsageDetails uds args' = addInScope env bndrs $ \ env ->
+ occAnalList env args
+ in WithUsageDetails uds (TE 0 (unf { df_args = args' }))
+ -- No need to use tagLamBinders because we
-- never inline DFuns so the occ-info on binders doesn't matter
- unf -> WithTailUsageDetails (TUD 0 emptyDetails) unf
+ unf -> WithUsageDetails emptyDetails (TE 0 unf)
occAnalRules :: OccEnv
-> Id -- Get rules from here
-> [(CoreRule, -- Each (non-built-in) rule
UsageDetails, -- Usage details for LHS
- TailUsageDetails)] -- Usage details for RHS
+ WithUsageDetails (Tail ()))] -- Usage details for RHS
occAnalRules !env bndr
= map occ_anal_rule (idCoreRules bndr)
where
occ_anal_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
- = (rule', lhs_uds', TUD rhs_ja rhs_uds')
+ = (rule', lhs_uds', WithUsageDetails rhs_uds' (TE rhs_ja ()))
where
- env' = env `addInScope` bndrs
rule' | noBinderSwaps env = rule -- Note [Unfoldings and rules]
| otherwise = rule { ru_args = args', ru_rhs = rhs' }
- (WithUsageDetails lhs_uds args') = occAnalList env' args
- lhs_uds' = markAllManyNonTail (lhs_uds `delDetailsList` bndrs)
- `addLamCoVarOccs` bndrs
+ WithUsageDetails lhs_uds args' = addInScope env bndrs $ \env ->
+ occAnalList env args
- (WithUsageDetails rhs_uds rhs') = occAnal env' rhs
+ lhs_uds' = markAllManyNonTail lhs_uds
+ WithUsageDetails rhs_uds rhs' = addInScope env bndrs $ \env ->
+ occAnal env rhs
-- Note [Rules are extra RHSs]
-- Note [Rule dependency info]
- rhs_uds' = markAllMany $
- rhs_uds `delDetailsList` bndrs
+ rhs_uds' = markAllMany rhs_uds
rhs_ja = length args -- See Note [Join points and unfoldings/rules]
- occ_anal_rule other_rule = (other_rule, emptyDetails, TUD 0 emptyDetails)
+ occ_anal_rule other_rule = ( other_rule, emptyDetails
+ , WithUsageDetails emptyDetails (TE 0 ()))
{- Note [Join point RHSs]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2167,7 +2236,7 @@ a big deal.
Note [Cascading inlines]
~~~~~~~~~~~~~~~~~~~~~~~~
-By default we use an rhsCtxt for the RHS of a binding. This tells the
+By default we use an OccRhs for the RHS of a binding. This tells the
occ anal n that it's looking at an RHS, which has an effect in
occAnalApp. In particular, for constructor applications, it makes
the arguments appear to have NoOccInfo, so that we don't inline into
@@ -2188,7 +2257,7 @@ Result: multiple simplifier iterations. Sigh.
So, when analysing the RHS of x3 we notice that x3 will itself
definitely inline the next time round, and so we analyse x3's rhs in
-an ordinary context, not rhsCtxt. Hence the "certainly_inline" stuff.
+an OccVanilla context, not OccRhs. Hence the "certainly_inline" stuff.
Annoyingly, we have to approximate GHC.Core.Opt.Simplify.Utils.preInlineUnconditionally.
If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and
@@ -2332,29 +2401,38 @@ occAnal env expr@(Lam {})
occAnal env (Case scrut bndr ty alts)
= let
- (WithUsageDetails scrut_usage scrut') = occAnal (scrutCtxt env alts) scrut
- alt_env = addBndrSwap scrut' bndr $ env { occ_encl = OccVanilla } `addOneInScope` bndr
- (alts_usage_s, alts') = mapAndUnzip (do_alt alt_env) alts
- alts_usage = foldr orUDs emptyDetails alts_usage_s
- (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr
- total_usage = markAllNonTail scrut_usage `andUDs` alts_usage1
+ WithUsageDetails scrut_usage scrut' = occAnal (scrutCtxt env alts) scrut
+
+ WithUsageDetails alts_usage (tagged_bndr, alts')
+ = addInScope env [bndr] $ \env ->
+ let alt_env = addBndrSwap scrut' bndr $
+ setRhsCtxt OccVanilla env
+ WithUsageDetails alts_usage alts' = do_alts alt_env alts
+ tagged_bndr = tagLamBinder alts_usage bndr
+ in WithUsageDetails alts_usage (tagged_bndr, alts')
+
+ total_usage = markAllNonTail scrut_usage `andUDs` alts_usage
-- Alts can have tail calls, but the scrutinee can't
+
in WithUsageDetails total_usage (Case scrut' tagged_bndr ty alts')
where
+ do_alts :: OccEnv -> [CoreAlt] -> WithUsageDetails [CoreAlt]
+ do_alts _ [] = WithUsageDetails emptyDetails []
+ do_alts env (alt:alts) = WithUsageDetails (uds1 `orUDs` uds2) (alt':alts')
+ where
+ WithUsageDetails uds1 alt' = do_alt env alt
+ WithUsageDetails uds2 alts' = do_alts env alts
+
do_alt !env (Alt con bndrs rhs)
- = let
- (WithUsageDetails rhs_usage1 rhs1) = occAnal (env `addInScope` bndrs) rhs
- (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs
- in -- See Note [Binders in case alternatives]
- (alt_usg, Alt con tagged_bndrs rhs1)
+ = addInScope env bndrs $ \ env ->
+ let WithUsageDetails rhs_usage rhs' = occAnal env rhs
+ tagged_bndrs = tagLamBinders rhs_usage bndrs
+ in -- See Note [Binders in case alternatives]
+ WithUsageDetails rhs_usage (Alt con tagged_bndrs rhs')
occAnal env (Let bind body)
- = let
- body_env = env { occ_encl = OccVanilla } `addInScope` bindersOf bind
- (WithUsageDetails body_usage body') = occAnal body_env body
- (WithUsageDetails final_usage binds') = occAnalBind env NotTopLevel
- noImpRuleEdges bind body_usage
- in WithUsageDetails final_usage (mkLets binds' body')
+ = occAnalBind env NotTopLevel noImpRuleEdges bind
+ (\env -> occAnal env body) mkLets
occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr] -> [OneShots] -> WithUsageDetails CoreExpr
-- The `fun` argument is just an accumulating parameter,
@@ -2415,7 +2493,7 @@ occAnalApp env (Var fun_id, args, ticks)
!(fun', fun_id') = lookupBndrSwap env fun_id
!(WithUsageDetails args_uds app') = occAnalArgs env fun' args one_shots
- fun_uds = mkOneOcc fun_id' int_cxt n_args
+ fun_uds = mkOneOcc env fun_id' int_cxt n_args
-- NB: fun_uds is computed for fun_id', not fun_id
-- See (BS1) in Note [The binder-swap substitution]
@@ -2588,6 +2666,9 @@ data OccEnv
-- Range is just Local Ids
, occ_bs_rng :: !VarSet
-- Vars (TyVars and Ids) free in the range of occ_bs_env
+
+ , occ_join_points :: !(IdEnv UsageDetails)
+ -- Usage details of the RHS of in-scope non-recursive join points
}
@@ -2630,6 +2711,7 @@ initOccEnv
, occ_unf_act = \_ -> True
, occ_rule_act = \_ -> True
+ , occ_join_points = emptyVarEnv
, occ_bs_env = emptyVarEnv
, occ_bs_rng = emptyVarSet }
@@ -2649,8 +2731,8 @@ scrutCtxt !env alts
-- non-default alternative. That in turn influences
-- pre/postInlineUnconditionally. Grep for "occ_int_cxt"!
-rhsCtxt :: OccEnv -> OccEnv
-rhsCtxt !env = env { occ_encl = OccRhs, occ_one_shots = [] }
+setRhsCtxt :: OccEncl -> OccEnv -> OccEnv
+setRhsCtxt ctxt !env = env { occ_encl = ctxt, occ_one_shots = [] }
valArgCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])
valArgCtxt !env []
@@ -2663,20 +2745,45 @@ isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of
OccRhs -> True
_ -> False
-addOneInScope :: OccEnv -> CoreBndr -> OccEnv
--- Needed for all Vars not just Ids
--- See Note [The binder-swap substitution] (BS3)
-addOneInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndr
- | bndr `elemVarSet` rng_vars = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
- | otherwise = env { occ_bs_env = swap_env `delVarEnv` bndr }
+addInScope :: OccEnv -> [Var] -> (OccEnv -> WithUsageDetails a)
+ -> WithUsageDetails a
+-- Needed for all Vars not just Ids; a TyVar might have a CoVars in its kind
+addInScope env@(OccEnv { occ_join_points = join_points })
+ bndrs thing_inside
+ = fix_up_uds $ thing_inside $
+ drop_shadowed_swaps $ drop_shadowed_joins env
+ where
+
+ drop_shadowed_swaps :: OccEnv -> OccEnv
+ -- See Note [The binder-swap substitution] (BS3)
+ drop_shadowed_swaps env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = bs_rng_vars })
+ | any (`elemVarSet` bs_rng_vars) bndrs
+ = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
+ | otherwise
+ = env { occ_bs_env = swap_env `delVarEnvList` bndrs }
+
+ drop_shadowed_joins :: OccEnv -> OccEnv
+ -- See Note [Occurrence analysis for join points]
+ drop_shadowed_joins env = env { occ_join_points = good_joins `delVarEnvList` bndrs}
-addInScope :: OccEnv -> [Var] -> OccEnv
--- Needed for all Vars not just Ids
--- See Note [The binder-swap substitution] (BS3)
-addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs
- | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
- | otherwise = env { occ_bs_env = swap_env `delVarEnvList` bndrs }
+ fix_up_uds :: WithUsageDetails a -> WithUsageDetails a
+ -- Remove usage for bndrs
+ -- Add usage info for (a) CoVars used in the types of bndrs
+ -- and (b) occ_join_points that we cannot push inwards because of shadowing
+ fix_up_uds (WithUsageDetails uds res) = WithUsageDetails with_joins res
+ where
+ trimmed_uds = uds `delDetails` bndrs
+ with_co_var_occs = trimmed_uds `addManyOccs` coVarOccs bndrs
+ with_joins = nonDetStrictFoldUFM andUDs with_co_var_occs bad_joins
+
+ (bad_joins, good_joins) = partitionVarEnv bad_join_rhs join_points
+ bad_join_rhs :: UsageDetails -> Bool
+ bad_join_rhs (UD { ud_env = rhs_usage }) = any (`elemVarEnv` rhs_usage) bndrs
+
+addJoinPoint :: OccEnv -> Id -> UsageDetails -> OccEnv
+addJoinPoint env bndr rhs_uds
+ = env { occ_join_points = extendVarEnv (occ_join_points env) bndr rhs_uds }
--------------------
transClosureFV :: VarEnv VarSet -> VarEnv VarSet
@@ -3097,9 +3204,10 @@ info then simply means setting the corresponding zapped set to the whole
'OccInfoEnv', a fast O(1) operation.
-}
-type OccInfoEnv = IdEnv OccInfo -- A finite map from ids to their usage
- -- INVARIANT: never IAmDead
- -- (Deadness is signalled by not being in the map at all)
+type OccInfoEnv = IdEnv OccInfo -- A finite map from an expression's
+ -- free variables to their usage
+ -- INVARIANT: never IAmDead
+ -- Deadness is signalled by not being in the map at all
type ZappedSet = OccInfoEnv -- Values are ignored
@@ -3113,18 +3221,6 @@ data UsageDetails
instance Outputable UsageDetails where
ppr ud = ppr (ud_env (flattenUsageDetails ud))
--- | Captures the result of applying 'occAnalLamTail' to a function `\xyz.body`.
--- The TailUsageDetails records
--- * the number of lambdas (including type lambdas: a JoinArity)
--- * UsageDetails for the `body`, unadjusted by `adjustTailUsage`.
--- If the binding turns out to be a join point with the indicated join
--- arity, this unadjusted usage details is just what we need; otherwise we
--- need to discard tail calls. That's what `adjustTailUsage` does.
-data TailUsageDetails = TUD !JoinArity !UsageDetails
-
-instance Outputable TailUsageDetails where
- ppr (TUD ja uds) = lambda <> ppr ja <> ppr uds
-
-------------------
-- UsageDetails API
@@ -3134,12 +3230,14 @@ andUDs, orUDs
andUDs = combineUsageDetailsWith addOccInfo
orUDs = combineUsageDetailsWith orOccInfo
-mkOneOcc :: Id -> InterestingCxt -> JoinArity -> UsageDetails
-mkOneOcc id int_cxt arity
- | isLocalId id
- = emptyDetails { ud_env = unitVarEnv id occ_info }
- | otherwise
+mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails
+mkOneOcc env id int_cxt arity
+ | not (isLocalId id)
= emptyDetails
+ | Just uds <- lookupVarEnv (occ_join_points env) id
+ = uds { ud_env = extendVarEnv (ud_env uds) id occ_info }
+ | otherwise
+ = emptyDetails { ud_env = unitVarEnv id occ_info }
where
occ_info = OneOcc { occ_in_lam = NotInsideLam
, occ_n_br = oneBranch
@@ -3164,18 +3262,18 @@ addManyOccs :: UsageDetails -> VarSet -> UsageDetails
addManyOccs usage id_set = nonDetStrictFoldUniqSet addManyOcc usage id_set
-- It's OK to use nonDetStrictFoldUniqSet here because addManyOcc commutes
-addLamCoVarOccs :: UsageDetails -> [Var] -> UsageDetails
--- Add any CoVars free in the type of a lambda-binder
+coVarOccs :: [Var] -> VarSet
+-- Add any CoVars free in the types of a telescope of lambda-binders
-- See Note [Gather occurrences of coercion variables]
-addLamCoVarOccs uds bndrs
- = uds `addManyOccs` coVarsOfTypes (map varType bndrs)
-
-delDetails :: UsageDetails -> Id -> UsageDetails
-delDetails ud bndr
- = ud `alterUsageDetails` (`delVarEnv` bndr)
+coVarOccs bndrs
+ = foldr get emptyVarSet bndrs
+ where
+ get bndr cvs = (cvs `delVarSet` bndr) `unionVarSet`
+ coVarsOfType (varType bndr)
-delDetailsList :: UsageDetails -> [Id] -> UsageDetails
-delDetailsList ud bndrs
+delDetails :: UsageDetails -> [Id] -> UsageDetails
+-- Delete these binders from the UsageDetails
+delDetails ud bndrs
= ud `alterUsageDetails` (`delVarEnvList` bndrs)
emptyDetails :: UsageDetails
@@ -3189,9 +3287,10 @@ isEmptyDetails = isEmptyVarEnv . ud_env
markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail
:: UsageDetails -> UsageDetails
-markAllMany ud = ud { ud_z_many = ud_env ud }
-markAllInsideLam ud = ud { ud_z_in_lam = ud_env ud }
-markAllNonTail ud = ud { ud_z_no_tail = ud_env ud }
+markAllMany ud = ud { ud_z_many = ud_env ud }
+markAllInsideLam ud = ud { ud_z_in_lam = ud_env ud }
+markAllNonTail ud = ud { ud_z_no_tail = ud_env ud }
+markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo
markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails
@@ -3201,9 +3300,6 @@ markAllInsideLamIf False ud = ud
markAllNonTailIf True ud = markAllNonTail ud
markAllNonTailIf False ud = ud
-
-markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo
-
lookupDetails :: UsageDetails -> Id -> OccInfo
lookupDetails ud id
= case lookupVarEnv (ud_env ud) id of
@@ -3213,6 +3309,15 @@ lookupDetails ud id
usedIn :: Id -> UsageDetails -> Bool
v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud
+partitionOneOccUDs :: UsageDetails -> (UsageDetails, UsageDetails)
+partitionOneOccUDs uds
+ = (emptyDetails{ud_env = interesting_env}, emptyDetails{ud_env = boring_env})
+ where
+ UD{ud_env=env} = flattenUsageDetails uds
+ (interesting_env,boring_env) = partitionVarEnv interesting env
+ interesting OneOcc{} = True
+ interesting _ = False
+
udFreeVars :: VarSet -> UsageDetails -> VarSet
-- Find the subset of bndrs that are mentioned in uds
udFreeVars bndrs ud = restrictFreeVars bndrs (ud_env ud)
@@ -3268,10 +3373,9 @@ flattenUsageDetails ud@(UD { ud_env = env })
-------------------
-- See Note [Adjusting right-hand sides]
adjustTailUsage :: Maybe JoinArity
- -> CoreExpr -- Rhs, AFTER occAnalLamTail
- -> TailUsageDetails -- From body of lambda
- -> UsageDetails
-adjustTailUsage mb_join_arity rhs (TUD rhs_ja usage)
+ -> WithUsageDetails (Tail CoreExpr) -- Rhs, AFTER occAnalLamTail
+ -> UsageDetails
+adjustTailUsage mb_join_arity (WithUsageDetails usage (TE rhs_ja rhs))
= -- c.f. occAnal (Lam {})
markAllInsideLamIf (not one_shot) $
markAllNonTailIf (not exact_join) $
@@ -3280,9 +3384,9 @@ adjustTailUsage mb_join_arity rhs (TUD rhs_ja usage)
one_shot = isOneShotFun rhs
exact_join = mb_join_arity == Just rhs_ja
-adjustTailArity :: Maybe JoinArity -> TailUsageDetails -> UsageDetails
-adjustTailArity mb_rhs_ja (TUD ud_ja usage) =
- markAllNonTailIf (mb_rhs_ja /= Just ud_ja) usage
+adjustTailArity :: Maybe JoinArity -> WithUsageDetails (Tail a) -> UsageDetails
+adjustTailArity mb_rhs_ja (WithUsageDetails usage (TE ja _))
+ = markAllNonTailIf (mb_rhs_ja /= Just ja) usage
markNonRecJoinOneShots :: JoinArity -> CoreExpr -> CoreExpr
-- For a /non-recursive/ join point we can mark all
@@ -3313,52 +3417,38 @@ markNonRecUnfoldingOneShots mb_join_arity unf
type IdWithOccInfo = Id
-tagLamBinders :: UsageDetails -- Of scope
- -> [Id] -- Binders
- -> (UsageDetails, -- Details with binders removed
- [IdWithOccInfo]) -- Tagged binders
+tagLamBinders :: UsageDetails -- Of scope
+ -> [Id] -- Binders
+ -> [IdWithOccInfo] -- Tagged binders
tagLamBinders usage binders
- = usage' `seq` (usage', bndrs')
- where
- (usage', bndrs') = mapAccumR tagLamBinder usage binders
+ = map (tagLamBinder usage) binders
tagLamBinder :: UsageDetails -- Of scope
-> Id -- Binder
- -> (UsageDetails, -- Details with binder removed
- IdWithOccInfo) -- Tagged binders
+ -> IdWithOccInfo -- Tagged binders
-- Used for lambda and case binders
--- It copes with the fact that lambda bindings can have a
--- stable unfolding, used for join points
+-- No-op on TyVars
+-- A lambda binder never has an unfolding, so no need to look for that
tagLamBinder usage bndr
- = (usage2, bndr')
+ = setBinderOcc (markNonTail occ) bndr
+ -- markNonTail: don't try to make an argument into a join point
where
- occ = lookupDetails usage bndr
- bndr' = setBinderOcc (markNonTail occ) bndr
- -- Don't try to make an argument into a join point
- usage1 = usage `delDetails` bndr
- usage2 | isId bndr = addManyOccs usage1 (idUnfoldingVars bndr)
- -- This is effectively the RHS of a
- -- non-join-point binding, so it's okay to use
- -- addManyOccsSet, which assumes no tail calls
- | otherwise = usage1
+ occ = lookupDetails usage bndr
tagNonRecBinder :: TopLevelFlag -- At top level?
-> UsageDetails -- Of scope
-> CoreBndr -- Binder
- -> WithUsageDetails -- Details with binder removed
- IdWithOccInfo -- Tagged binder
+ -> IdWithOccInfo -- Tagged binder
+-- No-op on TyVars
tagNonRecBinder lvl usage binder
- = let
- occ = lookupDetails usage binder
- will_be_join = decideJoinPointHood lvl usage (NE.singleton binder)
- occ' | will_be_join = -- must already be marked AlwaysTailCalled
- assert (isAlwaysTailCalled occ) occ
- | otherwise = markNonTail occ
- binder' = setBinderOcc occ' binder
- usage' = usage `delDetails` binder
- in
- WithUsageDetails usage' binder'
+ = setBinderOcc occ' binder
+ where
+ occ = lookupDetails usage binder
+ will_be_join = decideJoinPointHood lvl usage (NE.singleton binder)
+ occ' | will_be_join = -- must already be marked AlwaysTailCalled
+ assert (isAlwaysTailCalled occ) occ
+ | otherwise = markNonTail occ
tagRecBinders :: TopLevelFlag -- At top level?
-> UsageDetails -- Of body of let ONLY
@@ -3377,8 +3467,8 @@ tagRecBinders lvl body_uds details_s
-- manifest join arity M.
-- This (re-)asserts that makeNode had made tuds for that same arity M!
unadj_uds = foldr (andUDs . test_manifest_arity) body_uds details_s
- test_manifest_arity ND{nd_rhs=WithTailUsageDetails tuds rhs}
- = adjustTailArity (Just (joinRhsArity rhs)) tuds
+ test_manifest_arity ND{nd_rhs = wud_rhs@(WithUsageDetails _ (TE _ rhs))}
+ = adjustTailArity (Just (joinRhsArity rhs)) wud_rhs
bndr_ne = expectNonEmpty "List of binders is never empty" bndrs
will_be_joins = decideJoinPointHood lvl unadj_uds bndr_ne
@@ -3399,9 +3489,9 @@ tagRecBinders lvl body_uds details_s
-- 2. Adjust usage details of each RHS, taking into account the
-- join-point-hood decision
- rhs_udss' = [ adjustTailUsage (mb_join_arity bndr) rhs rhs_tuds -- matching occAnalLamTail in makeNode
- | ND { nd_bndr = bndr, nd_rhs = WithTailUsageDetails rhs_tuds rhs }
- <- details_s ]
+ rhs_udss' = [ adjustTailUsage (mb_join_arity bndr) rhs_wuds
+ -- Matching occAnalLamTail in makeNode
+ | ND { nd_bndr = bndr, nd_rhs = rhs_wuds } <- details_s ]
-- 3. Compute final usage details from adjusted RHS details
adj_uds = foldr andUDs body_uds rhs_udss'
@@ -3409,11 +3499,8 @@ tagRecBinders lvl body_uds details_s
-- 4. Tag each binder with its adjusted details
bndrs' = [ setBinderOcc (lookupDetails adj_uds bndr) bndr
| bndr <- bndrs ]
-
- -- 5. Drop the binders from the adjusted details and return
- usage' = adj_uds `delDetailsList` bndrs
in
- WithUsageDetails usage' bndrs'
+ WithUsageDetails adj_uds bndrs'
setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr
setBinderOcc occ_info bndr
=====================================
libraries/bytestring
=====================================
@@ -1 +1 @@
-Subproject commit 1543e054a314865d89a259065921d5acba03d966
+Subproject commit 9cab76dc861f651c3940e873ce921d9e09733cc8
=====================================
testsuite/tests/ghci/scripts/T9881.stdout
=====================================
@@ -19,19 +19,19 @@ instance Ord Data.ByteString.Lazy.ByteString
type Data.ByteString.ByteString :: *
data Data.ByteString.ByteString
- = Data.ByteString.Internal.BS {-# UNPACK #-}(GHC.ForeignPtr.ForeignPtr
- GHC.Word.Word8)
- {-# UNPACK #-}Int
- -- Defined in ‘Data.ByteString.Internal’
+ = bytestring-0.11.4.0:Data.ByteString.Internal.Type.BS {-# UNPACK #-}(GHC.ForeignPtr.ForeignPtr
+ GHC.Word.Word8)
+ {-# UNPACK #-}Int
+ -- Defined in ‘bytestring-0.11.4.0:Data.ByteString.Internal.Type’
instance Monoid Data.ByteString.ByteString
- -- Defined in ‘Data.ByteString.Internal’
+ -- Defined in ‘bytestring-0.11.4.0:Data.ByteString.Internal.Type’
instance Read Data.ByteString.ByteString
- -- Defined in ‘Data.ByteString.Internal’
+ -- Defined in ‘bytestring-0.11.4.0:Data.ByteString.Internal.Type’
instance Semigroup Data.ByteString.ByteString
- -- Defined in ‘Data.ByteString.Internal’
+ -- Defined in ‘bytestring-0.11.4.0:Data.ByteString.Internal.Type’
instance Show Data.ByteString.ByteString
- -- Defined in ‘Data.ByteString.Internal’
+ -- Defined in ‘bytestring-0.11.4.0:Data.ByteString.Internal.Type’
instance Eq Data.ByteString.ByteString
- -- Defined in ‘Data.ByteString.Internal’
+ -- Defined in ‘bytestring-0.11.4.0:Data.ByteString.Internal.Type’
instance Ord Data.ByteString.ByteString
- -- Defined in ‘Data.ByteString.Internal’
+ -- Defined in ‘bytestring-0.11.4.0:Data.ByteString.Internal.Type’
=====================================
testsuite/tests/ghci/scripts/ghci025.stdout
=====================================
@@ -53,7 +53,9 @@ Prelude.length :: Data.Foldable.Foldable t => t a -> GHC.Types.Int
-- imported via T
type T.Integer :: *
data T.Integer = ...
-T.length :: Data.ByteString.Internal.ByteString -> GHC.Types.Int
+T.length ::
+ bytestring-0.11.4.0:Data.ByteString.Internal.Type.ByteString
+ -> GHC.Types.Int
:browse! T
-- defined locally
T.length :: T.Integer
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff458a719fd86f5f88d62f12933aab82aca44477...614e35acd06214b318bcac5797ca6e2bd0d3dc96
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ff458a719fd86f5f88d62f12933aab82aca44477...614e35acd06214b318bcac5797ca6e2bd0d3dc96
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/20230113/dd5bc7da/attachment-0001.html>
More information about the ghc-commits
mailing list