occAnalBind _ env (Rec pairs) body_usage
  = foldr (occAnalRec env) (body_usage, []) sccs
	-- For a recursive group, we 
	--	* occ-analyse all the RHSs
	--	* compute strongly-connected components
	--	* feed those components to occAnalRec
  where
    -------------Dependency analysis ------------------------------
    bndr_set = mkVarSet (map fst pairs)

    sccs :: [SCC (Node Details)]
    sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR rec_edges

    rec_edges :: [Node Details]
    rec_edges = {-# SCC "occAnalBind.assoc" #-}  map make_node pairs
    
    make_node (bndr, rhs)
        = (details, varUnique bndr, keysUFM out_edges)
	where
          details = ND { nd_bndr = bndr, nd_rhs = rhs'
                       , nd_uds = rhs_usage3, nd_inl = inl_fvs}

          (rhs_usage1, rhs') = occAnalRhs env NoOccInfo rhs
          rhs_usage2 = addIdOccs rhs_usage1 rule_fvs -- Note [Rules are extra RHSs]
          rhs_usage3 = addIdOccs rhs_usage2 unf_fvs
          unf        = realIdUnfolding bndr     -- Ignore any current loop-breaker flag
          unf_fvs    = stableUnfoldingVars unf
          rule_fvs   = idRuleVars bndr          -- See Note [Rule dependency info]

          inl_fvs   = rhs_fvs `unionVarSet` unf_fvs
          rhs_fvs   = intersectUFM_C (\b _ -> b) bndr_set rhs_usage1
          out_edges = intersectUFM_C (\b _ -> b) bndr_set rhs_usage3
        -- (a -> b) means a mentions b
        -- Given the usage details (a UFM that gives occ info for each free var of
        -- the RHS) we can get the list of free vars -- or rather their Int keys --
        -- by just extracting the keys from the finite map.  Grimy, but fast.
        -- Previously we had this:
        --      [ bndr | bndr <- bndrs,
        --               maybeToBool (lookupVarEnv rhs_usage bndr)]
        -- which has n**2 cost, and this meant that edges_from alone
        -- consumed 10% of total runtime!

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

	-- The NonRec case is just like a Let (NonRec ...) above
occAnalRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs, nd_uds = rhs_usage}, _, _))
             (body_usage, binds)
  | not (bndr `usedIn` body_usage) 
  = (body_usage, binds)

  | otherwise			-- It's mentioned in the body
  = (body_usage' +++ rhs_usage,	
     NonRec tagged_bndr rhs : binds)
  where
    (body_usage', tagged_bndr) = tagBinder body_usage bndr


	-- The Rec case is the interesting one
	-- See Note [Loop breaking]
occAnalRec env (CyclicSCC nodes) (body_usage, binds)
  | not (any (`usedIn` body_usage) bndrs)	-- NB: look at body_usage, not total_usage
  = (body_usage, binds)				-- Dead code

  | otherwise	-- At this point we always build a single Rec
  = (final_usage, Rec pairs : binds)

  where
    bndrs    = [b | (ND { nd_bndr = b }, _, _) <- nodes]
    bndr_set = mkVarSet bndrs
    non_boring bndr = isId bndr &&
                      (isStableUnfolding (realIdUnfolding bndr) || idHasRules bndr)

	----------------------------
	-- Tag the binders with their occurrence info
    total_usage = foldl add_usage body_usage nodes
    add_usage usage_so_far (ND { nd_uds = rhs_usage }, _, _) = usage_so_far +++ rhs_usage
    (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes

    tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details)
	-- (a) Tag the binders in the details with occ info
	-- (b) Mark the binder with "weak loop-breaker" OccInfo 
	--	saying "no preInlineUnconditionally" if it is used
	-- 	in any rule (lhs or rhs) of the recursive group
	--      See Note [Weak loop breakers]
    tag_node usage (details@ND { nd_bndr = bndr }, k, ks)
      = (usage `delVarEnv` bndr, (details { nd_bndr = bndr2 }, k, ks))
      where
	bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1
	      | otherwise  		       = bndr1
	bndr1 = setBinderOcc usage bndr
    all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars) 
						    emptyVarSet bndrs

	----------------------------
	-- Now reconstruct the cycle
    pairs | any non_boring bndrs
          = foldr (reOrderRec 0) [] $
            stronglyConnCompFromEdgedVerticesR loop_breaker_edges
          | otherwise
          = reOrderCycle 0 tagged_nodes []

	-- See Note [Choosing loop breakers] for loop_breaker_edges
    loop_breaker_edges = map mk_node tagged_nodes
    mk_node (details@(ND { nd_inl = inl_fvs }), k, _) = (details, k, new_ks)
	where
          new_ks = keysUFM (fst (extendFvs rule_fv_env inl_fvs))

    ------------------------------------
    rule_fv_env :: IdEnv IdSet  -- Variables from this group mentioned in RHS of rules
                                -- Domain is *subset* of bound vars (others have no rule fvs)
    rule_fv_env = transClosureFV init_rule_fvs
    init_rule_fvs
      | Just is_active <- occ_rule_act env  -- See Note [Finding rule RHS free vars]
      = [ (b, rule_fvs)
        | b <- bndrs
	, isId b
        , let rule_fvs = idRuleRhsVars is_active b
                         `intersectVarSet` bndr_set
        , not (isEmptyVarSet rule_fvs)]
      | otherwise 
      = []

type Node details = (details, Unique, [Unique])	-- The Ints are gotten from the Unique,
						-- which is gotten from the Id.
data Details
  = ND { nd_bndr :: Id          -- Binder
       , nd_rhs  :: CoreExpr    -- RHS

       , nd_uds  :: UsageDetails  -- Usage from RHS,
                                  -- including RULES and InlineRule unfolding

       , nd_inl  :: IdSet       -- Other binders *from this Rec group* mentioned in
       }                        --   its InlineRule unfolding (if present)
                                --   AND the  RHS
                                -- but *excluding* any RULES
                                -- This is the IdSet that may be used if the Id is inlined

reOrderRec :: Int -> SCC (Node Details)
           -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
-- Sorted into a plausible order.  Enough of the Ids have
--      IAmALoopBreaker pragmas that there are no loops left.
reOrderRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _))
                                   pairs = (bndr, rhs) : pairs
reOrderRec depth (CyclicSCC cycle) pairs = reOrderCycle depth cycle pairs

reOrderCycle :: Int -> [Node Details] -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]
reOrderCycle _ [] _
  = panic "reOrderCycle"
reOrderCycle _ [(ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)] pairs
  =    -- Common case of simple self-recursion
    (makeLoopBreaker False bndr, rhs) : pairs

reOrderCycle depth (bind : binds) pairs
  =     -- Choose a loop breaker, mark it no-inline,
        -- do SCC analysis on the rest, and recursively sort them out
--    pprTrace "reOrderCycle" (ppr [b | (ND { nd_bndr = b }, _, _) <- bind:binds]) $
    foldr (reOrderRec new_depth)
          ([ (makeLoopBreaker False bndr, rhs) 
           | (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _) <- chosen_binds] ++ pairs)
	  (stronglyConnCompFromEdgedVerticesR unchosen) 
  where
    (chosen_binds, unchosen) = choose_loop_breaker [bind] (score bind) [] binds

    approximate_loop_breaker = depth >= 2
    new_depth | approximate_loop_breaker = 0
	      | otherwise		 = depth+1
	-- After two iterations (d=0, d=1) give up
	-- and approximate, returning to d=0

        -- This loop looks for the bind with the lowest score
        -- to pick as the loop  breaker.  The rest accumulate in
    choose_loop_breaker loop_binds _loop_sc acc []
        = (loop_binds, acc)        -- Done

	-- If approximate_loop_breaker is True, we pick *all*
	-- nodes with lowest score, else just one
	-- See Note [Complexity of loop breaking]
    choose_loop_breaker loop_binds loop_sc acc (bind : binds)
        | sc < loop_sc  -- Lower score so pick this new one
        = choose_loop_breaker [bind] sc (loop_binds ++ acc) binds

	| approximate_loop_breaker && sc == loop_sc
	= choose_loop_breaker (bind : loop_binds) loop_sc acc binds
	
        | otherwise     -- Higher score so don't pick it
        = choose_loop_breaker loop_binds loop_sc (bind : acc) binds
        where
          sc = score bind

    score :: Node Details -> Int        -- Higher score => less likely to be picked as loop breaker
    score (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)
        | not (isId bndr) = 100	    -- A type or cercion variable is never a loop breaker

        | isDFunId bndr = 9   -- Never choose a DFun as a loop breaker
	   	     	      -- Note [DFuns should not be loop breakers]

        | Just inl_source <- isStableCoreUnfolding_maybe (idUnfolding bndr)
	= case inl_source of
	     InlineWrapper {} -> 10  -- Note [INLINE pragmas]
	     _other	      ->  3  -- Data structures are more important than this
	     		             -- so that dictionary/method recursion unravels
		-- Note that this case hits all InlineRule things, so we
		-- never look at 'rhs for InlineRule stuff. That's right, because
		-- 'rhs' is irrelevant for inlining things with an InlineRule
                
        | is_con_app rhs = 5  -- Data types help with cases: Note [Constructor applications]
                
        | exprIsTrivial rhs = 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

	
-- If an Id is marked "never inline" then it makes a great loop breaker
-- The only reason for not checking that here is that it is rare
-- and I've never seen a situation where it makes a difference,
-- so it probably isn't worth the time to test on every binder
--	| isNeverActive (idInlinePragma bndr) = -10

        | isOneOcc (idOccInfo bndr) = 2  -- Likely to be inlined

        | canUnfold (realIdUnfolding bndr) = 1
                -- The Id has some kind of unfolding
		-- Ignore loop-breaker-ness here because that is what we are setting!

        | otherwise = 0

	-- Checking for a constructor application
        -- Cheap and cheerful; the simplifer 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 (Var v)    = isConLikeId v
    is_con_app (App f _)  = is_con_app f
    is_con_app (Lam _ e)  = is_con_app e
    is_con_app (Note _ e) = is_con_app e
    is_con_app _          = False

makeLoopBreaker :: Bool -> Id -> Id
-- Set the loop-breaker flag: see Note [Weak loop breakers]
makeLoopBreaker weak bndr 
  = ASSERT2( isId bndr, ppr bndr ) setIdOccInfo bndr (IAmALoopBreaker weak)

occAnalRhs :: OccEnv
           -> OccInfo -> CoreExpr    -- Binder and rhs
                                -- For non-recs the binder is alrady tagged
                                -- with occurrence info
           -> (UsageDetails, CoreExpr)
              -- Returned usage details covers only the RHS,
              -- and *not* the RULE or INLINE template for the Id
occAnalRhs env occ rhs
  = occAnal ctxt rhs
  where
    ctxt | certainly_inline = env
         | otherwise        = rhsCtxt env
        -- Note that we generally use an rhsCtxt.  This tells the occ anal n
        -- that it's looking at an RHS, which has an effect in occAnalApp
        --
        -- 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.
        -- Crude solution: use rhsCtxt for things that occur just once...

    certainly_inline = case occ of
                            OneOcc in_lam one_br _ -> not in_lam && one_br
                            _                      -> False


addIdOccs :: UsageDetails -> VarSet -> UsageDetails
addIdOccs usage id_set = foldVarSet add usage id_set
  where
    add v u | isId v    = addOneOcc u v NoOccInfo
            | otherwise = 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.)

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

occAnal _   (Type t)  = (emptyDetails, Type t)
occAnal env (Var v)   = (mkOneOcc env v False, Var v)
    -- At one stage, I gathered the idRuleVars for v 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 _   expr@(Lit _) = (emptyDetails, expr)

occAnal env (Note note@(SCC _) body)
  = case occAnal env body of { (usage, body') ->
    (mapVarEnv markInsideSCC usage, Note note body')
    }

occAnal env (Note note body)
  = case occAnal env body of { (usage, body') ->
    (usage, Note note body')
    }

occAnal env (Cast expr co)
  = case occAnal env expr of { (usage, expr') ->
      (markManyIf (isRhsEnv env) usage, Cast expr' co)
        -- If we see let x = y `cast` co
        -- then mark y as 'Many' so that we don't
        -- immediately inline y again.
    }

occAnal env app@(App _ _)
  = occAnalApp env (collectArgs app)

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

occAnal env (Lam x body) | isTyCoVar x
  = case occAnal env body of { (body_usage, body') ->
    (body_usage, Lam x 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 expr@(Lam _ _)
  = case occAnal env_body body of { (body_usage, body') ->
    let
        (final_usage, tagged_binders) = tagLamBinders body_usage binders'
		      -- Use binders' to put one-shot info on the lambdas

        --      URGH!  Sept 99: we don't seem to be able to use binders' here, because
        --      we get linear-typed things in the resulting program that we can't handle yet.
        --      (e.g. PrelShow)  TODO

        really_final_usage = if linear then
                                final_usage
                             else
                                mapVarEnv markInsideLam final_usage
    in
    (really_final_usage,
     mkLams tagged_binders body') }
  where
    env_body        = vanillaCtxt (trimOccEnv env binders)
		        -- Body is (no longer) an RhsContext
    (binders, body) = collectBinders expr
    binders'        = oneShotGroup env binders
    linear          = all is_one_shot binders'
    is_one_shot b   = isId b && isOneShotBndr b

occAnal env (Case scrut bndr ty alts)
  = case occ_anal_scrut scrut alts     of { (scrut_usage, scrut') ->
    case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts')   ->
    let
        alts_usage  = foldr1 combineAltsUsageDetails alts_usage_s
        (alts_usage1, tagged_bndr) = tag_case_bndr alts_usage bndr
        total_usage = scrut_usage +++ alts_usage1
    in
    total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
  where
	-- Note [Case binder usage]	
	-- ~~~~~~~~~~~~~~~~~~~~~~~~
        -- The case binder gets a usage of either "many" or "dead", never "one".
        -- Reason: we like to inline single occurrences, to eliminate a binding,
        -- but inlining a case binder *doesn't* eliminate a binding.
        -- We *don't* want to transform
        --      case x of w { (p,q) -> f w }
        -- into
        --      case x of w { (p,q) -> f (p,q) }
    tag_case_bndr usage bndr
      = case lookupVarEnv usage bndr of
          Nothing -> (usage,                  setIdOccInfo bndr IAmDead)
          Just _  -> (usage `delVarEnv` bndr, setIdOccInfo bndr NoOccInfo)

    alt_env      = mkAltEnv env scrut bndr
    occ_anal_alt = occAnalAlt alt_env bndr

    occ_anal_scrut (Var v) (alt1 : other_alts)
        | not (null other_alts) || not (isDefaultAlt alt1)
        = (mkOneOcc env v True, Var v)	-- The 'True' says that the variable occurs
					-- in an interesting context; the case has
					-- at least one non-default alternative
    occ_anal_scrut scrut _alts  
	= occAnal (vanillaCtxt env) scrut    -- No need for rhsCtxt

occAnal env (Let bind body)
  = case occAnal env_body body                    of { (body_usage, body') ->
    case occAnalBind env env_body bind body_usage of { (final_usage, new_binds) ->
       (final_usage, mkLets new_binds body') }}
  where
    env_body = trimOccEnv env (bindersOf bind)

occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr])
occAnalArgs env args
  = case mapAndUnzip (occAnal arg_env) args of  { (arg_uds_s, args') ->
    (foldr (+++) emptyDetails arg_uds_s, args')}
  where
    arg_env = vanillaCtxt env

occAnalApp :: OccEnv
           -> (Expr CoreBndr, [Arg CoreBndr])
           -> (UsageDetails, Expr CoreBndr)
occAnalApp env (Var fun, args)
  = case args_stuff of { (args_uds, args') ->
    let
       final_args_uds = markManyIf (isRhsEnv env && is_exp) args_uds
	  -- We mark the free vars of the argument of a constructor or PAP
	  -- as "many", if it is the RHS of a let(rec).
	  -- This means that nothing gets inlined into a constructor argument
	  -- position, which is what we want.  Typically those constructor
	  -- arguments are just variables, or trivial expressions.
	  --
	  -- This is the *whole point* of the isRhsEnv predicate
    in
    (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
  where
    fun_uniq = idUnique fun
    fun_uds  = mkOneOcc env fun (valArgCount args > 0)
    is_exp = isExpandableApp fun (valArgCount args)
    	   -- See Note [CONLIKE pragma] in BasicTypes
	   -- The definition of is_exp should match that in
	   -- Simplify.prepareRhs

                -- Hack for build, fold, runST
    args_stuff  | fun_uniq == buildIdKey    = appSpecial env 2 [True,True]  args
                | fun_uniq == augmentIdKey  = appSpecial env 2 [True,True]  args
                | fun_uniq == foldrIdKey    = appSpecial env 3 [False,True] args
                | fun_uniq == runSTRepIdKey = appSpecial env 2 [True]       args
                        -- (foldr k z xs) may call k many times, but it never
                        -- shares a partial application of k; hence [False,True]
                        -- This means we can optimise
                        --      foldr (\x -> let v = ...x... in \y -> ...v...) z xs
                        -- by floating in the v

                | otherwise = occAnalArgs env args


occAnalApp env (fun, args)
  = case occAnal (addAppCtxt env args) fun of   { (fun_uds, 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.

    case occAnalArgs env args of        { (args_uds, args') ->
    let
        final_uds = fun_uds +++ args_uds
    in
    (final_uds, mkApps fun' args') }}


markManyIf :: Bool              -- If this is true
           -> UsageDetails      -- Then do markMany on this
           -> UsageDetails
markManyIf True  uds = mapVarEnv markMany uds
markManyIf False uds = uds

appSpecial :: OccEnv
           -> Int -> CtxtTy     -- Argument number, and context to use for it
           -> [CoreExpr]
           -> (UsageDetails, [CoreExpr])
appSpecial env n ctxt args
  = go n args
  where
    arg_env = vanillaCtxt env

    go _ [] = (emptyDetails, [])        -- Too few args

    go 1 (arg:args)                     -- The magic arg
      = case occAnal (setCtxtTy arg_env ctxt) arg of    { (arg_uds, arg') ->
        case occAnalArgs env args of                    { (args_uds, args') ->
        (arg_uds +++ args_uds, arg':args') }}

    go n (arg:args)
      = case occAnal arg_env arg of     { (arg_uds, arg') ->
        case go (n-1) args of           { (args_uds, args') ->
        (arg_uds +++ args_uds, arg':args') }}

occAnalAlt :: OccEnv
           -> CoreBndr
           -> CoreAlt
           -> (UsageDetails, Alt IdWithOccInfo)
occAnalAlt env case_bndr (con, bndrs, rhs)
  = let 
        env' = trimOccEnv env bndrs
    in 
    case occAnal env' rhs of { (rhs_usage1, rhs1) ->
    let
	proxies = getProxies env' case_bndr 
	(rhs_usage2, rhs2) = foldrBag wrapProxy (rhs_usage1, rhs1) proxies
        (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage2 bndrs
        bndrs' = tagged_bndrs      -- See Note [Binders in case alternatives]
    in
    (alt_usg, (con, bndrs', rhs2)) }

wrapProxy :: ProxyBind -> (UsageDetails, CoreExpr) -> (UsageDetails, CoreExpr)
wrapProxy (bndr, rhs_var, co) (body_usg, body)
  | not (bndr `usedIn` body_usg) 
  = (body_usg, body)
  | otherwise
  = (body_usg' +++ rhs_usg, Let (NonRec tagged_bndr rhs) body)
  where
    (body_usg', tagged_bndr) = tagBinder body_usg bndr
    rhs_usg = unitVarEnv rhs_var NoOccInfo	-- We don't need exact info
    rhs = mkCoerceI co (Var rhs_var)

data OccEnv
  = OccEnv { occ_encl  	  :: !OccEncl      -- Enclosing context information
    	   , occ_ctxt  	  :: !CtxtTy       -- Tells about linearity
	   , occ_proxy 	  :: ProxyEnv
           , occ_rule_fvs :: ImpRuleUsage
           , occ_rule_act :: Maybe (Activation -> Bool)	-- Nothing => Rules are inactive
             -- See Note [Finding rule RHS free vars]
    }


-----------------------------
-- 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 enought about the context to know what to do when
-- we encounter a contructor 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 OccRhs     = ptext (sLit "occRhs")
  ppr OccVanilla = ptext (sLit "occVanilla")

type CtxtTy = [Bool]
        -- []           No info
        --
        -- True:ctxt    Analysing a function-valued expression that will be
        --                      applied just once
        --
        -- False:ctxt   Analysing a function-valued expression that may
        --                      be applied many times; but when it is,
        --                      the CtxtTy inside applies

initOccEnv :: Maybe (Activation -> Bool) -> [CoreRule] 
           -> OccEnv
initOccEnv active_rule imp_rules
  = OccEnv { occ_encl  = OccVanilla
	   , occ_ctxt  = []
	   , occ_proxy = PE emptyVarEnv emptyVarSet
           , occ_rule_fvs = findImpRuleUsage active_rule imp_rules
           , occ_rule_act = active_rule }

vanillaCtxt :: OccEnv -> OccEnv
vanillaCtxt env = env { occ_encl = OccVanilla, occ_ctxt = [] }

rhsCtxt :: OccEnv -> OccEnv
rhsCtxt env = env { occ_encl = OccRhs, occ_ctxt = [] }

setCtxtTy :: OccEnv -> CtxtTy -> OccEnv
setCtxtTy env ctxt = env { occ_ctxt = ctxt }

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

oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr]
        -- The result binders have one-shot-ness set that they might not have had originally.
        -- This happens in (build (\cn -> 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 { occ_ctxt = ctxt }) bndrs
  = go ctxt bndrs []
  where
    go _ [] rev_bndrs = reverse rev_bndrs

    go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
        | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
        where
          bndr' | lin_ctxt  = setOneShotLambda bndr
                | otherwise = bndr

    go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)

addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
addAppCtxt env@(OccEnv { occ_ctxt = ctxt }) args
  = env { occ_ctxt = replicate (valArgCount args) True ++ ctxt }

type ImpRuleUsage = NameEnv UsageDetails
  -- Maps an *imported* Id f to the UsageDetails for *local* Ids
  -- used on the RHS for a *local* rule for f.

findImpRuleUsage :: Maybe (Activation -> Bool) -> [CoreRule] -> ImpRuleUsage
-- Find the *local* Ids that can be reached transitively,
-- via local rules, from each *imported* Id.  
-- Sigh: this function seems more complicated than it is really worth
findImpRuleUsage Nothing _ = emptyNameEnv
findImpRuleUsage (Just is_active) rules
  = mkNameEnv [ (f, mapUFM (\_ -> NoOccInfo) ls)
              | f <- rule_names 
              , let ls = find_lcl_deps f
              , not (isEmptyVarSet ls) ]
  where
    rule_names    = map ru_fn rules
    rule_name_set = mkNameSet rule_names

    imp_deps :: NameEnv VarSet
      -- (f,g) means imported Id 'g' appears in RHS of 
      --       rule for imported Id 'f', *or* does so transitively
    imp_deps = foldr add_imp emptyNameEnv rules
    add_imp rule acc 
      | is_active (ruleActivation rule)
      = extendNameEnv_C unionVarSet acc (ru_fn rule)
                        (exprSomeFreeVars keep_imp (ru_rhs rule))
      | otherwise = acc
    keep_imp v = isId v && (idName v `elemNameSet` rule_name_set)
    full_imp_deps = transClosureFV (ufmToList imp_deps)

    lcl_deps :: NameEnv VarSet
      -- (f, l) means localId 'l' appears immediately 
      --        in the RHS of a rule for imported Id 'f'
      -- Remember, many rules might have the same ru_fn
      -- so we do need to fold 
    lcl_deps = foldr add_lcl emptyNameEnv rules
    add_lcl rule acc = extendNameEnv_C unionVarSet acc (ru_fn rule)
                                       (exprFreeIds (ru_rhs rule))

    find_lcl_deps :: Name -> VarSet
    find_lcl_deps f 
      = foldVarSet (unionVarSet . lookup_lcl . idName) (lookup_lcl f) 
                   (lookupNameEnv full_imp_deps f `orElse` emptyVarSet)
    lookup_lcl :: Name -> VarSet
    lookup_lcl g = lookupNameEnv lcl_deps g `orElse` emptyVarSet

-------------
transClosureFV :: Uniquable a => [(a, VarSet)] -> UniqFM VarSet
-- If (f,g), (g,h) are in the input, then (f,h) is in the output
transClosureFV fv_list
  | no_change = env
  | otherwise = transClosureFV new_fv_list
  where
    env = listToUFM fv_list
    (no_change, new_fv_list) = mapAccumL bump True fv_list
    bump no_change (b,fvs)
      | no_change_here = (no_change, (b,fvs))
      | otherwise      = (False,     (b,new_fvs))
      where
        (new_fvs, no_change_here) = extendFvs env fvs

-------------
extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool)
-- (extendFVs env s) returns 
--     (s `union` env(s), env(s) `subset` s)
extendFvs env s
  = foldVarSet add (s, True) s
  where
    add v (vs, no_change_so_far)
        = case lookupUFM env v of
            Just fvs | not (fvs `subVarSet` s) 
                     -> (vs `unionVarSet` fvs, False)
            _        -> (vs, no_change_so_far)

data ProxyEnv 
   = PE (IdEnv (Id, [(Id,CoercionI)])) VarSet
     	-- Main env, and its free variables (of both range and domain)

extendProxyEnv :: ProxyEnv -> Id -> CoercionI -> Id -> ProxyEnv
-- (extendPE x co y) typically arises from 
--		  case (x |> co) of y { ... }
-- It extends the proxy env with the binding 
-- 	               y = x |> co
extendProxyEnv pe scrut co case_bndr
  | scrut == case_bndr = PE env1 fvs1	-- If case_bndr shadows scrut,
  | otherwise          = PE env2 fvs2	--   don't extend
  where
    PE env1 fvs1 = trimProxyEnv pe [case_bndr]
    env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co)
    single cb_co = (scrut1, [cb_co]) 
    add cb_co (x, cb_cos) = (x, cb_co:cb_cos)
    fvs2 = fvs1 `unionVarSet`  freeVarsCoI co
		`extendVarSet` case_bndr
		`extendVarSet` scrut1

    scrut1 = mkLocalId (localiseName (idName scrut)) (idType scrut)
	-- 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 INLILNE or NOINLINE pragmas!

-----------
type ProxyBind = (Id, Id, CoercionI)

getProxies :: OccEnv -> Id -> Bag ProxyBind
-- Return a bunch of bindings [...(xi,ei)...] 
-- such that  let { ...; xi=ei; ... } binds the xi using y alone
-- See Note [getProxies is subtle]
getProxies (OccEnv { occ_proxy = PE pe _ }) case_bndr
  = -- pprTrace "wrapProxies" (ppr case_bndr) $
    go_fwd case_bndr
  where
    fwd_pe :: IdEnv (Id, CoercionI)
    fwd_pe = foldVarEnv add1 emptyVarEnv pe
           where
             add1 (x,ycos) env = foldr (add2 x) env ycos
             add2 x (y,co) env = extendVarEnv env y (x,co)

    go_fwd :: Id -> Bag ProxyBind
	-- Return bindings derivable from case_bndr
    go_fwd case_bndr = -- pprTrace "go_fwd" (vcat [ppr case_bndr, text "fwd_pe =" <+> ppr fwd_pe, 
                       --                         text "pe =" <+> ppr pe]) $ 
                       go_fwd' case_bndr

    go_fwd' case_bndr
        | Just (scrut, co) <- lookupVarEnv fwd_pe case_bndr
        = unitBag (scrut,  case_bndr, mkSymCoI co)
	  `unionBags` go_fwd scrut
          `unionBags` go_bwd scrut [pr | pr@(cb,_) <- lookup_bwd scrut
                                       , cb /= case_bndr]
        | otherwise 
        = emptyBag

    lookup_bwd :: Id -> [(Id, CoercionI)]
	-- Return case_bndrs that are connected to scrut 
    lookup_bwd scrut = case lookupVarEnv pe scrut of
          		  Nothing          -> []
	  		  Just (_, cb_cos) -> cb_cos

    go_bwd :: Id -> [(Id, CoercionI)] -> Bag ProxyBind
    go_bwd scrut cb_cos = foldr (unionBags . go_bwd1 scrut) emptyBag cb_cos

    go_bwd1 :: Id -> (Id, CoercionI) -> Bag ProxyBind
    go_bwd1 scrut (case_bndr, co) 
       = -- pprTrace "go_bwd1" (ppr case_bndr) $
         unitBag (case_bndr, scrut, co)
	 `unionBags` go_bwd case_bndr (lookup_bwd case_bndr)

-----------
mkAltEnv :: OccEnv -> CoreExpr -> Id -> OccEnv
-- Does two things: a) makes the occ_ctxt = OccVanilla
-- 	    	    b) extends the ProxyEnv if possible
mkAltEnv env scrut cb
  = env { occ_encl  = OccVanilla, occ_proxy = pe' }
  where
    pe  = occ_proxy env
    pe' = case scrut of
             Var v           -> extendProxyEnv pe v (IdCo (idType v)) cb
             Cast (Var v) co -> extendProxyEnv pe v (ACo co)          cb
	     _other          -> trimProxyEnv pe [cb]

-----------
trimOccEnv :: OccEnv -> [CoreBndr] -> OccEnv
trimOccEnv env bndrs = env { occ_proxy = trimProxyEnv (occ_proxy env) bndrs }

-----------
trimProxyEnv :: ProxyEnv -> [CoreBndr] -> ProxyEnv
-- We are about to push this ProxyEnv inside a binding for 'bndrs'
-- So dump any ProxyEnv bindings which mention any of the bndrs
trimProxyEnv (PE pe fvs) bndrs 
  | not (bndr_set `intersectsVarSet` fvs) 
  = PE pe fvs
  | otherwise
  = PE pe' (fvs `minusVarSet` bndr_set)
  where
    pe' = mapVarEnv trim pe
    bndr_set = mkVarSet bndrs
    trim (scrut, cb_cos) | scrut `elemVarSet` bndr_set = (scrut, [])
			 | otherwise = (scrut, filterOut discard cb_cos)
    discard (cb,co) = bndr_set `intersectsVarSet` 
                      extendVarSet (freeVarsCoI co) cb
                             
-----------
freeVarsCoI :: CoercionI -> VarSet
freeVarsCoI (IdCo t) = tyVarsOfType t
freeVarsCoI (ACo co) = tyVarsOfType co

type UsageDetails = IdEnv OccInfo       -- A finite map from ids to their usage
		-- INVARIANT: never IAmDead
		-- (Deadness is signalled by not being in the map at all)

(+++), combineAltsUsageDetails
        :: UsageDetails -> UsageDetails -> UsageDetails

(+++) usage1 usage2
  = plusVarEnv_C addOccInfo usage1 usage2

combineAltsUsageDetails usage1 usage2
  = plusVarEnv_C orOccInfo usage1 usage2

addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
addOneOcc usage id info
  = plusVarEnv_C addOccInfo usage (unitVarEnv id info)
        -- ToDo: make this more efficient

emptyDetails :: UsageDetails
emptyDetails = (emptyVarEnv :: UsageDetails)

usedIn :: Id -> UsageDetails -> Bool
v `usedIn` details = isExportedId v || v `elemVarEnv` details

type IdWithOccInfo = Id

tagLamBinders :: UsageDetails          -- Of scope
              -> [Id]                  -- Binders
              -> (UsageDetails,        -- Details with binders removed
                 [IdWithOccInfo])    -- Tagged binders
-- Used for lambda and case binders
-- It copes with the fact that lambda bindings can have InlineRule 
-- unfoldings, used for join points
tagLamBinders usage binders = usage' `seq` (usage', bndrs')
  where
    (usage', bndrs') = mapAccumR tag_lam usage binders
    tag_lam usage bndr = (usage2, setBinderOcc usage bndr)
      where
        usage1 = usage `delVarEnv` bndr
        usage2 | isId bndr = addIdOccs usage1 (idUnfoldingVars bndr)
               | otherwise = usage1

tagBinder :: UsageDetails           -- Of scope
          -> Id                     -- Binders
          -> (UsageDetails,         -- Details with binders removed
              IdWithOccInfo)        -- Tagged binders

tagBinder usage binder
 = let
     usage'  = usage `delVarEnv` binder
     binder' = setBinderOcc usage binder
   in
   usage' `seq` (usage', binder')

setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
setBinderOcc usage bndr
  | isTyCoVar bndr    = bndr
  | isExportedId bndr = case idOccInfo bndr of
                          NoOccInfo -> bndr
                          _         -> setIdOccInfo bndr 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"

  | otherwise = setIdOccInfo bndr occ_info
  where
    occ_info = lookupVarEnv usage bndr `orElse` IAmDead

mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
mkOneOcc env id int_cxt
  | isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
  | PE env _ <- occ_proxy env
  , id `elemVarEnv` env = unitVarEnv id NoOccInfo
  | Just uds <- lookupNameEnv (occ_rule_fvs env) (idName id)
  = uds
  | otherwise           = emptyDetails

markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo

markMany _  = NoOccInfo

markInsideSCC occ = markMany occ

markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
markInsideLam occ                       = occ

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

addOccInfo a1 a2  = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
		    NoOccInfo	-- 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 (OneOcc in_lam1 _ int_cxt1)
          (OneOcc in_lam2 _ int_cxt2)
  = OneOcc (in_lam1 || in_lam2)
           False        -- False, because it occurs in both branches
           (int_cxt1 && int_cxt2)
orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
		  NoOccInfo