{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

************************************************************************
*                                                                      *
\section[OccurAnal]{Occurrence analysis pass}
*                                                                      *
************************************************************************

The occurrence analyser re-typechecks a core expression, returning a new
core expression with (hopefully) improved usage information.
-}

{-# LANGUAGE CPP, BangPatterns, MultiWayIf, ViewPatterns  #-}

module OccurAnal (
        occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap
    ) where

#include "HsVersions.h"

import GhcPrelude

import CoreSyn
import CoreFVs
import CoreUtils        ( exprIsTrivial, isDefaultAlt, isExpandableApp,
                          stripTicksTopE, mkTicks )
import CoreArity        ( joinRhsArity )
import Id
import IdInfo
import Name( localiseName )
import BasicTypes
import Module( Module )
import Coercion
import Type

import VarSet
import VarEnv
import Var
import Demand           ( argOneShots, argsOneShots )
import Digraph          ( SCC(..), Node(..)
                        , stronglyConnCompFromEdgedVerticesUniq
                        , stronglyConnCompFromEdgedVerticesUniqR )
import Unique
import UniqFM
import UniqSet
import Util
import Outputable
import Data.List
import Control.Arrow    ( second )

{-
************************************************************************
*                                                                      *
    occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap
*                                                                      *
************************************************************************

Here's the externally-callable interface:
-}

occurAnalysePgm :: Module         -- Used only in debug output
                -> (Id -> Bool)         -- Active unfoldings
                -> (Activation -> Bool) -- Active rules
                -> [CoreRule]
                -> CoreProgram -> CoreProgram
occurAnalysePgm :: Module
-> (Id -> Bool)
-> (Activation -> Bool)
-> [CoreRule]
-> CoreProgram
-> CoreProgram
occurAnalysePgm this_mod :: Module
this_mod active_unf :: Id -> Bool
active_unf active_rule :: Activation -> Bool
active_rule imp_rules :: [CoreRule]
imp_rules binds :: CoreProgram
binds
  | UsageDetails -> Bool
isEmptyDetails UsageDetails
final_usage
  = CoreProgram
occ_anald_binds

  | Bool
otherwise   -- See Note [Glomming]
  = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon)
                   2 (ppr final_usage ) )
    CoreProgram
occ_anald_glommed_binds
  where
    init_env :: OccEnv
init_env = OccEnv
initOccEnv { occ_rule_act :: Activation -> Bool
occ_rule_act = Activation -> Bool
active_rule
                          , occ_unf_act :: Id -> Bool
occ_unf_act  = Id -> Bool
active_unf }

    (final_usage :: UsageDetails
final_usage, occ_anald_binds :: CoreProgram
occ_anald_binds) = OccEnv -> CoreProgram -> (UsageDetails, CoreProgram)
go OccEnv
init_env CoreProgram
binds
    (_, occ_anald_glommed_binds :: CoreProgram
occ_anald_glommed_binds)   = OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> [(Id, CoreExpr)]
-> UsageDetails
-> (UsageDetails, CoreProgram)
occAnalRecBind OccEnv
init_env TopLevelFlag
TopLevel
                                                    ImpRuleEdges
imp_rule_edges
                                                    (CoreProgram -> [(Id, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds CoreProgram
occ_anald_binds)
                                                    UsageDetails
initial_uds
          -- It's crucial to re-analyse the glommed-together bindings
          -- so that we establish the right loop breakers. Otherwise
          -- we can easily create an infinite loop (Trac #9583 is an example)

    initial_uds :: UsageDetails
initial_uds = UsageDetails -> VarSet -> UsageDetails
addManyOccsSet UsageDetails
emptyDetails
                            ([CoreRule] -> VarSet
rulesFreeVars [CoreRule]
imp_rules)
    -- The RULES declarations keep things alive!

    -- Note [Preventing loops due to imported functions rules]
    imp_rule_edges :: ImpRuleEdges
imp_rule_edges = (ImpRuleEdges -> ImpRuleEdges -> ImpRuleEdges)
-> ImpRuleEdges -> [ImpRuleEdges] -> ImpRuleEdges
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((VarSet -> VarSet -> VarSet)
-> ImpRuleEdges -> ImpRuleEdges -> ImpRuleEdges
forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_C VarSet -> VarSet -> VarSet
unionVarSet) ImpRuleEdges
forall a. VarEnv a
emptyVarEnv
                            [ (Id -> VarSet) -> VarEnv Id -> ImpRuleEdges
forall a b. (a -> b) -> VarEnv a -> VarEnv b
mapVarEnv (VarSet -> Id -> VarSet
forall a b. a -> b -> a
const VarSet
maps_to) (VarEnv Id -> ImpRuleEdges) -> VarEnv Id -> ImpRuleEdges
forall a b. (a -> b) -> a -> b
$
                                VarSet -> VarEnv Id
forall a. UniqSet a -> UniqFM a
getUniqSet (CoreExpr -> VarSet
exprFreeIds CoreExpr
arg VarSet -> [Id] -> VarSet
`delVarSetList` CoreRule -> [Id]
ru_bndrs CoreRule
imp_rule)
                            | CoreRule
imp_rule <- [CoreRule]
imp_rules
                            , Bool -> Bool
not (CoreRule -> Bool
isBuiltinRule CoreRule
imp_rule)  -- See Note [Plugin rules]
                            , let maps_to :: VarSet
maps_to = CoreExpr -> VarSet
exprFreeIds (CoreRule -> CoreExpr
ru_rhs CoreRule
imp_rule)
                                             VarSet -> [Id] -> VarSet
`delVarSetList` CoreRule -> [Id]
ru_bndrs CoreRule
imp_rule
                            , CoreExpr
arg <- CoreRule -> [CoreExpr]
ru_args CoreRule
imp_rule ]

    go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
    go :: OccEnv -> CoreProgram -> (UsageDetails, CoreProgram)
go _ []
        = (UsageDetails
initial_uds, [])
    go env :: OccEnv
env (bind :: CoreBind
bind:binds :: CoreProgram
binds)
        = (UsageDetails
final_usage, CoreProgram
bind' CoreProgram -> CoreProgram -> CoreProgram
forall a. [a] -> [a] -> [a]
++ CoreProgram
binds')
        where
           (bs_usage :: UsageDetails
bs_usage, binds' :: CoreProgram
binds')   = OccEnv -> CoreProgram -> (UsageDetails, CoreProgram)
go OccEnv
env CoreProgram
binds
           (final_usage :: UsageDetails
final_usage, bind' :: CoreProgram
bind') = OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> CoreBind
-> UsageDetails
-> (UsageDetails, CoreProgram)
occAnalBind OccEnv
env TopLevelFlag
TopLevel ImpRuleEdges
imp_rule_edges CoreBind
bind
                                              UsageDetails
bs_usage

occurAnalyseExpr :: CoreExpr -> CoreExpr
        -- Do occurrence analysis, and discard occurrence info returned
occurAnalyseExpr :: CoreExpr -> CoreExpr
occurAnalyseExpr = Bool -> CoreExpr -> CoreExpr
occurAnalyseExpr' Bool
True -- do binder swap

occurAnalyseExpr_NoBinderSwap :: CoreExpr -> CoreExpr
occurAnalyseExpr_NoBinderSwap :: CoreExpr -> CoreExpr
occurAnalyseExpr_NoBinderSwap = Bool -> CoreExpr -> CoreExpr
occurAnalyseExpr' Bool
False -- do not do binder swap

occurAnalyseExpr' :: Bool -> CoreExpr -> CoreExpr
occurAnalyseExpr' :: Bool -> CoreExpr -> CoreExpr
occurAnalyseExpr' enable_binder_swap :: Bool
enable_binder_swap expr :: CoreExpr
expr
  = (UsageDetails, CoreExpr) -> CoreExpr
forall a b. (a, b) -> b
snd (OccEnv -> CoreExpr -> (UsageDetails, CoreExpr)
occAnal OccEnv
env CoreExpr
expr)
  where
    env :: OccEnv
env = OccEnv
initOccEnv { occ_binder_swap :: Bool
occ_binder_swap = Bool
enable_binder_swap }

{- Note [Plugin rules]
~~~~~~~~~~~~~~~~~~~~~~
Conal Elliott (Trac #11651) built a GHC plugin that added some
BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to
do some domain-specific transformations that could not be expressed
with an ordinary pattern-matching CoreRule.  But then we can't extract
the dependencies (in imp_rule_edges) from ru_rhs etc, because a
BuiltinRule doesn't have any of that stuff.

So we simply assume that BuiltinRules have no dependencies, and filter
them out from the imp_rule_edges comprehension.
-}

{-
************************************************************************
*                                                                      *
                Bindings
*                                                                      *
************************************************************************

Note [Recursive bindings: the grand plan]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we come across a binding group
  Rec { x1 = r1; ...; xn = rn }
we treat it like this (occAnalRecBind):

1. Occurrence-analyse each right hand side, and build a
   "Details" for each binding to capture the results.

   Wrap the details in a Node (details, node-id, dep-node-ids),
   where node-id is just the unique of the binder, and
   dep-node-ids lists all binders on which this binding depends.
   We'll call these the "scope edges".
   See Note [Forming the Rec groups].

   All this is done by makeNode.

2. Do SCC-analysis on these Nodes.  Each SCC will become a new Rec or
   NonRec.  The key property is that every free variable of a binding
   is accounted for by the scope edges, so that when we are done
   everything is still in scope.

3. For each Cyclic SCC of the scope-edge SCC-analysis in (2), we
   identify suitable loop-breakers to ensure that inlining terminates.
   This is done by occAnalRec.

4. To do so we form a new set of Nodes, with the same details, but
   different edges, the "loop-breaker nodes". The loop-breaker nodes
   have both more and fewer dependencies than the scope edges
   (see Note [Choosing loop breakers])

   More edges: if f calls g, and g has an active rule that mentions h
               then we add an edge from f -> h

   Fewer edges: we only include dependencies on active rules, on rule
                RHSs (not LHSs) and if there is an INLINE pragma only
                on the stable unfolding (and vice versa).  The scope
                edges must be much more inclusive.

5.  The "weak fvs" of a node are, by definition:
       the scope fvs - the loop-breaker fvs
    See Note [Weak loop breakers], and the nd_weak field of Details

6.  Having formed the loop-breaker nodes

Note [Dead code]
~~~~~~~~~~~~~~~~
Dropping dead code for a cyclic Strongly Connected Component is done
in a very simple way:

        the entire SCC is dropped if none of its binders are mentioned
        in the body; otherwise the whole thing is kept.

The key observation is that dead code elimination happens after
dependency analysis: so 'occAnalBind' processes SCCs instead of the
original term's binding groups.

Thus 'occAnalBind' does indeed drop 'f' in an example like

        letrec f = ...g...
               g = ...(...g...)...
        in
           ...g...

when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in
'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes
'AcyclicSCC f', where 'body_usage' won't contain 'f'.

------------------------------------------------------------
Note [Forming Rec groups]
~~~~~~~~~~~~~~~~~~~~~~~~~
We put bindings {f = ef; g = eg } in a Rec group if "f uses g"
and "g uses f", no matter how indirectly.  We do a SCC analysis
with an edge f -> g if "f uses g".

More precisely, "f uses g" iff g should be in scope wherever f is.
That is, g is free in:
  a) the rhs 'ef'
  b) or the RHS of a rule for f (Note [Rules are extra RHSs])
  c) or the LHS or a rule for f (Note [Rule dependency info])

These conditions apply regardless of the activation of the RULE (eg it might be
inactive in this phase but become active later).  Once a Rec is broken up
it can never be put back together, so we must be conservative.

The principle is that, regardless of rule firings, every variable is
always in scope.

  * Note [Rules are extra RHSs]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~
    A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"
    keeps the specialised "children" alive.  If the parent dies
    (because it isn't referenced any more), then the children will die
    too (unless they are already referenced directly).

    To that end, we build a Rec group for each cyclic strongly
    connected component,
        *treating f's rules as extra RHSs for 'f'*.
    More concretely, the SCC analysis runs on a graph with an edge
    from f -> g iff g is mentioned in
        (a) f's rhs
        (b) f's RULES
    These are rec_edges.

    Under (b) we include variables free in *either* LHS *or* RHS of
    the rule.  The former might seems silly, but see Note [Rule
    dependency info].  So in Example [eftInt], eftInt and eftIntFB
    will be put in the same Rec, even though their 'main' RHSs are
    both non-recursive.

  * Note [Rule dependency info]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The VarSet in a RuleInfo is used for dependency analysis in the
    occurrence analyser.  We must track free vars in *both* lhs and rhs.
    Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.
    Why both? Consider
        x = y
        RULE f x = v+4
    Then if we substitute y for x, we'd better do so in the
    rule's LHS too, so we'd better ensure the RULE appears to mention 'x'
    as well as 'v'

  * Note [Rules are visible in their own rec group]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We want the rules for 'f' to be visible in f's right-hand side.
    And we'd like them to be visible in other functions in f's Rec
    group.  E.g. in Note [Specialisation rules] we want f' rule
    to be visible in both f's RHS, and fs's RHS.

    This means that we must simplify the RULEs first, before looking
    at any of the definitions.  This is done by Simplify.simplRecBind,
    when it calls addLetIdInfo.

------------------------------------------------------------
Note [Choosing loop breakers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Loop breaking is surprisingly subtle.  First read the section 4 of
"Secrets of the GHC inliner".  This describes our basic plan.
We avoid infinite inlinings by choosing loop breakers, and
ensuring that a loop breaker cuts each loop.

See also Note [Inlining and hs-boot files] in ToIface, which deals
with a closely related source of infinite loops.

Fundamentally, we do SCC analysis on a graph.  For each recursive
group we choose a loop breaker, delete all edges to that node,
re-analyse the SCC, and iterate.

But what is the graph?  NOT the same graph as was used for Note
[Forming Rec groups]!  In particular, a RULE is like an equation for
'f' that is *always* inlined if it is applicable.  We do *not* disable
rules for loop-breakers.  It's up to whoever makes the rules to make
sure that the rules themselves always terminate.  See Note [Rules for
recursive functions] in Simplify.hs

Hence, if
    f's RHS (or its INLINE template if it has one) mentions g, and
    g has a RULE that mentions h, and
    h has a RULE that mentions f

then we *must* choose f to be a loop breaker.  Example: see Note
[Specialisation rules].

In general, take the free variables of f's RHS, and augment it with
all the variables reachable by RULES from those starting points.  That
is the whole reason for computing rule_fv_env in occAnalBind.  (Of
course we only consider free vars that are also binders in this Rec
group.)  See also Note [Finding rule RHS free vars]

Note that when we compute this rule_fv_env, we only consider variables
free in the *RHS* of the rule, in contrast to the way we build the
Rec group in the first place (Note [Rule dependency info])

Note that if 'g' has RHS that mentions 'w', we should add w to
g's loop-breaker edges.  More concretely there is an edge from f -> g
iff
        (a) g is mentioned in f's RHS `xor` f's INLINE rhs
            (see Note [Inline rules])
        (b) or h is mentioned in f's RHS, and
            g appears in the RHS of an active RULE of h
            or a transitive sequence of active rules starting with h

Why "active rules"?  See Note [Finding rule RHS free vars]

Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is
chosen as a loop breaker, because their RHSs don't mention each other.
And indeed both can be inlined safely.

Note again that the edges of the graph we use for computing loop breakers
are not the same as the edges we use for computing the Rec blocks.
That's why we compute

- rec_edges          for the Rec block analysis
- loop_breaker_nodes for the loop breaker analysis

  * Note [Finding rule RHS free vars]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider this real example from Data Parallel Haskell
         tagZero :: Array Int -> Array Tag
         {-# INLINE [1] tagZeroes #-}
         tagZero xs = pmap (\x -> fromBool (x==0)) xs

         {-# RULES "tagZero" [~1] forall xs n.
             pmap fromBool <blah blah> = tagZero xs #-}
    So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.
    However, tagZero can only be inlined in phase 1 and later, while
    the RULE is only active *before* phase 1.  So there's no problem.

    To make this work, we look for the RHS free vars only for
    *active* rules. That's the reason for the occ_rule_act field
    of the OccEnv.

  * Note [Weak loop breakers]
    ~~~~~~~~~~~~~~~~~~~~~~~~~
    There is a last nasty wrinkle.  Suppose we have

        Rec { f = f_rhs
              RULE f [] = g

              h = h_rhs
              g = h
              ...more...
        }

    Remember that we simplify the RULES before any RHS (see Note
    [Rules are visible in their own rec group] above).

    So we must *not* postInlineUnconditionally 'g', even though
    its RHS turns out to be trivial.  (I'm assuming that 'g' is
    not choosen as a loop breaker.)  Why not?  Because then we
    drop the binding for 'g', which leaves it out of scope in the
    RULE!

    Here's a somewhat different example of the same thing
        Rec { g = h
            ; h = ...f...
            ; f = f_rhs
              RULE f [] = g }
    Here the RULE is "below" g, but we *still* can't postInlineUnconditionally
    g, because the RULE for f is active throughout.  So the RHS of h
    might rewrite to     h = ...g...
    So g must remain in scope in the output program!

    We "solve" this by:

        Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True)
        iff g is a "missing free variable" of the Rec group

    A "missing free variable" x is one that is mentioned in an RHS or
    INLINE or RULE of a binding in the Rec group, but where the
    dependency on x may not show up in the loop_breaker_nodes (see
    note [Choosing loop breakers} above).

    A normal "strong" loop breaker has IAmLoopBreaker False.  So

                                    Inline  postInlineUnconditionally
   strong   IAmLoopBreaker False    no      no
   weak     IAmLoopBreaker True     yes     no
            other                   yes     yes

    The **sole** reason for this kind of loop breaker is so that
    postInlineUnconditionally does not fire.  Ugh.  (Typically it'll
    inline via the usual callSiteInline stuff, so it'll be dead in the
    next pass, so the main Ugh is the tiresome complication.)

Note [Rules for imported functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
   f = /\a. B.g a
   RULE B.g Int = 1 + f Int
Note that
  * The RULE is for an imported function.
  * f is non-recursive
Now we
can get
   f Int --> B.g Int      Inlining f
         --> 1 + f Int    Firing RULE
and so the simplifier goes into an infinite loop. This
would not happen if the RULE was for a local function,
because we keep track of dependencies through rules.  But
that is pretty much impossible to do for imported Ids.  Suppose
f's definition had been
   f = /\a. C.h a
where (by some long and devious process), C.h eventually inlines to
B.g.  We could only spot such loops by exhaustively following
unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE)
f.

Note that RULES for imported functions are important in practice; they
occur a lot in the libraries.

We regard this potential infinite loop as a *programmer* error.
It's up the programmer not to write silly rules like
     RULE f x = f x
and the example above is just a more complicated version.

Note [Preventing loops due to imported functions rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider:
  import GHC.Base (foldr)

  {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-}
  filter p xs = build (\c n -> foldr (filterFB c p) n xs)
  filterFB c p = ...

  f = filter p xs

Note that filter is not a loop-breaker, so what happens is:
  f =          filter p xs
    = {inline} build (\c n -> foldr (filterFB c p) n xs)
    = {inline} foldr (filterFB (:) p) [] xs
    = {RULE}   filter p xs

We are in an infinite loop.

A more elaborate example (that I actually saw in practice when I went to
mark GHC.List.filter as INLINABLE) is as follows. Say I have this module:
  {-# LANGUAGE RankNTypes #-}
  module GHCList where

  import Prelude hiding (filter)
  import GHC.Base (build)

  {-# INLINABLE filter #-}
  filter :: (a -> Bool) -> [a] -> [a]
  filter p [] = []
  filter p (x:xs) = if p x then x : filter p xs else filter p xs

  {-# NOINLINE [0] filterFB #-}
  filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b
  filterFB c p x r | p x       = x `c` r
                   | otherwise = r

  {-# RULES
  "filter"     [~1] forall p xs.  filter p xs = build (\c n -> foldr
  (filterFB c p) n xs)
  "filterList" [1]  forall p.     foldr (filterFB (:) p) [] = filter p
   #-}

Then (because RULES are applied inside INLINABLE unfoldings, but inlinings
are not), the unfolding given to "filter" in the interface file will be:
  filter p []     = []
  filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs)
                           else     build (\c n -> foldr (filterFB c p) n xs

Note that because this unfolding does not mention "filter", filter is not
marked as a strong loop breaker. Therefore at a use site in another module:
  filter p xs
    = {inline}
      case xs of []     -> []
                 (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs)
                                  else     build (\c n -> foldr (filterFB c p) n xs)

  build (\c n -> foldr (filterFB c p) n xs)
    = {inline} foldr (filterFB (:) p) [] xs
    = {RULE}   filter p xs

And we are in an infinite loop again, except that this time the loop is producing an
infinitely large *term* (an unrolling of filter) and so the simplifier finally
dies with "ticks exhausted"

Because of this problem, we make a small change in the occurrence analyser
designed to mark functions like "filter" as strong loop breakers on the basis that:
  1. The RHS of filter mentions the local function "filterFB"
  2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS

So for each RULE for an *imported* function we are going to add
dependency edges between the *local* FVS of the rule LHS and the
*local* FVS of the rule RHS. We don't do anything special for RULES on
local functions because the standard occurrence analysis stuff is
pretty good at getting loop-breakerness correct there.

It is important to note that even with this extra hack we aren't always going to get
things right. For example, it might be that the rule LHS mentions an imported Id,
and another module has a RULE that can rewrite that imported Id to one of our local
Ids.

Note [Specialising imported functions] (referred to from Specialise)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
BUT for *automatically-generated* rules, the programmer can't be
responsible for the "programmer error" in Note [Rules for imported
functions].  In paricular, consider specialising a recursive function
defined in another module.  If we specialise a recursive function B.g,
we get
         g_spec = .....(B.g Int).....
         RULE B.g Int = g_spec
Here, g_spec doesn't look recursive, but when the rule fires, it
becomes so.  And if B.g was mutually recursive, the loop might
not be as obvious as it is here.

To avoid this,
 * When specialising a function that is a loop breaker,
   give a NOINLINE pragma to the specialised function

Note [Glomming]
~~~~~~~~~~~~~~~
RULES for imported Ids can make something at the top refer to something at the bottom:
        f = \x -> B.g (q x)
        h = \y -> 3

        RULE:  B.g (q x) = h x

Applying this rule makes f refer to h, although f doesn't appear to
depend on h.  (And, as in Note [Rules for imported functions], the
dependency might be more indirect. For example, f might mention C.t
rather than B.g, where C.t eventually inlines to B.g.)

NOTICE that this cannot happen for rules whose head is a
locally-defined function, because we accurately track dependencies
through RULES.  It only happens for rules whose head is an imported
function (B.g in the example above).

Solution:
  - When simplifying, bring all top level identifiers into
    scope at the start, ignoring the Rec/NonRec structure, so
    that when 'h' pops up in f's rhs, we find it in the in-scope set
    (as the simplifier generally expects). This happens in simplTopBinds.

  - In the occurrence analyser, if there are any out-of-scope
    occurrences that pop out of the top, which will happen after
    firing the rule:      f = \x -> h x
                          h = \y -> 3
    then just glom all the bindings into a single Rec, so that
    the *next* iteration of the occurrence analyser will sort
    them all out.   This part happens in occurAnalysePgm.

------------------------------------------------------------
Note [Inline rules]
~~~~~~~~~~~~~~~~~~~
None of the above stuff about RULES applies to Inline Rules,
stored in a CoreUnfolding.  The unfolding, if any, is simplified
at the same time as the regular RHS of the function (ie *not* like
Note [Rules are visible in their own rec group]), so it should be
treated *exactly* like an extra RHS.

Or, rather, when computing loop-breaker edges,
  * If f has an INLINE pragma, and it is active, we treat the
    INLINE rhs as f's rhs
  * If it's inactive, we treat f as having no rhs
  * If it has no INLINE pragma, we look at f's actual rhs


There is a danger that we'll be sub-optimal if we see this
     f = ...f...
     [INLINE f = ..no f...]
where f is recursive, but the INLINE is not. This can just about
happen with a sufficiently odd set of rules; eg

        foo :: Int -> Int
        {-# INLINE [1] foo #-}
        foo x = x+1

        bar :: Int -> Int
        {-# INLINE [1] bar #-}
        bar x = foo x + 1

        {-# RULES "foo" [~1] forall x. foo x = bar x #-}

Here the RULE makes bar recursive; but it's INLINE pragma remains
non-recursive. It's tempting to then say that 'bar' should not be
a loop breaker, but an attempt to do so goes wrong in two ways:
   a) We may get
         $df = ...$cfoo...
         $cfoo = ...$df....
         [INLINE $cfoo = ...no-$df...]
      But we want $cfoo to depend on $df explicitly so that we
      put the bindings in the right order to inline $df in $cfoo
      and perhaps break the loop altogether.  (Maybe this
   b)


Example [eftInt]
~~~~~~~~~~~~~~~
Example (from GHC.Enum):

  eftInt :: Int# -> Int# -> [Int]
  eftInt x y = ...(non-recursive)...

  {-# INLINE [0] eftIntFB #-}
  eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
  eftIntFB c n x y = ...(non-recursive)...

  {-# RULES
  "eftInt"  [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
  "eftIntList"  [1] eftIntFB  (:) [] = eftInt
   #-}

Note [Specialisation rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this group, which is typical of what SpecConstr builds:

   fs a = ....f (C a)....
   f  x = ....f (C a)....
   {-# RULE f (C a) = fs a #-}

So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).

But watch out!  If 'fs' is not chosen as a loop breaker, we may get an infinite loop:
  - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify
  - fs is inlined (say it's small)
  - now there's another opportunity to apply the RULE

This showed up when compiling Control.Concurrent.Chan.getChanContents.

------------------------------------------------------------
Note [Finding join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~
It's the occurrence analyser's job to find bindings that we can turn into join
points, but it doesn't perform that transformation right away. Rather, it marks
the eligible bindings as part of their occurrence data, leaving it to the
simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'.
The simplifier then eta-expands the RHS if needed and then updates the
occurrence sites. Dividing the work this way means that the occurrence analyser
still only takes one pass, yet one can always tell the difference between a
function call and a jump by looking at the occurrence (because the same pass
changes the 'IdDetails' and propagates the binders to their occurrence sites).

To track potential join points, we use the 'occ_tail' field of OccInfo. A value
of `AlwaysTailCalled n` indicates that every occurrence of the variable is a
tail call with `n` arguments (counting both value and type arguments). Otherwise
'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the
rest of 'OccInfo' until it goes on the binder.

Note [Rules and join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Things get fiddly with rules. Suppose we have:

  let j :: Int -> Int
      j y = 2 * y
      k :: Int -> Int -> Int
      {-# RULES "SPEC k 0" k 0 = j #-}
      k x y = x + 2 * y
  in ...

Now suppose that both j and k appear only as saturated tail calls in the body.
Thus we would like to make them both join points. The rule complicates matters,
though, as its RHS has an unapplied occurrence of j. *However*, if we were to
eta-expand the rule, all would be well:

  {-# RULES "SPEC k 0" forall a. k 0 a = j a #-}

So conceivably we could notice that a potential join point would have an
"undersaturated" rule and account for it. This would mean we could make
something that's been specialised a join point, for instance. But local bindings
are rarely specialised, and being overly cautious about rules only
costs us anything when, for some `j`:

  * Before specialisation, `j` has non-tail calls, so it can't be a join point.
  * During specialisation, `j` gets specialised and thus acquires rules.
  * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say),
    and so now `j` *could* become a join point.

This appears to be very rare in practice. TODO Perhaps we should gather
statistics to be sure.

------------------------------------------------------------
Note [Adjusting right-hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
There's a bit of a dance we need to do after analysing a lambda expression or
a right-hand side. In particular, we need to

  a) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot
     lambda, or a non-recursive join point; and
  b) call 'markAllNonTailCalled' *unless* the binding is for a join point.

Some examples, with how the free occurrences in e (assumed not to be a value
lambda) get marked:

                             inside lam    non-tail-called
  ------------------------------------------------------------
  let x = e                  No            Yes
  let f = \x -> e            Yes           Yes
  let f = \x{OneShot} -> e   No            Yes
  \x -> e                    Yes           Yes
  join j x = e               No            No
  joinrec j x = e            Yes           No

There are a few other caveats; most importantly, if we're marking a binding as
'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so
that the effect cascades properly. Consequently, at the time the RHS is
analysed, we won't know what adjustments to make; thus 'occAnalLamOrRhs' must
return the unadjusted 'UsageDetails', to be adjusted by 'adjustRhsUsage' once
join-point-hood has been decided.

Thus the overall sequence taking place in 'occAnalNonRecBind' and
'occAnalRecBind' is as follows:

  1. Call 'occAnalLamOrRhs' to find usage information for the RHS.
  2. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make
     the binding a join point.
  3. Call 'adjustRhsUsage' accordingly. (Done as part of 'tagRecBinders' when
     recursive.)

(In the recursive case, this logic is spread between 'makeNode' and
'occAnalRec'.)
-}

------------------------------------------------------------------
--                 occAnalBind
------------------------------------------------------------------

occAnalBind :: OccEnv           -- The incoming OccEnv
            -> TopLevelFlag
            -> ImpRuleEdges
            -> CoreBind
            -> UsageDetails             -- Usage details of scope
            -> (UsageDetails,           -- Of the whole let(rec)
                [CoreBind])

occAnalBind :: OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> CoreBind
-> UsageDetails
-> (UsageDetails, CoreProgram)
occAnalBind env :: OccEnv
env lvl :: TopLevelFlag
lvl top_env :: ImpRuleEdges
top_env (NonRec binder :: Id
binder rhs :: CoreExpr
rhs) body_usage :: UsageDetails
body_usage
  = OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> Id
-> CoreExpr
-> UsageDetails
-> (UsageDetails, CoreProgram)
occAnalNonRecBind OccEnv
env TopLevelFlag
lvl ImpRuleEdges
top_env Id
binder CoreExpr
rhs UsageDetails
body_usage
occAnalBind env :: OccEnv
env lvl :: TopLevelFlag
lvl top_env :: ImpRuleEdges
top_env (Rec pairs :: [(Id, CoreExpr)]
pairs) body_usage :: UsageDetails
body_usage
  = OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> [(Id, CoreExpr)]
-> UsageDetails
-> (UsageDetails, CoreProgram)
occAnalRecBind OccEnv
env TopLevelFlag
lvl ImpRuleEdges
top_env [(Id, CoreExpr)]
pairs UsageDetails
body_usage

-----------------
occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr
                  -> UsageDetails -> (UsageDetails, [CoreBind])
occAnalNonRecBind :: OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> Id
-> CoreExpr
-> UsageDetails
-> (UsageDetails, CoreProgram)
occAnalNonRecBind env :: OccEnv
env lvl :: TopLevelFlag
lvl imp_rule_edges :: ImpRuleEdges
imp_rule_edges binder :: Id
binder rhs :: CoreExpr
rhs body_usage :: UsageDetails
body_usage
  | Id -> Bool
isTyVar Id
binder      -- A type let; we don't gather usage info
  = (UsageDetails
body_usage, [Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
binder CoreExpr
rhs])

  | Bool -> Bool
not (Id
binder Id -> UsageDetails -> Bool
`usedIn` UsageDetails
body_usage)    -- It's not mentioned
  = (UsageDetails
body_usage, [])

  | Bool
otherwise                   -- It's mentioned in the body
  = (UsageDetails
body_usage' UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
rhs_usage', [Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
tagged_binder CoreExpr
rhs'])
  where
    (body_usage' :: UsageDetails
body_usage', tagged_binder :: Id
tagged_binder) = TopLevelFlag -> UsageDetails -> Id -> (UsageDetails, Id)
tagNonRecBinder TopLevelFlag
lvl UsageDetails
body_usage Id
binder
    mb_join_arity :: Maybe Int
mb_join_arity = Id -> Maybe Int
willBeJoinId_maybe Id
tagged_binder

    (bndrs :: [Id]
bndrs, body :: CoreExpr
body) = CoreExpr -> ([Id], CoreExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders CoreExpr
rhs

    (rhs_usage1 :: UsageDetails
rhs_usage1, bndrs' :: [Id]
bndrs', body' :: CoreExpr
body') = OccEnv -> Id -> [Id] -> CoreExpr -> (UsageDetails, [Id], CoreExpr)
occAnalNonRecRhs OccEnv
env Id
tagged_binder [Id]
bndrs CoreExpr
body
    rhs' :: CoreExpr
rhs' = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams (Maybe Int -> [Id] -> [Id]
markJoinOneShots Maybe Int
mb_join_arity [Id]
bndrs') CoreExpr
body'
           -- For a /non-recursive/ join point we can mark all
           -- its join-lambda as one-shot; and it's a good idea to do so

    -- Unfoldings
    -- See Note [Unfoldings and join points]
    rhs_usage2 :: UsageDetails
rhs_usage2 = case OccEnv -> RecFlag -> Id -> Maybe UsageDetails
occAnalUnfolding OccEnv
env RecFlag
NonRecursive Id
binder of
                   Just unf_usage :: UsageDetails
unf_usage -> UsageDetails
rhs_usage1 UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
unf_usage
                   Nothing        -> UsageDetails
rhs_usage1

    -- Rules
    -- See Note [Rules are extra RHSs] and Note [Rule dependency info]
    rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]
rules_w_uds = OccEnv
-> Maybe Int
-> RecFlag
-> Id
-> [(CoreRule, UsageDetails, UsageDetails)]
occAnalRules OccEnv
env Maybe Int
mb_join_arity RecFlag
NonRecursive Id
tagged_binder
    rule_uds :: [UsageDetails]
rule_uds    = ((CoreRule, UsageDetails, UsageDetails) -> UsageDetails)
-> [(CoreRule, UsageDetails, UsageDetails)] -> [UsageDetails]
forall a b. (a -> b) -> [a] -> [b]
map (\(_, l :: UsageDetails
l, r :: UsageDetails
r) -> UsageDetails
l UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
r) [(CoreRule, UsageDetails, UsageDetails)]
rules_w_uds
    rhs_usage3 :: UsageDetails
rhs_usage3 = (UsageDetails -> UsageDetails -> UsageDetails)
-> UsageDetails -> [UsageDetails] -> UsageDetails
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr UsageDetails -> UsageDetails -> UsageDetails
andUDs UsageDetails
rhs_usage2 [UsageDetails]
rule_uds
    rhs_usage4 :: UsageDetails
rhs_usage4 = case ImpRuleEdges -> Id -> Maybe VarSet
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv ImpRuleEdges
imp_rule_edges Id
binder of
                   Nothing -> UsageDetails
rhs_usage3
                   Just vs :: VarSet
vs -> UsageDetails -> VarSet -> UsageDetails
addManyOccsSet UsageDetails
rhs_usage3 VarSet
vs
       -- See Note [Preventing loops due to imported functions rules]

    -- Final adjustment
    rhs_usage' :: UsageDetails
rhs_usage' = Maybe Int -> RecFlag -> [Id] -> UsageDetails -> UsageDetails
adjustRhsUsage Maybe Int
mb_join_arity RecFlag
NonRecursive [Id]
bndrs' UsageDetails
rhs_usage4

-----------------
occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]
               -> UsageDetails -> (UsageDetails, [CoreBind])
occAnalRecBind :: OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> [(Id, CoreExpr)]
-> UsageDetails
-> (UsageDetails, CoreProgram)
occAnalRecBind env :: OccEnv
env lvl :: TopLevelFlag
lvl imp_rule_edges :: ImpRuleEdges
imp_rule_edges pairs :: [(Id, CoreExpr)]
pairs body_usage :: UsageDetails
body_usage
  = (SCC Details
 -> (UsageDetails, CoreProgram) -> (UsageDetails, CoreProgram))
-> (UsageDetails, CoreProgram)
-> [SCC Details]
-> (UsageDetails, CoreProgram)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (OccEnv
-> TopLevelFlag
-> SCC Details
-> (UsageDetails, CoreProgram)
-> (UsageDetails, CoreProgram)
occAnalRec OccEnv
env TopLevelFlag
lvl) (UsageDetails
body_usage, []) [SCC Details]
sccs
        -- For a recursive group, we
        --      * occ-analyse all the RHSs
        --      * compute strongly-connected components
        --      * feed those components to occAnalRec
        -- See Note [Recursive bindings: the grand plan]
  where
    sccs :: [SCC Details]
    sccs :: [SCC Details]
sccs = {-# SCC "occAnalBind.scc" #-}
           [Node Unique Details] -> [SCC Details]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq [Node Unique Details]
nodes

    nodes :: [LetrecNode]
    nodes :: [Node Unique Details]
nodes = {-# SCC "occAnalBind.assoc" #-}
            ((Id, CoreExpr) -> Node Unique Details)
-> [(Id, CoreExpr)] -> [Node Unique Details]
forall a b. (a -> b) -> [a] -> [b]
map (OccEnv
-> ImpRuleEdges -> VarSet -> (Id, CoreExpr) -> Node Unique Details
makeNode OccEnv
env ImpRuleEdges
imp_rule_edges VarSet
bndr_set) [(Id, CoreExpr)]
pairs

    bndr_set :: VarSet
bndr_set = [Id] -> VarSet
mkVarSet (((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
pairs)

{-
Note [Unfoldings and join points]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

We assume that anything in an unfolding occurs multiple times, since unfoldings
are often copied (that's the whole point!). But we still need to track tail
calls for the purpose of finding join points.
-}

-----------------------------
occAnalRec :: OccEnv -> TopLevelFlag
           -> SCC Details
           -> (UsageDetails, [CoreBind])
           -> (UsageDetails, [CoreBind])

        -- The NonRec case is just like a Let (NonRec ...) above
occAnalRec :: OccEnv
-> TopLevelFlag
-> SCC Details
-> (UsageDetails, CoreProgram)
-> (UsageDetails, CoreProgram)
occAnalRec _ lvl :: TopLevelFlag
lvl (AcyclicSCC (ND { nd_bndr :: Details -> Id
nd_bndr = Id
bndr, nd_rhs :: Details -> CoreExpr
nd_rhs = CoreExpr
rhs
                                 , nd_uds :: Details -> UsageDetails
nd_uds = UsageDetails
rhs_uds, nd_rhs_bndrs :: Details -> [Id]
nd_rhs_bndrs = [Id]
rhs_bndrs }))
           (body_uds :: UsageDetails
body_uds, binds :: CoreProgram
binds)
  | Bool -> Bool
not (Id
bndr Id -> UsageDetails -> Bool
`usedIn` UsageDetails
body_uds)
  = (UsageDetails
body_uds, CoreProgram
binds)           -- See Note [Dead code]

  | Bool
otherwise                   -- It's mentioned in the body
  = (UsageDetails
body_uds' UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
rhs_uds',
     Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
tagged_bndr CoreExpr
rhs CoreBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
: CoreProgram
binds)
  where
    (body_uds' :: UsageDetails
body_uds', tagged_bndr :: Id
tagged_bndr) = TopLevelFlag -> UsageDetails -> Id -> (UsageDetails, Id)
tagNonRecBinder TopLevelFlag
lvl UsageDetails
body_uds Id
bndr
    rhs_uds' :: UsageDetails
rhs_uds' = Maybe Int -> RecFlag -> [Id] -> UsageDetails -> UsageDetails
adjustRhsUsage (Id -> Maybe Int
willBeJoinId_maybe Id
tagged_bndr) RecFlag
NonRecursive
                              [Id]
rhs_bndrs UsageDetails
rhs_uds

        -- The Rec case is the interesting one
        -- See Note [Recursive bindings: the grand plan]
        -- See Note [Loop breaking]
occAnalRec env :: OccEnv
env lvl :: TopLevelFlag
lvl (CyclicSCC details_s :: [Details]
details_s) (body_uds :: UsageDetails
body_uds, binds :: CoreProgram
binds)
  | Bool -> Bool
not ((Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Id -> UsageDetails -> Bool
`usedIn` UsageDetails
body_uds) [Id]
bndrs) -- NB: look at body_uds, not total_uds
  = (UsageDetails
body_uds, CoreProgram
binds)                   -- See Note [Dead code]

  | Bool
otherwise   -- At this point we always build a single Rec
  = -- pprTrace "occAnalRec" (vcat
    --  [ text "weak_fvs" <+> ppr weak_fvs
    --  , text "lb nodes" <+> ppr loop_breaker_nodes])
    (UsageDetails
final_uds, [(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CoreExpr)]
pairs CoreBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
: CoreProgram
binds)

  where
    bndrs :: [Id]
bndrs    = (Details -> Id) -> [Details] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map Details -> Id
nd_bndr [Details]
details_s
    bndr_set :: VarSet
bndr_set = [Id] -> VarSet
mkVarSet [Id]
bndrs

    ------------------------------
        -- See Note [Choosing loop breakers] for loop_breaker_nodes
    final_uds :: UsageDetails
    loop_breaker_nodes :: [LetrecNode]
    (final_uds :: UsageDetails
final_uds, loop_breaker_nodes :: [Node Unique Details]
loop_breaker_nodes)
      = OccEnv
-> TopLevelFlag
-> VarSet
-> UsageDetails
-> [Details]
-> (UsageDetails, [Node Unique Details])
mkLoopBreakerNodes OccEnv
env TopLevelFlag
lvl VarSet
bndr_set UsageDetails
body_uds [Details]
details_s

    ------------------------------
    weak_fvs :: VarSet
    weak_fvs :: VarSet
weak_fvs = (Details -> VarSet) -> [Details] -> VarSet
forall a. (a -> VarSet) -> [a] -> VarSet
mapUnionVarSet Details -> VarSet
nd_weak [Details]
details_s

    ---------------------------
    -- Now reconstruct the cycle
    pairs :: [(Id,CoreExpr)]
    pairs :: [(Id, CoreExpr)]
pairs | VarSet -> Bool
isEmptyVarSet VarSet
weak_fvs = Int
-> VarSet
-> VarSet
-> [Node Unique Details]
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
reOrderNodes   0 VarSet
bndr_set VarSet
weak_fvs [Node Unique Details]
loop_breaker_nodes []
          | Bool
otherwise              = Int
-> VarSet
-> VarSet
-> [Node Unique Details]
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
loopBreakNodes 0 VarSet
bndr_set VarSet
weak_fvs [Node Unique Details]
loop_breaker_nodes []
          -- If weak_fvs is empty, the loop_breaker_nodes will include
          -- all the edges in the original scope edges [remember,
          -- weak_fvs is the difference between scope edges and
          -- lb-edges], so a fresh SCC computation would yield a
          -- single CyclicSCC result; and reOrderNodes deals with
          -- exactly that case


------------------------------------------------------------------
--                 Loop breaking
------------------------------------------------------------------

type Binding = (Id,CoreExpr)

loopBreakNodes :: Int
               -> VarSet        -- All binders
               -> VarSet        -- Binders whose dependencies may be "missing"
                                -- See Note [Weak loop breakers]
               -> [LetrecNode]
               -> [Binding]             -- Append these to the end
               -> [Binding]
{-
loopBreakNodes is applied to the list of nodes for a cyclic strongly
connected component (there's guaranteed to be a cycle).  It returns
the same nodes, but
        a) in a better order,
        b) with some of the Ids having a IAmALoopBreaker pragma

The "loop-breaker" Ids are sufficient to break all cycles in the SCC.  This means
that the simplifier can guarantee not to loop provided it never records an inlining
for these no-inline guys.

Furthermore, the order of the binds is such that if we neglect dependencies
on the no-inline Ids then the binds are topologically sorted.  This means
that the simplifier will generally do a good job if it works from top bottom,
recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
-}

-- Return the bindings sorted into a plausible order, and marked with loop breakers.
loopBreakNodes :: Int
-> VarSet
-> VarSet
-> [Node Unique Details]
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
loopBreakNodes depth :: Int
depth bndr_set :: VarSet
bndr_set weak_fvs :: VarSet
weak_fvs nodes :: [Node Unique Details]
nodes binds :: [(Id, CoreExpr)]
binds
  = -- pprTrace "loopBreakNodes" (ppr nodes) $
    [SCC (Node Unique Details)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
go ([Node Unique Details] -> [SCC (Node Unique Details)]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesUniqR [Node Unique Details]
nodes) [(Id, CoreExpr)]
binds
  where
    go :: [SCC (Node Unique Details)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
go []         binds :: [(Id, CoreExpr)]
binds = [(Id, CoreExpr)]
binds
    go (scc :: SCC (Node Unique Details)
scc:sccs :: [SCC (Node Unique Details)]
sccs) binds :: [(Id, CoreExpr)]
binds = SCC (Node Unique Details) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
loop_break_scc SCC (Node Unique Details)
scc ([SCC (Node Unique Details)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
go [SCC (Node Unique Details)]
sccs [(Id, CoreExpr)]
binds)

    loop_break_scc :: SCC (Node Unique Details) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
loop_break_scc scc :: SCC (Node Unique Details)
scc binds :: [(Id, CoreExpr)]
binds
      = case SCC (Node Unique Details)
scc of
          AcyclicSCC node :: Node Unique Details
node  -> VarSet -> Node Unique Details -> (Id, CoreExpr)
mk_non_loop_breaker VarSet
weak_fvs Node Unique Details
node (Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. a -> [a] -> [a]
: [(Id, CoreExpr)]
binds
          CyclicSCC nodes :: [Node Unique Details]
nodes  -> Int
-> VarSet
-> VarSet
-> [Node Unique Details]
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
reOrderNodes Int
depth VarSet
bndr_set VarSet
weak_fvs [Node Unique Details]
nodes [(Id, CoreExpr)]
binds

----------------------------------
reOrderNodes :: Int -> VarSet -> VarSet -> [LetrecNode] -> [Binding] -> [Binding]
    -- Choose a loop breaker, mark it no-inline,
    -- and call loopBreakNodes on the rest
reOrderNodes :: Int
-> VarSet
-> VarSet
-> [Node Unique Details]
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
reOrderNodes _ _ _ []     _     = String -> [(Id, CoreExpr)]
forall a. String -> a
panic "reOrderNodes"
reOrderNodes _ _ _ [node :: Node Unique Details
node] binds :: [(Id, CoreExpr)]
binds = Node Unique Details -> (Id, CoreExpr)
mk_loop_breaker Node Unique Details
node (Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. a -> [a] -> [a]
: [(Id, CoreExpr)]
binds
reOrderNodes depth :: Int
depth bndr_set :: VarSet
bndr_set weak_fvs :: VarSet
weak_fvs (node :: Node Unique Details
node : nodes :: [Node Unique Details]
nodes) binds :: [(Id, CoreExpr)]
binds
  = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen
    --                              , text "chosen" <+> ppr chosen_nodes ]) $
    Int
-> VarSet
-> VarSet
-> [Node Unique Details]
-> [(Id, CoreExpr)]
-> [(Id, CoreExpr)]
loopBreakNodes Int
new_depth VarSet
bndr_set VarSet
weak_fvs [Node Unique Details]
unchosen ([(Id, CoreExpr)] -> [(Id, CoreExpr)])
-> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a b. (a -> b) -> a -> b
$
    ((Node Unique Details -> (Id, CoreExpr))
-> [Node Unique Details] -> [(Id, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map Node Unique Details -> (Id, CoreExpr)
mk_loop_breaker [Node Unique Details]
chosen_nodes [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [(Id, CoreExpr)]
binds)
  where
    (chosen_nodes :: [Node Unique Details]
chosen_nodes, unchosen :: [Node Unique Details]
unchosen) = Bool
-> NodeScore
-> [Node Unique Details]
-> [Node Unique Details]
-> [Node Unique Details]
-> ([Node Unique Details], [Node Unique Details])
chooseLoopBreaker Bool
approximate_lb
                                                 (Details -> NodeScore
nd_score (Node Unique Details -> Details
forall key payload. Node key payload -> payload
node_payload Node Unique Details
node))
                                                 [Node Unique Details
node] [] [Node Unique Details]
nodes

    approximate_lb :: Bool
approximate_lb = Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 2
    new_depth :: Int
new_depth | Bool
approximate_lb = 0
              | Bool
otherwise      = Int
depthInt -> Int -> Int
forall a. Num a => a -> a -> a
+1
        -- After two iterations (d=0, d=1) give up
        -- and approximate, returning to d=0

mk_loop_breaker :: LetrecNode -> Binding
mk_loop_breaker :: Node Unique Details -> (Id, CoreExpr)
mk_loop_breaker (Node Unique Details -> Details
forall key payload. Node key payload -> payload
node_payload -> ND { nd_bndr :: Details -> Id
nd_bndr = Id
bndr, nd_rhs :: Details -> CoreExpr
nd_rhs = CoreExpr
rhs})
  = (Id
bndr Id -> OccInfo -> Id
`setIdOccInfo` OccInfo
strongLoopBreaker { occ_tail :: TailCallInfo
occ_tail = TailCallInfo
tail_info }, CoreExpr
rhs)
  where
    tail_info :: TailCallInfo
tail_info = OccInfo -> TailCallInfo
tailCallInfo (Id -> OccInfo
idOccInfo Id
bndr)

mk_non_loop_breaker :: VarSet -> LetrecNode -> Binding
-- See Note [Weak loop breakers]
mk_non_loop_breaker :: VarSet -> Node Unique Details -> (Id, CoreExpr)
mk_non_loop_breaker weak_fvs :: VarSet
weak_fvs (Node Unique Details -> Details
forall key payload. Node key payload -> payload
node_payload -> ND { nd_bndr :: Details -> Id
nd_bndr = Id
bndr
                                                 , nd_rhs :: Details -> CoreExpr
nd_rhs = CoreExpr
rhs})
  | Id
bndr Id -> VarSet -> Bool
`elemVarSet` VarSet
weak_fvs = (Id -> OccInfo -> Id
setIdOccInfo Id
bndr OccInfo
occ', CoreExpr
rhs)
  | Bool
otherwise                  = (Id
bndr, CoreExpr
rhs)
  where
    occ' :: OccInfo
occ' = OccInfo
weakLoopBreaker { occ_tail :: TailCallInfo
occ_tail = TailCallInfo
tail_info }
    tail_info :: TailCallInfo
tail_info = OccInfo -> TailCallInfo
tailCallInfo (Id -> OccInfo
idOccInfo Id
bndr)

----------------------------------
chooseLoopBreaker :: Bool             -- True <=> Too many iterations,
                                      --          so approximate
                  -> NodeScore            -- Best score so far
                  -> [LetrecNode]       -- Nodes with this score
                  -> [LetrecNode]       -- Nodes with higher scores
                  -> [LetrecNode]       -- Unprocessed nodes
                  -> ([LetrecNode], [LetrecNode])
    -- This loop looks for the bind with the lowest score
    -- to pick as the loop  breaker.  The rest accumulate in
chooseLoopBreaker :: Bool
-> NodeScore
-> [Node Unique Details]
-> [Node Unique Details]
-> [Node Unique Details]
-> ([Node Unique Details], [Node Unique Details])
chooseLoopBreaker _ _ loop_nodes :: [Node Unique Details]
loop_nodes acc :: [Node Unique Details]
acc []
  = ([Node Unique Details]
loop_nodes, [Node Unique Details]
acc)        -- Done

    -- If approximate_loop_breaker is True, we pick *all*
    -- nodes with lowest score, else just one
    -- See Note [Complexity of loop breaking]
chooseLoopBreaker approx_lb :: Bool
approx_lb loop_sc :: NodeScore
loop_sc loop_nodes :: [Node Unique Details]
loop_nodes acc :: [Node Unique Details]
acc (node :: Node Unique Details
node : nodes :: [Node Unique Details]
nodes)
  | Bool
approx_lb
  , NodeScore -> Int
rank NodeScore
sc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== NodeScore -> Int
rank NodeScore
loop_sc
  = Bool
-> NodeScore
-> [Node Unique Details]
-> [Node Unique Details]
-> [Node Unique Details]
-> ([Node Unique Details], [Node Unique Details])
chooseLoopBreaker Bool
approx_lb NodeScore
loop_sc (Node Unique Details
node Node Unique Details
-> [Node Unique Details] -> [Node Unique Details]
forall a. a -> [a] -> [a]
: [Node Unique Details]
loop_nodes) [Node Unique Details]
acc [Node Unique Details]
nodes

  | NodeScore
sc NodeScore -> NodeScore -> Bool
`betterLB` NodeScore
loop_sc  -- Better score so pick this new one
  = Bool
-> NodeScore
-> [Node Unique Details]
-> [Node Unique Details]
-> [Node Unique Details]
-> ([Node Unique Details], [Node Unique Details])
chooseLoopBreaker Bool
approx_lb NodeScore
sc [Node Unique Details
node] ([Node Unique Details]
loop_nodes [Node Unique Details]
-> [Node Unique Details] -> [Node Unique Details]
forall a. [a] -> [a] -> [a]
++ [Node Unique Details]
acc) [Node Unique Details]
nodes

  | Bool
otherwise              -- Worse score so don't pick it
  = Bool
-> NodeScore
-> [Node Unique Details]
-> [Node Unique Details]
-> [Node Unique Details]
-> ([Node Unique Details], [Node Unique Details])
chooseLoopBreaker Bool
approx_lb NodeScore
loop_sc [Node Unique Details]
loop_nodes (Node Unique Details
node Node Unique Details
-> [Node Unique Details] -> [Node Unique Details]
forall a. a -> [a] -> [a]
: [Node Unique Details]
acc) [Node Unique Details]
nodes
  where
    sc :: NodeScore
sc = Details -> NodeScore
nd_score (Node Unique Details -> Details
forall key payload. Node key payload -> payload
node_payload Node Unique Details
node)

{-
Note [Complexity of loop breaking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The loop-breaking algorithm knocks out one binder at a time, and
performs a new SCC analysis on the remaining binders.  That can
behave very badly in tightly-coupled groups of bindings; in the
worst case it can be (N**2)*log N, because it does a full SCC
on N, then N-1, then N-2 and so on.

To avoid this, we switch plans after 2 (or whatever) attempts:
  Plan A: pick one binder with the lowest score, make it
          a loop breaker, and try again
  Plan B: pick *all* binders with the lowest score, make them
          all loop breakers, and try again
Since there are only a small finite number of scores, this will
terminate in a constant number of iterations, rather than O(N)
iterations.

You might thing that it's very unlikely, but RULES make it much
more likely.  Here's a real example from Trac #1969:
  Rec { $dm = \d.\x. op d
        {-# RULES forall d. $dm Int d  = $s$dm1
                  forall d. $dm Bool d = $s$dm2 #-}

        dInt = MkD .... opInt ...
        dInt = MkD .... opBool ...
        opInt  = $dm dInt
        opBool = $dm dBool

        $s$dm1 = \x. op dInt
        $s$dm2 = \x. op dBool }
The RULES stuff means that we can't choose $dm as a loop breaker
(Note [Choosing loop breakers]), so we must choose at least (say)
opInt *and* opBool, and so on.  The number of loop breakders is
linear in the number of instance declarations.

Note [Loop breakers and INLINE/INLINABLE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Avoid choosing a function with an INLINE pramga as the loop breaker!
If such a function is mutually-recursive with a non-INLINE thing,
then the latter should be the loop-breaker.

It's vital to distinguish between INLINE and INLINABLE (the
Bool returned by hasStableCoreUnfolding_maybe).  If we start with
   Rec { {-# INLINABLE f #-}
         f x = ...f... }
and then worker/wrapper it through strictness analysis, we'll get
   Rec { {-# INLINABLE $wf #-}
         $wf p q = let x = (p,q) in ...f...

         {-# INLINE f #-}
         f x = case x of (p,q) -> $wf p q }

Now it is vital that we choose $wf as the loop breaker, so we can
inline 'f' in '$wf'.

Note [DFuns should not be loop breakers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's particularly bad to make a DFun into a loop breaker.  See
Note [How instance declarations are translated] in TcInstDcls

We give DFuns a higher score than ordinary CONLIKE things because
if there's a choice we want the DFun to be the non-loop breaker. Eg

rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)

      $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)
      {-# DFUN #-}
      $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC)
    }

Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it
if we can't unravel the DFun first.

Note [Constructor applications]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's really really important to inline dictionaries.  Real
example (the Enum Ordering instance from GHC.Base):

     rec     f = \ x -> case d of (p,q,r) -> p x
             g = \ x -> case d of (p,q,r) -> q x
             d = (v, f, g)

Here, f and g occur just once; but we can't inline them into d.
On the other hand we *could* simplify those case expressions if
we didn't stupidly choose d as the loop breaker.
But we won't because constructor args are marked "Many".
Inlining dictionaries is really essential to unravelling
the loops in static numeric dictionaries, see GHC.Float.

Note [Closure conversion]
~~~~~~~~~~~~~~~~~~~~~~~~~
We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.
The immediate motivation came from the result of a closure-conversion transformation
which generated code like this:

    data Clo a b = forall c. Clo (c -> a -> b) c

    ($:) :: Clo a b -> a -> b
    Clo f env $: x = f env x

    rec { plus = Clo plus1 ()

        ; plus1 _ n = Clo plus2 n

        ; plus2 Zero     n = n
        ; plus2 (Succ m) n = Succ (plus $: m $: n) }

If we inline 'plus' and 'plus1', everything unravels nicely.  But if
we choose 'plus1' as the loop breaker (which is entirely possible
otherwise), the loop does not unravel nicely.


@occAnalUnfolding@ deals with the question of bindings where the Id is marked
by an INLINE pragma.  For these we record that anything which occurs
in its RHS occurs many times.  This pessimistically assumes that this
inlined binder also occurs many times in its scope, but if it doesn't
we'll catch it next time round.  At worst this costs an extra simplifier pass.
ToDo: try using the occurrence info for the inline'd binder.

[March 97] We do the same for atomic RHSs.  Reason: see notes with loopBreakSCC.
[June 98, SLPJ]  I've undone this change; I don't understand it.  See notes with loopBreakSCC.


************************************************************************
*                                                                      *
                   Making nodes
*                                                                      *
************************************************************************
-}

type ImpRuleEdges = IdEnv IdSet     -- Mapping from FVs of imported RULE LHSs to RHS FVs

noImpRuleEdges :: ImpRuleEdges
noImpRuleEdges :: ImpRuleEdges
noImpRuleEdges = ImpRuleEdges
forall a. VarEnv a
emptyVarEnv

type LetrecNode = Node Unique Details  -- Node comes from Digraph
                                       -- The Unique key is gotten from the Id
data Details
  = ND { Details -> Id
nd_bndr :: Id          -- Binder
       , Details -> CoreExpr
nd_rhs  :: CoreExpr    -- RHS, already occ-analysed
       , Details -> [Id]
nd_rhs_bndrs :: [CoreBndr] -- Outer lambdas of RHS
                                    -- INVARIANT: (nd_rhs_bndrs nd, _) ==
                                    --              collectBinders (nd_rhs nd)

       , Details -> UsageDetails
nd_uds  :: UsageDetails  -- Usage from RHS, and RULES, and stable unfoldings
                                  -- ignoring phase (ie assuming all are active)
                                  -- See Note [Forming Rec groups]

       , Details -> VarSet
nd_inl  :: IdSet       -- Free variables of
                                --   the stable unfolding (if present and active)
                                --   or the RHS (if not)
                                -- but excluding any RULES
                                -- This is the IdSet that may be used if the Id is inlined

       , Details -> VarSet
nd_weak :: IdSet       -- Binders of this Rec that are mentioned in nd_uds
                                -- but are *not* in nd_inl.  These are the ones whose
                                -- dependencies might not be respected by loop_breaker_nodes
                                -- See Note [Weak loop breakers]

       , Details -> VarSet
nd_active_rule_fvs :: IdSet   -- Free variables of the RHS of active RULES

       , Details -> NodeScore
nd_score :: NodeScore
  }

instance Outputable Details where
   ppr :: Details -> SDoc
ppr nd :: Details
nd = String -> SDoc
text "ND" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces
             ([SDoc] -> SDoc
sep [ String -> SDoc
text "bndr =" SDoc -> SDoc -> SDoc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Details -> Id
nd_bndr Details
nd)
                  , String -> SDoc
text "uds =" SDoc -> SDoc -> SDoc
<+> UsageDetails -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Details -> UsageDetails
nd_uds Details
nd)
                  , String -> SDoc
text "inl =" SDoc -> SDoc -> SDoc
<+> VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Details -> VarSet
nd_inl Details
nd)
                  , String -> SDoc
text "weak =" SDoc -> SDoc -> SDoc
<+> VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Details -> VarSet
nd_weak Details
nd)
                  , String -> SDoc
text "rule =" SDoc -> SDoc -> SDoc
<+> VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Details -> VarSet
nd_active_rule_fvs Details
nd)
                  , String -> SDoc
text "score =" SDoc -> SDoc -> SDoc
<+> NodeScore -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Details -> NodeScore
nd_score Details
nd)
             ])

-- The NodeScore is compared lexicographically;
--      e.g. lower rank wins regardless of size
type NodeScore = ( Int     -- Rank: lower => more likely to be picked as loop breaker
                 , Int     -- Size of rhs: higher => more likely to be picked as LB
                           -- Maxes out at maxExprSize; we just use it to prioritise
                           -- small functions
                 , Bool )  -- Was it a loop breaker before?
                           -- True => more likely to be picked
                           -- Note [Loop breakers, node scoring, and stability]

rank :: NodeScore -> Int
rank :: NodeScore -> Int
rank (r :: Int
r, _, _) = Int
r

makeNode :: OccEnv -> ImpRuleEdges -> VarSet
         -> (Var, CoreExpr) -> LetrecNode
-- See Note [Recursive bindings: the grand plan]
makeNode :: OccEnv
-> ImpRuleEdges -> VarSet -> (Id, CoreExpr) -> Node Unique Details
makeNode env :: OccEnv
env imp_rule_edges :: ImpRuleEdges
imp_rule_edges bndr_set :: VarSet
bndr_set (bndr :: Id
bndr, rhs :: CoreExpr
rhs)
  = Details -> Unique -> [Unique] -> Node Unique Details
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode Details
details (Id -> Unique
varUnique Id
bndr) (VarSet -> [Unique]
forall elt. UniqSet elt -> [Unique]
nonDetKeysUniqSet VarSet
node_fvs)
    -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR
    -- is still deterministic with edges in nondeterministic order as
    -- explained in Note [Deterministic SCC] in Digraph.
  where
    details :: Details
details = ND :: Id
-> CoreExpr
-> [Id]
-> UsageDetails
-> VarSet
-> VarSet
-> VarSet
-> NodeScore
-> Details
ND { nd_bndr :: Id
nd_bndr            = Id
bndr
                 , nd_rhs :: CoreExpr
nd_rhs             = CoreExpr
rhs'
                 , nd_rhs_bndrs :: [Id]
nd_rhs_bndrs       = [Id]
bndrs'
                 , nd_uds :: UsageDetails
nd_uds             = UsageDetails
rhs_usage3
                 , nd_inl :: VarSet
nd_inl             = VarSet
inl_fvs
                 , nd_weak :: VarSet
nd_weak            = VarSet
node_fvs VarSet -> VarSet -> VarSet
`minusVarSet` VarSet
inl_fvs
                 , nd_active_rule_fvs :: VarSet
nd_active_rule_fvs = VarSet
active_rule_fvs
                 , nd_score :: NodeScore
nd_score           = String -> SDoc -> NodeScore
forall a. HasCallStack => String -> SDoc -> a
pprPanic "makeNodeDetails" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
bndr) }

    -- Constructing the edges for the main Rec computation
    -- See Note [Forming Rec groups]
    (bndrs :: [Id]
bndrs, body :: CoreExpr
body) = CoreExpr -> ([Id], CoreExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders CoreExpr
rhs
    (rhs_usage1 :: UsageDetails
rhs_usage1, bndrs' :: [Id]
bndrs', body' :: CoreExpr
body') = OccEnv -> [Id] -> CoreExpr -> (UsageDetails, [Id], CoreExpr)
occAnalRecRhs OccEnv
env [Id]
bndrs CoreExpr
body
    rhs' :: CoreExpr
rhs' = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
bndrs' CoreExpr
body'
    rhs_usage2 :: UsageDetails
rhs_usage2 = (UsageDetails -> UsageDetails -> UsageDetails)
-> UsageDetails -> [UsageDetails] -> UsageDetails
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr UsageDetails -> UsageDetails -> UsageDetails
andUDs UsageDetails
rhs_usage1 [UsageDetails]
rule_uds
                   -- Note [Rules are extra RHSs]
                   -- Note [Rule dependency info]
    rhs_usage3 :: UsageDetails
rhs_usage3 = case Maybe UsageDetails
mb_unf_uds of
                   Just unf_uds :: UsageDetails
unf_uds -> UsageDetails
rhs_usage2 UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
unf_uds
                   Nothing      -> UsageDetails
rhs_usage2
    node_fvs :: VarSet
node_fvs = VarSet -> UsageDetails -> VarSet
udFreeVars VarSet
bndr_set UsageDetails
rhs_usage3

    -- Finding the free variables of the rules
    is_active :: Activation -> Bool
is_active = OccEnv -> Activation -> Bool
occ_rule_act OccEnv
env :: Activation -> Bool

    rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]
    rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]
rules_w_uds = OccEnv
-> Maybe Int
-> RecFlag
-> Id
-> [(CoreRule, UsageDetails, UsageDetails)]
occAnalRules OccEnv
env (Int -> Maybe Int
forall a. a -> Maybe a
Just ([Id] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
bndrs)) RecFlag
Recursive Id
bndr

    rules_w_rhs_fvs :: [(Activation, VarSet)]    -- Find the RHS fvs
    rules_w_rhs_fvs :: [(Activation, VarSet)]
rules_w_rhs_fvs = ([(Activation, VarSet)] -> [(Activation, VarSet)])
-> (VarSet -> [(Activation, VarSet)] -> [(Activation, VarSet)])
-> Maybe VarSet
-> [(Activation, VarSet)]
-> [(Activation, VarSet)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [(Activation, VarSet)] -> [(Activation, VarSet)]
forall a. a -> a
id (\ids :: VarSet
ids -> ((Activation
AlwaysActive, VarSet
ids)(Activation, VarSet)
-> [(Activation, VarSet)] -> [(Activation, VarSet)]
forall a. a -> [a] -> [a]
:))
                               (ImpRuleEdges -> Id -> Maybe VarSet
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv ImpRuleEdges
imp_rule_edges Id
bndr)
      -- See Note [Preventing loops due to imported functions rules]
                      [ (CoreRule -> Activation
ru_act CoreRule
rule, VarSet -> UsageDetails -> VarSet
udFreeVars VarSet
bndr_set UsageDetails
rhs_uds)
                      | (rule :: CoreRule
rule, _, rhs_uds :: UsageDetails
rhs_uds) <- [(CoreRule, UsageDetails, UsageDetails)]
rules_w_uds ]
    rule_uds :: [UsageDetails]
rule_uds = ((CoreRule, UsageDetails, UsageDetails) -> UsageDetails)
-> [(CoreRule, UsageDetails, UsageDetails)] -> [UsageDetails]
forall a b. (a -> b) -> [a] -> [b]
map (\(_, l :: UsageDetails
l, r :: UsageDetails
r) -> UsageDetails
l UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
r) [(CoreRule, UsageDetails, UsageDetails)]
rules_w_uds
    active_rule_fvs :: VarSet
active_rule_fvs = [VarSet] -> VarSet
unionVarSets [VarSet
fvs | (a :: Activation
a,fvs :: VarSet
fvs) <- [(Activation, VarSet)]
rules_w_rhs_fvs
                                        , Activation -> Bool
is_active Activation
a]

    -- Finding the usage details of the INLINE pragma (if any)
    mb_unf_uds :: Maybe UsageDetails
mb_unf_uds = OccEnv -> RecFlag -> Id -> Maybe UsageDetails
occAnalUnfolding OccEnv
env RecFlag
Recursive Id
bndr

    -- Find the "nd_inl" free vars; for the loop-breaker phase
    inl_fvs :: VarSet
inl_fvs = case Maybe UsageDetails
mb_unf_uds of
                Nothing -> VarSet -> UsageDetails -> VarSet
udFreeVars VarSet
bndr_set UsageDetails
rhs_usage1 -- No INLINE, use RHS
                Just unf_uds :: UsageDetails
unf_uds -> VarSet -> UsageDetails -> VarSet
udFreeVars VarSet
bndr_set UsageDetails
unf_uds
                      -- We could check for an *active* INLINE (returning
                      -- emptyVarSet for an inactive one), but is_active
                      -- isn't the right thing (it tells about
                      -- RULE activation), so we'd need more plumbing

mkLoopBreakerNodes :: OccEnv -> TopLevelFlag
                   -> VarSet
                   -> UsageDetails   -- for BODY of let
                   -> [Details]
                   -> (UsageDetails, -- adjusted
                       [LetrecNode])
-- Does four things
--   a) tag each binder with its occurrence info
--   b) add a NodeScore to each node
--   c) make a Node with the right dependency edges for
--      the loop-breaker SCC analysis
--   d) adjust each RHS's usage details according to
--      the binder's (new) shotness and join-point-hood
mkLoopBreakerNodes :: OccEnv
-> TopLevelFlag
-> VarSet
-> UsageDetails
-> [Details]
-> (UsageDetails, [Node Unique Details])
mkLoopBreakerNodes env :: OccEnv
env lvl :: TopLevelFlag
lvl bndr_set :: VarSet
bndr_set body_uds :: UsageDetails
body_uds details_s :: [Details]
details_s
  = (UsageDetails
final_uds, (Details -> Id -> Node Unique Details)
-> [Details] -> [Id] -> [Node Unique Details]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Details -> Id -> Node Unique Details
mk_lb_node [Details]
details_s [Id]
bndrs')
  where
    (final_uds :: UsageDetails
final_uds, bndrs' :: [Id]
bndrs') = TopLevelFlag
-> UsageDetails
-> [(Id, UsageDetails, [Id])]
-> (UsageDetails, [Id])
tagRecBinders TopLevelFlag
lvl UsageDetails
body_uds
                            [ ((Details -> Id
nd_bndr Details
nd)
                               ,(Details -> UsageDetails
nd_uds Details
nd)
                               ,(Details -> [Id]
nd_rhs_bndrs Details
nd))
                            | Details
nd <- [Details]
details_s ]
    mk_lb_node :: Details -> Id -> Node Unique Details
mk_lb_node nd :: Details
nd@(ND { nd_bndr :: Details -> Id
nd_bndr = Id
bndr, nd_rhs :: Details -> CoreExpr
nd_rhs = CoreExpr
rhs, nd_inl :: Details -> VarSet
nd_inl = VarSet
inl_fvs }) bndr' :: Id
bndr'
      = Details -> Unique -> [Unique] -> Node Unique Details
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode Details
nd' (Id -> Unique
varUnique Id
bndr) (VarSet -> [Unique]
forall elt. UniqSet elt -> [Unique]
nonDetKeysUniqSet VarSet
lb_deps)
              -- It's OK to use nonDetKeysUniqSet here as
              -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges
              -- in nondeterministic order as explained in
              -- Note [Deterministic SCC] in Digraph.
      where
        nd' :: Details
nd'     = Details
nd { nd_bndr :: Id
nd_bndr = Id
bndr', nd_score :: NodeScore
nd_score = NodeScore
score }
        score :: NodeScore
score   = OccEnv -> Id -> Id -> CoreExpr -> VarSet -> NodeScore
nodeScore OccEnv
env Id
bndr Id
bndr' CoreExpr
rhs VarSet
lb_deps
        lb_deps :: VarSet
lb_deps = ImpRuleEdges -> VarSet -> VarSet
extendFvs_ ImpRuleEdges
rule_fv_env VarSet
inl_fvs

    rule_fv_env :: IdEnv IdSet
        -- Maps a variable f to the variables from this group
        --      mentioned in RHS of active rules for f
        -- Domain is *subset* of bound vars (others have no rule fvs)
    rule_fv_env :: ImpRuleEdges
rule_fv_env = ImpRuleEdges -> ImpRuleEdges
transClosureFV ([(Id, VarSet)] -> ImpRuleEdges
forall a. [(Id, a)] -> VarEnv a
mkVarEnv [(Id, VarSet)]
init_rule_fvs)
    init_rule_fvs :: [(Id, VarSet)]
init_rule_fvs   -- See Note [Finding rule RHS free vars]
      = [ (Id
b, VarSet
trimmed_rule_fvs)
        | ND { nd_bndr :: Details -> Id
nd_bndr = Id
b, nd_active_rule_fvs :: Details -> VarSet
nd_active_rule_fvs = VarSet
rule_fvs } <- [Details]
details_s
        , let trimmed_rule_fvs :: VarSet
trimmed_rule_fvs = VarSet
rule_fvs VarSet -> VarSet -> VarSet
`intersectVarSet` VarSet
bndr_set
        , Bool -> Bool
not (VarSet -> Bool
isEmptyVarSet VarSet
trimmed_rule_fvs) ]


------------------------------------------
nodeScore :: OccEnv
          -> Id        -- Binder has old occ-info (just for loop-breaker-ness)
          -> Id        -- Binder with new occ-info
          -> CoreExpr  -- RHS
          -> VarSet    -- Loop-breaker dependencies
          -> NodeScore
nodeScore :: OccEnv -> Id -> Id -> CoreExpr -> VarSet -> NodeScore
nodeScore env :: OccEnv
env old_bndr :: Id
old_bndr new_bndr :: Id
new_bndr bind_rhs :: CoreExpr
bind_rhs lb_deps :: VarSet
lb_deps
  | Bool -> Bool
not (Id -> Bool
isId Id
old_bndr)     -- A type or cercion variable is never a loop breaker
  = (100, 0, Bool
False)

  | Id
old_bndr Id -> VarSet -> Bool
`elemVarSet` VarSet
lb_deps  -- Self-recursive things are great loop breakers
  = (0, 0, Bool
True)                   -- See Note [Self-recursion and loop breakers]

  | Bool -> Bool
not (OccEnv -> Id -> Bool
occ_unf_act OccEnv
env Id
old_bndr) -- A binder whose inlining is inactive (e.g. has
  = (0, 0, Bool
True)                   -- a NOINLINE pragma) makes a great loop breaker

  | CoreExpr -> Bool
exprIsTrivial CoreExpr
rhs
  = Int -> NodeScore
mk_score 10  -- Practically certain to be inlined
    -- Used to have also: && not (isExportedId bndr)
    -- But I found this sometimes cost an extra iteration when we have
    --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }
    -- where df is the exported dictionary. Then df makes a really
    -- bad choice for loop breaker

  | DFunUnfolding { df_args :: Unfolding -> [CoreExpr]
df_args = [CoreExpr]
args } <- Unfolding
id_unfolding
    -- Never choose a DFun as a loop breaker
    -- Note [DFuns should not be loop breakers]
  = (9, [CoreExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
args, Bool
is_lb)

    -- Data structures are more important than INLINE pragmas
    -- so that dictionary/method recursion unravels

  | CoreUnfolding { uf_guidance :: Unfolding -> UnfoldingGuidance
uf_guidance = UnfWhen {} } <- Unfolding
id_unfolding
  = Int -> NodeScore
mk_score 6

  | CoreExpr -> Bool
forall b. Expr b -> Bool
is_con_app CoreExpr
rhs   -- Data types help with cases:
  = Int -> NodeScore
mk_score 5       -- Note [Constructor applications]

  | Unfolding -> Bool
isStableUnfolding Unfolding
id_unfolding
  , Bool
can_unfold
  = Int -> NodeScore
mk_score 3

  | OccInfo -> Bool
isOneOcc (Id -> OccInfo
idOccInfo Id
new_bndr)
  = Int -> NodeScore
mk_score 2  -- Likely to be inlined

  | Bool
can_unfold  -- The Id has some kind of unfolding
  = Int -> NodeScore
mk_score 1

  | Bool
otherwise
  = (0, 0, Bool
is_lb)

  where
    mk_score :: Int -> NodeScore
    mk_score :: Int -> NodeScore
mk_score rank :: Int
rank = (Int
rank, Int
rhs_size, Bool
is_lb)

    is_lb :: Bool
is_lb    = OccInfo -> Bool
isStrongLoopBreaker (Id -> OccInfo
idOccInfo Id
old_bndr)
    rhs :: CoreExpr
rhs      = case Unfolding
id_unfolding of
                 CoreUnfolding { uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src, uf_tmpl :: Unfolding -> CoreExpr
uf_tmpl = CoreExpr
unf_rhs }
                    | UnfoldingSource -> Bool
isStableSource UnfoldingSource
src
                    -> CoreExpr
unf_rhs
                 _  -> CoreExpr
bind_rhs
       -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding
    rhs_size :: Int
rhs_size = case Unfolding
id_unfolding of
                 CoreUnfolding { uf_guidance :: Unfolding -> UnfoldingGuidance
uf_guidance = UnfoldingGuidance
guidance }
                    | UnfIfGoodArgs { ug_size :: UnfoldingGuidance -> Int
ug_size = Int
size } <- UnfoldingGuidance
guidance
                    -> Int
size
                 _  -> CoreExpr -> Int
cheapExprSize CoreExpr
rhs

    can_unfold :: Bool
can_unfold   = Unfolding -> Bool
canUnfold Unfolding
id_unfolding
    id_unfolding :: Unfolding
id_unfolding = Id -> Unfolding
realIdUnfolding Id
old_bndr
       -- realIdUnfolding: Ignore loop-breaker-ness here because
       -- that is what we are setting!

        -- Checking for a constructor application
        -- Cheap and cheerful; the simplifier moves casts out of the way
        -- The lambda case is important to spot x = /\a. C (f a)
        -- which comes up when C is a dictionary constructor and
        -- f is a default method.
        -- Example: the instance for Show (ST s a) in GHC.ST
        --
        -- However we *also* treat (\x. C p q) as a con-app-like thing,
        --      Note [Closure conversion]
    is_con_app :: Expr b -> Bool
is_con_app (Var v :: Id
v)    = Id -> Bool
isConLikeId Id
v
    is_con_app (App f :: Expr b
f _)  = Expr b -> Bool
is_con_app Expr b
f
    is_con_app (Lam _ e :: Expr b
e)  = Expr b -> Bool
is_con_app Expr b
e
    is_con_app (Tick _ e :: Expr b
e) = Expr b -> Bool
is_con_app Expr b
e
    is_con_app _          = Bool
False

maxExprSize :: Int
maxExprSize :: Int
maxExprSize = 20  -- Rather arbitrary

cheapExprSize :: CoreExpr -> Int
-- Maxes out at maxExprSize
cheapExprSize :: CoreExpr -> Int
cheapExprSize e :: CoreExpr
e
  = Int -> CoreExpr -> Int
go 0 CoreExpr
e
  where
    go :: Int -> CoreExpr -> Int
go n :: Int
n e :: CoreExpr
e | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxExprSize = Int
n
           | Bool
otherwise        = Int -> CoreExpr -> Int
go1 Int
n CoreExpr
e

    go1 :: Int -> CoreExpr -> Int
go1 n :: Int
n (Var {})        = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1
    go1 n :: Int
n (Lit {})        = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1
    go1 n :: Int
n (Type {})       = Int
n
    go1 n :: Int
n (Coercion {})   = Int
n
    go1 n :: Int
n (Tick _ e :: CoreExpr
e)      = Int -> CoreExpr -> Int
go1 Int
n CoreExpr
e
    go1 n :: Int
n (Cast e :: CoreExpr
e _)      = Int -> CoreExpr -> Int
go1 Int
n CoreExpr
e
    go1 n :: Int
n (App f :: CoreExpr
f a :: CoreExpr
a)       = Int -> CoreExpr -> Int
go (Int -> CoreExpr -> Int
go1 Int
n CoreExpr
f) CoreExpr
a
    go1 n :: Int
n (Lam b :: Id
b e :: CoreExpr
e)
      | Id -> Bool
isTyVar Id
b         = Int -> CoreExpr -> Int
go1 Int
n CoreExpr
e
      | Bool
otherwise         = Int -> CoreExpr -> Int
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) CoreExpr
e
    go1 n :: Int
n (Let b :: CoreBind
b e :: CoreExpr
e)       = Int -> [CoreExpr] -> Int
gos (Int -> CoreExpr -> Int
go1 Int
n CoreExpr
e) (CoreBind -> [CoreExpr]
forall b. Bind b -> [Expr b]
rhssOfBind CoreBind
b)
    go1 n :: Int
n (Case e :: CoreExpr
e _ _ as :: [Alt Id]
as) = Int -> [CoreExpr] -> Int
gos (Int -> CoreExpr -> Int
go1 Int
n CoreExpr
e) ([Alt Id] -> [CoreExpr]
forall b. [Alt b] -> [Expr b]
rhssOfAlts [Alt Id]
as)

    gos :: Int -> [CoreExpr] -> Int
gos n :: Int
n [] = Int
n
    gos n :: Int
n (e :: CoreExpr
e:es :: [CoreExpr]
es) | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxExprSize = Int
n
                 | Bool
otherwise        = Int -> [CoreExpr] -> Int
gos (Int -> CoreExpr -> Int
go1 Int
n CoreExpr
e) [CoreExpr]
es

betterLB :: NodeScore -> NodeScore -> Bool
-- If  n1 `betterLB` n2  then choose n1 as the loop breaker
betterLB :: NodeScore -> NodeScore -> Bool
betterLB (rank1 :: Int
rank1, size1 :: Int
size1, lb1 :: Bool
lb1) (rank2 :: Int
rank2, size2 :: Int
size2, _)
  | Int
rank1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
rank2 = Bool
True
  | Int
rank1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
rank2 = Bool
False
  | Int
size1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
size2 = Bool
False   -- Make the bigger n2 into the loop breaker
  | Int
size1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
size2 = Bool
True
  | Bool
lb1           = Bool
True    -- Tie-break: if n1 was a loop breaker before, choose it
  | Bool
otherwise     = Bool
False   -- See Note [Loop breakers, node scoring, and stability]

{- Note [Self-recursion and loop breakers]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have
   rec { f = ...f...g...
       ; g = .....f...   }
then 'f' has to be a loop breaker anyway, so we may as well choose it
right away, so that g can inline freely.

This is really just a cheap hack. Consider
   rec { f = ...g...
       ; g = ..f..h...
      ;  h = ...f....}
Here f or g are better loop breakers than h; but we might accidentally
choose h.  Finding the minimal set of loop breakers is hard.

Note [Loop breakers, node scoring, and stability]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
To choose a loop breaker, we give a NodeScore to each node in the SCC,
and pick the one with the best score (according to 'betterLB').

We need to be jolly careful (Trac #12425, #12234) about the stability
of this choice. Suppose we have

    let rec { f = ...g...g...
            ; g = ...f...f... }
    in
    case x of
      True  -> ...f..
      False -> ..f...

In each iteration of the simplifier the occurrence analyser OccAnal
chooses a loop breaker. Suppose in iteration 1 it choose g as the loop
breaker. That means it is free to inline f.

Suppose that GHC decides to inline f in the branches of the case, but
(for some reason; eg it is not saturated) in the rhs of g. So we get

    let rec { f = ...g...g...
            ; g = ...f...f... }
    in
    case x of
      True  -> ...g...g.....
      False -> ..g..g....

Now suppose that, for some reason, in the next iteration the occurrence
analyser chooses f as the loop breaker, so it can freely inline g. And
again for some reason the simplifier inlines g at its calls in the case
branches, but not in the RHS of f. Then we get

    let rec { f = ...g...g...
            ; g = ...f...f... }
    in
    case x of
      True  -> ...(...f...f...)...(...f..f..).....
      False -> ..(...f...f...)...(..f..f...)....

You can see where this is going! Each iteration of the simplifier
doubles the number of calls to f or g. No wonder GHC is slow!

(In the particular example in comment:3 of #12425, f and g are the two
mutually recursive fmap instances for CondT and Result. They are both
marked INLINE which, oddly, is why they don't inline in each other's
RHS, because the call there is not saturated.)

The root cause is that we flip-flop on our choice of loop breaker. I
always thought it didn't matter, and indeed for any single iteration
to terminate, it doesn't matter. But when we iterate, it matters a
lot!!

So The Plan is this:
   If there is a tie, choose the node that
   was a loop breaker last time round

Hence the is_lb field of NodeScore

************************************************************************
*                                                                      *
                   Right hand sides
*                                                                      *
************************************************************************
-}

occAnalRhs :: OccEnv -> RecFlag -> Id -> [CoreBndr] -> CoreExpr
           -> (UsageDetails, [CoreBndr], CoreExpr)
              -- Returned usage details covers only the RHS,
              -- and *not* the RULE or INLINE template for the Id
occAnalRhs :: OccEnv
-> RecFlag
-> Id
-> [Id]
-> CoreExpr
-> (UsageDetails, [Id], CoreExpr)
occAnalRhs env :: OccEnv
env Recursive _ bndrs :: [Id]
bndrs body :: CoreExpr
body
  = OccEnv -> [Id] -> CoreExpr -> (UsageDetails, [Id], CoreExpr)
occAnalRecRhs OccEnv
env [Id]
bndrs CoreExpr
body
occAnalRhs env :: OccEnv
env NonRecursive id :: Id
id bndrs :: [Id]
bndrs body :: CoreExpr
body
  = OccEnv -> Id -> [Id] -> CoreExpr -> (UsageDetails, [Id], CoreExpr)
occAnalNonRecRhs OccEnv
env Id
id [Id]
bndrs CoreExpr
body

occAnalRecRhs :: OccEnv -> [CoreBndr] -> CoreExpr    -- Rhs lambdas, body
           -> (UsageDetails, [CoreBndr], CoreExpr)
              -- Returned usage details covers only the RHS,
              -- and *not* the RULE or INLINE template for the Id
occAnalRecRhs :: OccEnv -> [Id] -> CoreExpr -> (UsageDetails, [Id], CoreExpr)
occAnalRecRhs env :: OccEnv
env bndrs :: [Id]
bndrs body :: CoreExpr
body = OccEnv -> [Id] -> CoreExpr -> (UsageDetails, [Id], CoreExpr)
occAnalLamOrRhs (OccEnv -> OccEnv
rhsCtxt OccEnv
env) [Id]
bndrs CoreExpr
body

occAnalNonRecRhs :: OccEnv
                 -> Id -> [CoreBndr] -> CoreExpr    -- Binder; rhs lams, body
                     -- Binder is already tagged with occurrence info
                 -> (UsageDetails, [CoreBndr], CoreExpr)
              -- Returned usage details covers only the RHS,
              -- and *not* the RULE or INLINE template for the Id
occAnalNonRecRhs :: OccEnv -> Id -> [Id] -> CoreExpr -> (UsageDetails, [Id], CoreExpr)
occAnalNonRecRhs env :: OccEnv
env bndr :: Id
bndr bndrs :: [Id]
bndrs body :: CoreExpr
body
  = OccEnv -> [Id] -> CoreExpr -> (UsageDetails, [Id], CoreExpr)
occAnalLamOrRhs OccEnv
rhs_env [Id]
bndrs CoreExpr
body
  where
    env1 :: OccEnv
env1 | Bool
is_join_point    = OccEnv
env  -- See Note [Join point RHSs]
         | Bool
certainly_inline = OccEnv
env  -- See Note [Cascading inlines]
         | Bool
otherwise        = OccEnv -> OccEnv
rhsCtxt OccEnv
env

    -- See Note [Sources of one-shot information]
    rhs_env :: OccEnv
rhs_env = OccEnv
env1 { occ_one_shots :: OneShots
occ_one_shots = Demand -> OneShots
argOneShots Demand
dmd }

    certainly_inline :: Bool
certainly_inline -- See Note [Cascading inlines]
      = case OccInfo
occ of
          OneOcc { occ_in_lam :: OccInfo -> Bool
occ_in_lam = Bool
in_lam, occ_one_br :: OccInfo -> Bool
occ_one_br = Bool
one_br }
            -> Bool -> Bool
not Bool
in_lam Bool -> Bool -> Bool
&& Bool
one_br Bool -> Bool -> Bool
&& Bool
active Bool -> Bool -> Bool
&& Bool
not_stable
          _ -> Bool
False

    is_join_point :: Bool
is_join_point = OccInfo -> Bool
isAlwaysTailCalled OccInfo
occ
    -- Like (isJoinId bndr) but happens one step earlier
    --  c.f. willBeJoinId_maybe

    occ :: OccInfo
occ        = Id -> OccInfo
idOccInfo Id
bndr
    dmd :: Demand
dmd        = Id -> Demand
idDemandInfo Id
bndr
    active :: Bool
active     = Activation -> Bool
isAlwaysActive (Id -> Activation
idInlineActivation Id
bndr)
    not_stable :: Bool
not_stable = Bool -> Bool
not (Unfolding -> Bool
isStableUnfolding (Id -> Unfolding
idUnfolding Id
bndr))

occAnalUnfolding :: OccEnv
                 -> RecFlag
                 -> Id
                 -> Maybe UsageDetails
                      -- Just the analysis, not a new unfolding. The unfolding
                      -- got analysed when it was created and we don't need to
                      -- update it.
occAnalUnfolding :: OccEnv -> RecFlag -> Id -> Maybe UsageDetails
occAnalUnfolding env :: OccEnv
env rec_flag :: RecFlag
rec_flag id :: Id
id
  = case Id -> Unfolding
realIdUnfolding Id
id of -- ignore previous loop-breaker flag
      CoreUnfolding { uf_tmpl :: Unfolding -> CoreExpr
uf_tmpl = CoreExpr
rhs, uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src }
        | Bool -> Bool
not (UnfoldingSource -> Bool
isStableSource UnfoldingSource
src)
        -> Maybe UsageDetails
forall a. Maybe a
Nothing
        | Bool
otherwise
        -> UsageDetails -> Maybe UsageDetails
forall a. a -> Maybe a
Just (UsageDetails -> Maybe UsageDetails)
-> UsageDetails -> Maybe UsageDetails
forall a b. (a -> b) -> a -> b
$ UsageDetails -> UsageDetails
markAllMany UsageDetails
usage
        where
          (bndrs :: [Id]
bndrs, body :: CoreExpr
body) = CoreExpr -> ([Id], CoreExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders CoreExpr
rhs
          (usage :: UsageDetails
usage, _, _) = OccEnv
-> RecFlag
-> Id
-> [Id]
-> CoreExpr
-> (UsageDetails, [Id], CoreExpr)
occAnalRhs OccEnv
env RecFlag
rec_flag Id
id [Id]
bndrs CoreExpr
body

      DFunUnfolding { df_bndrs :: Unfolding -> [Id]
df_bndrs = [Id]
bndrs, df_args :: Unfolding -> [CoreExpr]
df_args = [CoreExpr]
args }
        -> UsageDetails -> Maybe UsageDetails
forall a. a -> Maybe a
Just (UsageDetails -> Maybe UsageDetails)
-> UsageDetails -> Maybe UsageDetails
forall a b. (a -> b) -> a -> b
$ UsageDetails -> UsageDetails
zapDetails (UsageDetails -> [Id] -> UsageDetails
delDetailsList UsageDetails
usage [Id]
bndrs)
        where
          usage :: UsageDetails
usage = [UsageDetails] -> UsageDetails
andUDsList ((CoreExpr -> UsageDetails) -> [CoreExpr] -> [UsageDetails]
forall a b. (a -> b) -> [a] -> [b]
map ((UsageDetails, CoreExpr) -> UsageDetails
forall a b. (a, b) -> a
fst ((UsageDetails, CoreExpr) -> UsageDetails)
-> (CoreExpr -> (UsageDetails, CoreExpr))
-> CoreExpr
-> UsageDetails
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccEnv -> CoreExpr -> (UsageDetails, CoreExpr)
occAnal OccEnv
env) [CoreExpr]
args)

      _ -> Maybe UsageDetails
forall a. Maybe a
Nothing

occAnalRules :: OccEnv
             -> Maybe JoinArity -- If the binder is (or MAY become) a join
                                -- point, what its join arity is (or WOULD
                                -- become). See Note [Rules and join points].
             -> RecFlag
             -> Id
             -> [(CoreRule,      -- Each (non-built-in) rule
                  UsageDetails,  -- Usage details for LHS
                  UsageDetails)] -- Usage details for RHS
occAnalRules :: OccEnv
-> Maybe Int
-> RecFlag
-> Id
-> [(CoreRule, UsageDetails, UsageDetails)]
occAnalRules env :: OccEnv
env mb_expected_join_arity :: Maybe Int
mb_expected_join_arity rec_flag :: RecFlag
rec_flag id :: Id
id
  = [ (CoreRule
rule, UsageDetails
lhs_uds, UsageDetails
rhs_uds) | rule :: CoreRule
rule@Rule {} <- Id -> [CoreRule]
idCoreRules Id
id
                               , let (lhs_uds :: UsageDetails
lhs_uds, rhs_uds :: UsageDetails
rhs_uds) = CoreRule -> (UsageDetails, UsageDetails)
occ_anal_rule CoreRule
rule ]
  where
    occ_anal_rule :: CoreRule -> (UsageDetails, UsageDetails)
occ_anal_rule (Rule { ru_bndrs :: CoreRule -> [Id]
ru_bndrs = [Id]
bndrs, ru_args :: CoreRule -> [CoreExpr]
ru_args = [CoreExpr]
args, ru_rhs :: CoreRule -> CoreExpr
ru_rhs = CoreExpr
rhs })
      = (UsageDetails
lhs_uds, UsageDetails
final_rhs_uds)
      where
        lhs_uds :: UsageDetails
lhs_uds = UsageDetails -> VarSet -> UsageDetails
addManyOccsSet UsageDetails
emptyDetails (VarSet -> UsageDetails) -> VarSet -> UsageDetails
forall a b. (a -> b) -> a -> b
$
                    ([CoreExpr] -> VarSet
exprsFreeVars [CoreExpr]
args VarSet -> [Id] -> VarSet
`delVarSetList` [Id]
bndrs)
        (rhs_bndrs :: [Id]
rhs_bndrs, rhs_body :: CoreExpr
rhs_body) = CoreExpr -> ([Id], CoreExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders CoreExpr
rhs
        (rhs_uds :: UsageDetails
rhs_uds, _, _) = OccEnv
-> RecFlag
-> Id
-> [Id]
-> CoreExpr
-> (UsageDetails, [Id], CoreExpr)
occAnalRhs OccEnv
env RecFlag
rec_flag Id
id [Id]
rhs_bndrs CoreExpr
rhs_body
                            -- Note [Rules are extra RHSs]
                            -- Note [Rule dependency info]
        final_rhs_uds :: UsageDetails
final_rhs_uds = [CoreExpr] -> UsageDetails -> UsageDetails
forall a. [a] -> UsageDetails -> UsageDetails
adjust_tail_info [CoreExpr]
args (UsageDetails -> UsageDetails) -> UsageDetails -> UsageDetails
forall a b. (a -> b) -> a -> b
$ UsageDetails -> UsageDetails
markAllMany (UsageDetails -> UsageDetails) -> UsageDetails -> UsageDetails
forall a b. (a -> b) -> a -> b
$
                          (UsageDetails
rhs_uds UsageDetails -> [Id] -> UsageDetails
`delDetailsList` [Id]
bndrs)
    occ_anal_rule _
      = (UsageDetails
emptyDetails, UsageDetails
emptyDetails)

    adjust_tail_info :: [a] -> UsageDetails -> UsageDetails
adjust_tail_info args :: [a]
args uds :: UsageDetails
uds -- see Note [Rules and join points]
      = case Maybe Int
mb_expected_join_arity of
          Just ar :: Int
ar | [a]
args [a] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
ar -> UsageDetails
uds
          _                            -> UsageDetails -> UsageDetails
markAllNonTailCalled UsageDetails
uds
{- Note [Join point RHSs]
~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   x = e
   join j = Just x

We want to inline x into j right away, so we don't want to give
the join point a RhsCtxt (Trac #14137).  It's not a huge deal, because
the FloatIn pass knows to float into join point RHSs; and the simplifier
does not float things out of join point RHSs.  But it's a simple, cheap
thing to do.  See Trac #14137.

Note [Cascading inlines]
~~~~~~~~~~~~~~~~~~~~~~~~
By default we use an rhsCtxt 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
them. Thus    x = f y
              k = Just x
we do not want to inline x.

But there's a problem.  Consider
     x1 = a0 : []
     x2 = a1 : x1
     x3 = a2 : x2
     g  = f x3
First time round, it looks as if x1 and x2 occur as an arg of a
let-bound constructor ==> give them a many-occurrence.
But then x3 is inlined (unconditionally as it happens) and
next time round, x2 will be, and the next time round x1 will be
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.

Annoyingly, we have to approximate SimplUtils.preInlineUnconditionally.
If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and
   (b) certainly_inline says "yes" when preInlineUnconditionally says "no"
then the simplifier iterates indefinitely:
        x = f y
        k = Just x   -- We decide that k is 'certainly_inline'
        v = ...k...  -- but preInlineUnconditionally doesn't inline it
inline ==>
        k = Just (f y)
        v = ...k...
float ==>
        x1 = f y
        k = Just x1
        v = ...k...

This is worse than the slow cascade, so we only want to say "certainly_inline"
if it really is certain.  Look at the note with preInlineUnconditionally
for the various clauses.


************************************************************************
*                                                                      *
                Expressions
*                                                                      *
************************************************************************
-}

occAnal :: OccEnv
        -> CoreExpr
        -> (UsageDetails,       -- Gives info only about the "interesting" Ids
            CoreExpr)

occAnal :: OccEnv -> CoreExpr -> (UsageDetails, CoreExpr)
occAnal _   expr :: CoreExpr
expr@(Type _) = (UsageDetails
emptyDetails,         CoreExpr
expr)
occAnal _   expr :: CoreExpr
expr@(Lit _)  = (UsageDetails
emptyDetails,         CoreExpr
expr)
occAnal env :: OccEnv
env expr :: CoreExpr
expr@(Var _)  = OccEnv
-> (CoreExpr, [CoreExpr], [Tickish Id]) -> (UsageDetails, CoreExpr)
occAnalApp OccEnv
env (CoreExpr
expr, [], [])
    -- At one stage, I gathered the idRuleVars for the variable here too,
    -- which in a way is the right thing to do.
    -- But that went wrong right after specialisation, when
    -- the *occurrences* of the overloaded function didn't have any
    -- rules in them, so the *specialised* versions looked as if they
    -- weren't used at all.

occAnal _ (Coercion co :: Coercion
co)
  = (UsageDetails -> VarSet -> UsageDetails
addManyOccsSet UsageDetails
emptyDetails (Coercion -> VarSet
coVarsOfCo Coercion
co), Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion Coercion
co)
        -- See Note [Gather occurrences of coercion variables]

{-
Note [Gather occurrences of coercion variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We need to gather info about what coercion variables appear, so that
we can sort them into the right place when doing dependency analysis.
-}

occAnal env :: OccEnv
env (Tick tickish :: Tickish Id
tickish body :: CoreExpr
body)
  | SourceNote{} <- Tickish Id
tickish
  = (UsageDetails
usage, Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
tickish CoreExpr
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 Id
tickish Tickish Id -> TickishScoping -> Bool
forall id. Tickish id -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
  = (UsageDetails -> UsageDetails
markAllNonTailCalled UsageDetails
usage, Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
tickish CoreExpr
body')

  | Breakpoint _ ids :: [Id]
ids <- Tickish Id
tickish
  = (UsageDetails
usage_lam UsageDetails -> UsageDetails -> UsageDetails
`andUDs` (Id -> UsageDetails -> UsageDetails)
-> UsageDetails -> [Id] -> UsageDetails
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Id -> UsageDetails -> UsageDetails
addManyOccs UsageDetails
emptyDetails [Id]
ids, Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
tickish CoreExpr
body')
    -- never substitute for any of the Ids in a Breakpoint

  | Bool
otherwise
  = (UsageDetails
usage_lam, Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
tickish CoreExpr
body')
  where
    !(usage :: UsageDetails
usage,body' :: CoreExpr
body') = OccEnv -> CoreExpr -> (UsageDetails, CoreExpr)
occAnal OccEnv
env CoreExpr
body
    -- for a non-soft tick scope, we can inline lambdas only
    usage_lam :: UsageDetails
usage_lam = UsageDetails -> UsageDetails
markAllNonTailCalled (UsageDetails -> UsageDetails
markAllInsideLam UsageDetails
usage)
                  -- TODO There may be ways to make ticks and join points play
                  -- nicer together, but right now there are problems:
                  --   let j x = ... in tick<t> (j 1)
                  -- Making j a join point may cause the simplifier to drop t
                  -- (if the tick is put into the continuation). So we don't
                  -- count j 1 as a tail call.
                  -- See #14242.

occAnal env :: OccEnv
env (Cast expr :: CoreExpr
expr co :: Coercion
co)
  = case OccEnv -> CoreExpr -> (UsageDetails, CoreExpr)
occAnal OccEnv
env CoreExpr
expr of { (usage :: UsageDetails
usage, expr' :: CoreExpr
expr') ->
    let usage1 :: UsageDetails
usage1 = Bool -> UsageDetails -> UsageDetails
zapDetailsIf (OccEnv -> Bool
isRhsEnv OccEnv
env) UsageDetails
usage
          -- usage1: if we see let x = y `cast` co
          -- then mark y as 'Many' so that we don't
          -- immediately inline y again.
        usage2 :: UsageDetails
usage2 = UsageDetails -> VarSet -> UsageDetails
addManyOccsSet UsageDetails
usage1 (Coercion -> VarSet
coVarsOfCo Coercion
co)
          -- usage2: see Note [Gather occurrences of coercion variables]
    in (UsageDetails -> UsageDetails
markAllNonTailCalled UsageDetails
usage2, CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
expr' Coercion
co)
    }

occAnal env :: OccEnv
env app :: CoreExpr
app@(App _ _)
  = OccEnv
-> (CoreExpr, [CoreExpr], [Tickish Id]) -> (UsageDetails, CoreExpr)
occAnalApp OccEnv
env ((Tickish Id -> Bool)
-> CoreExpr -> (CoreExpr, [CoreExpr], [Tickish Id])
forall b.
(Tickish Id -> Bool) -> Expr b -> (Expr b, [Expr b], [Tickish Id])
collectArgsTicks Tickish Id -> Bool
forall id. Tickish id -> Bool
tickishFloatable CoreExpr
app)

-- Ignore type variables altogether
--   (a) occurrences inside type lambdas only not marked as InsideLam
--   (b) type variables not in environment

occAnal env :: OccEnv
env (Lam x :: Id
x body :: CoreExpr
body)
  | Id -> Bool
isTyVar Id
x
  = case OccEnv -> CoreExpr -> (UsageDetails, CoreExpr)
occAnal OccEnv
env CoreExpr
body of { (body_usage :: UsageDetails
body_usage, body' :: CoreExpr
body') ->
    (UsageDetails -> UsageDetails
markAllNonTailCalled UsageDetails
body_usage, Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
x CoreExpr
body')
    }

-- For value lambdas we do a special hack.  Consider
--      (\x. \y. ...x...)
-- If we did nothing, x is used inside the \y, so would be marked
-- as dangerous to dup.  But in the common case where the abstraction
-- is applied to two arguments this is over-pessimistic.
-- So instead, we just mark each binder with its occurrence
-- info in the *body* of the multiple lambda.
-- Then, the simplifier is careful when partially applying lambdas.

occAnal env :: OccEnv
env expr :: CoreExpr
expr@(Lam _ _)
  = case OccEnv -> [Id] -> CoreExpr -> (UsageDetails, [Id], CoreExpr)
occAnalLamOrRhs OccEnv
env [Id]
binders CoreExpr
body of { (usage :: UsageDetails
usage, tagged_binders :: [Id]
tagged_binders, body' :: CoreExpr
body') ->
    let
        expr' :: CoreExpr
expr'       = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tagged_binders CoreExpr
body'
        usage1 :: UsageDetails
usage1      = UsageDetails -> UsageDetails
markAllNonTailCalled UsageDetails
usage
        one_shot_gp :: Bool
one_shot_gp = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isOneShotBndr [Id]
tagged_binders
        final_usage :: UsageDetails
final_usage | Bool
one_shot_gp = UsageDetails
usage1
                    | Bool
otherwise   = UsageDetails -> UsageDetails
markAllInsideLam UsageDetails
usage1
    in
    (UsageDetails
final_usage, CoreExpr
expr') }
  where
    (binders :: [Id]
binders, body :: CoreExpr
body) = CoreExpr -> ([Id], CoreExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders CoreExpr
expr

occAnal env :: OccEnv
env (Case scrut :: CoreExpr
scrut bndr :: Id
bndr ty :: Type
ty alts :: [Alt Id]
alts)
  = case CoreExpr -> [Alt Id] -> (UsageDetails, CoreExpr)
forall a b.
CoreExpr -> [(AltCon, a, b)] -> (UsageDetails, CoreExpr)
occ_anal_scrut CoreExpr
scrut [Alt Id]
alts     of { (scrut_usage :: UsageDetails
scrut_usage, scrut' :: CoreExpr
scrut') ->
    case (Alt Id -> (UsageDetails, Alt Id))
-> [Alt Id] -> ([UsageDetails], [Alt Id])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip Alt Id -> (UsageDetails, Alt Id)
occ_anal_alt [Alt Id]
alts of { (alts_usage_s :: [UsageDetails]
alts_usage_s, alts' :: [Alt Id]
alts')   ->
    let
        alts_usage :: UsageDetails
alts_usage  = (UsageDetails -> UsageDetails -> UsageDetails)
-> UsageDetails -> [UsageDetails] -> UsageDetails
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr UsageDetails -> UsageDetails -> UsageDetails
orUDs UsageDetails
emptyDetails [UsageDetails]
alts_usage_s
        (alts_usage1 :: UsageDetails
alts_usage1, tagged_bndr :: Id
tagged_bndr) = UsageDetails -> Id -> (UsageDetails, Id)
tagLamBinder UsageDetails
alts_usage Id
bndr
        total_usage :: UsageDetails
total_usage = UsageDetails -> UsageDetails
markAllNonTailCalled UsageDetails
scrut_usage UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
alts_usage1
                        -- Alts can have tail calls, but the scrutinee can't
    in
    UsageDetails
total_usage UsageDetails
-> (UsageDetails, CoreExpr) -> (UsageDetails, CoreExpr)
forall a b. a -> b -> b
`seq` (UsageDetails
total_usage, CoreExpr -> Id -> Type -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut' Id
tagged_bndr Type
ty [Alt Id]
alts') }}
  where
    alt_env :: (OccEnv, Maybe (Id, CoreExpr))
alt_env = OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr))
mkAltEnv OccEnv
env CoreExpr
scrut Id
bndr
    occ_anal_alt :: Alt Id -> (UsageDetails, Alt Id)
occ_anal_alt = (OccEnv, Maybe (Id, CoreExpr)) -> Alt Id -> (UsageDetails, Alt Id)
occAnalAlt (OccEnv, Maybe (Id, CoreExpr))
alt_env

    occ_anal_scrut :: CoreExpr -> [(AltCon, a, b)] -> (UsageDetails, CoreExpr)
occ_anal_scrut (Var v :: Id
v) (alt1 :: (AltCon, a, b)
alt1 : other_alts :: [(AltCon, a, b)]
other_alts)
        | Bool -> Bool
not ([(AltCon, a, b)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(AltCon, a, b)]
other_alts) Bool -> Bool -> Bool
|| Bool -> Bool
not ((AltCon, a, b) -> Bool
forall a b. (AltCon, a, b) -> Bool
isDefaultAlt (AltCon, a, b)
alt1)
        = (OccEnv -> Id -> Bool -> Int -> UsageDetails
mkOneOcc OccEnv
env Id
v Bool
True 0, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
v)
            -- The 'True' says that the variable occurs in an interesting
            -- context; the case has at least one non-default alternative
    occ_anal_scrut (Tick t :: Tickish Id
t e :: CoreExpr
e) alts :: [(AltCon, a, b)]
alts
        | Tickish Id
t Tickish Id -> TickishScoping -> Bool
forall id. Tickish id -> TickishScoping -> Bool
`tickishScopesLike` TickishScoping
SoftScope
          -- No reason to not look through all ticks here, but only
          -- for soft-scoped ticks we can do so without having to
          -- update returned occurance info (see occAnal)
        = (CoreExpr -> CoreExpr)
-> (UsageDetails, CoreExpr) -> (UsageDetails, CoreExpr)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Tickish Id -> CoreExpr -> CoreExpr
forall b. Tickish Id -> Expr b -> Expr b
Tick Tickish Id
t) ((UsageDetails, CoreExpr) -> (UsageDetails, CoreExpr))
-> (UsageDetails, CoreExpr) -> (UsageDetails, CoreExpr)
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [(AltCon, a, b)] -> (UsageDetails, CoreExpr)
occ_anal_scrut CoreExpr
e [(AltCon, a, b)]
alts

    occ_anal_scrut scrut :: CoreExpr
scrut _alts :: [(AltCon, a, b)]
_alts
        = OccEnv -> CoreExpr -> (UsageDetails, CoreExpr)
occAnal (OccEnv -> OccEnv
vanillaCtxt OccEnv
env) CoreExpr
scrut    -- No need for rhsCtxt

occAnal env :: OccEnv
env (Let bind :: CoreBind
bind body :: CoreExpr
body)
  = case OccEnv -> CoreExpr -> (UsageDetails, CoreExpr)
occAnal OccEnv
env CoreExpr
body                of { (body_usage :: UsageDetails
body_usage, body' :: CoreExpr
body') ->
    case OccEnv
-> TopLevelFlag
-> ImpRuleEdges
-> CoreBind
-> UsageDetails
-> (UsageDetails, CoreProgram)
occAnalBind OccEnv
env TopLevelFlag
NotTopLevel
                     ImpRuleEdges
noImpRuleEdges CoreBind
bind
                     UsageDetails
body_usage          of { (final_usage :: UsageDetails
final_usage, new_binds :: CoreProgram
new_binds) ->
       (UsageDetails
final_usage, CoreProgram -> CoreExpr -> CoreExpr
forall b. [Bind b] -> Expr b -> Expr b
mkLets CoreProgram
new_binds CoreExpr
body') }}

occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])
occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])
occAnalArgs _ [] _
  = (UsageDetails
emptyDetails, [])

occAnalArgs env :: OccEnv
env (arg :: CoreExpr
arg:args :: [CoreExpr]
args) one_shots :: [OneShots]
one_shots
  | CoreExpr -> Bool
forall b. Expr b -> Bool
isTypeArg CoreExpr
arg
  = case OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])
occAnalArgs OccEnv
env [CoreExpr]
args [OneShots]
one_shots of { (uds :: UsageDetails
uds, args' :: [CoreExpr]
args') ->
    (UsageDetails
uds, CoreExpr
argCoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
:[CoreExpr]
args') }

  | Bool
otherwise
  = case OccEnv -> [OneShots] -> (OccEnv, [OneShots])
argCtxt OccEnv
env [OneShots]
one_shots           of { (arg_env :: OccEnv
arg_env, one_shots' :: [OneShots]
one_shots') ->
    case OccEnv -> CoreExpr -> (UsageDetails, CoreExpr)
occAnal OccEnv
arg_env CoreExpr
arg             of { (uds1 :: UsageDetails
uds1, arg' :: CoreExpr
arg') ->
    case OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])
occAnalArgs OccEnv
env [CoreExpr]
args [OneShots]
one_shots' of { (uds2 :: UsageDetails
uds2, args' :: [CoreExpr]
args') ->
    (UsageDetails
uds1 UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
uds2, CoreExpr
arg'CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
:[CoreExpr]
args') }}}

{-
Applications are dealt with specially because we want
the "build hack" to work.

Note [Arguments of let-bound constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
    f x = let y = expensive x in
          let z = (True,y) in
          (case z of {(p,q)->q}, case z of {(p,q)->q})
We feel free to duplicate the WHNF (True,y), but that means
that y may be duplicated thereby.

If we aren't careful we duplicate the (expensive x) call!
Constructors are rather like lambdas in this way.
-}

occAnalApp :: OccEnv
           -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id])
           -> (UsageDetails, Expr CoreBndr)
occAnalApp :: OccEnv
-> (CoreExpr, [CoreExpr], [Tickish Id]) -> (UsageDetails, CoreExpr)
occAnalApp env :: OccEnv
env (Var fun :: Id
fun, args :: [CoreExpr]
args, ticks :: [Tickish Id]
ticks)
  | [Tickish Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Tickish Id]
ticks = (UsageDetails
uds, CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
fun) [CoreExpr]
args')
  | Bool
otherwise  = (UsageDetails
uds, [Tickish Id] -> CoreExpr -> CoreExpr
mkTicks [Tickish Id]
ticks (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
fun) [CoreExpr]
args')
  where
    uds :: UsageDetails
uds = UsageDetails
fun_uds UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
final_args_uds

    !(args_uds :: UsageDetails
args_uds, args' :: [CoreExpr]
args') = OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])
occAnalArgs OccEnv
env [CoreExpr]
args [OneShots]
one_shots
    !final_args_uds :: UsageDetails
final_args_uds
       | OccEnv -> Bool
isRhsEnv OccEnv
env Bool -> Bool -> Bool
&& Bool
is_exp = UsageDetails -> UsageDetails
markAllNonTailCalled (UsageDetails -> UsageDetails) -> UsageDetails -> UsageDetails
forall a b. (a -> b) -> a -> b
$
                                  UsageDetails -> UsageDetails
markAllInsideLam UsageDetails
args_uds
       | Bool
otherwise              = UsageDetails -> UsageDetails
markAllNonTailCalled UsageDetails
args_uds
       -- We mark the free vars of the argument of a constructor or PAP
       -- as "inside-lambda", if it is the RHS of a let(rec).
       -- This means that nothing gets inlined into a constructor or PAP
       -- argument position, which is what we want.  Typically those
       -- constructor arguments are just variables, or trivial expressions.
       -- We use inside-lam because it's like eta-expanding the PAP.
       --
       -- This is the *whole point* of the isRhsEnv predicate
       -- See Note [Arguments of let-bound constructors]

    n_val_args :: Int
n_val_args = [CoreExpr] -> Int
forall b. [Arg b] -> Int
valArgCount [CoreExpr]
args
    n_args :: Int
n_args     = [CoreExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
args
    fun_uds :: UsageDetails
fun_uds    = OccEnv -> Id -> Bool -> Int -> UsageDetails
mkOneOcc OccEnv
env Id
fun (Int
n_val_args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0) Int
n_args
    is_exp :: Bool
is_exp     = CheapAppFun
isExpandableApp Id
fun Int
n_val_args
        -- See Note [CONLIKE pragma] in BasicTypes
        -- The definition of is_exp should match that in Simplify.prepareRhs

    one_shots :: [OneShots]
one_shots  = StrictSig -> Int -> [OneShots]
argsOneShots (Id -> StrictSig
idStrictness Id
fun) Int
guaranteed_val_args
    guaranteed_val_args :: Int
guaranteed_val_args = Int
n_val_args Int -> Int -> Int
forall a. Num a => a -> a -> a
+ OneShots -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((OneShotInfo -> Bool) -> OneShots -> OneShots
forall a. (a -> Bool) -> [a] -> [a]
takeWhile OneShotInfo -> Bool
isOneShotInfo
                                                         (OccEnv -> OneShots
occ_one_shots OccEnv
env))
        -- See Note [Sources of one-shot information], bullet point A']

occAnalApp env :: OccEnv
env (fun :: CoreExpr
fun, args :: [CoreExpr]
args, ticks :: [Tickish Id]
ticks)
  = (UsageDetails -> UsageDetails
markAllNonTailCalled (UsageDetails
fun_uds UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
args_uds),
     [Tickish Id] -> CoreExpr -> CoreExpr
mkTicks [Tickish Id]
ticks (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$ CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps CoreExpr
fun' [CoreExpr]
args')
  where
    !(fun_uds :: UsageDetails
fun_uds, fun' :: CoreExpr
fun') = OccEnv -> CoreExpr -> (UsageDetails, CoreExpr)
occAnal (OccEnv -> [CoreExpr] -> OccEnv
addAppCtxt OccEnv
env [CoreExpr]
args) CoreExpr
fun
        -- The addAppCtxt is a bit cunning.  One iteration of the simplifier
        -- often leaves behind beta redexs 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 True items
        -- onto the context stack.
    !(args_uds :: UsageDetails
args_uds, args' :: [CoreExpr]
args') = OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])
occAnalArgs OccEnv
env [CoreExpr]
args []

zapDetailsIf :: Bool              -- If this is true
             -> UsageDetails      -- Then do zapDetails on this
             -> UsageDetails
zapDetailsIf :: Bool -> UsageDetails -> UsageDetails
zapDetailsIf True  uds :: UsageDetails
uds = UsageDetails -> UsageDetails
zapDetails UsageDetails
uds
zapDetailsIf False uds :: UsageDetails
uds = UsageDetails
uds

{-
Note [Sources of one-shot information]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The occurrence analyser obtains one-shot-lambda information from two sources:

A:  Saturated applications:  eg   f e1 .. en

    In general, given a call (f e1 .. en) we can propagate one-shot info from
    f's strictness signature into e1 .. en, but /only/ if n is enough to
    saturate the strictness signature. A strictness signature like

          f :: C1(C1(L))LS

    means that *if f is applied to three arguments* then it will guarantee to
    call its first argument at most once, and to call the result of that at
    most once. But if f has fewer than three arguments, all bets are off; e.g.

          map (f (\x y. expensive) e2) xs

    Here the \x y abstraction may be called many times (once for each element of
    xs) so we should not mark x and y as one-shot. But if it was

          map (f (\x y. expensive) 3 2) xs

    then the first argument of f will be called at most once.

    The one-shot info, derived from f's strictness signature, is
    computed by 'argsOneShots', called in occAnalApp.

A': Non-obviously saturated applications: eg    build (f (\x y -> expensive))
    where f is as above.

    In this case, f is only manifestly applied to one argument, so it does not
    look saturated. So by the previous point, we should not use its strictness
    signature to learn about the one-shotness of \x y. But in this case we can:
    build is fully applied, so we may use its strictness signature; and from
    that we learn that build calls its argument with two arguments *at most once*.

    So there is really only one call to f, and it will have three arguments. In
    that sense, f is saturated, and we may proceed as described above.

    Hence the computation of 'guaranteed_val_args' in occAnalApp, using
    '(occ_one_shots env)'.  See also Trac #13227, comment:9

B:  Let-bindings:  eg   let f = \c. let ... in \n -> blah
                        in (build f, build f)

    Propagate one-shot info from the demanand-info on 'f' to the
    lambdas in its RHS (which may not be syntactically at the top)

    This information must have come from a previous run of the demanand
    analyser.

Previously, the demand analyser would *also* set the one-shot information, but
that code was buggy (see #11770), so doing it only in on place, namely here, is
saner.

Note [OneShots]
~~~~~~~~~~~~~~~
When analysing an expression, the occ_one_shots argument contains information
about how the function is being used. The length of the list indicates
how many arguments will eventually be passed to the analysed expression,
and the OneShotInfo indicates whether this application is once or multiple times.

Example:

 Context of f                occ_one_shots when analysing f

 f 1 2                       [OneShot, OneShot]
 map (f 1)                   [OneShot, NoOneShotInfo]
 build f                     [OneShot, OneShot]
 f 1 2 `seq` f 2 1           [NoOneShotInfo, OneShot]

Note [Binders in case alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
    case x of y { (a,b) -> f y }
We treat 'a', 'b' as dead, because they don't physically occur in the
case alternative.  (Indeed, a variable is dead iff it doesn't occur in
its scope in the output of OccAnal.)  It really helps to know when
binders are unused.  See esp the call to isDeadBinder in
Simplify.mkDupableAlt

In this example, though, the Simplifier will bring 'a' and 'b' back to
life, beause it binds 'y' to (a,b) (imagine got inlined and
scrutinised y).
-}

occAnalLamOrRhs :: OccEnv -> [CoreBndr] -> CoreExpr
                -> (UsageDetails, [CoreBndr], CoreExpr)
occAnalLamOrRhs :: OccEnv -> [Id] -> CoreExpr -> (UsageDetails, [Id], CoreExpr)
occAnalLamOrRhs env :: OccEnv
env [] body :: CoreExpr
body
  = case OccEnv -> CoreExpr -> (UsageDetails, CoreExpr)
occAnal OccEnv
env CoreExpr
body of (body_usage :: UsageDetails
body_usage, body' :: CoreExpr
body') -> (UsageDetails
body_usage, [], CoreExpr
body')
      -- RHS of thunk or nullary join point
occAnalLamOrRhs env :: OccEnv
env (bndr :: Id
bndr:bndrs :: [Id]
bndrs) body :: CoreExpr
body
  | Id -> Bool
isTyVar Id
bndr
  = -- Important: Keep the environment so that we don't inline into an RHS like
    --   \(@ x) -> C @x (f @x)
    -- (see the beginning of Note [Cascading inlines]).
    case OccEnv -> [Id] -> CoreExpr -> (UsageDetails, [Id], CoreExpr)
occAnalLamOrRhs OccEnv
env [Id]
bndrs CoreExpr
body of
      (body_usage :: UsageDetails
body_usage, bndrs' :: [Id]
bndrs', body' :: CoreExpr
body') -> (UsageDetails
body_usage, Id
bndrId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
bndrs', CoreExpr
body')
occAnalLamOrRhs env :: OccEnv
env binders :: [Id]
binders body :: CoreExpr
body
  = case OccEnv -> CoreExpr -> (UsageDetails, CoreExpr)
occAnal OccEnv
env_body CoreExpr
body of { (body_usage :: UsageDetails
body_usage, body' :: CoreExpr
body') ->
    let
        (final_usage :: UsageDetails
final_usage, tagged_binders :: [Id]
tagged_binders) = UsageDetails -> [Id] -> (UsageDetails, [Id])
tagLamBinders UsageDetails
body_usage [Id]
binders'
                      -- Use binders' to put one-shot info on the lambdas
    in
    (UsageDetails
final_usage, [Id]
tagged_binders, CoreExpr
body') }
  where
    (env_body :: OccEnv
env_body, binders' :: [Id]
binders') = OccEnv -> [Id] -> (OccEnv, [Id])
oneShotGroup OccEnv
env [Id]
binders

occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr))
           -> CoreAlt
           -> (UsageDetails, Alt IdWithOccInfo)
occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr)) -> Alt Id -> (UsageDetails, Alt Id)
occAnalAlt (env :: OccEnv
env, scrut_bind :: Maybe (Id, CoreExpr)
scrut_bind) (con :: AltCon
con, bndrs :: [Id]
bndrs, rhs :: CoreExpr
rhs)
  = case OccEnv -> CoreExpr -> (UsageDetails, CoreExpr)
occAnal OccEnv
env CoreExpr
rhs of { (rhs_usage1 :: UsageDetails
rhs_usage1, rhs1 :: CoreExpr
rhs1) ->
    let
      (alt_usg :: UsageDetails
alt_usg, tagged_bndrs :: [Id]
tagged_bndrs) = UsageDetails -> [Id] -> (UsageDetails, [Id])
tagLamBinders UsageDetails
rhs_usage1 [Id]
bndrs
                                -- See Note [Binders in case alternatives]
      (alt_usg' :: UsageDetails
alt_usg', rhs2 :: CoreExpr
rhs2) = OccEnv
-> Maybe (Id, CoreExpr)
-> UsageDetails
-> [Id]
-> CoreExpr
-> (UsageDetails, CoreExpr)
wrapAltRHS OccEnv
env Maybe (Id, CoreExpr)
scrut_bind UsageDetails
alt_usg [Id]
tagged_bndrs CoreExpr
rhs1
    in
    (UsageDetails
alt_usg', (AltCon
con, [Id]
tagged_bndrs, CoreExpr
rhs2)) }

wrapAltRHS :: OccEnv
           -> Maybe (Id, CoreExpr)      -- proxy mapping generated by mkAltEnv
           -> UsageDetails              -- usage for entire alt (p -> rhs)
           -> [Var]                     -- alt binders
           -> CoreExpr                  -- alt RHS
           -> (UsageDetails, CoreExpr)
wrapAltRHS :: OccEnv
-> Maybe (Id, CoreExpr)
-> UsageDetails
-> [Id]
-> CoreExpr
-> (UsageDetails, CoreExpr)
wrapAltRHS env :: OccEnv
env (Just (scrut_var :: Id
scrut_var, let_rhs :: CoreExpr
let_rhs)) alt_usg :: UsageDetails
alt_usg bndrs :: [Id]
bndrs alt_rhs :: CoreExpr
alt_rhs
  | OccEnv -> Bool
occ_binder_swap OccEnv
env
  , Id
scrut_var Id -> UsageDetails -> Bool
`usedIn` UsageDetails
alt_usg -- bndrs are not be present in alt_usg so this
                               -- handles condition (a) in Note [Binder swap]
  , Bool -> Bool
not Bool
captured               -- See condition (b) in Note [Binder swap]
  = ( UsageDetails
alt_usg' UsageDetails -> UsageDetails -> UsageDetails
`andUDs` UsageDetails
let_rhs_usg
    , CoreBind -> CoreExpr -> CoreExpr
forall b. Bind b -> Expr b -> Expr b
Let (Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
tagged_scrut_var CoreExpr
let_rhs') CoreExpr
alt_rhs )
  where
    captured :: Bool
captured = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Id -> UsageDetails -> Bool
`usedIn` UsageDetails
let_rhs_usg) [Id]
bndrs  -- Check condition (b)

    -- The rhs of the let may include coercion variables
    -- if the scrutinee was a cast, so we must gather their
    -- usage. See Note [Gather occurrences of coercion variables]
    -- Moreover, the rhs of the let may mention the case-binder, and
    -- we want to gather its occ-info as well
    (let_rhs_usg :: UsageDetails
let_rhs_usg, let_rhs' :: CoreExpr
let_rhs') = OccEnv -> CoreExpr -> (UsageDetails, CoreExpr)
occAnal OccEnv
env CoreExpr
let_rhs

    (alt_usg' :: UsageDetails
alt_usg', tagged_scrut_var :: Id
tagged_scrut_var) = UsageDetails -> Id -> (UsageDetails, Id)
tagLamBinder UsageDetails
alt_usg Id
scrut_var

wrapAltRHS _ _ alt_usg :: UsageDetails
alt_usg _ alt_rhs :: CoreExpr
alt_rhs
  = (UsageDetails
alt_usg, CoreExpr
alt_rhs)

{-
************************************************************************
*                                                                      *
                    OccEnv
*                                                                      *
************************************************************************
-}

data OccEnv
  = OccEnv { OccEnv -> OccEncl
occ_encl       :: !OccEncl      -- Enclosing context information
           , OccEnv -> OneShots
occ_one_shots  :: !OneShots     -- See Note [OneShots]
           , OccEnv -> VarSet
occ_gbl_scrut  :: GlobalScruts

           , OccEnv -> Id -> Bool
occ_unf_act   :: Id -> Bool   -- Which Id unfoldings are active

           , OccEnv -> Activation -> Bool
occ_rule_act   :: Activation -> Bool   -- Which rules are active
             -- See Note [Finding rule RHS free vars]

           , OccEnv -> Bool
occ_binder_swap :: !Bool -- enable the binder_swap
             -- See CorePrep Note [Dead code in CorePrep]
    }

type GlobalScruts = IdSet   -- See Note [Binder swap on GlobalId scrutinees]

-----------------------------
-- OccEncl is used to control whether to inline into constructor arguments
-- For example:
--      x = (p,q)               -- Don't inline p or q
--      y = /\a -> (p a, q a)   -- Still don't inline p or q
--      z = f (p,q)             -- Do inline p,q; it may make a rule fire
-- So OccEncl tells enough about the context to know what to do when
-- we encounter a constructor application or PAP.

data OccEncl
  = OccRhs              -- RHS of let(rec), albeit perhaps inside a type lambda
                        -- Don't inline into constructor args here
  | OccVanilla          -- Argument of function, body of lambda, scruintee of case etc.
                        -- Do inline into constructor args here

instance Outputable OccEncl where
  ppr :: OccEncl -> SDoc
ppr OccRhs     = String -> SDoc
text "occRhs"
  ppr OccVanilla = String -> SDoc
text "occVanilla"

-- See note [OneShots]
type OneShots = [OneShotInfo]

initOccEnv :: OccEnv
initOccEnv :: OccEnv
initOccEnv
  = $WOccEnv :: OccEncl
-> OneShots
-> VarSet
-> (Id -> Bool)
-> (Activation -> Bool)
-> Bool
-> OccEnv
OccEnv { occ_encl :: OccEncl
occ_encl      = OccEncl
OccVanilla
           , occ_one_shots :: OneShots
occ_one_shots = []
           , occ_gbl_scrut :: VarSet
occ_gbl_scrut = VarSet
emptyVarSet
                 -- To be conservative, we say that all
                 -- inlines and rules are active
           , occ_unf_act :: Id -> Bool
occ_unf_act   = \_ -> Bool
True
           , occ_rule_act :: Activation -> Bool
occ_rule_act  = \_ -> Bool
True
           , occ_binder_swap :: Bool
occ_binder_swap = Bool
True }

vanillaCtxt :: OccEnv -> OccEnv
vanillaCtxt :: OccEnv -> OccEnv
vanillaCtxt env :: OccEnv
env = OccEnv
env { occ_encl :: OccEncl
occ_encl = OccEncl
OccVanilla, occ_one_shots :: OneShots
occ_one_shots = [] }

rhsCtxt :: OccEnv -> OccEnv
rhsCtxt :: OccEnv -> OccEnv
rhsCtxt env :: OccEnv
env = OccEnv
env { occ_encl :: OccEncl
occ_encl = OccEncl
OccRhs, occ_one_shots :: OneShots
occ_one_shots = [] }

argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])
argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])
argCtxt env :: OccEnv
env []
  = (OccEnv
env { occ_encl :: OccEncl
occ_encl = OccEncl
OccVanilla, occ_one_shots :: OneShots
occ_one_shots = [] }, [])
argCtxt env :: OccEnv
env (one_shots :: OneShots
one_shots:one_shots_s :: [OneShots]
one_shots_s)
  = (OccEnv
env { occ_encl :: OccEncl
occ_encl = OccEncl
OccVanilla, occ_one_shots :: OneShots
occ_one_shots = OneShots
one_shots }, [OneShots]
one_shots_s)

isRhsEnv :: OccEnv -> Bool
isRhsEnv :: OccEnv -> Bool
isRhsEnv (OccEnv { occ_encl :: OccEnv -> OccEncl
occ_encl = OccEncl
OccRhs })     = Bool
True
isRhsEnv (OccEnv { occ_encl :: OccEnv -> OccEncl
occ_encl = OccEncl
OccVanilla }) = Bool
False

oneShotGroup :: OccEnv -> [CoreBndr]
             -> ( OccEnv
                , [CoreBndr] )
        -- The result binders have one-shot-ness set that they might not have had originally.
        -- This happens in (build (\c n -> e)).  Here the occurrence analyser
        -- linearity context knows that c,n are one-shot, and it records that fact in
        -- the binder. This is useful to guide subsequent float-in/float-out tranformations

oneShotGroup :: OccEnv -> [Id] -> (OccEnv, [Id])
oneShotGroup env :: OccEnv
env@(OccEnv { occ_one_shots :: OccEnv -> OneShots
occ_one_shots = OneShots
ctxt }) bndrs :: [Id]
bndrs
  = OneShots -> [Id] -> [Id] -> (OccEnv, [Id])
go OneShots
ctxt [Id]
bndrs []
  where
    go :: OneShots -> [Id] -> [Id] -> (OccEnv, [Id])
go ctxt :: OneShots
ctxt [] rev_bndrs :: [Id]
rev_bndrs
      = ( OccEnv
env { occ_one_shots :: OneShots
occ_one_shots = OneShots
ctxt, occ_encl :: OccEncl
occ_encl = OccEncl
OccVanilla }
        , [Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
rev_bndrs )

    go [] bndrs :: [Id]
bndrs rev_bndrs :: [Id]
rev_bndrs
      = ( OccEnv
env { occ_one_shots :: OneShots
occ_one_shots = [], occ_encl :: OccEncl
occ_encl = OccEncl
OccVanilla }
        , [Id] -> [Id]
forall a. [a] -> [a]
reverse [Id]
rev_bndrs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
bndrs )

    go ctxt :: OneShots
ctxt@(one_shot :: OneShotInfo
one_shot : ctxt' :: OneShots
ctxt') (bndr :: Id
bndr : bndrs :: [Id]
bndrs) rev_bndrs :: [Id]
rev_bndrs
      | Id -> Bool
isId Id
bndr = OneShots -> [Id] -> [Id] -> (OccEnv, [Id])
go OneShots
ctxt' [Id]
bndrs (Id
bndr'Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
rev_bndrs)
      | Bool
otherwise = OneShots -> [Id] -> [Id] -> (OccEnv, [Id])
go OneShots
ctxt  [Id]
bndrs (Id
bndr Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
rev_bndrs)
      where
        bndr' :: Id
bndr' = Id -> OneShotInfo -> Id
updOneShotInfo Id
bndr OneShotInfo
one_shot
               -- Use updOneShotInfo, not setOneShotInfo, as pre-existing
               -- one-shot info might be better than what we can infer, e.g.
               -- due to explicit use of the magic 'oneShot' function.
               -- See Note [The oneShot function]


markJoinOneShots :: Maybe JoinArity -> [Var] -> [Var]
-- Mark the lambdas of a non-recursive join point as one-shot.
-- This is good to prevent gratuitous float-out etc
markJoinOneShots :: Maybe Int -> [Id] -> [Id]
markJoinOneShots mb_join_arity :: Maybe Int
mb_join_arity bndrs :: [Id]
bndrs
  = case Maybe Int
mb_join_arity of
      Nothing -> [Id]
bndrs
      Just n :: Int
n  -> Int -> [Id] -> [Id]
forall t. (Eq t, Num t) => t -> [Id] -> [Id]
go Int
n [Id]
bndrs
 where
   go :: t -> [Id] -> [Id]
go 0 bndrs :: [Id]
bndrs  = [Id]
bndrs
   go _ []     = [] -- This can legitimately happen.
                    -- e.g.    let j = case ... in j True
                    -- This will become an arity-1 join point after the
                    -- simplifier has eta-expanded it; but it may not have
                    -- enough lambdas /yet/. (Lint checks that JoinIds do
                    -- have enough lambdas.)
   go n :: t
n (b :: Id
b:bs :: [Id]
bs) = Id
b' Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: t -> [Id] -> [Id]
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-1) [Id]
bs
     where
       b' :: Id
b' | Id -> Bool
isId Id
b    = Id -> Id
setOneShotLambda Id
b
          | Bool
otherwise = Id
b

addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
addAppCtxt :: OccEnv -> [CoreExpr] -> OccEnv
addAppCtxt env :: OccEnv
env@(OccEnv { occ_one_shots :: OccEnv -> OneShots
occ_one_shots = OneShots
ctxt }) args :: [CoreExpr]
args
  = OccEnv
env { occ_one_shots :: OneShots
occ_one_shots = Int -> OneShotInfo -> OneShots
forall a. Int -> a -> [a]
replicate ([CoreExpr] -> Int
forall b. [Arg b] -> Int
valArgCount [CoreExpr]
args) OneShotInfo
OneShotLam OneShots -> OneShots -> OneShots
forall a. [a] -> [a] -> [a]
++ OneShots
ctxt }

transClosureFV :: UniqFM VarSet -> UniqFM VarSet
-- If (f,g), (g,h) are in the input, then (f,h) is in the output
--                                   as well as (f,g), (g,h)
transClosureFV :: ImpRuleEdges -> ImpRuleEdges
transClosureFV env :: ImpRuleEdges
env
  | Bool
no_change = ImpRuleEdges
env
  | Bool
otherwise = ImpRuleEdges -> ImpRuleEdges
transClosureFV ([(Unique, VarSet)] -> ImpRuleEdges
forall key elt. Uniquable key => [(key, elt)] -> UniqFM elt
listToUFM [(Unique, VarSet)]
new_fv_list)
  where
    (no_change :: Bool
no_change, new_fv_list :: [(Unique, VarSet)]
new_fv_list) = (Bool -> (Unique, VarSet) -> (Bool, (Unique, VarSet)))
-> Bool -> [(Unique, VarSet)] -> (Bool, [(Unique, VarSet)])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL Bool -> (Unique, VarSet) -> (Bool, (Unique, VarSet))
forall a. Bool -> (a, VarSet) -> (Bool, (a, VarSet))
bump Bool
True (ImpRuleEdges -> [(Unique, VarSet)]
forall elt. UniqFM elt -> [(Unique, elt)]
nonDetUFMToList ImpRuleEdges
env)
      -- It's OK to use nonDetUFMToList here because we'll forget the
      -- ordering by creating a new set with listToUFM
    bump :: Bool -> (a, VarSet) -> (Bool, (a, VarSet))
bump no_change :: Bool
no_change (b :: a
b,fvs :: VarSet
fvs)
      | Bool
no_change_here = (Bool
no_change, (a
b,VarSet
fvs))
      | Bool
otherwise      = (Bool
False,     (a
b,VarSet
new_fvs))
      where
        (new_fvs :: VarSet
new_fvs, no_change_here :: Bool
no_change_here) = ImpRuleEdges -> VarSet -> (VarSet, Bool)
extendFvs ImpRuleEdges
env VarSet
fvs

-------------
extendFvs_ :: UniqFM VarSet -> VarSet -> VarSet
extendFvs_ :: ImpRuleEdges -> VarSet -> VarSet
extendFvs_ env :: ImpRuleEdges
env s :: VarSet
s = (VarSet, Bool) -> VarSet
forall a b. (a, b) -> a
fst (ImpRuleEdges -> VarSet -> (VarSet, Bool)
extendFvs ImpRuleEdges
env VarSet
s)   -- Discard the Bool flag

extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool)
-- (extendFVs env s) returns
--     (s `union` env(s), env(s) `subset` s)
extendFvs :: ImpRuleEdges -> VarSet -> (VarSet, Bool)
extendFvs env :: ImpRuleEdges
env s :: VarSet
s
  | ImpRuleEdges -> Bool
forall elt. UniqFM elt -> Bool
isNullUFM ImpRuleEdges
env
  = (VarSet
s, Bool
True)
  | Bool
otherwise
  = (VarSet
s VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
extras, VarSet
extras VarSet -> VarSet -> Bool
`subVarSet` VarSet
s)
  where
    extras :: VarSet    -- env(s)
    extras :: VarSet
extras = (VarSet -> VarSet -> VarSet) -> VarSet -> ImpRuleEdges -> VarSet
forall elt a. (elt -> a -> a) -> a -> UniqFM elt -> a
nonDetFoldUFM VarSet -> VarSet -> VarSet
unionVarSet VarSet
emptyVarSet (ImpRuleEdges -> VarSet) -> ImpRuleEdges -> VarSet
forall a b. (a -> b) -> a -> b
$
      -- It's OK to use nonDetFoldUFM here because unionVarSet commutes
             (VarSet -> Id -> VarSet)
-> ImpRuleEdges -> VarEnv Id -> ImpRuleEdges
forall elt1 elt2 elt3.
(elt1 -> elt2 -> elt3) -> UniqFM elt1 -> UniqFM elt2 -> UniqFM elt3
intersectUFM_C (\x :: VarSet
x _ -> VarSet
x) ImpRuleEdges
env (VarSet -> VarEnv Id
forall a. UniqSet a -> UniqFM a
getUniqSet VarSet
s)

{-
************************************************************************
*                                                                      *
                    Binder swap
*                                                                      *
************************************************************************

Note [Binder swap]
~~~~~~~~~~~~~~~~~~
We do these two transformations right here:

 (1)   case x of b { pi -> ri }
    ==>
      case x of b { pi -> let x=b in ri }

 (2)  case (x |> co) of b { pi -> ri }
    ==>
      case (x |> co) of b { pi -> let x = b |> sym co in ri }

    Why (2)?  See Note [Case of cast]

In both cases, in a particular alternative (pi -> ri), we only
add the binding if
  (a) x occurs free in (pi -> ri)
        (ie it occurs in ri, but is not bound in pi)
  (b) the pi does not bind b (or the free vars of co)
We need (a) and (b) for the inserted binding to be correct.

For the alternatives where we inject the binding, we can transfer
all x's OccInfo to b.  And that is the point.

Notice that
  * The deliberate shadowing of 'x'.
  * That (a) rapidly becomes false, so no bindings are injected.

The reason for doing these transformations here is because it allows
us to adjust the OccInfo for 'x' and 'b' as we go.

  * Suppose the only occurrences of 'x' are the scrutinee and in the
    ri; then this transformation makes it occur just once, and hence
    get inlined right away.

  * If we do this in the Simplifier, we don't know whether 'x' is used
    in ri, so we are forced to pessimistically zap b's OccInfo even
    though it is typically dead (ie neither it nor x appear in the
    ri).  There's nothing actually wrong with zapping it, except that
    it's kind of nice to know which variables are dead.  My nose
    tells me to keep this information as robustly as possible.

The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding
{x=b}; it's Nothing if the binder-swap doesn't happen.

There is a danger though.  Consider
      let v = x +# y
      in case (f v) of w -> ...v...v...
And suppose that (f v) expands to just v.  Then we'd like to
use 'w' instead of 'v' in the alternative.  But it may be too
late; we may have substituted the (cheap) x+#y for v in the
same simplifier pass that reduced (f v) to v.

I think this is just too bad.  CSE will recover some of it.

Note [Case of cast]
~~~~~~~~~~~~~~~~~~~
Consider        case (x `cast` co) of b { I# ->
                ... (case (x `cast` co) of {...}) ...
We'd like to eliminate the inner case.  That is the motivation for
equation (2) in Note [Binder swap].  When we get to the inner case, we
inline x, cancel the casts, and away we go.

Note [Binder swap on GlobalId scrutinees]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When the scrutinee is a GlobalId we must take care in two ways

 i) In order to *know* whether 'x' occurs free in the RHS, we need its
    occurrence info. BUT, we don't gather occurrence info for
    GlobalIds.  That's the reason for the (small) occ_gbl_scrut env in
    OccEnv is for: it says "gather occurrence info for these".

 ii) We must call localiseId on 'x' first, in case it's a GlobalId, or
     has an External Name. See, for example, SimplEnv Note [Global Ids in
     the substitution].

Note [Zap case binders in proxy bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
From the original
     case x of cb(dead) { p -> ...x... }
we will get
     case x of cb(live) { p -> let x = cb in ...x... }

Core Lint never expects to find an *occurrence* of an Id marked
as Dead, so we must zap the OccInfo on cb before making the
binding x = cb.  See Trac #5028.

NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier
doesn't use it. So this is only to satisfy the perhpas-over-picky Lint.

Historical note [no-case-of-case]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We *used* to suppress the binder-swap in case expressions when
-fno-case-of-case is on.  Old remarks:
    "This happens in the first simplifier pass,
    and enhances full laziness.  Here's the bad case:
            f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )
    If we eliminate the inner case, we trap it inside the I# v -> arm,
    which might prevent some full laziness happening.  I've seen this
    in action in spectral/cichelli/Prog.hs:
             [(m,n) | m <- [1..max], n <- [1..max]]
    Hence the check for NoCaseOfCase."
However, now the full-laziness pass itself reverses the binder-swap, so this
check is no longer necessary.

Historical note [Suppressing the case binder-swap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This old note describes a problem that is also fixed by doing the
binder-swap in OccAnal:

    There is another situation when it might make sense to suppress the
    case-expression binde-swap. If we have

        case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }
                       ...other cases .... }

    We'll perform the binder-swap for the outer case, giving

        case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }
                       ...other cases .... }

    But there is no point in doing it for the inner case, because w1 can't
    be inlined anyway.  Furthermore, doing the case-swapping involves
    zapping w2's occurrence info (see paragraphs that follow), and that
    forces us to bind w2 when doing case merging.  So we get

        case x of w1 { A -> let w2 = w1 in e1
                       B -> let w2 = w1 in e2
                       ...other cases .... }

    This is plain silly in the common case where w2 is dead.

    Even so, I can't see a good way to implement this idea.  I tried
    not doing the binder-swap if the scrutinee was already evaluated
    but that failed big-time:

            data T = MkT !Int

            case v of w  { MkT x ->
            case x of x1 { I# y1 ->
            case x of x2 { I# y2 -> ...

    Notice that because MkT is strict, x is marked "evaluated".  But to
    eliminate the last case, we must either make sure that x (as well as
    x1) has unfolding MkT y1.  The straightforward thing to do is to do
    the binder-swap.  So this whole note is a no-op.

It's fixed by doing the binder-swap in OccAnal because we can do the
binder-swap unconditionally and still get occurrence analysis
information right.
-}

mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr))
-- Does three things: a) makes the occ_one_shots = OccVanilla
--                    b) extends the GlobalScruts if possible
--                    c) returns a proxy mapping, binding the scrutinee
--                       to the case binder, if possible
mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr))
mkAltEnv env :: OccEnv
env@(OccEnv { occ_gbl_scrut :: OccEnv -> VarSet
occ_gbl_scrut = VarSet
pe }) scrut :: CoreExpr
scrut case_bndr :: Id
case_bndr
  = case (Tickish Id -> Bool) -> CoreExpr -> CoreExpr
forall b. (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicksTopE (Bool -> Tickish Id -> Bool
forall a b. a -> b -> a
const Bool
True) CoreExpr
scrut of
      Var v :: Id
v           -> Id -> CoreExpr -> (OccEnv, Maybe (Id, CoreExpr))
forall b. Id -> b -> (OccEnv, Maybe (Id, b))
add_scrut Id
v CoreExpr
forall b. Expr b
case_bndr'
      Cast (Var v :: Id
v) co :: Coercion
co -> Id -> CoreExpr -> (OccEnv, Maybe (Id, CoreExpr))
forall b. Id -> b -> (OccEnv, Maybe (Id, b))
add_scrut Id
v (CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
forall b. Expr b
case_bndr' (Coercion -> Coercion
mkSymCo Coercion
co))
                          -- See Note [Case of cast]
      _               -> (OccEnv
env { occ_encl :: OccEncl
occ_encl = OccEncl
OccVanilla }, Maybe (Id, CoreExpr)
forall a. Maybe a
Nothing)

  where
    add_scrut :: Id -> b -> (OccEnv, Maybe (Id, b))
add_scrut v :: Id
v rhs :: b
rhs = ( OccEnv
env { occ_encl :: OccEncl
occ_encl = OccEncl
OccVanilla
                            , occ_gbl_scrut :: VarSet
occ_gbl_scrut = VarSet
pe VarSet -> Id -> VarSet
`extendVarSet` Id
v }
                      , (Id, b) -> Maybe (Id, b)
forall a. a -> Maybe a
Just (Id -> Id
localise Id
v, b
rhs) )

    case_bndr' :: Expr b
case_bndr' = Id -> Expr b
forall b. Id -> Expr b
Var (Id -> Id
zapIdOccInfo Id
case_bndr)
                   -- See Note [Zap case binders in proxy bindings]

    -- Localise the scrut_var before shadowing it; we're making a
    -- new binding for it, and it might have an External Name, or
    -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]
    -- Also we don't want any INLINE or NOINLINE pragmas!
    localise :: Id -> Id
localise scrut_var :: Id
scrut_var = Name -> Type -> Id
mkLocalIdOrCoVar (Name -> Name
localiseName (Id -> Name
idName Id
scrut_var))
                                          (Id -> Type
idType Id
scrut_var)

{-
************************************************************************
*                                                                      *
\subsection[OccurAnal-types]{OccEnv}
*                                                                      *
************************************************************************

Note [UsageDetails and zapping]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

On many occasions, we must modify all gathered occurrence data at once. For
instance, all occurrences underneath a (non-one-shot) lambda set the
'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but
that takes O(n) time and we will do this often---in particular, there are many
places where tail calls are not allowed, and each of these causes all variables
to get marked with 'NoTailCallInfo'.

Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along
with the 'OccInfoEnv'. Each of these extra environments is a "zapped set"
recording which variables have been zapped in some way. Zapping all occurrence
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 ZappedSet = OccInfoEnv -- Values are ignored

data UsageDetails
  = UD { UsageDetails -> OccInfoEnv
ud_env       :: !OccInfoEnv
       , UsageDetails -> OccInfoEnv
ud_z_many    :: ZappedSet   -- apply 'markMany' to these
       , UsageDetails -> OccInfoEnv
ud_z_in_lam  :: ZappedSet   -- apply 'markInsideLam' to these
       , UsageDetails -> OccInfoEnv
ud_z_no_tail :: ZappedSet } -- apply 'markNonTailCalled' to these
  -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv

instance Outputable UsageDetails where
  ppr :: UsageDetails -> SDoc
ppr ud :: UsageDetails
ud = OccInfoEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UsageDetails -> OccInfoEnv
ud_env (UsageDetails -> UsageDetails
flattenUsageDetails UsageDetails
ud))

-------------------
-- UsageDetails API

andUDs, orUDs
        :: UsageDetails -> UsageDetails -> UsageDetails
andUDs :: UsageDetails -> UsageDetails -> UsageDetails
andUDs = (OccInfo -> OccInfo -> OccInfo)
-> UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetailsWith OccInfo -> OccInfo -> OccInfo
addOccInfo
orUDs :: UsageDetails -> UsageDetails -> UsageDetails
orUDs  = (OccInfo -> OccInfo -> OccInfo)
-> UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetailsWith OccInfo -> OccInfo -> OccInfo
orOccInfo

andUDsList :: [UsageDetails] -> UsageDetails
andUDsList :: [UsageDetails] -> UsageDetails
andUDsList = (UsageDetails -> UsageDetails -> UsageDetails)
-> UsageDetails -> [UsageDetails] -> UsageDetails
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UsageDetails -> UsageDetails -> UsageDetails
andUDs UsageDetails
emptyDetails

mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails
mkOneOcc :: OccEnv -> Id -> Bool -> Int -> UsageDetails
mkOneOcc env :: OccEnv
env id :: Id
id int_cxt :: Bool
int_cxt arity :: Int
arity
  | Id -> Bool
isLocalId Id
id
  = OccInfo -> UsageDetails
singleton (OccInfo -> UsageDetails) -> OccInfo -> UsageDetails
forall a b. (a -> b) -> a -> b
$ $WOneOcc :: Bool -> Bool -> Bool -> TailCallInfo -> OccInfo
OneOcc { occ_in_lam :: Bool
occ_in_lam  = Bool
False
                       , occ_one_br :: Bool
occ_one_br  = Bool
True
                       , occ_int_cxt :: Bool
occ_int_cxt = Bool
int_cxt
                       , occ_tail :: TailCallInfo
occ_tail    = Int -> TailCallInfo
AlwaysTailCalled Int
arity }
  | Id
id Id -> VarSet -> Bool
`elemVarSet` OccEnv -> VarSet
occ_gbl_scrut OccEnv
env
  = OccInfo -> UsageDetails
singleton OccInfo
noOccInfo

  | Bool
otherwise
  = UsageDetails
emptyDetails
  where
    singleton :: OccInfo -> UsageDetails
singleton info :: OccInfo
info = UsageDetails
emptyDetails { ud_env :: OccInfoEnv
ud_env = Id -> OccInfo -> OccInfoEnv
forall a. Id -> a -> VarEnv a
unitVarEnv Id
id OccInfo
info }

addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
addOneOcc ud :: UsageDetails
ud id :: Id
id info :: OccInfo
info
  = UsageDetails
ud { ud_env :: OccInfoEnv
ud_env = (OccInfo -> OccInfo -> OccInfo)
-> OccInfoEnv -> Id -> OccInfo -> OccInfoEnv
forall a. (a -> a -> a) -> VarEnv a -> Id -> a -> VarEnv a
extendVarEnv_C OccInfo -> OccInfo -> OccInfo
plus_zapped (UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud) Id
id OccInfo
info }
      UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails
`alterZappedSets` (OccInfoEnv -> Id -> OccInfoEnv
forall a. VarEnv a -> Id -> VarEnv a
`delVarEnv` Id
id)
  where
    plus_zapped :: OccInfo -> OccInfo -> OccInfo
plus_zapped old :: OccInfo
old new :: OccInfo
new = UsageDetails -> Id -> OccInfo -> OccInfo
doZapping UsageDetails
ud Id
id OccInfo
old OccInfo -> OccInfo -> OccInfo
`addOccInfo` OccInfo
new

addManyOccsSet :: UsageDetails -> VarSet -> UsageDetails
addManyOccsSet :: UsageDetails -> VarSet -> UsageDetails
addManyOccsSet usage :: UsageDetails
usage id_set :: VarSet
id_set = (Id -> UsageDetails -> UsageDetails)
-> UsageDetails -> VarSet -> UsageDetails
forall elt a. (elt -> a -> a) -> a -> UniqSet elt -> a
nonDetFoldUniqSet Id -> UsageDetails -> UsageDetails
addManyOccs UsageDetails
usage VarSet
id_set
  -- It's OK to use nonDetFoldUFM here because addManyOccs commutes

-- Add several occurrences, assumed not to be tail calls
addManyOccs :: Var -> UsageDetails -> UsageDetails
addManyOccs :: Id -> UsageDetails -> UsageDetails
addManyOccs v :: Id
v u :: UsageDetails
u | Id -> Bool
isId Id
v    = UsageDetails -> Id -> OccInfo -> UsageDetails
addOneOcc UsageDetails
u Id
v OccInfo
noOccInfo
                | Bool
otherwise = UsageDetails
u
        -- Give a non-committal binder info (i.e noOccInfo) because
        --   a) Many copies of the specialised thing can appear
        --   b) We don't want to substitute a BIG expression inside a RULE
        --      even if that's the only occurrence of the thing
        --      (Same goes for INLINE.)

delDetails :: UsageDetails -> Id -> UsageDetails
delDetails :: UsageDetails -> Id -> UsageDetails
delDetails ud :: UsageDetails
ud bndr :: Id
bndr
  = UsageDetails
ud UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails
`alterUsageDetails` (OccInfoEnv -> Id -> OccInfoEnv
forall a. VarEnv a -> Id -> VarEnv a
`delVarEnv` Id
bndr)

delDetailsList :: UsageDetails -> [Id] -> UsageDetails
delDetailsList :: UsageDetails -> [Id] -> UsageDetails
delDetailsList ud :: UsageDetails
ud bndrs :: [Id]
bndrs
  = UsageDetails
ud UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails
`alterUsageDetails` (OccInfoEnv -> [Id] -> OccInfoEnv
forall a. VarEnv a -> [Id] -> VarEnv a
`delVarEnvList` [Id]
bndrs)

emptyDetails :: UsageDetails
emptyDetails :: UsageDetails
emptyDetails = $WUD :: OccInfoEnv
-> OccInfoEnv -> OccInfoEnv -> OccInfoEnv -> UsageDetails
UD { ud_env :: OccInfoEnv
ud_env       = OccInfoEnv
forall a. VarEnv a
emptyVarEnv
                  , ud_z_many :: OccInfoEnv
ud_z_many    = OccInfoEnv
forall a. VarEnv a
emptyVarEnv
                  , ud_z_in_lam :: OccInfoEnv
ud_z_in_lam  = OccInfoEnv
forall a. VarEnv a
emptyVarEnv
                  , ud_z_no_tail :: OccInfoEnv
ud_z_no_tail = OccInfoEnv
forall a. VarEnv a
emptyVarEnv }

isEmptyDetails :: UsageDetails -> Bool
isEmptyDetails :: UsageDetails -> Bool
isEmptyDetails = OccInfoEnv -> Bool
forall elt. UniqFM elt -> Bool
isEmptyVarEnv (OccInfoEnv -> Bool)
-> (UsageDetails -> OccInfoEnv) -> UsageDetails -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UsageDetails -> OccInfoEnv
ud_env

markAllMany, markAllInsideLam, markAllNonTailCalled, zapDetails
  :: UsageDetails -> UsageDetails
markAllMany :: UsageDetails -> UsageDetails
markAllMany          ud :: UsageDetails
ud = UsageDetails
ud { ud_z_many :: OccInfoEnv
ud_z_many    = UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud }
markAllInsideLam :: UsageDetails -> UsageDetails
markAllInsideLam     ud :: UsageDetails
ud = UsageDetails
ud { ud_z_in_lam :: OccInfoEnv
ud_z_in_lam  = UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud }
markAllNonTailCalled :: UsageDetails -> UsageDetails
markAllNonTailCalled ud :: UsageDetails
ud = UsageDetails
ud { ud_z_no_tail :: OccInfoEnv
ud_z_no_tail = UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud }

zapDetails :: UsageDetails -> UsageDetails
zapDetails = UsageDetails -> UsageDetails
markAllMany (UsageDetails -> UsageDetails)
-> (UsageDetails -> UsageDetails) -> UsageDetails -> UsageDetails
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UsageDetails -> UsageDetails
markAllNonTailCalled -- effectively sets to noOccInfo

lookupDetails :: UsageDetails -> Id -> OccInfo
lookupDetails :: UsageDetails -> Id -> OccInfo
lookupDetails ud :: UsageDetails
ud id :: Id
id
  | Id -> Bool
isCoVar Id
id  -- We do not currenly gather occurrence info (from types)
  = OccInfo
noOccInfo   -- for CoVars, so we must conservatively mark them as used
                -- See Note [DoO not mark CoVars as dead]
  | Bool
otherwise
  = case OccInfoEnv -> Id -> Maybe OccInfo
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv (UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud) Id
id of
      Just occ :: OccInfo
occ -> UsageDetails -> Id -> OccInfo -> OccInfo
doZapping UsageDetails
ud Id
id OccInfo
occ
      Nothing  -> OccInfo
IAmDead

usedIn :: Id -> UsageDetails -> Bool
v :: Id
v usedIn :: Id -> UsageDetails -> Bool
`usedIn` ud :: UsageDetails
ud = Id -> Bool
isExportedId Id
v Bool -> Bool -> Bool
|| Id
v Id -> OccInfoEnv -> Bool
forall a. Id -> VarEnv a -> Bool
`elemVarEnv` UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud

udFreeVars :: VarSet -> UsageDetails -> VarSet
-- Find the subset of bndrs that are mentioned in uds
udFreeVars :: VarSet -> UsageDetails -> VarSet
udFreeVars bndrs :: VarSet
bndrs ud :: UsageDetails
ud = VarSet -> OccInfoEnv -> VarSet
forall a b. UniqSet a -> UniqFM b -> UniqSet a
restrictUniqSetToUFM VarSet
bndrs (UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud)

{- Note [Do not mark CoVars as dead]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's obviously wrong to mark CoVars as dead if they are used.
Currently we don't traverse types to gather usase info for CoVars,
so we had better treat them as having noOccInfo.

This showed up in Trac #15696 we had something like
  case eq_sel d of co -> ...(typeError @(...co...) "urk")...

Then 'd' was substitued by a dictionary, so the expression
simpified to
  case (Coercion <blah>) of co -> ...(typeError @(...co...) "urk")...

But then the "drop the case altogether" equation of rebuildCase
thought that 'co' was dead, and discarded the entire case. Urk!

I have no idea how we managed to avoid this pitfall for so long!
-}

-------------------
-- Auxiliary functions for UsageDetails implementation

combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo)
                        -> UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo)
-> UsageDetails -> UsageDetails -> UsageDetails
combineUsageDetailsWith plus_occ_info :: OccInfo -> OccInfo -> OccInfo
plus_occ_info ud1 :: UsageDetails
ud1 ud2 :: UsageDetails
ud2
  | UsageDetails -> Bool
isEmptyDetails UsageDetails
ud1 = UsageDetails
ud2
  | UsageDetails -> Bool
isEmptyDetails UsageDetails
ud2 = UsageDetails
ud1
  | Bool
otherwise
  = $WUD :: OccInfoEnv
-> OccInfoEnv -> OccInfoEnv -> OccInfoEnv -> UsageDetails
UD { ud_env :: OccInfoEnv
ud_env       = (OccInfo -> OccInfo -> OccInfo)
-> OccInfoEnv -> OccInfoEnv -> OccInfoEnv
forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_C OccInfo -> OccInfo -> OccInfo
plus_occ_info (UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud1) (UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud2)
       , ud_z_many :: OccInfoEnv
ud_z_many    = OccInfoEnv -> OccInfoEnv -> OccInfoEnv
forall a. VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv (UsageDetails -> OccInfoEnv
ud_z_many    UsageDetails
ud1) (UsageDetails -> OccInfoEnv
ud_z_many    UsageDetails
ud2)
       , ud_z_in_lam :: OccInfoEnv
ud_z_in_lam  = OccInfoEnv -> OccInfoEnv -> OccInfoEnv
forall a. VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv (UsageDetails -> OccInfoEnv
ud_z_in_lam  UsageDetails
ud1) (UsageDetails -> OccInfoEnv
ud_z_in_lam  UsageDetails
ud2)
       , ud_z_no_tail :: OccInfoEnv
ud_z_no_tail = OccInfoEnv -> OccInfoEnv -> OccInfoEnv
forall a. VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv (UsageDetails -> OccInfoEnv
ud_z_no_tail UsageDetails
ud1) (UsageDetails -> OccInfoEnv
ud_z_no_tail UsageDetails
ud2) }

doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo
doZapping :: UsageDetails -> Id -> OccInfo -> OccInfo
doZapping ud :: UsageDetails
ud var :: Id
var occ :: OccInfo
occ
  = UsageDetails -> Unique -> OccInfo -> OccInfo
doZappingByUnique UsageDetails
ud (Id -> Unique
varUnique Id
var) OccInfo
occ

doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo
doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo
doZappingByUnique ud :: UsageDetails
ud uniq :: Unique
uniq
  = (if | (UsageDetails -> OccInfoEnv) -> Bool
forall a. (UsageDetails -> VarEnv a) -> Bool
in_subset UsageDetails -> OccInfoEnv
ud_z_many    -> OccInfo -> OccInfo
markMany
        | (UsageDetails -> OccInfoEnv) -> Bool
forall a. (UsageDetails -> VarEnv a) -> Bool
in_subset UsageDetails -> OccInfoEnv
ud_z_in_lam  -> OccInfo -> OccInfo
markInsideLam
        | Bool
otherwise              -> OccInfo -> OccInfo
forall a. a -> a
id) (OccInfo -> OccInfo) -> (OccInfo -> OccInfo) -> OccInfo -> OccInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (if | (UsageDetails -> OccInfoEnv) -> Bool
forall a. (UsageDetails -> VarEnv a) -> Bool
in_subset UsageDetails -> OccInfoEnv
ud_z_no_tail -> OccInfo -> OccInfo
markNonTailCalled
        | Bool
otherwise              -> OccInfo -> OccInfo
forall a. a -> a
id)
  where
    in_subset :: (UsageDetails -> VarEnv a) -> Bool
in_subset field :: UsageDetails -> VarEnv a
field = Unique
uniq Unique -> VarEnv a -> Bool
forall a. Unique -> VarEnv a -> Bool
`elemVarEnvByKey` UsageDetails -> VarEnv a
field UsageDetails
ud

alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails
alterZappedSets :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails
alterZappedSets ud :: UsageDetails
ud f :: OccInfoEnv -> OccInfoEnv
f
  = UsageDetails
ud { ud_z_many :: OccInfoEnv
ud_z_many    = OccInfoEnv -> OccInfoEnv
f (UsageDetails -> OccInfoEnv
ud_z_many    UsageDetails
ud)
       , ud_z_in_lam :: OccInfoEnv
ud_z_in_lam  = OccInfoEnv -> OccInfoEnv
f (UsageDetails -> OccInfoEnv
ud_z_in_lam  UsageDetails
ud)
       , ud_z_no_tail :: OccInfoEnv
ud_z_no_tail = OccInfoEnv -> OccInfoEnv
f (UsageDetails -> OccInfoEnv
ud_z_no_tail UsageDetails
ud) }

alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails
alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails
alterUsageDetails ud :: UsageDetails
ud f :: OccInfoEnv -> OccInfoEnv
f
  = UsageDetails
ud { ud_env :: OccInfoEnv
ud_env = OccInfoEnv -> OccInfoEnv
f (UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud) }
      UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails
`alterZappedSets` OccInfoEnv -> OccInfoEnv
f

flattenUsageDetails :: UsageDetails -> UsageDetails
flattenUsageDetails :: UsageDetails -> UsageDetails
flattenUsageDetails ud :: UsageDetails
ud
  = UsageDetails
ud { ud_env :: OccInfoEnv
ud_env = (Unique -> OccInfo -> OccInfo) -> OccInfoEnv -> OccInfoEnv
forall elt1 elt2.
(Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
mapUFM_Directly (UsageDetails -> Unique -> OccInfo -> OccInfo
doZappingByUnique UsageDetails
ud) (UsageDetails -> OccInfoEnv
ud_env UsageDetails
ud) }
      UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails
`alterZappedSets` OccInfoEnv -> OccInfoEnv -> OccInfoEnv
forall a b. a -> b -> a
const OccInfoEnv
forall a. VarEnv a
emptyVarEnv

-------------------
-- See Note [Adjusting right-hand sides]
adjustRhsUsage :: Maybe JoinArity -> RecFlag
               -> [CoreBndr] -- Outer lambdas, AFTER occ anal
               -> UsageDetails -> UsageDetails
adjustRhsUsage :: Maybe Int -> RecFlag -> [Id] -> UsageDetails -> UsageDetails
adjustRhsUsage mb_join_arity :: Maybe Int
mb_join_arity rec_flag :: RecFlag
rec_flag bndrs :: [Id]
bndrs usage :: UsageDetails
usage
  = UsageDetails -> UsageDetails
maybe_mark_lam (UsageDetails -> UsageDetails
maybe_drop_tails UsageDetails
usage)
  where
    maybe_mark_lam :: UsageDetails -> UsageDetails
maybe_mark_lam ud :: UsageDetails
ud   | Bool
one_shot   = UsageDetails
ud
                        | Bool
otherwise  = UsageDetails -> UsageDetails
markAllInsideLam UsageDetails
ud
    maybe_drop_tails :: UsageDetails -> UsageDetails
maybe_drop_tails ud :: UsageDetails
ud | Bool
exact_join = UsageDetails
ud
                        | Bool
otherwise  = UsageDetails -> UsageDetails
markAllNonTailCalled UsageDetails
ud

    one_shot :: Bool
one_shot = case Maybe Int
mb_join_arity of
                 Just join_arity :: Int
join_arity
                   | RecFlag -> Bool
isRec RecFlag
rec_flag -> Bool
False
                   | Bool
otherwise      -> (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isOneShotBndr (Int -> [Id] -> [Id]
forall a. Int -> [a] -> [a]
drop Int
join_arity [Id]
bndrs)
                 Nothing            -> (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
isOneShotBndr [Id]
bndrs

    exact_join :: Bool
exact_join = case Maybe Int
mb_join_arity of
                   Just join_arity :: Int
join_arity -> [Id]
bndrs [Id] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
join_arity
                   _               -> Bool
False

type IdWithOccInfo = Id

tagLamBinders :: UsageDetails          -- Of scope
              -> [Id]                  -- Binders
              -> (UsageDetails,        -- Details with binders removed
                 [IdWithOccInfo])    -- Tagged binders
tagLamBinders :: UsageDetails -> [Id] -> (UsageDetails, [Id])
tagLamBinders usage :: UsageDetails
usage binders :: [Id]
binders
  = UsageDetails
usage' UsageDetails -> (UsageDetails, [Id]) -> (UsageDetails, [Id])
forall a b. a -> b -> b
`seq` (UsageDetails
usage', [Id]
bndrs')
  where
    (usage' :: UsageDetails
usage', bndrs' :: [Id]
bndrs') = (UsageDetails -> Id -> (UsageDetails, Id))
-> UsageDetails -> [Id] -> (UsageDetails, [Id])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumR UsageDetails -> Id -> (UsageDetails, Id)
tagLamBinder UsageDetails
usage [Id]
binders

tagLamBinder :: UsageDetails       -- Of scope
             -> Id                 -- Binder
             -> (UsageDetails,     -- Details with binder removed
                 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
tagLamBinder :: UsageDetails -> Id -> (UsageDetails, Id)
tagLamBinder usage :: UsageDetails
usage bndr :: Id
bndr
  = (UsageDetails
usage2, Id
bndr')
  where
        occ :: OccInfo
occ    = UsageDetails -> Id -> OccInfo
lookupDetails UsageDetails
usage Id
bndr
        bndr' :: Id
bndr'  = OccInfo -> Id -> Id
setBinderOcc (OccInfo -> OccInfo
markNonTailCalled OccInfo
occ) Id
bndr
                   -- Don't try to make an argument into a join point
        usage1 :: UsageDetails
usage1 = UsageDetails
usage UsageDetails -> Id -> UsageDetails
`delDetails` Id
bndr
        usage2 :: UsageDetails
usage2 | Id -> Bool
isId Id
bndr = UsageDetails -> VarSet -> UsageDetails
addManyOccsSet UsageDetails
usage1 (Id -> VarSet
idUnfoldingVars Id
bndr)
                               -- This is effectively the RHS of a
                               -- non-join-point binding, so it's okay to use
                               -- addManyOccsSet, which assumes no tail calls
               | Bool
otherwise = UsageDetails
usage1

tagNonRecBinder :: TopLevelFlag           -- At top level?
                -> UsageDetails           -- Of scope
                -> CoreBndr               -- Binder
                -> (UsageDetails,         -- Details with binder removed
                    IdWithOccInfo)        -- Tagged binder

tagNonRecBinder :: TopLevelFlag -> UsageDetails -> Id -> (UsageDetails, Id)
tagNonRecBinder lvl :: TopLevelFlag
lvl usage :: UsageDetails
usage binder :: Id
binder
 = let
     occ :: OccInfo
occ     = UsageDetails -> Id -> OccInfo
lookupDetails UsageDetails
usage Id
binder
     will_be_join :: Bool
will_be_join = TopLevelFlag -> UsageDetails -> [Id] -> Bool
decideJoinPointHood TopLevelFlag
lvl UsageDetails
usage [Id
binder]
     occ' :: OccInfo
occ'    | Bool
will_be_join = -- must already be marked AlwaysTailCalled
                              ASSERT(isAlwaysTailCalled occ) occ
             | Bool
otherwise    = OccInfo -> OccInfo
markNonTailCalled OccInfo
occ
     binder' :: Id
binder' = OccInfo -> Id -> Id
setBinderOcc OccInfo
occ' Id
binder
     usage' :: UsageDetails
usage'  = UsageDetails
usage UsageDetails -> Id -> UsageDetails
`delDetails` Id
binder
   in
   UsageDetails
usage' UsageDetails -> (UsageDetails, Id) -> (UsageDetails, Id)
forall a b. a -> b -> b
`seq` (UsageDetails
usage', Id
binder')

tagRecBinders :: TopLevelFlag           -- At top level?
              -> UsageDetails           -- Of body of let ONLY
              -> [(CoreBndr,            -- Binder
                   UsageDetails,        -- RHS usage details
                   [CoreBndr])]         -- Lambdas in new RHS
              -> (UsageDetails,         -- Adjusted details for whole scope,
                                        -- with binders removed
                  [IdWithOccInfo])      -- Tagged binders
-- Substantially more complicated than non-recursive case. Need to adjust RHS
-- details *before* tagging binders (because the tags depend on the RHSes).
tagRecBinders :: TopLevelFlag
-> UsageDetails
-> [(Id, UsageDetails, [Id])]
-> (UsageDetails, [Id])
tagRecBinders lvl :: TopLevelFlag
lvl body_uds :: UsageDetails
body_uds triples :: [(Id, UsageDetails, [Id])]
triples
 = let
     (bndrs :: [Id]
bndrs, rhs_udss :: [UsageDetails]
rhs_udss, _) = [(Id, UsageDetails, [Id])] -> ([Id], [UsageDetails], [[Id]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(Id, UsageDetails, [Id])]
triples

     -- 1. Determine join-point-hood of whole group, as determined by
     --    the *unadjusted* usage details
     unadj_uds :: UsageDetails
unadj_uds     = (UsageDetails -> UsageDetails -> UsageDetails)
-> UsageDetails -> [UsageDetails] -> UsageDetails
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr UsageDetails -> UsageDetails -> UsageDetails
andUDs UsageDetails
body_uds [UsageDetails]
rhs_udss
     will_be_joins :: Bool
will_be_joins = TopLevelFlag -> UsageDetails -> [Id] -> Bool
decideJoinPointHood TopLevelFlag
lvl UsageDetails
unadj_uds [Id]
bndrs

     -- 2. Adjust usage details of each RHS, taking into account the
     --    join-point-hood decision
     rhs_udss' :: [UsageDetails]
rhs_udss' = ((Id, UsageDetails, [Id]) -> UsageDetails)
-> [(Id, UsageDetails, [Id])] -> [UsageDetails]
forall a b. (a -> b) -> [a] -> [b]
map (Id, UsageDetails, [Id]) -> UsageDetails
adjust [(Id, UsageDetails, [Id])]
triples
     adjust :: (Id, UsageDetails, [Id]) -> UsageDetails
adjust (bndr :: Id
bndr, rhs_uds :: UsageDetails
rhs_uds, rhs_bndrs :: [Id]
rhs_bndrs)
       = Maybe Int -> RecFlag -> [Id] -> UsageDetails -> UsageDetails
adjustRhsUsage Maybe Int
mb_join_arity RecFlag
Recursive [Id]
rhs_bndrs UsageDetails
rhs_uds
       where
         -- Can't use willBeJoinId_maybe here because we haven't tagged the
         -- binder yet (the tag depends on these adjustments!)
         mb_join_arity :: Maybe Int
mb_join_arity
           | Bool
will_be_joins
           , let occ :: OccInfo
occ = UsageDetails -> Id -> OccInfo
lookupDetails UsageDetails
unadj_uds Id
bndr
           , AlwaysTailCalled arity :: Int
arity <- OccInfo -> TailCallInfo
tailCallInfo OccInfo
occ
           = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
arity
           | Bool
otherwise
           = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if
             Maybe Int
forall a. Maybe a
Nothing                   -- we are making join points!

     -- 3. Compute final usage details from adjusted RHS details
     adj_uds :: UsageDetails
adj_uds   = (UsageDetails -> UsageDetails -> UsageDetails)
-> UsageDetails -> [UsageDetails] -> UsageDetails
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr UsageDetails -> UsageDetails -> UsageDetails
andUDs UsageDetails
body_uds [UsageDetails]
rhs_udss'

     -- 4. Tag each binder with its adjusted details
     bndrs' :: [Id]
bndrs'    = [ OccInfo -> Id -> Id
setBinderOcc (UsageDetails -> Id -> OccInfo
lookupDetails UsageDetails
adj_uds Id
bndr) Id
bndr
                 | Id
bndr <- [Id]
bndrs ]

     -- 5. Drop the binders from the adjusted details and return
     usage' :: UsageDetails
usage'    = UsageDetails
adj_uds UsageDetails -> [Id] -> UsageDetails
`delDetailsList` [Id]
bndrs
   in
   (UsageDetails
usage', [Id]
bndrs')

setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr
setBinderOcc :: OccInfo -> Id -> Id
setBinderOcc occ_info :: OccInfo
occ_info bndr :: Id
bndr
  | Id -> Bool
isTyVar Id
bndr      = Id
bndr
  | Id -> Bool
isExportedId Id
bndr = if OccInfo -> Bool
isManyOccs (Id -> OccInfo
idOccInfo Id
bndr)
                          then Id
bndr
                          else Id -> OccInfo -> Id
setIdOccInfo Id
bndr OccInfo
noOccInfo
            -- Don't use local usage info for visible-elsewhere things
            -- BUT *do* erase any IAmALoopBreaker annotation, because we're
            -- about to re-generate it and it shouldn't be "sticky"

  | Bool
otherwise = Id -> OccInfo -> Id
setIdOccInfo Id
bndr OccInfo
occ_info

-- | Decide whether some bindings should be made into join points or not.
-- Returns `False` if they can't be join points. Note that it's an
-- all-or-nothing decision, as if multiple binders are given, they're
-- assumed to be mutually recursive.
--
-- It must, however, be a final decision. If we say "True" for 'f',
-- and then subsequently decide /not/ make 'f' into a join point, then
-- the decision about another binding 'g' might be invalidated if (say)
-- 'f' tail-calls 'g'.
--
-- See Note [Invariants on join points] in CoreSyn.
decideJoinPointHood :: TopLevelFlag -> UsageDetails
                    -> [CoreBndr]
                    -> Bool
decideJoinPointHood :: TopLevelFlag -> UsageDetails -> [Id] -> Bool
decideJoinPointHood TopLevel _ _
  = Bool
False
decideJoinPointHood NotTopLevel usage :: UsageDetails
usage bndrs :: [Id]
bndrs
  | Id -> Bool
isJoinId ([Id] -> Id
forall a. [a] -> a
head [Id]
bndrs)
  = WARN(not all_ok, text "OccurAnal failed to rediscover join point(s):" <+>
                       ppr bndrs)
    Bool
all_ok
  | Bool
otherwise
  = Bool
all_ok
  where
    -- See Note [Invariants on join points]; invariants cited by number below.
    -- Invariant 2 is always satisfiable by the simplifier by eta expansion.
    all_ok :: Bool
all_ok = -- Invariant 3: Either all are join points or none are
             (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
ok [Id]
bndrs

    ok :: Id -> Bool
ok bndr :: Id
bndr
      | -- Invariant 1: Only tail calls, all same join arity
        AlwaysTailCalled arity :: Int
arity <- OccInfo -> TailCallInfo
tailCallInfo (UsageDetails -> Id -> OccInfo
lookupDetails UsageDetails
usage Id
bndr)

      , -- Invariant 1 as applied to LHSes of rules
        (CoreRule -> Bool) -> [CoreRule] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> CoreRule -> Bool
ok_rule Int
arity) (Id -> [CoreRule]
idCoreRules Id
bndr)

        -- Invariant 2a: stable unfoldings
        -- See Note [Join points and INLINE pragmas]
      , Int -> Unfolding -> Bool
ok_unfolding Int
arity (Id -> Unfolding
realIdUnfolding Id
bndr)

        -- Invariant 4: Satisfies polymorphism rule
      , Int -> Type -> Bool
isValidJoinPointType Int
arity (Id -> Type
idType Id
bndr)
      = Bool
True

      | Bool
otherwise
      = Bool
False

    ok_rule :: Int -> CoreRule -> Bool
ok_rule _ BuiltinRule{} = Bool
False -- only possible with plugin shenanigans
    ok_rule join_arity :: Int
join_arity (Rule { ru_args :: CoreRule -> [CoreExpr]
ru_args = [CoreExpr]
args })
      = [CoreExpr]
args [CoreExpr] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
join_arity
        -- Invariant 1 as applied to LHSes of rules

    -- ok_unfolding returns False if we should /not/ convert a non-join-id
    -- into a join-id, even though it is AlwaysTailCalled
    ok_unfolding :: Int -> Unfolding -> Bool
ok_unfolding join_arity :: Int
join_arity (CoreUnfolding { uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src, uf_tmpl :: Unfolding -> CoreExpr
uf_tmpl = CoreExpr
rhs })
      = Bool -> Bool
not (UnfoldingSource -> Bool
isStableSource UnfoldingSource
src Bool -> Bool -> Bool
&& Int
join_arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> CoreExpr -> Int
joinRhsArity CoreExpr
rhs)
    ok_unfolding _ (DFunUnfolding {})
      = Bool
False
    ok_unfolding _ _
      = Bool
True

willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity
willBeJoinId_maybe :: Id -> Maybe Int
willBeJoinId_maybe bndr :: Id
bndr
  = case OccInfo -> TailCallInfo
tailCallInfo (Id -> OccInfo
idOccInfo Id
bndr) of
      AlwaysTailCalled arity :: Int
arity -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
arity
      _                      -> Id -> Maybe Int
isJoinId_maybe Id
bndr


{- Note [Join points and INLINE pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
   f x = let g = \x. not  -- Arity 1
             {-# INLINE g #-}
         in case x of
              A -> g True True
              B -> g True False
              C -> blah2

Here 'g' is always tail-called applied to 2 args, but the stable
unfolding captured by the INLINE pragma has arity 1.  If we try to
convert g to be a join point, its unfolding will still have arity 1
(since it is stable, and we don't meddle with stable unfoldings), and
Lint will complain (see Note [Invariants on join points], (2a), in
CoreSyn.  Trac #13413.

Moreover, since g is going to be inlined anyway, there is no benefit
from making it a join point.

If it is recursive, and uselessly marked INLINE, this will stop us
making it a join point, which is annoying.  But occasionally
(notably in class methods; see Note [Instances and loop breakers] in
TcInstDcls) we mark recursive things as INLINE but the recursion
unravels; so ignoring INLINE pragmas on recursive things isn't good
either.

See Invariant 2a of Note [Invariants on join points] in CoreSyn


************************************************************************
*                                                                      *
\subsection{Operations over OccInfo}
*                                                                      *
************************************************************************
-}

markMany, markInsideLam, markNonTailCalled :: OccInfo -> OccInfo

markMany :: OccInfo -> OccInfo
markMany IAmDead = OccInfo
IAmDead
markMany occ :: OccInfo
occ     = $WManyOccs :: TailCallInfo -> OccInfo
ManyOccs { occ_tail :: TailCallInfo
occ_tail = OccInfo -> TailCallInfo
occ_tail OccInfo
occ }

markInsideLam :: OccInfo -> OccInfo
markInsideLam occ :: OccInfo
occ@(OneOcc {}) = OccInfo
occ { occ_in_lam :: Bool
occ_in_lam = Bool
True }
markInsideLam occ :: OccInfo
occ             = OccInfo
occ

markNonTailCalled :: OccInfo -> OccInfo
markNonTailCalled IAmDead = OccInfo
IAmDead
markNonTailCalled occ :: OccInfo
occ     = OccInfo
occ { occ_tail :: TailCallInfo
occ_tail = TailCallInfo
NoTailCallInfo }

addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo

addOccInfo :: OccInfo -> OccInfo -> OccInfo
addOccInfo a1 :: OccInfo
a1 a2 :: OccInfo
a2  = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
                    $WManyOccs :: TailCallInfo -> OccInfo
ManyOccs { occ_tail :: TailCallInfo
occ_tail = OccInfo -> TailCallInfo
tailCallInfo OccInfo
a1 TailCallInfo -> TailCallInfo -> TailCallInfo
`andTailCallInfo`
                                          OccInfo -> TailCallInfo
tailCallInfo OccInfo
a2 }
                                -- Both branches are at least One
                                -- (Argument is never IAmDead)

-- (orOccInfo orig new) is used
-- when combining occurrence info from branches of a case

orOccInfo :: OccInfo -> OccInfo -> OccInfo
orOccInfo (OneOcc { occ_in_lam :: OccInfo -> Bool
occ_in_lam = Bool
in_lam1, occ_int_cxt :: OccInfo -> Bool
occ_int_cxt = Bool
int_cxt1
                  , occ_tail :: OccInfo -> TailCallInfo
occ_tail   = TailCallInfo
tail1 })
          (OneOcc { occ_in_lam :: OccInfo -> Bool
occ_in_lam = Bool
in_lam2, occ_int_cxt :: OccInfo -> Bool
occ_int_cxt = Bool
int_cxt2
                  , occ_tail :: OccInfo -> TailCallInfo
occ_tail   = TailCallInfo
tail2 })
  = $WOneOcc :: Bool -> Bool -> Bool -> TailCallInfo -> OccInfo
OneOcc { occ_one_br :: Bool
occ_one_br  = Bool
False -- False, because it occurs in both branches
           , occ_in_lam :: Bool
occ_in_lam  = Bool
in_lam1 Bool -> Bool -> Bool
|| Bool
in_lam2
           , occ_int_cxt :: Bool
occ_int_cxt = Bool
int_cxt1 Bool -> Bool -> Bool
&& Bool
int_cxt2
           , occ_tail :: TailCallInfo
occ_tail    = TailCallInfo
tail1 TailCallInfo -> TailCallInfo -> TailCallInfo
`andTailCallInfo` TailCallInfo
tail2 }

orOccInfo a1 :: OccInfo
a1 a2 :: OccInfo
a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
                  $WManyOccs :: TailCallInfo -> OccInfo
ManyOccs { occ_tail :: TailCallInfo
occ_tail = OccInfo -> TailCallInfo
tailCallInfo OccInfo
a1 TailCallInfo -> TailCallInfo -> TailCallInfo
`andTailCallInfo`
                                        OccInfo -> TailCallInfo
tailCallInfo OccInfo
a2 }

andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo
andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo
andTailCallInfo info :: TailCallInfo
info@(AlwaysTailCalled arity1 :: Int
arity1) (AlwaysTailCalled arity2 :: Int
arity2)
  | Int
arity1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
arity2 = TailCallInfo
info
andTailCallInfo _ _  = TailCallInfo
NoTailCallInfo