-- | Construct an expression which represents the application of a number of

 -- expressions to another. The leftmost expression in the list is applied first

            -> [CoreExpr] -- ^ arguments

            -> CoreExpr

 -- | Construct an expression which represents the application of one expression

 -- to the other

           -> CoreExpr -- ^ argument

           -> CoreExpr

 {- *********************************************************************

 *                                                                      *

 import GHC.Unit.Module( Module )

 import Data.List (mapAccumL)

 {-

 ************************************************************************

 * In occ_env, the new (occ_join_points :: IdEnv OccInfoEnv) maps

   each in-scope non-recursive join point, such as `j` above, to

   a "zeroed form" of its RHS's usage details. The "zeroed form"

     * deletes ManyOccs

     * maps a OneOcc to OneOcc{ occ_n_br = 0 }

       [j :-> [v :-> OneOcc{occ_n_br=0}]]

 * At an occurrence of a join point, we do everything as normal, but add in the

   UsageDetails from the occ_join_points.  See mkOneOcc.

 Here are the consequences

   There are two lexical occurrences of `v`!

   (NB: `orUDs` adds occ_n_br together, so occ_n_br=1 is impossible, too.)

     * OneOcc{occ_n_br=1} from the (f v)

   These are `andUDs` together in `addOccInfo`, and hence

   `v` gets ManyOccs, just as it should.  Clever!

 (W1) Consider this example which shadows `j`:

           join j = rhs in

      * In `postprcess_uds`, we add the chucked-out join points to the

        returned UsageDetails, with `andUDs`.

 (W3) Consider this example, which shadows `j`, but this time in an argument

               join j = rhs

               in f (case x of { K j -> ...; ... })

      NB: this is just about efficiency: it is always safe /not/ to zap the

      occ_join_points.

 Note [Finding join points]

 ~~~~~~~~~~~~~~~~~~~~~~~~~~

 Note [Join arity prediction based on joinRhsArity]

 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

   ==> { Contify for join arity 1 }

   join f x = \y -> x + y

   in if b then jump f 1 else jump f 2

   ==> { Contify for join arity 1, eta-expand f }

   join f x = id x

   in if b then jump f 12 else jump f 13

   letrec f x y = if ... then f x else True

   in f 42

 would not happen in a tail context! Contification is invalid here.

 points paper nor GHC does this at the moment.)

 We can capitalise on this observation and conclude that *if* f could become a

 It is also the join arity inside the 'TailUsageDetails' returned by

 'occAnalLamTail', so we can predict join arity without doing any fixed-point

 iteration or really doing any deep traversal of let body or RHS at all.

 All this is quite apparent if you look at the contification transformation in

 Fig. 5 of "Compiling without Continuations" (which does not account for

     ... and a bunch of conditions establishing that f only occurs

         in app heads of join arity (len as + len xs) inside us and es ...

 for non-recursive functions, this is the definition of contification from the

 paper:

   let f = /\as.\xs.u in L[es]     ... conditions ...

 Note [Join points and unfoldings/rules]

 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      Cyclic Recursive case:   'tagRecBinders'

      Acyclic Recursive case:  'adjustNonRecRhs'

      Non-recursive case:      'adjustNonRecRhs'

 -}

 ------------------------------------------------------------------

   | mb_join@(JoinPoint {}) <- idJoinPointHood bndr

   = -- Analyse the RHS and /then/ the body

     let -- Analyse the rhs first, generating rhs_uds

         -- Now analyse the body, adding the join point

         -- into the environment with addJoinPoint

                                       thing_inside (addJoinPoint env bndr' rhs_uds)

     in

     if isDeadOcc occ     -- Drop dead code; see Note [Dead code]

     then WUD body_uds body

              (combine [NonRec (fst (tagNonRecBinder lvl occ bndr')) rhs']

                       body)

   -- The normal case, including newly-discovered join points

   -- Analyse the body and /then/ the RHS

   = if isDeadOcc occ   -- Drop dead code; see Note [Dead code]

     then WUD body_uds body

     else let

         -- => join arity O of Note [Join arity prediction based on joinRhsArity]

         (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr

            (combine [NonRec final_bndr rhs'] body)

 -----------------

 -----------------

 occAnalNonRecRhs :: OccEnv -> TopLevelFlag -> ImpRuleEdges

 occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs

   | null rules, null imp_rule_infos

   =  -- Fast path for common case of no rules. This is only worth

      -- 0.1% perf on average, but it's also only a line or two of code

   | otherwise

   where

     --------- Right hand side ---------

     -- For join points, set occ_encl to OccVanilla, via setTailCtxt.  If we have

     rhs_ctxt = mkNonRecRhsCtxt lvl bndr unf

     -- See Note [Join arity prediction based on joinRhsArity]

     -- returned by of occAnalLamTail. It's totally OK for them to mismatch;

     -- hence adjust the UDs from the RHS

                                -- here because that is what we are setting!

     WTUD unf_tuds unf' = occAnalUnfolding rhs_env unf

     adj_unf_uds = adjustTailArity (JoinPoint rhs_ja) unf_tuds

       -- of Note [Join arity prediction based on joinRhsArity]

     --------- IMP-RULES --------

     --------- All rules --------

     -- See Note [Join points and unfoldings/rules]

     -- of Note [Join arity prediction based on joinRhsArity]

     rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]

     rules_w_uds = [ (r,l,adjustTailArity (JoinPoint rhs_ja) rhs_wuds)

 -- See Note [Adjusting right-hand sides]

 occAnalLamTail env expr

   = let !(WUD usage expr') = occ_anal_lam_tail env expr

 occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr

 -- Does not markInsideLam etc for the outmost batch of lambdas

               WTUD (TUD rhs_ja uds) rhs' = occAnalLamTail env rhs

               unf' = unf { uf_tmpl = rhs' }

             in WTUD (TUD rhs_ja (markAllMany uds)) unf'

         | otherwise -> WTUD (TUD 0 emptyDetails) unf

               -- For non-Stable unfoldings we leave them undisturbed, but

                           -- Note [Rules are extra RHSs]

                           -- Note [Rule dependency info]

     rhs_uds' = markAllMany rhs_uds

     rhs_ja = length args -- See Note [Join points and unfoldings/rules]

 occAnalRule _ other_rule = (other_rule, emptyDetails, TUD 0 emptyDetails)

 Consider

     f p = BIG

     {-# INLINE g #-}

 The INLINE pragma says "inline exactly this RHS"; perhaps the

 programmer wants to expose that 'not', say. If we inline f that will make

 Another way to think about it: if we inlined g as-is into multiple

 call sites, now there's be multiple calls to f.

 We still leave tail call information intact, though, as to not spoil

 potential join points.

 Note [Unfoldings and rules]

 ~~~~~~~~~~~~~~~~~~~~~~~~~~~

 Generally unfoldings and rules are already occurrence-analysed, so we

             -> WithUsageDetails CoreExpr

 -- The `fun` argument is just an accumulating parameter,

 -- the base for building the application we return

   = go emptyDetails fun args one_shots

   where

     env_args = setNonTailCtxt encl env

 occAnalApp :: OccEnv

            -> (Expr CoreBndr, [Arg CoreBndr], [CoreTickish])

            -> WithUsageDetails (Expr CoreBndr)

   -- Account for join arity of runRW# continuation

   -- See Note [Simplification of runRW#]

   --

              -- Invariant: no Id maps to an empty OccInfoEnv

              -- See Note [Occurrence analysis for join points]

            , occ_join_points :: !JoinPointInfo

 type JoinPointInfo = IdEnv OccInfoEnv

            , occ_join_points = emptyVarEnv

            , occ_bs_env = emptyVarEnv

 noBinderSwaps :: OccEnv -> Bool

 noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env

       | uniq `elemVarEnvByKey` env = plusVarEnv_C andLocalOcc env join_env

       | otherwise                  = env

 addJoinPoint :: OccEnv -> Id -> UsageDetails -> OccEnv

   | isEmptyVarEnv zeroed_form

   = env

   | otherwise

   where

 --------------------

 transClosureFV :: VarEnv VarSet -> VarEnv VarSet

                    -- Combining (AlwaysTailCalled 2) and (AlwaysTailCalled 3)

                    -- gives NoTailCallInfo

               , lo_int_cxt :: !InterestingCxt }

     | ManyOccL !TailCallInfo

 instance Outputable LocalOcc where

   ppr (OneOccL { lo_n_br = n, lo_tail = tci })

 instance Outputable UsageDetails where

   ppr ud@(UD { ud_env = env, ud_z_tail = z_tail })

     where

       do_one :: Unique -> LocalOcc -> [(Unique,LocalOcc)] -> [(Unique,LocalOcc)]

       do_one uniq occ occs = (uniq, occ) : occs

 -- | TailUsageDetails captures the result of applying 'occAnalLamTail'

 --   to a function `\xyz.body`. The TailUsageDetails pairs together

 --   * the number of lambdas (including type lambdas: a JoinArity)

 -- If the binding turns out to be a join point with the indicated join

 -- arity, this unadjusted usage details is just what we need; otherwise we

 -- need to discard tail calls. That's what `adjustTailUsage` does.

 andUDs:: UsageDetails -> UsageDetails -> UsageDetails

 orUDs :: UsageDetails -> UsageDetails -> UsageDetails

 mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails

 mkOneOcc !env id int_cxt arity

   = mkSimpleDetails (unitVarEnv id occ)

   where

                   , lo_tail = AlwaysTailCalled arity }

 -- Add several occurrences, assumed not to be tail calls

 -------------------

 -- Auxiliary functions for UsageDetails implementation

                         -> UsageDetails -> UsageDetails -> UsageDetails

 {-# INLINE combineUsageDetailsWith #-}

 combineUsageDetailsWith plus_occ_info

   | isEmptyVarEnv env2 = uds1

   | otherwise

   -- See Note [Strictness in the occurrence analyser]

        , ud_z_many    = strictPlusVarEnv z_many1   z_many2

        , ud_z_in_lam  = plusVarEnv z_in_lam1 z_in_lam2

        , ud_z_tail    = strictPlusVarEnv z_tail1   z_tail2 }

         | uniq `elemVarEnvByKey` z_tail = NoTailCallInfo

         | otherwise                     = ti

 -------------------

 -- See Note [Adjusting right-hand sides]

 -- ^ This function concentrates shared logic between occAnalNonRecBind and the

 -- AcyclicSCC case of occAnalRec.

 -- It returns the adjusted rhs UsageDetails combined with the body usage

                 -> UsageDetails

   = -- c.f. occAnal (Lam {})

     markAllInsideLamIf (not one_shot) $

     markAllNonTailIf (not exact_join) $

     uds

   where

     one_shot   = isOneShotFun rhs

 adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails

 adjustTailArity mb_rhs_ja (TUD ja usage)

 tagRecBinders :: TopLevelFlag           -- At top level?

               -> UsageDetails           -- Of body of let ONLY

               -> [NodeDetails]

                   [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).

      -- 1. See Note [Join arity prediction based on joinRhsArity]

      --    Determine possible join-point-hood of whole group, by testing for

      unadj_uds = foldr (andUDs . test_manifest_arity) body_uds details_s

      will_be_joins = decideRecJoinPointHood lvl unadj_uds bndrs

      -- 2. Adjust usage details of each RHS, taking into account the

      --    join-point-hood decision

                      -- Matching occAnalLamTail in makeNode

      -- 3. Compute final usage details from adjusted RHS details

      adj_uds = foldr andUDs body_uds rhs_udss'

   | otherwise                  = setIdOccInfo bndr occ_info

 -- | Decide whether some bindings should be made into join points or not, based

 -- Returns `False` if they can't be join points. Note that it's an

 -- assumed to be mutually recursive.

 --

 -- It must, however, be a final decision. If we say `True` for 'f',

                               do { x <- newSysLocalDs (mkScaled (subMultCoRKind w_co) t)

                                  ; go c1 $ \w1 ->

                                    go c2 $ \w2 ->

                                        arg     = w1 (Var x)

                                    in k (\e -> (Lam x (w2 (app e arg)))) }

   | Just (builder_name, _, add_void) <- patSynBuilder ps

   = do { builder_id <- dsLookupGlobalId builder_name

        ; return (if add_void

                  else Var builder_id) }

   | otherwise

   = pprPanic "dsConLike" (ppr ps)

          -- compile the view expressions

         ; viewExpr' <- dsExpr viewExpr

         ; return (mkViewMatchResult var'

                     match_result) }

 -- decompose the first pattern and leave the rest alone

 instance Outputable OccInfo where

   -- only used for debugging; never parsed.  KSW 1999-07

   ppr IAmDead              = text "Dead"

   ppr (IAmALoopBreaker rule_only tails)

         = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails

         plusUFM,

         strictPlusUFM,

         plusUFM_C,

         plusUFM_CD,

         plusUFM_CD2,

         mergeUFM,

 strictPlusUFM_C :: (elt -> elt -> elt) -> UniqFM key elt -> UniqFM key elt -> UniqFM key elt

 strictPlusUFM_C f (UFM x) (UFM y) = UFM (MS.unionWith f x y)

 -- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the

 -- combinding function and `d1` resp. `d2` as the default value if

 -- there is no entry in `m1` reps. `m2`. The domain is the union of

         lookupUniqSet_Directly,

         partitionUniqSet,

         mapUniqSet,

         unsafeUFMToUniqSet,

         nonDetEltsUniqSet,

         nonDetKeysUniqSet,

 mapMaybeUniqSet_sameUnique :: (a -> Maybe b) -> UniqSet a -> UniqSet b

 mapMaybeUniqSet_sameUnique f (UniqSet a) = UniqSet $ mapMaybeUFM_sameUnique f a

 -- Two 'UniqSet's are considered equal if they contain the same

 -- uniques.

 instance Eq (UniqSet a) where

         elemVarEnv, disjointVarEnv, anyVarEnv,

         extendVarEnv, extendVarEnv_C, extendVarEnv_Acc,

         extendVarEnvList,

         plusVarEnv_CD, plusMaybeVarEnv_C,

         plusVarEnvList, alterVarEnv,

         delVarEnvList, delVarEnv,

 minusVarEnv       :: VarEnv a -> VarEnv b -> VarEnv a

 plusVarEnv_C      :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a

 strictPlusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a

 plusVarEnv_CD     :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a

 plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a

 mapVarEnv         :: (a -> b) -> VarEnv a -> VarEnv b

 extendVarEnvList = addListToUFM

 plusVarEnv_C     = plusUFM_C

 strictPlusVarEnv_C = strictPlusUFM_C

 plusVarEnv_CD    = plusUFM_CD

 plusMaybeVarEnv_C = plusMaybeUFM_C

 delVarEnvList    = delListFromUFM

                  {-# UNPACK #-} !Int8

     deriving (Show)