[Git][ghc/ghc][wip/T22404] 18 commits: Update `Data.List.singleton` doc comment
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Sat Feb 11 01:49:08 UTC 2023
Simon Peyton Jones pushed to branch wip/T22404 at Glasgow Haskell Compiler / GHC
Commits:
d9d0c28d by konsumlamm at 2023-02-09T14:07:48-05:00
Update `Data.List.singleton` doc comment
- - - - -
fe9cd6ef by Ben Gamari at 2023-02-09T14:08:23-05:00
gitlab-template: Emphasize `user facing` label
My sense is that the current mention of the ~"user facing" label is
overlooked by many MR authors.
Let's move this point up in the list to make it more likely that it is
seen. Also rephrase some of the points.
- - - - -
e45eb828 by Simon Peyton Jones at 2023-02-10T06:51:28-05:00
Refactor the simplifier a bit to fix #22761
The core change in this commit, which fixes #22761, is that
* In a Core rule, ru_rhs is always occ-analysed.
This means adding a couple of calls to occurAnalyseExpr when
building a Rule, in
* GHC.Core.Rules.mkRule
* GHC.Core.Opt.Simplify.Iteration.simplRules
But diagosing the bug made me stare carefully at the code of the
Simplifier, and I ended up doing some only-loosely-related refactoring.
* I think that RULES could be lost because not every code path
did addBndrRules
* The code around lambdas was very convoluted
It's mainly moving deck chairs around, but I like it more now.
- - - - -
11e0cacb by Rebecca Turner at 2023-02-10T06:52:09-05:00
Detect the `mold` linker
Enables support for the `mold` linker by rui314.
- - - - -
59556235 by parsonsmatt at 2023-02-10T09:53:11-05:00
Add Lift instance for Fixed
- - - - -
c44e5f30 by Sylvain Henry at 2023-02-10T09:53:51-05:00
Testsuite: decrease length001 timeout for JS (#22921)
- - - - -
133516af by Zubin Duggal at 2023-02-10T09:54:27-05:00
compiler: Use NamedFieldPuns for `ModIface_` and `ModIfaceBackend` `NFData`
instances
This is a minor refactor that makes it easy to add and remove fields from
`ModIface_` and `ModIfaceBackend`.
Also change the formatting to make it clear exactly which fields are
fully forced with `rnf`
- - - - -
9959c95b by Simon Peyton Jones at 2023-02-10T18:39:18+00:00
Work in progress on #22404
Very much not ready!
- - - - -
688c529d by Sebastian Graf at 2023-02-10T18:39:18+00:00
Partition into OneOccs and ManyOccs
- - - - -
12dad6ab by Simon Peyton Jones at 2023-02-10T18:39:18+00:00
Wibbles
- - - - -
636d0580 by Simon Peyton Jones at 2023-02-10T18:39:18+00:00
Refactor WithTailJoinDetails
- - - - -
a7733cbf by Simon Peyton Jones at 2023-02-10T18:39:18+00:00
Wibbles
- - - - -
5e2f4779 by Simon Peyton Jones at 2023-02-10T18:39:18+00:00
Wibbles
- - - - -
1693f381 by Simon Peyton Jones at 2023-02-10T18:39:18+00:00
Major wibbles
- - - - -
092ae329 by Simon Peyton Jones at 2023-02-10T18:39:18+00:00
Wibble
- - - - -
fc501737 by Simon Peyton Jones at 2023-02-10T18:39:18+00:00
Vital fix to alt_env
- - - - -
5da33394 by Simon Peyton Jones at 2023-02-10T18:39:18+00:00
Comments
- - - - -
66c44df2 by Simon Peyton Jones at 2023-02-11T02:38:58+01:00
Another crucial change
Fixing a wrongly-zapped occ_join_points
..and a DEBUG check to catch it if it happens again
- - - - -
23 changed files:
- .gitlab/merge_request_templates/merge-request.md
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/SysTools/Info.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Unique/FM.hs
- compiler/GHC/Unit/Module/ModIface.hs
- libraries/base/Data/OldList.hs
- libraries/base/tests/all.T
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- testsuite/driver/testlib.py
- + testsuite/tests/simplCore/should_compile/T22761.hs
- + testsuite/tests/simplCore/should_compile/T22761a.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
.gitlab/merge_request_templates/merge-request.md
=====================================
@@ -5,18 +5,19 @@ expectations. Also please answer the following question in your MR description:*
**Where is the key part of this patch? That is, what should reviewers look at first?**
-Please take a few moments to verify that your commits fulfill the following:
+Please take a few moments to address the following points:
- * [ ] are either individually buildable or squashed
- * [ ] have commit messages which describe *what they do*
- (referring to [Notes][notes] and tickets using `#NNNN` syntax when
- appropriate)
+ * [ ] if your MR may break existing programs (e.g. touches `base` or causes the
+ compiler to reject programs), please describe the expected breakage and add
+ the ~"user facing" label. This will run ghc/head.hackage> to characterise
+ the effect of your change on Hackage.
+ * [ ] ensure that your commits are either individually buildable or squashed
+ * [ ] ensure that your commit messages describe *what they do*
+ (referring to tickets using `#NNNN` syntax when appropriate)
* [ ] have added source comments describing your change. For larger changes you
likely should add a [Note][notes] and cross-reference it from the relevant
places.
- * [ ] add a [testcase to the testsuite](https://gitlab.haskell.org/ghc/ghc/wikis/building/running-tests/adding).
- * [ ] if your MR affects library interfaces (e.g. changes `base`) or affects whether GHC will accept user-written code, please add
- the ~"user facing" label.
+ * [ ] add a [testcase to the testsuite][adding test].
* [ ] updates the users guide if applicable
* [ ] mentions new features in the release notes for the next release
@@ -29,3 +30,4 @@ no one has offerred review in a few days then please leave a comment mentioning
@triagers.
[notes]: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/coding-style#comments-in-the-source-code
+[adding test]: https://gitlab.haskell.org/ghc/ghc/wikis/building/running-tests/adding
=====================================
compiler/GHC/Core.hs
=====================================
@@ -1300,16 +1300,19 @@ data Unfolding
df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods,
} -- in positional order
- | CoreUnfolding { -- An unfolding for an Id with no pragma,
- -- or perhaps a NOINLINE pragma
- -- (For NOINLINE, the phase, if any, is in the
- -- InlinePragInfo for this Id.)
- uf_tmpl :: CoreExpr, -- Template; occurrence info is correct
- uf_src :: UnfoldingSource, -- Where the unfolding came from
- uf_is_top :: Bool, -- True <=> top level binding
- uf_cache :: UnfoldingCache, -- Cache of flags computable from the expr
- -- See Note [Tying the 'CoreUnfolding' knot]
- uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template.
+ | CoreUnfolding { -- An unfolding for an Id with no pragma,
+ -- or perhaps a NOINLINE pragma
+ -- (For NOINLINE, the phase, if any, is in the
+ -- InlinePragInfo for this Id.)
+ uf_tmpl :: CoreExpr, -- The unfolding itself (aka "template")
+ -- Always occ-analysed;
+ -- See Note [OccInfo in unfoldings and rules]
+
+ uf_src :: UnfoldingSource, -- Where the unfolding came from
+ uf_is_top :: Bool, -- True <=> top level binding
+ uf_cache :: UnfoldingCache, -- Cache of flags computable from the expr
+ -- See Note [Tying the 'CoreUnfolding' knot]
+ uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template.
}
-- ^ An unfolding with redundant cached information. Parameters:
--
@@ -1637,14 +1640,37 @@ change was requested by Roman, but it seems to make sense.
Note [OccInfo in unfoldings and rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In unfoldings and rules, we guarantee that the template is occ-analysed,
-so that the occurrence info on the binders is correct. This is important,
-because the Simplifier does not re-analyse the template when using it. If
-the occurrence info is wrong
- - We may get more simplifier iterations than necessary, because
- once-occ info isn't there
- - More seriously, we may get an infinite loop if there's a Rec
- without a loop breaker marked
+In unfoldings and rules, we guarantee that the template is occ-analysed, so
+that the occurrence info on the binders is correct. That way, when the
+Simplifier inlines an unfolding, it doesn't need to occ-analysis it first.
+(The Simplifier is designed to simplify occ-analysed expressions.)
+
+Given this decision it's vital that we do *always* do it.
+
+* If we don't, we may get more simplifier iterations than necessary,
+ because once-occ info isn't there
+
+* More seriously, we may get an infinite loop if there's a Rec without a
+ loop breaker marked.
+
+* Or we may get code that mentions variables not in scope: #22761
+ e.g. Suppose we have a stable unfolding : \y. let z = p+1 in 3
+ Then the pre-simplifier occ-anal will occ-anal the unfolding
+ (redundantly perhaps, but we need its free vars); this will not report
+ the use of `p`; so p's binding will be discarded, and yet `p` is still
+ mentioned.
+
+ Better to occ-anal the unfolding at birth, which will drop the
+ z-binding as dead code. (Remember, it's the occurrence analyser that
+ drops dead code.)
+
+* Another example is #8892:
+ \x -> letrec { f = ...g...; g* = f } in body
+ where g* is (for some strange reason) the loop breaker. If we don't
+ occ-anal it when reading it in, we won't mark g as a loop breaker, and we
+ may inline g entirely in body, dropping its binding, and leaving the
+ occurrence in f out of scope. This happened in #8892, where the unfolding
+ in question was a DFun unfolding.
************************************************************************
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -3088,8 +3088,15 @@ etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs
| need_args < 0
= pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule)
| otherwise
- = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args
- , ru_rhs = new_rhs }
+ = rule { ru_bndrs = bndrs ++ new_bndrs
+ , ru_args = args ++ new_args
+ , ru_rhs = new_rhs }
+ -- new_rhs really ought to be occ-analysed (see GHC.Core Note
+ -- [OccInfo in unfoldings and rules]), but it makes a module loop to
+ -- do so; it doesn't happen often; and it doesn't really matter if
+ -- the outer binders have bogus occurrence info; and new_rhs won't
+ -- have dead code if rhs didn't.
+
where
need_args = join_arity - length args
(new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -1935,10 +1935,13 @@ finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs
-- The normal case
| otherwise -- NB: threshold_arity might be less than
-- manifest arity for join points
- = -- pprTrace "finaliseArgBoxities" (
+ = -- pprTrace "finaliseArgBoxities {" (
-- vcat [text "function:" <+> ppr fn
+ -- , text "max" <+> ppr max_wkr_args
-- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs))
- -- , text "dmds after: " <+> ppr arg_dmds' ]) $
+ -- , text "triples:" <+> ppr arg_triples ]) $
+ -- pprTrace "finalase 2 }" (
+ -- vcat [ text "dmds after: " <+> ppr arg_dmds' ]) $
(arg_dmds', add_demands arg_dmds' rhs)
-- add_demands: we must attach the final boxities to the lambda-binders
-- of the function, both because that's kosher, and because CPR analysis
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -1,7 +1,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+{-# OPTIONS_GHC -cpp -Wno-incomplete-record-updates #-}
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@@ -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
@@ -76,7 +76,7 @@ Here's the externally-callable interface:
occurAnalyseExpr :: CoreExpr -> CoreExpr
occurAnalyseExpr expr = expr'
where
- (WithUsageDetails _ expr') = occAnal initOccEnv expr
+ WUD _ expr' = occAnal initOccEnv expr
occurAnalysePgm :: Module -- Used only in debug output
-> (Id -> Bool) -- Active unfoldings
@@ -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
+ WUD final_usage occ_anald_binds = go binds init_env
+ WUD _ 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 [] _ = WUD initial_uds []
+ go (bind:binds) env = occAnalBind env TopLevel
+ imp_rule_edges bind (go binds) (++)
{- *********************************************************************
* *
@@ -599,7 +595,124 @@ This showed up when compiling Control.Concurrent.Chan.getChanContents.
Hence the transitive rule_fv_env stuff described in
Note [Rules and loop breakers].
-------------------------------------------------------------
+Note [Occurrence analysis for join points]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider these two somewhat artificial programs (#22404)
+
+ Program (P1) Program (P2)
+ ------------------------------ -------------------------------------
+ let v = <small thunk> in let v = <small thunk> in
+ join j = case v of (a,b) -> a
+ in case x of in case x of
+ A -> case v of (a,b) -> a A -> j
+ B -> case v of (a,b) -> a B -> j
+ C -> case v of (a,b) -> b C -> case v of (a,b) -> b
+ D -> [] D -> []
+
+In (P1), `v` gets allocated, as a thunk, every time this code is executed. But
+notice that `v` occurs at most once in any case branch; the occurrence analyser
+spots this and returns a OneOcc{ occ_n_br = 3 } for `v`. Then the code in
+GHC.Core.Opt.Simplify.Utils.postInlineUnconditionally inlines `v` at its three
+use sites, and discards the let-binding. That way, we avoid allocating `v` in
+the A,B,C branches (though we still compute it of course), and branch D
+doesn't involve <small thunk> at all. This sometimes makes a Really Big
+Difference.
+
+In (P2) we have shared the common RHS of A, B, in a join point `j`. We would
+like to inline `v1 in just the same way as in (P1). But if we "andUDs"
+the usage from j's RHS and its body, we'll get ManyOccs for `v`. Important
+optimisation lost!
+
+The occurrence analyser therefore has clever code that behaves just as
+if you inlined `j` at all its call sites. Here is a tricky variant (P3)
+to keep in mind:
+ join j = case v of (a,b) -> a
+ in case f v of
+ A -> j
+ B -> j
+ C -> []
+If you mentally inline `j` you'll see that `v` is used twice on the path
+through A, so it should have ManyOcc. Bear this caes in mind!
+
+* We treat /non-recursive/ join points specially. Recursive join points
+ are treated like any other letrec, as before. Moreover, we only
+ deal with /pre-existing/ non-recursive join points, not the ones
+ that we discover for the first time in this sweep of the
+ occurrence analyser.
+
+* In occ_env, the new (occ_join_points :: IdEnv UsageDetails) maps
+ each in-scope non-recursive join point, such as `j` above, to
+ a "zeroed form" of its RHS's usage details. The "zeroed form"
+ * deletes ManyOccs
+ * maps a OneOcc to OneOcc{ occ_n_br = 0 }
+ In our example, occ_join_points will be extended with
+ [j :-> [v :-> OneOcc{occ_n_br=0}]]
+ See addJoinPoint.
+
+* At an occurence of a join point, we do everything as normal, but add in the
+ UsageDetails from the occ_join_points. See mkOneOcc.
+
+* At the NonRec binding of the join point, we use `orUDs`, not `andUDs` to
+ combine the usage from the RHS with the usage from the body.
+
+Here are the consequences
+
+* Because of the perhaps-surprising OneOcc{occ_n_br=0} idea of the zeroed
+ form, the occ_n_br field of a OneOcc binder still counts the number of
+ /actual lexical occurrences/ of the variable. In Program P2, for example,
+ `v` will end up with OneOcc{occ_n_br=2}, not occ_n_br=3. There are two
+ lexical occurrences of `v`!
+
+* In the tricky (P3) we'll get an `andUDs` of
+ * OneOcc{occ_n_br=0} from the occurrences of `j`)
+ * OneOcc{occ_n_br=1} from the (f v)
+ These are `andUDs` together, and hence `addOccInfo`, and hence
+ `v` gets ManyOccs, just as it should. Clever!
+
+There are a couple of tricky wrinkles
+
+(W1) Consider this example which shadows `j`:
+ join j = rhs in
+ in case x of { K j -> ..j..; ... }
+ Clearly when we come to the pattern `K j` we must drop the `j`
+ entry in occ_join_points.
+
+ This is done by `drop_shadowed_joins` in `addInScope`.
+
+(W2) Consider this example which shadows `v`:
+ join j = ...v...
+ in case x of { K v -> ..j..; ... }
+
+ We can't make j's occurrences in the K alternative give rise to an
+ occurrence of `v` (via occ_join_points), because it'll just be deleted by
+ the `K v` pattern. Yikes. This is rare because shadowing is rare, but
+ it definitely can happen. Solution: when bringing `v` into scope at
+ the `K v` pattern, chuck out of occ_join_points any elements whose
+ UsageDetails mentions `v`. Instead, just `andUDs` all that usage in
+ right here.
+
+ This is done by `add_bad_joins`` in `addInScope`; we use
+ `partitionVarEnv` to identify the `bad_joins` (the ones whose
+ UsageDetails mention the newly bound variables); then for any of /those/
+ that are /actually mentioned/ in the body, use `andUDs` to add their
+ UsageDetails to the returned UsageDetails. Tricky!
+
+(W3) Consider this example, which shadows `j`, but this time in an argument
+ join j = rhs
+ in f (case x of { K j -> ...; ... })
+ We can zap the entire occ_join_points when looking at the argument,
+ because `j` can't posibly occur -- it's a join point! And the smaller
+ occ_join_points is, the better. Smaller to look up in mkOneOcc, and
+ more important, less looking-up when partitioning in (W2), in addInScope.
+
+ This is done in setNonTailCtxt. It's important /not/ to do this for
+ join-point RHS's because of course `j` can occur there!
+
+ NB: this is just about efficiency: it is always safe /not/ to zap the
+ occ_join_points.
+
+Wrinkles (W1) and (W2) are very similar to Note [Binder swap] (BS3).
+
Note [Finding join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~
It's the occurrence analyser's job to find bindings that we can turn into join
@@ -817,41 +930,76 @@ of both functions, serving as a specification:
Non-recursive case: 'adjustNonRecRhs'
-}
-data WithUsageDetails a = WithUsageDetails !UsageDetails !a
-
-data WithTailUsageDetails a = WithTailUsageDetails !TailUsageDetails !a
-
------------------------------------------------------------------
-- 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 WUD body_uds body' = thing_inside env
+ WUD bind_uds binds' = occAnalRecBind env lvl ire pairs body_uds
+ in WUD 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 !(WUD body_uds res) = addInScope env [bndr] thing_inside
+ in WUD 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
+ WUD rhs_uds rhs' = adjustNonRecRhs mb_join $
+ occAnalLamTail (setTailCtxt env) rhs
+
+ -- Now analyse the body, adding the join point
+ -- into the environment with addJoinPoint
+ WUD body_uds (tagged_bndr, body)
+ = occAnalNonRecBody env lvl bndr $ \env ->
+ thing_inside (addJoinPoint env bndr rhs_uds)
+ in
+ if isDeadBinder tagged_bndr -- Drop dead code; see Note [Dead code]
+ then WUD body_uds body
+ else WUD (rhs_uds `orUDs` body_uds)
+ (combine [NonRec tagged_bndr rhs'] body)
-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
+ -- The normal case
+ | otherwise
+ = let WUD body_uds (tagged_bndr, body) = occAnalNonRecBody env lvl bndr thing_inside
+ WUD bind_uds binds = occAnalNonRecRhs env ire tagged_bndr rhs
+ in
+ if isDeadBinder tagged_bndr -- Drop dead code; see Note [Dead code]
+ then WUD body_uds body
+ else WUD (bind_uds `andUDs` body_uds)
+ (combine binds body)
-----------------
-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]
-
- | not (bndr `usedIn` body_usage)
- = WithUsageDetails body_usage [] -- See Note [Dead code]
+occAnalNonRecBody :: OccEnv -> TopLevelFlag -> Id
+ -> (OccEnv -> WithUsageDetails r) -- Scope of the bind
+ -> (WithUsageDetails (Id, r))
+occAnalNonRecBody env lvl bndr thing_inside
+ = addInScope env [bndr] $ \env ->
+ let !(WUD inner_uds res) = thing_inside env
+ tagged_bndr = tagNonRecBinder lvl inner_uds bndr
+ in WUD inner_uds (tagged_bndr, res)
- | otherwise -- It's mentioned in the body
- = WithUsageDetails (body_usage' `andUDs` rhs_usage) [NonRec final_bndr final_rhs]
+-----------------
+occAnalNonRecRhs :: OccEnv -> ImpRuleEdges -> Id -> CoreExpr
+ -> WithUsageDetails [CoreBind]
+occAnalNonRecRhs !env imp_rule_edges tagged_bndr rhs
+ = WUD 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 +1007,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 | is_join_point = setTailCtxt env
+ | otherwise = setNonTailCtxt rhs_ctxt env
+ rhs_ctxt | certainly_inline = OccVanilla -- See Note [Cascading inlines]
+ | otherwise = OccRhs
-- See Note [Sources of one-shot information]
rhs_env = env1 { occ_one_shots = argOneShots dmd }
@@ -869,26 +1018,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
+ WUD 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
+ WTUD unf_tuds 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_tuds
--------- 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 +1057,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,8 +1069,8 @@ 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
- = foldr (occAnalRec rhs_env lvl) (WithUsageDetails body_usage []) sccs
+occAnalRecBind !rhs_env lvl imp_rule_edges pairs body_usage
+ = foldr (occAnalRec rhs_env lvl) (WUD body_usage []) sccs
where
sccs :: [SCC NodeDetails]
sccs = {-# SCC "occAnalBind.scc" #-}
@@ -934,21 +1082,6 @@ 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
--- ^ 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)
- = 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
bindersOfSCC :: SCC NodeDetails -> [Var]
bindersOfSCC (AcyclicSCC nd) = [nd_bndr nd]
@@ -962,28 +1095,29 @@ occAnalRec :: OccEnv -> TopLevelFlag
-- Check for Note [Dead code]
-- NB: Only look at body_uds, ignoring uses in the SCC
-occAnalRec !_ _ scc (WithUsageDetails body_uds binds)
+occAnalRec !_ _ scc (WUD body_uds binds)
| not (any (`usedIn` body_uds) (bindersOfSCC scc))
- = WithUsageDetails body_uds binds
+ = WUD body_uds binds
-- The NonRec case is just like a Let (NonRec ...) above
occAnalRec !_ lvl
(AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds }))
- (WithUsageDetails body_uds binds)
- = WithUsageDetails (body_uds' `andUDs` rhs_uds') (NonRec bndr' rhs' : binds)
+ (WUD body_uds binds)
+ = WUD (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
+ WUD rhs_uds' rhs' = adjustNonRecRhs mb_join_arity wtuds
!unf' = markNonRecUnfoldingOneShots mb_join_arity (idUnfolding tagged_bndr)
!bndr' = tagged_bndr `setIdUnfolding` unf'
-- The Rec case is the interesting one
-- See Note [Recursive bindings: the grand plan]
-- See Note [Loop breaking]
-occAnalRec env lvl (CyclicSCC details_s) (WithUsageDetails body_uds binds)
+occAnalRec env lvl (CyclicSCC details_s) (WUD body_uds binds)
= -- pprTrace "occAnalRec" (ppr loop_breaker_nodes)
- WithUsageDetails final_uds (Rec pairs : binds)
+ WUD final_uds (Rec pairs : binds)
where
all_simple = all nd_simple details_s
@@ -992,7 +1126,7 @@ occAnalRec env lvl (CyclicSCC details_s) (WithUsageDetails body_uds binds)
-- See Note [Choosing loop breakers] for loop_breaker_nodes
final_uds :: UsageDetails
loop_breaker_nodes :: [LoopBreakerNode]
- (WithUsageDetails final_uds loop_breaker_nodes) = mkLoopBreakerNodes env lvl body_uds details_s
+ (WUD final_uds loop_breaker_nodes) = mkLoopBreakerNodes env lvl body_uds details_s
------------------------------
weak_fvs :: VarSet
@@ -1481,7 +1615,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
+ WTUD uds _ = nd_rhs nd
-- | Digraph with simplified and completely occurrence analysed
-- 'SimpleNodeDetails', retaining just the info we need for breaking loops.
@@ -1525,7 +1660,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 = WTUD (TUD rhs_ja unadj_scope_uds) rhs'
, nd_inl = inl_fvs
, nd_simple = null rules_w_uds && null imp_rule_info
, nd_weak_fvs = weak_fvs
@@ -1538,7 +1673,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,15 +1700,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 | isJoinId bndr = setTailCtxt env
+ | otherwise = setNonTailCtxt OccRhs env
+ WTUD (TUD rhs_ja unadj_rhs_uds) rhs' = 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
+ WTUD unf_tuds unf' = occAnalUnfolding rhs_env unf
adj_unf_uds = adjustTailArity (Just rhs_ja) unf_tuds
-- `rhs_ja` is `joinRhsArity rhs` and is the prediction for source M
-- of Note [Join arity prediction based on joinRhsArity]
@@ -1590,8 +1725,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
@@ -1624,11 +1759,12 @@ mkLoopBreakerNodes :: OccEnv -> TopLevelFlag
-- d) adjust each RHS's usage details according to
-- the binder's (new) shotness and join-point-hood
mkLoopBreakerNodes !env lvl body_uds details_s
- = WithUsageDetails final_uds (zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs')
+ = WUD final_uds (zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs')
where
- WithUsageDetails final_uds bndrs' = tagRecBinders lvl body_uds details_s
+ WUD final_uds bndrs' = tagRecBinders lvl body_uds details_s
- mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs }) new_bndr
+ mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs
+ , nd_rhs = WTUD _ rhs }) new_bndr
= DigraphNode { node_payload = simple_nd
, node_key = varUnique old_bndr
, node_dependencies = nonDetKeysUniqSet lb_deps }
@@ -1637,7 +1773,6 @@ 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
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 +1812,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 = WTUD _ bind_rhs })
| not (isId old_bndr) -- A type or coercion variable is never a loop breaker
= (100, 0, False)
@@ -1974,18 +2109,25 @@ occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr
-- In effect, the analysis result is for a non-recursive join point with
-- manifest arity and adjustTailUsage does the fixup.
-- See Note [Adjusting right-hand sides]
-occAnalLamTail env (Lam bndr expr)
+occAnalLamTail env expr
+ = let WUD usage expr' = occ_anal_lam_tail env expr
+ in WTUD (TUD (joinRhsArity expr) usage) expr'
+
+occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr
+-- Does not markInsidLam etc for the outmost batch of lambdas
+occ_anal_lam_tail 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 WUD usage expr' = occ_anal_lam_tail env expr
+ in WUD usage (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 +2137,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')
+ WUD usage expr' = occ_anal_lam_tail env1 expr
+ bndr2 = tagLamBinder usage bndr1
+ in WUD usage (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
+occ_anal_lam_tail env (Cast expr co)
+ = let WUD usage expr' = occ_anal_lam_tail env expr
-- usage1: see Note [Gather occurrences of coercion variables]
usage1 = addManyOccs usage (coVarsOfCo co)
@@ -2019,10 +2160,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 WUD usage3 (Cast expr' co)
-occAnalLamTail env expr = case occAnal env expr of
- WithUsageDetails usage expr' -> WithTailUsageDetails (TUD 0 usage) expr'
+occ_anal_lam_tail env expr -- Not Lam, not Cast
+ = occAnal env expr
{- Note [Occ-anal and cast worker/wrapper]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2063,13 +2204,14 @@ occAnalUnfolding !env unf
unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src })
| isStableSource src ->
let
- WithTailUsageDetails (TUD rhs_ja usage) rhs' = occAnalLamTail env rhs
+ WTUD (TUD rhs_ja uds) 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 WTUD (TUD rhs_ja (markAllMany uds)) unf'
-- markAllMany: see Note [Occurrences in stable unfoldings]
- | otherwise -> WithTailUsageDetails (TUD 0 emptyDetails) unf
+
+ | otherwise -> WTUD (TUD 0 emptyDetails) 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,15 +2220,13 @@ 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 WUD uds args' = addInScope env bndrs $ \ env ->
+ occAnalList env args
+ in WTUD (TUD 0 uds) (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 -> WTUD (TUD 0 emptyDetails) unf
occAnalRules :: OccEnv
-> Id -- Get rules from here
@@ -2099,22 +2239,22 @@ occAnalRules !env bndr
occ_anal_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
= (rule', lhs_uds', TUD rhs_ja rhs_uds')
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
+ WUD lhs_uds args' = addInScope env bndrs $ \env ->
+ occAnalList env args
- (WithUsageDetails rhs_uds rhs') = occAnal env' rhs
+ lhs_uds' = markAllManyNonTail lhs_uds
+ WUD 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
+ , TUD 0 emptyDetails )
{- Note [Join point RHSs]
~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2165,9 +2305,20 @@ So we have a fast-path that keeps the old tree if the occ_bs_env is
empty. This just saves a bit of allocation and reconstruction; not
a big deal.
+This fast path exposes a tricky cornder, though (#22761). Supose we have
+ Unfolding = \x. let y = foo in x+1
+which includes a dead binding for `y`. In occAnalUnfolding we occ-anal
+the unfolding and produce /no/ occurrences of `foo` (since `y` is
+dead). But if we discard the occ-analysed syntax tree (which we do on
+our fast path), and use the old one, we still /have/ an occurrence of
+`foo` -- and that can lead to out-of-scope variables (#22761).
+
+Solution: always keep occ-analysed trees in unfoldings and rules, so they
+have no dead code. See Note [OccInfo in unfoldings and rules] in GHC.Core.
+
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 +2339,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
@@ -2218,17 +2369,17 @@ for the various clauses.
-}
occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]
-occAnalList !_ [] = WithUsageDetails emptyDetails []
+occAnalList !_ [] = WUD emptyDetails []
occAnalList env (e:es) = let
- (WithUsageDetails uds1 e') = occAnal env e
- (WithUsageDetails uds2 es') = occAnalList env es
- in WithUsageDetails (uds1 `andUDs` uds2) (e' : es')
+ (WUD uds1 e') = occAnal env e
+ (WUD uds2 es') = occAnalList env es
+ in WUD (uds1 `andUDs` uds2) (e' : es')
occAnal :: OccEnv
-> CoreExpr
-> WithUsageDetails CoreExpr -- Gives info only about the "interesting" Ids
-occAnal !_ expr@(Lit _) = WithUsageDetails emptyDetails expr
+occAnal !_ expr@(Lit _) = WUD emptyDetails expr
occAnal env expr@(Var _) = occAnalApp env (expr, [], [])
-- At one stage, I gathered the idRuleVars for the variable here too,
@@ -2239,9 +2390,9 @@ occAnal env expr@(Var _) = occAnalApp env (expr, [], [])
-- weren't used at all.
occAnal _ expr@(Type ty)
- = WithUsageDetails (addManyOccs emptyDetails (coVarsOfType ty)) expr
+ = WUD (addManyOccs emptyDetails (coVarsOfType ty)) expr
occAnal _ expr@(Coercion co)
- = WithUsageDetails (addManyOccs emptyDetails (coVarsOfCo co)) expr
+ = WUD (addManyOccs emptyDetails (coVarsOfCo co)) expr
-- See Note [Gather occurrences of coercion variables]
{- Note [Gather occurrences of coercion variables]
@@ -2290,22 +2441,22 @@ But it is not necessary to gather CoVars from the types of other binders.
occAnal env (Tick tickish body)
| SourceNote{} <- tickish
- = WithUsageDetails usage (Tick tickish body')
+ = WUD usage (Tick tickish body')
-- SourceNotes are best-effort; so we just proceed as usual.
-- If we drop a tick due to the issues described below it's
-- not the end of the world.
| tickish `tickishScopesLike` SoftScope
- = WithUsageDetails (markAllNonTail usage) (Tick tickish body')
+ = WUD (markAllNonTail usage) (Tick tickish body')
| Breakpoint _ _ ids <- tickish
- = WithUsageDetails (usage_lam `andUDs` foldr addManyOcc emptyDetails ids) (Tick tickish body')
+ = WUD (usage_lam `andUDs` foldr addManyOcc emptyDetails ids) (Tick tickish body')
-- never substitute for any of the Ids in a Breakpoint
| otherwise
- = WithUsageDetails usage_lam (Tick tickish body')
+ = WUD usage_lam (Tick tickish body')
where
- (WithUsageDetails usage body') = occAnal env body
+ (WUD usage body') = occAnal env body
-- for a non-soft tick scope, we can inline lambdas only
usage_lam = markAllNonTail (markAllInsideLam usage)
-- TODO There may be ways to make ticks and join points play
@@ -2317,44 +2468,54 @@ occAnal env (Tick tickish body)
-- See #14242.
occAnal env (Cast expr co)
- = let (WithUsageDetails usage expr') = occAnal env expr
+ = let (WUD usage expr') = occAnal env expr
usage1 = addManyOccs usage (coVarsOfCo co)
-- usage2: see Note [Gather occurrences of coercion variables]
usage2 = markAllNonTail usage1
-- usage3: calls inside expr aren't tail calls any more
- in WithUsageDetails usage2 (Cast expr' co)
+ in WUD usage2 (Cast expr' co)
occAnal env app@(App _ _)
= occAnalApp env (collectArgsTicks tickishFloatable app)
occAnal env expr@(Lam {})
- = adjustNonRecRhs Nothing $ occAnalLamTail env expr -- mb_join_arity == Nothing <=> markAllManyNonTail
+ = adjustNonRecRhs Nothing $ -- Nothing <=> markAllManyNonTail
+ occAnalLamTail env expr
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
+ WUD scrut_usage scrut' = occAnal (setScrutCtxt env alts) scrut
+
+ WUD alts_usage (tagged_bndr, alts')
+ = addInScope env [bndr] $ \env ->
+ let alt_env = addBndrSwap scrut' bndr $
+ setTailCtxt env -- Kill off OccRhs
+ WUD alts_usage alts' = do_alts alt_env alts
+ tagged_bndr = tagLamBinder alts_usage bndr
+ in WUD 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')
+
+ in WUD total_usage (Case scrut' tagged_bndr ty alts')
where
+ do_alts :: OccEnv -> [CoreAlt] -> WithUsageDetails [CoreAlt]
+ do_alts _ [] = WUD emptyDetails []
+ do_alts env (alt:alts) = WUD (uds1 `orUDs` uds2) (alt':alts')
+ where
+ WUD uds1 alt' = do_alt env alt
+ WUD 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 WUD rhs_usage rhs' = occAnal env rhs
+ tagged_bndrs = tagLamBinders rhs_usage bndrs
+ in -- See Note [Binders in case alternatives]
+ WUD 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,
@@ -2362,14 +2523,16 @@ occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr] -> [OneShots] -> WithUsageDetail
occAnalArgs !env fun args !one_shots
= go emptyDetails fun args one_shots
where
- go uds fun [] _ = WithUsageDetails uds fun
+ env_args = setNonTailCtxt OccVanilla env
+
+ go uds fun [] _ = WUD uds fun
go uds fun (arg:args) one_shots
= go (uds `andUDs` arg_uds) (fun `App` arg') args one_shots'
where
- !(WithUsageDetails arg_uds arg') = occAnal arg_env arg
+ !(WUD arg_uds arg') = occAnal arg_env arg
!(arg_env, one_shots')
| isTypeArg arg = (env, one_shots)
- | otherwise = valArgCtxt env one_shots
+ | otherwise = addOneShots env_args one_shots
{-
Applications are dealt with specially because we want
@@ -2403,19 +2566,19 @@ occAnalApp !env (Var fun, args, ticks)
-- This caused #18296
| fun `hasKey` runRWKey
, [t1, t2, arg] <- args
- , WithUsageDetails usage arg' <- adjustNonRecRhs (Just 1) $ occAnalLamTail env arg
- = WithUsageDetails usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])
+ , WUD usage arg' <- adjustNonRecRhs (Just 1) $ occAnalLamTail env arg
+ = WUD usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])
occAnalApp env (Var fun_id, args, ticks)
- = WithUsageDetails all_uds (mkTicks ticks app')
+ = WUD all_uds (mkTicks ticks app')
where
-- Lots of banged bindings: this is a very heavily bit of code,
-- so it pays not to make lots of thunks here, all of which
-- will ultimately be forced.
!(fun', fun_id') = lookupBndrSwap env fun_id
- !(WithUsageDetails args_uds app') = occAnalArgs env fun' args one_shots
+ !(WUD 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]
@@ -2451,13 +2614,13 @@ occAnalApp env (Var fun_id, args, ticks)
-- See Note [Sources of one-shot information], bullet point A']
occAnalApp env (fun, args, ticks)
- = WithUsageDetails (markAllNonTail (fun_uds `andUDs` args_uds))
+ = WUD (markAllNonTail (fun_uds `andUDs` args_uds))
(mkTicks ticks app')
where
- !(WithUsageDetails args_uds app') = occAnalArgs env fun' args []
- !(WithUsageDetails fun_uds fun') = occAnal (addAppCtxt env args) fun
+ !(WUD args_uds app') = occAnalArgs env fun' args []
+ !(WUD fun_uds fun') = occAnal (addAppCtxt env args) fun
-- The addAppCtxt is a bit cunning. One iteration of the simplifier
- -- often leaves behind beta redexs like
+ -- often leaves behind beta redexes like
-- (\x y -> e) a1 a2
-- Here we would like to mark x,y as one-shot, and treat the whole
-- thing much like a let. We do this by pushing some OneShotLam items
@@ -2584,10 +2747,14 @@ data OccEnv
-- then please replace x by (y |> mco)
-- Invariant of course: idType x = exprType (y |> mco)
, occ_bs_env :: !(IdEnv (OutId, MCoercion))
- -- Domain is Global and Local Ids
- -- Range is just Local Ids
+ -- Domain is Global and Local Ids
+ -- Range is just Local Ids
, occ_bs_rng :: !VarSet
- -- Vars (TyVars and Ids) free in the range of occ_bs_env
+ -- Vars (TyVars and Ids) free in the range of occ_bs_env
+
+ -- Usage details of the RHS of in-scope non-recursive join points
+ , occ_join_points :: !(IdEnv UsageDetails)
+ -- Invariant: no Id maps to emptyDetails
}
@@ -2630,17 +2797,20 @@ initOccEnv
, occ_unf_act = \_ -> True
, occ_rule_act = \_ -> True
+ , occ_join_points = emptyVarEnv
, occ_bs_env = emptyVarEnv
, occ_bs_rng = emptyVarSet }
noBinderSwaps :: OccEnv -> Bool
noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env
-scrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv
-scrutCtxt !env alts
- | interesting_alts = env { occ_encl = OccScrut, occ_one_shots = [] }
- | otherwise = env { occ_encl = OccVanilla, occ_one_shots = [] }
+setScrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv
+setScrutCtxt !env alts
+ = setNonTailCtxt encl env
where
+ encl | interesting_alts = OccScrut
+ | otherwise = OccVanilla
+
interesting_alts = case alts of
[] -> False
[alt] -> not (isDefaultAlt alt)
@@ -2649,34 +2819,113 @@ 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 = [] }
-
-valArgCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])
-valArgCtxt !env []
- = (env { occ_encl = OccVanilla, occ_one_shots = [] }, [])
-valArgCtxt env (one_shots:one_shots_s)
- = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s)
+setNonTailCtxt :: OccEncl -> OccEnv -> OccEnv
+setNonTailCtxt ctxt !env
+ = env { occ_encl = ctxt
+ , occ_one_shots = []
+ , occ_join_points = zapped_jp_env }
+ where
+ -- zapped_jp_env is basically just emptyVarEnv (hence zapped).
+ -- See (W3) of Note [Occurrence analysis for join points]
+ -- Zapping improves efficiency, slightly, but it is /dangerous/.
+ -- If we zap [jx :-> uds], and then we find an occurrence of jx
+ -- anyway, we might lose those uds, and that might mean we don't
+ -- record all occurrencs, and that means we duplicate a redex....
+ -- a very nasty bug (which I encountered!). Hence this DEBUG
+ -- code which doesn't remove jx from the envt; it just gives it
+ -- emptyDetails, which in turn causes a panic in mkOneOcc
+#ifdef DEBUG
+ zapped_jp_env
+ = mapVarEnv (\ _ -> emptyDetails) $
+ occ_join_points env
+#else
+ zapped_jp_env = emptyVarEnv
+#endif
+
+setTailCtxt :: OccEnv -> OccEnv
+setTailCtxt !env
+ = env { occ_encl = OccVanilla }
+ -- Preserve occ_one_shots, occ_join points
+ -- Do not use OccRhs for the RHS of a join point (which is a tail ctxt):
+ -- see Note [Join point RHSs]
+
+addOneShots :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])
+addOneShots !env one_shots
+ = case one_shots of
+ [] -> (env, [])
+ (os:oss) -> (env { occ_one_shots = os }, oss)
isRhsEnv :: OccEnv -> Bool
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 }
-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 }
+ drop_shadowed_joins :: OccEnv -> OccEnv
+ -- See Note [Occurrence analysis for join points] wrinkle (W1)
+ drop_shadowed_joins env = env { occ_join_points = good_joins `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 (WUD uds res) = WUD with_joins res
+ where
+ trimmed_uds = uds `delDetails` bndrs
+ with_co_var_occs = trimmed_uds `addManyOccs` coVarOccs bndrs
+ with_joins = add_bad_joins with_co_var_occs
+ add_bad_joins :: UsageDetails -> UsageDetails
+ add_bad_joins uds = nonDetStrictFoldUFM_Directly add_bad_join uds bad_joins
+
+ add_bad_join :: Unique -> UsageDetails -- Bad join and its usage details
+ -> UsageDetails -> UsageDetails
+ -- See Note [Occurrence analysis for join points] wrinkle (W2)
+ add_bad_join uniq bad_join_uds uds
+ | uniq `elemUFM_Directly` ud_env uds = uds `andUDs` bad_join_uds
+ | otherwise = uds
+
+ (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
+ | isEmptyDetails zeroed_form
+ = env
+ | otherwise
+ = env { occ_join_points = extendVarEnv (occ_join_points env) bndr zeroed_form }
+ where
+ zeroed_form = mkZeroedForm rhs_uds
+
+mkZeroedForm :: UsageDetails -> UsageDetails
+-- See Note [Occurrence analysis for join points] for "zeroed form"
+mkZeroedForm rhs_uds@(UD { ud_env = rhs_occs })
+ = emptyDetails { ud_env = mapMaybeUFM_Directly do_one rhs_occs }
+ where
+ do_one :: Unique -> OccInfo -> Maybe OccInfo
+ do_one key occ = case doZappingByUnique rhs_uds key occ of
+ ManyOccs {} -> Nothing
+ occ@(OneOcc {}) -> Just (occ { occ_n_br = 0 })
+ IAmDead -> pprPanic "addJoinPoint" (ppr key)
+ IAmALoopBreaker {} -> pprPanic "addJoinPoint" (ppr key)
--------------------
transClosureFV :: VarEnv VarSet -> VarEnv VarSet
@@ -3097,9 +3346,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, or IAmLoopBreaker
+ -- Deadness is signalled by not being in the map at all
type ZappedSet = OccInfoEnv -- Values are ignored
@@ -3113,18 +3363,23 @@ 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
+
+---------------------
+-- | TailUsageDetails captures the result of applying 'occAnalLamTail'
+-- to a function `\xyz.body`. The TailUsageDetails pairs together
-- * 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.
+-- * UsageDetails for the `body` of the lambda, 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
+---------------------
+data WithUsageDetails a = WUD !UsageDetails !a
+data WithTailUsageDetails a = WTUD !TailUsageDetails !a
-------------------
-- UsageDetails API
@@ -3134,17 +3389,25 @@ 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 join_uds <- lookupVarEnv (occ_join_points env) id
+ = -- pprTrace "mkOneOcc" (ppr id $$ ppr uds) $
+ assertPpr (not (isEmptyDetails join_uds)) (ppr id) $
+ one_occ_uds `andUDs` join_uds
+
+ | otherwise
+ = one_occ_uds
+
where
- occ_info = OneOcc { occ_in_lam = NotInsideLam
- , occ_n_br = oneBranch
- , occ_int_cxt = int_cxt
- , occ_tail = AlwaysTailCalled arity }
+ one_occ_uds = emptyDetails { ud_env = unitVarEnv id one_occ_info }
+ one_occ_info = OneOcc { occ_in_lam = NotInsideLam
+ , occ_n_br = oneBranch
+ , occ_int_cxt = int_cxt
+ , occ_tail = AlwaysTailCalled arity }
addManyOccId :: UsageDetails -> Id -> UsageDetails
-- Add the non-committal (id :-> noOccInfo) to the usage details
@@ -3164,19 +3427,14 @@ 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)
-
-delDetailsList :: UsageDetails -> [Id] -> UsageDetails
-delDetailsList ud bndrs
- = ud `alterUsageDetails` (`delVarEnvList` bndrs)
+coVarOccs bndrs
+ = foldr get emptyVarSet bndrs
+ where
+ get bndr cvs = (cvs `delVarSet` bndr) `unionVarSet`
+ coVarsOfType (varType bndr)
emptyDetails :: UsageDetails
emptyDetails = UD { ud_env = emptyVarEnv
@@ -3187,11 +3445,16 @@ emptyDetails = UD { ud_env = emptyVarEnv
isEmptyDetails :: UsageDetails -> Bool
isEmptyDetails = isEmptyVarEnv . ud_env
+delDetails :: UsageDetails -> [Id] -> UsageDetails
+-- Delete these binders from the UsageDetails
+delDetails ud bndrs = ud `alterUsageDetails` (`delVarEnvList` bndrs)
+
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 +3464,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 +3473,15 @@ lookupDetails ud id
usedIn :: Id -> UsageDetails -> Bool
v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud
+{- Commenting out
+ = (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)
@@ -3260,29 +3529,43 @@ alterUsageDetails !ud f
flattenUsageDetails :: UsageDetails -> UsageDetails
flattenUsageDetails ud@(UD { ud_env = env })
- = UD { ud_env = mapUFM_Directly (doZappingByUnique ud) env
- , ud_z_many = emptyVarEnv
- , ud_z_in_lam = emptyVarEnv
- , ud_z_no_tail = emptyVarEnv }
+ = emptyDetails { ud_env = mapUFM_Directly (doZappingByUnique ud) env }
-------------------
-- See Note [Adjusting right-hand sides]
+
+adjustNonRecRhs :: Maybe JoinArity
+ -> WithTailUsageDetails 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 rhs_wuds@(WTUD _ rhs)
+ = WUD 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_wuds
+
adjustTailUsage :: Maybe JoinArity
- -> CoreExpr -- Rhs, AFTER occAnalLamTail
- -> TailUsageDetails -- From body of lambda
- -> UsageDetails
-adjustTailUsage mb_join_arity rhs (TUD rhs_ja usage)
+ -> WithTailUsageDetails CoreExpr -- Rhs usage, AFTER occAnalLamTail
+ -> UsageDetails
+adjustTailUsage mb_join_arity (WTUD (TUD rhs_ja uds) rhs)
= -- c.f. occAnal (Lam {})
markAllInsideLamIf (not one_shot) $
markAllNonTailIf (not exact_join) $
- usage
+ uds
where
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 mb_rhs_ja (TUD ja usage)
+ = markAllNonTailIf (mb_rhs_ja /= Just ja) usage
markNonRecJoinOneShots :: JoinArity -> CoreExpr -> CoreExpr
-- For a /non-recursive/ join point we can mark all
@@ -3313,52 +3596,39 @@ 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, unless
+ -- it was a join point before but is now dead
+ assert (isAlwaysTailCalled occ || isDeadOcc occ) occ
+ | otherwise = markNonTail occ
tagRecBinders :: TopLevelFlag -- At top level?
-> UsageDetails -- Of body of let ONLY
@@ -3370,14 +3640,14 @@ tagRecBinders :: TopLevelFlag -- At top level?
-- details *before* tagging binders (because the tags depend on the RHSes).
tagRecBinders lvl body_uds details_s
= let
- bndrs = map nd_bndr details_s
+ bndrs = map nd_bndr details_s
-- 1. See Note [Join arity prediction based on joinRhsArity]
-- Determine possible join-point-hood of whole group, by testing for
-- 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}
+ unadj_uds = foldr (andUDs . test_manifest_arity) body_uds details_s
+ test_manifest_arity ND{nd_rhs = WTUD tuds rhs}
= adjustTailArity (Just (joinRhsArity rhs)) tuds
bndr_ne = expectNonEmpty "List of binders is never empty" bndrs
@@ -3395,25 +3665,23 @@ tagRecBinders lvl body_uds details_s
= Just arity
| otherwise
= assert (not will_be_joins) -- Should be AlwaysTailCalled if
- Nothing -- we are making join points!
+ Nothing -- we are making join points!
-- 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'
+ adj_uds = foldr andUDs body_uds rhs_udss'
-- 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'
+ WUD adj_uds bndrs'
setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr
setBinderOcc occ_info bndr
@@ -3444,14 +3712,21 @@ decideJoinPointHood :: TopLevelFlag -> UsageDetails
-> Bool
decideJoinPointHood TopLevel _ _
= False
+
decideJoinPointHood NotTopLevel usage bndrs
- | isJoinId (NE.head bndrs)
- = warnPprTrace (not all_ok)
+ | isJoinId bndr1
+ = warnPprTrace lost_join_point
"OccurAnal failed to rediscover join point(s)" (ppr bndrs)
- all_ok
+ all_ok
+-- = assertPpr (not lost_join_point) (ppr bndrs)
+-- True
+
| otherwise
= all_ok
where
+ bndr1 = NE.head bndrs
+ lost_join_point = not (isDeadOcc (lookupDetails usage bndr1)) && not all_ok
+
-- See Note [Invariants on join points]; invariants cited by number below.
-- Invariant 2 is always satisfiable by the simplifier by eta expansion.
all_ok = -- Invariant 3: Either all are join points or none are
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -1065,7 +1065,7 @@ subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
-- See Note [Bangs in the Simplifier]
!id1 = uniqAway in_scope old_id
!id2 = substIdType env id1
- !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
+ !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
-- and fragile OccInfo
!new_id = adjust_type id3
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -319,14 +319,14 @@ simplLazyBind :: SimplEnv
-> TopLevelFlag -> RecFlag
-> InId -> OutId -- Binder, both pre-and post simpl
-- Not a JoinId
- -- The OutId has IdInfo, except arity, unfolding
+ -- The OutId has IdInfo (notably RULES),
+ -- except arity, unfolding
-- Ids only, no TyVars
-> InExpr -> SimplEnv -- The RHS and its environment
-> SimplM (SimplFloats, SimplEnv)
-- Precondition: the OutId is already in the InScopeSet of the incoming 'env'
-- Precondition: not a JoinId
-- Precondition: rhs obeys the let-can-float invariant
--- NOT used for JoinIds
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
= assert (isId bndr )
assertPpr (not (isJoinId bndr)) (ppr bndr) $
@@ -398,48 +398,45 @@ simplJoinBind env is_rec cont old_bndr new_bndr rhs rhs_se
; completeBind env (BC_Join is_rec cont) old_bndr new_bndr rhs' }
--------------------------
-simplNonRecX :: SimplEnv
+simplAuxBind :: SimplEnv
-> InId -- Old binder; not a JoinId
-> OutExpr -- Simplified RHS
-> SimplM (SimplFloats, SimplEnv)
--- A specialised variant of simplNonRec used when the RHS is already
--- simplified, notably in knownCon. It uses case-binding where necessary.
+-- A specialised variant of completeBindX used to construct non-recursive
+-- auxiliary bindings, notably in knownCon.
+--
+-- The binder comes from a case expression (case binder or alternative)
+-- and so does not have rules, inline pragmas etc.
--
-- Precondition: rhs satisfies the let-can-float invariant
-simplNonRecX env bndr new_rhs
- | assertPpr (not (isJoinId bndr)) (ppr bndr) $
+simplAuxBind env bndr new_rhs
+ | assertPpr (isId bndr && not (isJoinId bndr)) (ppr bndr) $
isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
= return (emptyFloats env, env) -- Here c is dead, and we avoid
- -- creating the binding c = (a,b)
-
- | Coercion co <- new_rhs
- = return (emptyFloats env, extendCvSubst env bndr co)
+ -- creating the binding c = (a,b)
+ -- The cases would be inlined unconditionally by completeBind:
+ -- but it seems not uncommon, and avoids faff to do it here
+ -- This is safe because it's only used for auxiliary bindings, which
+ -- have no NOLINE pragmas, nor RULEs
| exprIsTrivial new_rhs -- Short-cut for let x = y in ...
- -- This case would ultimately land in postInlineUnconditionally
- -- but it seems not uncommon, and avoids a lot of faff to do it here
- = return (emptyFloats env
- , extendIdSubst env bndr (DoneEx new_rhs Nothing))
+ = return ( emptyFloats env
+ , case new_rhs of
+ Coercion co -> extendCvSubst env bndr co
+ _ -> extendIdSubst env bndr (DoneEx new_rhs Nothing) )
| otherwise
- = do { (env1, new_bndr) <- simplBinder env bndr
- ; let is_strict = isStrictId new_bndr
- -- isStrictId: use new_bndr because the InId bndr might not have
- -- a fixed runtime representation, which isStrictId doesn't expect
- -- c.f. Note [Dark corner with representation polymorphism]
-
- ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict
- new_bndr (emptyFloats env) new_rhs
- -- NB: it makes a surprisingly big difference (5% in compiler allocation
- -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env',
- -- because this is simplNonRecX, so bndr is not in scope in the RHS.
-
- ; (bind_float, env2) <- completeBind (env1 `setInScopeFromF` rhs_floats)
- (BC_Let NotTopLevel NonRecursive)
+ = do { -- ANF-ise the RHS
+ let !occ_fs = getOccFS bndr
+ ; (anf_floats, rhs1) <- prepareRhs env NotTopLevel occ_fs new_rhs
+ ; unless (isEmptyLetFloats anf_floats) (tick LetFloatFromLet)
+ ; let rhs_floats = emptyFloats env `addLetFloats` anf_floats
+
+ -- Simplify the binder and complete the binding
+ ; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr
+ ; (bind_float, env2) <- completeBind env1 (BC_Let NotTopLevel NonRecursive)
bndr new_bndr rhs1
- -- Must pass env1 to completeBind in case simplBinder had to clone,
- -- and extended the substitution with [bndr :-> new_bndr]
; return (rhs_floats `addFloats` bind_float, env2) }
@@ -761,49 +758,54 @@ prepareRhs :: HasDebugCallStack
-- x = Just a
-- See Note [prepareRhs]
prepareRhs env top_lvl occ rhs0
- = do { (_is_exp, floats, rhs1) <- go 0 rhs0
- ; return (floats, rhs1) }
+ | is_expandable = anfise rhs0
+ | otherwise = return (emptyLetFloats, rhs0)
where
- go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)
- go n_val_args (Cast rhs co)
- = do { (is_exp, floats, rhs') <- go n_val_args rhs
- ; return (is_exp, floats, Cast rhs' co) }
- go n_val_args (App fun (Type ty))
- = do { (is_exp, floats, rhs') <- go n_val_args fun
- ; return (is_exp, floats, App rhs' (Type ty)) }
- go n_val_args (App fun arg)
- = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun
- ; if is_exp
- then do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg
- ; return (True, floats1 `addLetFlts` floats2, App fun' arg') }
- else return (False, emptyLetFloats, App fun arg)
- }
- go n_val_args (Var fun)
- = return (is_exp, emptyLetFloats, Var fun)
- where
- is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP
- -- See Note [CONLIKE pragma] in GHC.Types.Basic
- -- The definition of is_exp should match that in
- -- 'GHC.Core.Opt.OccurAnal.occAnalApp'
-
- go n_val_args (Tick t rhs)
+ -- We can' use exprIsExpandable because the WHOLE POINT is that
+ -- we want to treat (K <big>) as expandable, because we are just
+ -- about "anfise" the <big> expression. exprIsExpandable would
+ -- just say no!
+ is_expandable = go rhs0 0
+ where
+ go (Var fun) n_val_args = isExpandableApp fun n_val_args
+ go (App fun arg) n_val_args
+ | isTypeArg arg = go fun n_val_args
+ | otherwise = go fun (n_val_args + 1)
+ go (Cast rhs _) n_val_args = go rhs n_val_args
+ go (Tick _ rhs) n_val_args = go rhs n_val_args
+ go _ _ = False
+
+ anfise :: OutExpr -> SimplM (LetFloats, OutExpr)
+ anfise (Cast rhs co)
+ = do { (floats, rhs') <- anfise rhs
+ ; return (floats, Cast rhs' co) }
+ anfise (App fun (Type ty))
+ = do { (floats, rhs') <- anfise fun
+ ; return (floats, App rhs' (Type ty)) }
+ anfise (App fun arg)
+ = do { (floats1, fun') <- anfise fun
+ ; (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg
+ ; return (floats1 `addLetFlts` floats2, App fun' arg') }
+ anfise (Var fun)
+ = return (emptyLetFloats, Var fun)
+
+ anfise (Tick t rhs)
-- We want to be able to float bindings past this
-- tick. Non-scoping ticks don't care.
| tickishScoped t == NoScope
- = do { (is_exp, floats, rhs') <- go n_val_args rhs
- ; return (is_exp, floats, Tick t rhs') }
+ = do { (floats, rhs') <- anfise rhs
+ ; return (floats, Tick t rhs') }
-- On the other hand, for scoping ticks we need to be able to
-- copy them on the floats, which in turn is only allowed if
-- we can obtain non-counting ticks.
| (not (tickishCounts t) || tickishCanSplit t)
- = do { (is_exp, floats, rhs') <- go n_val_args rhs
+ = do { (floats, rhs') <- anfise rhs
; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)
floats' = mapLetFloats floats tickIt
- ; return (is_exp, floats', Tick t rhs') }
+ ; return (floats', Tick t rhs') }
- go _ other
- = return (False, emptyLetFloats, other)
+ anfise other = return (emptyLetFloats, other)
makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)
makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd })
@@ -1244,7 +1246,7 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont
| otherwise
= {-#SCC "simplNonRecE" #-}
- simplNonRecE env False bndr (rhs, env) body cont
+ simplNonRecE env FromLet bndr (rhs, env) body cont
{- Note [Avoiding space leaks in OutType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1505,8 +1507,9 @@ rebuild env expr cont
StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }
-> rebuildCall env (addValArgTo fun expr fun_ty ) cont
- StrictBind { sc_bndr = b, sc_body = body, sc_env = se, sc_cont = cont }
- -> completeBindX (se `setInScopeFromE` env) b expr body cont
+ StrictBind { sc_bndr = b, sc_body = body, sc_env = se
+ , sc_cont = cont, sc_from = from_what }
+ -> completeBindX (se `setInScopeFromE` env) from_what b expr body cont
ApplyToTy { sc_arg_ty = ty, sc_cont = cont}
-> rebuild env (App expr (Type ty)) cont
@@ -1518,25 +1521,48 @@ rebuild env expr cont
; rebuild env (App expr arg') cont }
completeBindX :: SimplEnv
+ -> FromWhat
-> InId -> OutExpr -- Bind this Id to this (simplified) expression
-- (the let-can-float invariant may not be satisfied)
- -> InExpr -- In this lambda
+ -> InExpr -- In this body
-> SimplCont -- Consumed by this continuation
-> SimplM (SimplFloats, OutExpr)
-completeBindX env bndr rhs body cont
- | needsCaseBinding (idType bndr) rhs -- Enforcing the let-can-float-invariant
- = do { (env1, bndr1) <- simplNonRecBndr env bndr
- ; (floats, expr') <- simplLam env1 body cont
+completeBindX env from_what bndr rhs body cont
+ | FromBeta arg_ty <- from_what
+ , needsCaseBinding arg_ty rhs -- Enforcing the let-can-float-invariant
+ = do { (env1, bndr1) <- simplNonRecBndr env bndr -- Lambda binders don't have rules
+ ; (floats, expr') <- simplNonRecBody env1 from_what body cont
-- Do not float floats past the Case binder below
; let expr'' = wrapFloats floats expr'
- ; let case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr'']
+ case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr'']
; return (emptyFloats env, case_expr) }
- | otherwise
- = do { (floats1, env') <- simplNonRecX env bndr rhs
- ; (floats2, expr') <- simplLam env' body cont
- ; return (floats1 `addFloats` floats2, expr') }
+ | otherwise -- Make a let-binding
+ = do { (env1, bndr1) <- simplNonRecBndr env bndr
+ ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)
+
+ ; let is_strict = isStrictId bndr2
+ -- isStrictId: use simplified binder because the InId bndr might not have
+ -- a fixed runtime representation, which isStrictId doesn't expect
+ -- c.f. Note [Dark corner with representation polymorphism]
+
+ ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict
+ bndr2 (emptyFloats env) rhs
+ -- NB: it makes a surprisingly big difference (5% in compiler allocation
+ -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env',
+ -- because this is simplNonRecX, so bndr is not in scope in the RHS.
+
+ ; (bind_float, env2) <- completeBind (env2 `setInScopeFromF` rhs_floats)
+ (BC_Let NotTopLevel NonRecursive)
+ bndr bndr2 rhs1
+ -- Must pass env1 to completeBind in case simplBinder had to clone,
+ -- and extended the substitution with [bndr :-> new_bndr]
+
+ -- Simplify the body
+ ; (body_floats, body') <- simplNonRecBody env2 from_what body cont
+ ; let all_floats = rhs_floats `addFloats` bind_float `addFloats` body_floats
+ ; return ( all_floats, body' ) }
{-
************************************************************************
@@ -1674,6 +1700,14 @@ simplArg env dup_flag fun_ty arg_env arg
************************************************************************
-}
+simplNonRecBody :: SimplEnv -> FromWhat
+ -> InExpr -> SimplCont
+ -> SimplM (SimplFloats, OutExpr)
+simplNonRecBody env from_what body cont
+ = case from_what of
+ FromLet -> simplExprF env body cont
+ FromBeta {} -> simplLam env body cont
+
simplLam :: SimplEnv -> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
@@ -1690,15 +1724,24 @@ simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })
-- Value beta-reduction
simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se
- , sc_cont = cont, sc_dup = dup })
- | isSimplified dup -- Don't re-simplify if we've simplified it once
- -- See Note [Avoiding exponential behaviour]
+ , sc_cont = cont, sc_dup = dup
+ , sc_hole_ty = fun_ty})
= do { tick (BetaReduction bndr)
- ; completeBindX env bndr arg body cont }
+ ; let arg_ty = funArgTy fun_ty
+ ; if | isSimplified dup -- Don't re-simplify if we've simplified it once
+ -- Including don't preInlineUnconditionally
+ -- See Note [Avoiding exponential behaviour]
+ -> completeBindX env (FromBeta arg_ty) bndr arg body cont
+
+ | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se
+ , not (needsCaseBinding arg_ty arg)
+ -- Ok to test arg::InExpr in needsCaseBinding because
+ -- exprOkForSpeculation is stable under simplification
+ -> do { tick (PreInlineUnconditionally bndr)
+ ; simplLam env' body cont }
- | otherwise -- See Note [Avoiding exponential behaviour]
- = do { tick (BetaReduction bndr)
- ; simplNonRecE env True bndr (arg, arg_se) body cont }
+ | otherwise
+ -> simplNonRecE env (FromBeta arg_ty) bndr (arg, arg_se) body cont }
-- Discard a non-counting tick on a lambda. This may change the
-- cost attribution slightly (moving the allocation of the
@@ -1730,8 +1773,7 @@ simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
------------------
simplNonRecE :: SimplEnv
- -> Bool -- True <=> from a lambda
- -- False <=> from a let
+ -> FromWhat
-> InId -- The binder, always an Id
-- Never a join point
-> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
@@ -1740,56 +1782,48 @@ simplNonRecE :: SimplEnv
-> SimplM (SimplFloats, OutExpr)
-- simplNonRecE is used for
--- * non-top-level non-recursive non-join-point lets in expressions
--- * beta reduction
+-- * from=FromLet: a non-top-level non-recursive non-join-point let-expression
+-- * from=FromBeta: a binding arising from a beta reduction
--
--- simplNonRec env b (rhs, rhs_se) body k
+-- simplNonRecE env b (rhs, rhs_se) body k
-- = let env in
-- cont< let b = rhs_se(rhs) in body >
--
-- It deals with strict bindings, via the StrictBind continuation,
-- which may abort the whole process.
--
--- from_lam=False => the RHS satisfies the let-can-float invariant
+-- from_what=FromLet => the RHS satisfies the let-can-float invariant
-- Otherwise it may or may not satisfy it.
-simplNonRecE env from_lam bndr (rhs, rhs_se) body cont
- = assert (isId bndr && not (isJoinId bndr) ) $
- do { (env1, bndr1) <- simplNonRecBndr env bndr
- ; let needs_case_binding = needsCaseBinding (idType bndr1) rhs
- -- See Note [Dark corner with representation polymorphism]
- -- If from_lam=False then needs_case_binding is False,
- -- because the binding started as a let, which must
- -- satisfy let-can-float
-
- ; if | from_lam && not needs_case_binding
- -- If not from_lam we are coming from a (NonRec bndr rhs) binding
- -- and preInlineUnconditionally has been done already;
- -- no need to repeat it. But for lambdas we must be careful about
- -- preInlineUndonditionally: consider (\(x:Int#). 3) (error "urk")
- -- We must not drop the (error "urk").
- , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se
- -> do { tick (PreInlineUnconditionally bndr)
- ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
- simplLam env' body cont }
-
- -- Deal with strict bindings
- | isStrictId bndr1 && seCaseCase env
- || from_lam && needs_case_binding
- -- The important bit here is needs_case_binds; but no need to
- -- test it if from_lam is False because then needs_case_binding is False too
- -- NB: either way, the RHS may or may not satisfy let-can-float
- -- but that's ok for StrictBind.
- -> simplExprF (rhs_se `setInScopeFromE` env) rhs
- (StrictBind { sc_bndr = bndr, sc_body = body
- , sc_env = env, sc_cont = cont, sc_dup = NoDup })
-
- -- Deal with lazy bindings
- | otherwise
- -> do { (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)
- ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
- ; (floats2, expr') <- simplLam env3 body cont
- ; return (floats1 `addFloats` floats2, expr') } }
+simplNonRecE env from_what bndr (rhs, rhs_se) body cont
+ | assert (isId bndr && not (isJoinId bndr) ) $
+ is_strict_bind
+ = -- Evaluate RHS strictly
+ simplExprF (rhs_se `setInScopeFromE` env) rhs
+ (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what
+ , sc_env = env, sc_cont = cont, sc_dup = NoDup })
+
+ | otherwise -- Evaluate RHS lazily
+ = do { (env1, bndr1) <- simplNonRecBndr env bndr
+ ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)
+ ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive
+ bndr bndr2 rhs rhs_se
+ ; (floats2, expr') <- simplNonRecBody env3 from_what body cont
+ ; return (floats1 `addFloats` floats2, expr') }
+
+ where
+ is_strict_bind = case from_what of
+ FromBeta arg_ty | isUnliftedType arg_ty -> True
+ -- If we are coming from a beta-reduction (FromBeta) we must
+ -- establish the let-can-float invariant, so go via StrictBind
+ -- If not, the invariant holds already, and it's optional.
+ -- Using arg_ty: see Note [Dark corner with representation polymorphism]
+ -- e.g (\r \(a::TYPE r) \(x::a). blah) @LiftedRep @Int arg
+ -- When we come to `x=arg` we myst choose lazy/strict correctly
+ -- It's wrong to err in either directly
+
+ _ -> seCaseCase env && isStrUsedDmd (idDemandInfo bndr)
+
------------------
simplRecE :: SimplEnv
@@ -1835,7 +1869,7 @@ Note [Avoiding exponential behaviour]
One way in which we can get exponential behaviour is if we simplify a
big expression, and then re-simplify it -- and then this happens in a
deeply-nested way. So we must be jolly careful about re-simplifying
-an expression. That is why simplNonRecX does not try
+an expression (#13379). That is why simplNonRecX does not try
preInlineUnconditionally (unlike simplNonRecE).
Example:
@@ -2618,15 +2652,10 @@ Is this inefficient? Not really: we are about to walk over the result
of the rule firing to simplify it, so occurrence analysis is at most
a constant factor.
-Possible improvement: occ-anal the rules when putting them in the
-database; and in the simplifier just occ-anal the OutExpr arguments.
-But that's more complicated and the rule RHS is usually tiny; so I'm
-just doing the simple thing.
-
-Historical note: previously we did occ-anal the rules in Rule.hs,
-but failed to occ-anal the OutExpr arguments, which led to the
-nasty performance problem described above.
-
+Note, however, that the rule RHS is /already/ occ-analysed; see
+Note [OccInfo in unfoldings and rules] in GHC.Core. There is something
+unsatisfactory about doing it twice; but the rule RHS is usually very
+small, and this is simple.
Note [Optimising tagToEnum#]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2930,7 +2959,7 @@ rebuildCase env scrut case_bndr alts cont
where
simple_rhs env wfloats case_bndr_rhs bs rhs =
assert (null bs) $
- do { (floats1, env') <- simplNonRecX env case_bndr case_bndr_rhs
+ do { (floats1, env') <- simplAuxBind env case_bndr case_bndr_rhs
-- scrut is a constructor application,
-- hence satisfies let-can-float invariant
; (floats2, expr') <- simplExprF env' rhs cont
@@ -2997,7 +3026,7 @@ rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont
| all_dead_bndrs
, doCaseToLet scrut case_bndr
= do { tick (CaseElim case_bndr)
- ; (floats1, env') <- simplNonRecX env case_bndr scrut
+ ; (floats1, env') <- simplAuxBind env case_bndr scrut
; (floats2, expr') <- simplExprF env' rhs cont
; return (floats1 `addFloats` floats2, expr') }
@@ -3483,12 +3512,11 @@ knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont
bind_args env' (b:bs') (arg : args)
= assert (isId b) $
do { let b' = zap_occ b
- -- Note that the binder might be "dead", because it doesn't
- -- occur in the RHS; and simplNonRecX may therefore discard
- -- it via postInlineUnconditionally.
+ -- zap_occ: the binder might be "dead", because it doesn't
+ -- occur in the RHS; and simplAuxBind may therefore discard it.
-- Nevertheless we must keep it if the case-binder is alive,
-- because it may be used in the con_app. See Note [knownCon occ info]
- ; (floats1, env2) <- simplNonRecX env' b' arg -- arg satisfies let-can-float invariant
+ ; (floats1, env2) <- simplAuxBind env' b' arg -- arg satisfies let-can-float invariant
; (floats2, env3) <- bind_args env2 bs' args
; return (floats1 `addFloats` floats2, env3) }
@@ -3514,7 +3542,7 @@ knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont
; let con_app = Var (dataConWorkId dc)
`mkTyApps` dc_ty_args
`mkApps` dc_args
- ; simplNonRecX env bndr con_app }
+ ; simplAuxBind env bndr con_app }
-------------------
missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont
@@ -3621,15 +3649,15 @@ mkDupableContWithDmds env dmds (TickIt t cont)
; return (floats, TickIt t cont') }
mkDupableContWithDmds env _
- (StrictBind { sc_bndr = bndr, sc_body = body
+ (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what
, sc_env = se, sc_cont = cont})
-- See Note [Duplicating StrictBind]
-- K[ let x = <> in b ] --> join j x = K[ b ]
-- j <>
= do { let sb_env = se `setInScopeFromE` env
; (sb_env1, bndr') <- simplBinder sb_env bndr
- ; (floats1, join_inner) <- simplLam sb_env1 body cont
- -- No need to use mkDupableCont before simplLam; we
+ ; (floats1, join_inner) <- simplNonRecBody sb_env1 from_what body cont
+ -- No need to use mkDupableCont before simplNonRecBody; we
-- use cont once here, and then share the result if necessary
; let join_body = wrapFloats floats1 join_inner
@@ -3757,6 +3785,7 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty
, StrictBind { sc_bndr = arg_bndr
, sc_body = join_rhs
, sc_env = zapSubstEnv env
+ , sc_from = FromLet
-- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
, sc_dup = OkToDup
, sc_cont = mkBoringStop res_ty } )
@@ -4430,7 +4459,9 @@ simplRules env mb_new_id rules bind_cxt
; return (rule { ru_bndrs = bndrs'
, ru_fn = fn_name'
, ru_args = args'
- , ru_rhs = rhs' }) }
+ , ru_rhs = occurAnalyseExpr rhs' }) }
+ -- Remember to occ-analyse, to drop dead code.
+ -- See Note [OccInfo in unfoldings and rules] in GHC.Core
{- Note [Simplifying the RHS of a RULE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -21,7 +21,7 @@ module GHC.Core.Opt.Simplify.Utils (
BindContext(..), bindContextLevel,
-- The continuation type
- SimplCont(..), DupFlag(..), StaticEnv,
+ SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv,
isSimplified, contIsStop,
contIsDupable, contResultType, contHoleType, contHoleScaling,
contIsTrivial, contArgs, contIsRhs,
@@ -192,6 +192,7 @@ data SimplCont
-- or, equivalently, = K[ (\x.b) e ]
{ sc_dup :: DupFlag -- See Note [DupFlag invariants]
, sc_bndr :: InId
+ , sc_from :: FromWhat
, sc_body :: InExpr
, sc_env :: StaticEnv -- See Note [StaticEnv invariant]
, sc_cont :: SimplCont }
@@ -213,6 +214,8 @@ data SimplCont
type StaticEnv = SimplEnv -- Just the static part is relevant
+data FromWhat = FromLet | FromBeta OutType
+
-- See Note [DupFlag invariants]
data DupFlag = NoDup -- Unsimplified, might be big
| Simplified -- Simplified
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -63,6 +63,7 @@ import GHC.Core.Tidy ( tidyRules )
import GHC.Core.Map.Expr ( eqCoreExpr )
import GHC.Core.Opt.Arity( etaExpandToJoinPointRule )
import GHC.Core.Make ( mkCoreLams )
+import GHC.Core.Opt.OccurAnal( occurAnalyseExpr )
import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe )
import GHC.Builtin.Types ( anyTypeOfKind )
@@ -189,13 +190,18 @@ mkRule :: Module -> Bool -> Bool -> RuleName -> Activation
-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
-- compiled. See also 'GHC.Core.CoreRule'
mkRule this_mod is_auto is_local name act fn bndrs args rhs
- = Rule { ru_name = name, ru_fn = fn, ru_act = act,
- ru_bndrs = bndrs, ru_args = args,
- ru_rhs = rhs,
- ru_rough = roughTopNames args,
- ru_origin = this_mod,
- ru_orphan = orph,
- ru_auto = is_auto, ru_local = is_local }
+ = Rule { ru_name = name
+ , ru_act = act
+ , ru_fn = fn
+ , ru_bndrs = bndrs
+ , ru_args = args
+ , ru_rhs = occurAnalyseExpr rhs
+ -- See Note [OccInfo in unfoldings and rules]
+ , ru_rough = roughTopNames args
+ , ru_origin = this_mod
+ , ru_orphan = orph
+ , ru_auto = is_auto
+ , ru_local = is_local }
where
-- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv
-- A rule is an orphan only if none of the variables
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -513,8 +513,8 @@ bindNonRec bndr rhs body
-- | Tests whether we have to use a @case@ rather than @let@ binding for this
-- expression as per the invariants of 'CoreExpr': see "GHC.Core#let_can_float_invariant"
needsCaseBinding :: Type -> CoreExpr -> Bool
-needsCaseBinding ty rhs =
- mightBeUnliftedType ty && not (exprOkForSpeculation rhs)
+needsCaseBinding ty rhs
+ = mightBeUnliftedType ty && not (exprOkForSpeculation rhs)
-- Make a case expression instead of a let
-- These can arise either from the desugarer,
-- or from beta reductions: (\x.e) (x +# y)
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -4939,6 +4939,7 @@ needSourceNotes dflags = debugLevel dflags > 0
-- LinkerInfo contains any extra options needed by the system linker.
data LinkerInfo
= GnuLD [Option]
+ | Mold [Option]
| GnuGold [Option]
| LlvmLLD [Option]
| DarwinLD [Option]
=====================================
compiler/GHC/SysTools/Info.hs
=====================================
@@ -70,6 +70,7 @@ The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
neededLinkArgs :: LinkerInfo -> [Option]
neededLinkArgs (GnuLD o) = o
+neededLinkArgs (Mold o) = o
neededLinkArgs (GnuGold o) = o
neededLinkArgs (LlvmLLD o) = o
neededLinkArgs (DarwinLD o) = o
@@ -106,6 +107,10 @@ getLinkerInfo' logger dflags = do
-- see Note [ELF needed shared libs]
"-Wl,--no-as-needed"])
+ | any ("mold" `isPrefixOf`) stdo =
+ return (Mold $ map Option [ --see Note [ELF needed shared libs]
+ "-Wl,--no-as-needed"])
+
| any ("GNU gold" `isPrefixOf`) stdo =
-- GNU gold only needs --no-as-needed. #10110.
-- ELF specific flag, see Note [ELF needed shared libs]
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -723,12 +723,14 @@ setIdCprSig id sig = modifyIdInfo (\info -> setCprSigInfo info sig) id
zapIdDmdSig :: Id -> Id
zapIdDmdSig id = modifyIdInfo (`setDmdSigInfo` nopSig) id
--- | This predicate says whether the 'Id' has a strict demand placed on it or
--- has a type such that it can always be evaluated strictly (i.e an
--- unlifted type, as of GHC 7.6). We need to
--- check separately whether the 'Id' has a so-called \"strict type\" because if
--- the demand for the given @id@ hasn't been computed yet but @id@ has a strict
--- type, we still want @isStrictId id@ to be @True at .
+-- | `isStrictId` says whether either
+-- (a) the 'Id' has a strict demand placed on it or
+-- (b) definitely has a \"strict type\", such that it can always be
+-- evaluated strictly (i.e an unlifted type)
+-- We need to check (b) as well as (a), because when the demand for the
+-- given `id` hasn't been computed yet but `id` has a strict
+-- type, we still want `isStrictId id` to be `True`.
+-- Returns False if the type is levity polymorphic; False is always safe.
isStrictId :: Id -> Bool
isStrictId id
| assertPpr (isId id) (text "isStrictId: not an id: " <+> ppr id) $
=====================================
compiler/GHC/Types/Unique/FM.hs
=====================================
@@ -68,7 +68,7 @@ module GHC.Types.Unique.FM (
nonDetStrictFoldUFM_Directly,
anyUFM, allUFM, seqEltsUFM,
mapUFM, mapUFM_Directly,
- mapMaybeUFM,
+ mapMaybeUFM, mapMaybeUFM_Directly,
elemUFM, elemUFM_Directly,
filterUFM, filterUFM_Directly, partitionUFM,
sizeUFM,
@@ -362,11 +362,14 @@ foldUFM k z (UFM m) = M.foldr k z m
mapUFM :: (elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2
mapUFM f (UFM m) = UFM (M.map f m)
+mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2
+mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m)
+
mapMaybeUFM :: (elt1 -> Maybe elt2) -> UniqFM key elt1 -> UniqFM key elt2
mapMaybeUFM f (UFM m) = UFM (M.mapMaybe f m)
-mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM key elt1 -> UniqFM key elt2
-mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m)
+mapMaybeUFM_Directly :: (Unique -> elt1 -> Maybe elt2) -> UniqFM key elt1 -> UniqFM key elt2
+mapMaybeUFM_Directly f (UFM m) = UFM (M.mapMaybeWithKey (f . getUnique) m)
filterUFM :: (elt -> Bool) -> UniqFM key elt -> UniqFM key elt
filterUFM p (UFM m) = UFM (M.filter p m)
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
module GHC.Unit.Module.ModIface
( ModIface
@@ -549,20 +550,58 @@ emptyIfaceHashCache _occ = Nothing
-- Take care, this instance only forces to the degree necessary to
-- avoid major space leaks.
-instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where
- rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12
- f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) =
- rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq`
- f9 `seq` rnf f10 `seq` rnf f11 `seq` rnf f12 `seq` f13 `seq` rnf f14 `seq` rnf f15 `seq` rnf f16 `seq`
- rnf f17 `seq` f18 `seq` rnf f19 `seq` rnf f20 `seq` rnf f21 `seq` f22 `seq` f23 `seq` rnf f24
+instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase))
+ , NFData (IfaceDeclExts (phase :: ModIfacePhase))
+ ) => NFData (ModIface_ phase) where
+ rnf (ModIface{ mi_module, mi_sig_of, mi_hsc_src, mi_deps, mi_usages
+ , mi_exports, mi_used_th, mi_fixities, mi_warns, mi_anns
+ , mi_decls, mi_extra_decls, mi_globals, mi_insts
+ , mi_fam_insts, mi_rules, mi_hpc, mi_trust, mi_trust_pkg
+ , mi_complete_matches, mi_docs, mi_final_exts
+ , mi_ext_fields, mi_src_hash})
+ = rnf mi_module
+ `seq` rnf mi_sig_of
+ `seq` mi_hsc_src
+ `seq` mi_deps
+ `seq` mi_usages
+ `seq` mi_exports
+ `seq` rnf mi_used_th
+ `seq` mi_fixities
+ `seq` mi_warns
+ `seq` rnf mi_anns
+ `seq` rnf mi_decls
+ `seq` rnf mi_extra_decls
+ `seq` mi_globals
+ `seq` rnf mi_insts
+ `seq` rnf mi_fam_insts
+ `seq` rnf mi_rules
+ `seq` rnf mi_hpc
+ `seq` mi_trust
+ `seq` rnf mi_trust_pkg
+ `seq` rnf mi_complete_matches
+ `seq` rnf mi_docs
+ `seq` mi_final_exts
+ `seq` mi_ext_fields
+ `seq` rnf mi_src_hash
`seq` ()
-
instance NFData (ModIfaceBackend) where
- rnf (ModIfaceBackend f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13)
- = rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq`
- rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` rnf f8 `seq`
- rnf f9 `seq` rnf f10 `seq` rnf f11 `seq` rnf f12 `seq` rnf f13
+ rnf (ModIfaceBackend{ mi_iface_hash, mi_mod_hash, mi_flag_hash, mi_opt_hash
+ , mi_hpc_hash, mi_plugin_hash, mi_orphan, mi_finsts, mi_exp_hash
+ , mi_orphan_hash, mi_warn_fn, mi_fix_fn, mi_hash_fn})
+ = rnf mi_iface_hash
+ `seq` rnf mi_mod_hash
+ `seq` rnf mi_flag_hash
+ `seq` rnf mi_opt_hash
+ `seq` rnf mi_hpc_hash
+ `seq` rnf mi_plugin_hash
+ `seq` rnf mi_orphan
+ `seq` rnf mi_finsts
+ `seq` rnf mi_exp_hash
+ `seq` rnf mi_orphan_hash
+ `seq` rnf mi_warn_fn
+ `seq` rnf mi_fix_fn
+ `seq` rnf mi_hash_fn
forceModIface :: ModIface -> IO ()
=====================================
libraries/base/Data/OldList.hs
=====================================
@@ -1511,7 +1511,7 @@ sortOn :: Ord b => (a -> b) -> [a] -> [a]
sortOn f =
map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))
--- | Produce singleton list.
+-- | Construct a list from a single element.
--
-- >>> singleton True
-- [True]
=====================================
libraries/base/tests/all.T
=====================================
@@ -79,7 +79,9 @@ test('length001',
# excessive amounts of stack space. So we specifically set a low
# stack limit and mark it as failing under a few conditions.
[extra_run_opts('+RTS -K8m -RTS'),
- expect_fail_for(['normal', 'threaded1', 'llvm', 'nonmoving', 'nonmoving_thr', 'nonmoving_thr_ghc'])],
+ expect_fail_for(['normal', 'threaded1', 'llvm', 'nonmoving', 'nonmoving_thr', 'nonmoving_thr_ghc']),
+ # JS doesn't support stack limit so the test sometimes passes just fine. We decrease the timeout duration to force the failure.
+ when(js_arch(), run_timeout_multiplier(0.2))],
compile_and_run, [''])
test('ratio001', normal, compile_and_run, [''])
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -31,6 +31,7 @@ module Language.Haskell.TH.Syntax
-- $infix
) where
+import qualified Data.Fixed as Fixed
import Data.Data hiding (Fixity(..))
import Data.IORef
import System.IO.Unsafe ( unsafePerformIO )
@@ -1056,6 +1057,15 @@ instance Lift Natural where
liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
+instance Lift (Fixed.Fixed a) where
+ liftTyped x = unsafeCodeCoerce (lift x)
+ lift (Fixed.MkFixed x) = do
+ ex <- lift x
+ return (ConE mkFixedName `AppE` ex)
+ where
+ mkFixedName =
+ mkNameG DataName "base" "Data.Fixed" "MkFixed"
+
instance Integral a => Lift (Ratio a) where
liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (RationalL (toRational x)))
=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -7,6 +7,7 @@
* Add `TypeDataD` constructor to the `Dec` type for `type data`
declarations (GHC proposal #106).
+ * Add `instance Lift (Fixed a)`
## 2.19.0.0
=====================================
testsuite/driver/testlib.py
=====================================
@@ -129,14 +129,17 @@ def no_deps( name, opts):
def skip( name, opts ):
opts.skip = True
+def js_arch() -> bool:
+ return arch("javascript");
+
# disable test on JS arch
def js_skip( name, opts ):
- if arch("javascript"):
+ if js_arch():
skip(name,opts)
# expect broken for the JS backend
def js_broken( bug: IssueNumber ):
- if arch("javascript"):
+ if js_arch():
return expect_broken(bug);
else:
return normal;
=====================================
testsuite/tests/simplCore/should_compile/T22761.hs
=====================================
@@ -0,0 +1,40 @@
+module T22761 where
+
+import T22761a
+
+newtype Mod m = Mod m deriving Num
+
+gcdExt :: Integer -> (Integer, Integer)
+gcdExt x = go 0 x
+ where
+ go !_ 0 = (1, 1)
+ go r _ = go r r
+
+pow :: (Num m) => Mod m -> Mod m
+pow x = x*x*x
+{-# NOINLINE [1] pow #-}
+{-# RULES
+"powMod/3/Int" forall x. pow x = x*x*x
+#-}
+
+
+-- GHC puts `boo1` after `wom1` (since they don't appear connected)
+-- Then { wom1 = foo True } rewrites to { wom1 = boo False }
+-- so we need to do glomming. And that triggers the bug
+-- in the RULE for `pow`!
+--
+-- wom2/boo2 are there to still elicit the bug if
+-- GHC reverses its default ordering
+
+{-# RULES
+"wombat1" foo True = boo1 False
+#-}
+
+wom1 = foo True
+boo1 x = x
+
+{-# RULES
+"wombat2" foo True = boo2 False
+#-}
+boo2 x = x
+wom2 = foo True
=====================================
testsuite/tests/simplCore/should_compile/T22761a.hs
=====================================
@@ -0,0 +1,4 @@
+module T22761a where
+
+{-# NOINLINE [0] foo #-}
+foo x = x
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -471,5 +471,6 @@ test('T22611', [when(wordsize(32), skip), grep_errmsg(r'\$salterF') ], compile,
test('T22715_2', normal, multimod_compile, ['T22715_2', '-v0 -O -fspecialise-aggressively'])
test('T22802', normal, compile, ['-O'])
test('T15205', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
+test('T22761', normal, multimod_compile, ['T22761', '-O2 -v0'])
test('RewriteHigherOrderPatterns', normal, compile, ['-O -ddump-rule-rewrites -dsuppress-all -dsuppress-uniques'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/626ea35bbc51f7ce1a63f6b8fa6aff49539307b4...66c44df2b01fc5ba27e17991caaf1e84c4746b8b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/626ea35bbc51f7ce1a63f6b8fa6aff49539307b4...66c44df2b01fc5ba27e17991caaf1e84c4746b8b
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/20230210/6bcebce9/attachment-0001.html>
More information about the ghc-commits
mailing list