<commit_before>%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%************************************************************************
%*									*
\section[OccurAnal]{Occurrence analysis pass}
%*									*
%************************************************************************

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

\begin{code}
#include "HsVersions.h"

module OccurAnal (
	occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr
    ) where

IMP_Ubiq(){-uitous-}
IMPORT_1_3(List(partition))

import BinderInfo
import CmdLineOpts	( opt_D_dump_occur_anal, SimplifierSwitch(..) )
import CoreSyn
import Digraph		( stronglyConnComp, stronglyConnCompR, SCC(..) )
import Id		( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
			  idType, idUnique, SYN_IE(Id),
			  emptyIdSet, unionIdSets, mkIdSet,
			  unitIdSet, elementOfIdSet,
			  addOneToIdSet, SYN_IE(IdSet),
			  nullIdEnv, unitIdEnv, combineIdEnvs,
			  delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv, 
			  mapIdEnv, lookupIdEnv, SYN_IE(IdEnv), 
			  GenId{-instance Eq-}
			)
import Name		( isExported, isLocallyDefined )
import Type		( getFunTy_maybe, splitForAllTy )
import Maybes		( maybeToBool )
import Outputable	( PprStyle(..), Outputable(..){-instance * (,) -} )
import PprCore
import PprType		( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
import Pretty		( Doc, vcat, ptext, nest, punctuate, comma, hcat, text )
import TyVar		( GenTyVar{-instance Eq-} )
import Unique		( Unique{-instance Eq-}, u2i )
import UniqFM		( keysUFM ) 
import Util		( assoc, zipEqual, zipWithEqual, Ord3(..)
			, pprTrace, panic 
#ifdef DEBUG
			, assertPanic
#endif
			)

isSpecPragmaId_maybe x = Nothing -- ToDo:!trace "OccurAnal.isSpecPragmaId_maybe"
\end{code}


%************************************************************************
%*									*
\subsection[OccurAnal-types]{Data types}
%*									*
%************************************************************************

\begin{code}
data OccEnv =
  OccEnv
    Bool	-- Keep-unused-bindings flag
		-- False <=> OK to chuck away binding
		-- 	     and ignore occurrences within it
    Bool	-- Keep-spec-pragma-ids flag
		-- False <=> OK to chuck away spec pragma bindings
		-- 	     and ignore occurrences within it
    Bool	-- Keep-conjurable flag
		-- False <=> OK to throw away *dead*
		-- "conjurable" Ids; at the moment, that
		-- *only* means constant methods, which
		-- are top-level.  A use of a "conjurable"
		-- Id may appear out of thin air -- e.g.,
		-- specialiser conjuring up refs to const methods.
    Bool	-- IgnoreINLINEPragma flag
		-- False <=> OK to use INLINEPragma information
		-- True  <=> ignore INLINEPragma information

    (Id -> IdSet -> Bool)	-- Tells whether an Id occurrence is interesting,
				-- given the set of in-scope variables

    IdSet	-- In-scope Ids


addNewCands :: OccEnv -> [Id] -> OccEnv
addNewCands (OccEnv kd ks kc ip ifun cands) ids
  = OccEnv kd ks kc ip ifun (cands `unionIdSets` mkIdSet ids)

addNewCand :: OccEnv -> Id -> OccEnv
addNewCand (OccEnv ks kd kc ip ifun cands) id
  = OccEnv kd ks kc ip ifun (addOneToIdSet cands id)

isCandidate :: OccEnv -> Id -> Bool
isCandidate (OccEnv _ _ _ _ ifun cands) id = ifun id cands

inlineMe :: OccEnv -> Id -> Bool
inlineMe env id
  = {-	See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs 
	not ignore_inline_prag && 
    -}
    idWantsToBeINLINEd id

keepUnusedBinding :: OccEnv -> Id -> Bool
keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _ _) binder
  = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder))

keepBecauseConjurable :: OccEnv -> Id -> Bool
keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _ _) binder
  = False
    {- keep_conjurable && isConstMethodId binder -}

type UsageDetails = IdEnv BinderInfo	-- A finite map from ids to their usage

combineUsageDetails, combineAltsUsageDetails
	:: UsageDetails -> UsageDetails -> UsageDetails

combineUsageDetails usage1 usage2
  = combineIdEnvs addBinderInfo usage1 usage2

combineAltsUsageDetails usage1 usage2
  = combineIdEnvs orBinderInfo usage1 usage2

addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
addOneOcc usage id info
  = combineIdEnvs addBinderInfo usage (unitIdEnv id info)
	-- ToDo: make this more efficient

emptyDetails = (nullIdEnv :: UsageDetails)

unitDetails id info = (unitIdEnv id info :: UsageDetails)

tagBinders :: UsageDetails	    -- Of scope
	   -> [Id]		    -- Binders
	   -> (UsageDetails, 	    -- Details with binders removed
	      [(Id,BinderInfo)])    -- Tagged binders

tagBinders usage binders =
 let
  usage' = usage `delManyFromIdEnv` binders
  uss    = [ (binder, usage_of usage binder) | binder <- binders ]
 in
 if isNullIdEnv usage' then
    (usage', uss)
 else
    (usage', uss)
{-
  = (usage `delManyFromIdEnv` binders,
     [ (binder, usage_of usage binder) | binder <- binders ]
    )
-}
tagBinder :: UsageDetails	    -- Of scope
	  -> Id			    -- Binders
	  -> (UsageDetails, 	    -- Details with binders removed
	      (Id,BinderInfo))	    -- Tagged binders

tagBinder usage binder =
 let
   usage'  = usage `delOneFromIdEnv` binder
   us      = usage_of usage binder 
   cont =
    if isNullIdEnv usage' then  -- bogus test to force evaluation.
       (usage', (binder, us))
    else
       (usage', (binder, us))
 in
 case us of { DeadCode -> cont; _ -> cont }

--   (binder, usage_of usage binder)


usage_of usage binder
  | isExported binder = ManyOcc 0 -- Visible-elsewhere things count as many
  | otherwise
  = case (lookupIdEnv usage binder) of
      Nothing   -> DeadCode
      Just info -> info

isNeeded env usage binder
  = case (usage_of usage binder) of
      DeadCode  -> keepUnusedBinding env binder	-- Maybe keep it anyway
      other     -> True
\end{code}


%************************************************************************
%*									*
\subsection[OccurAnal-main]{Counting occurrences: main function}
%*									*
%************************************************************************

Here's the externally-callable interface:

\begin{code}
occurAnalyseBinds
	:: [CoreBinding]		-- input
	-> (SimplifierSwitch -> Bool)
	-> [SimplifiableCoreBinding]	-- output

occurAnalyseBinds binds simplifier_sw_chkr
  | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
				     (vcat (map ppr_bind binds'))
				     binds'
  | otherwise		  = binds'
  where
    (_, binds') = doo initial_env binds

    initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
			 (simplifier_sw_chkr KeepSpecPragmaIds)
			 (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
			 (simplifier_sw_chkr IgnoreINLINEPragma)
			 (\id in_scope -> isLocallyDefined id)	-- Anything local is interesting
			 emptyIdSet				-- Not actually used

    doo env [] = (emptyDetails, [])
    doo env (bind:binds)
      = (final_usage, new_binds ++ the_rest)
      where
	new_env			 = env `addNewCands` (bindersOf bind)
	(binds_usage, the_rest)  = doo new_env binds
	(final_usage, new_binds) = occAnalBind env bind binds_usage

	-- This really ought to be done properly by PprCore, but
	-- it isn't.  pprCoreBinding only works on Id binders, and
	-- the general case is complicated by the fact that it has to work
	-- for interface files too.  Sigh

ppr_bind bind@(NonRec binder expr)
  = ppr PprDebug bind

ppr_bind bind@(Rec binds)
  = vcat [ptext SLIT("Rec {"),
	      nest 2 (ppr PprDebug bind),
	      ptext SLIT("end Rec }")]
\end{code}

\begin{code}
occurAnalyseExpr :: (Id -> Bool)	-- Tells if a variable is interesting
		 -> CoreExpr
		 -> (IdEnv BinderInfo,	-- Occ info for interesting free vars
		     SimplifiableCoreExpr)

occurAnalyseExpr interesting expr
  = occAnal initial_env expr
  where
    initial_env = OccEnv False {- Drop unused bindings -}
			 False {- Drop SpecPragmaId bindings -}
			 True  {- Keep conjurable Ids -}
			 False {- Do not ignore INLINE Pragma -}
			 (\id locals -> interesting id || elementOfIdSet id locals)
			 emptyIdSet

occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
occurAnalyseGlobalExpr expr
  = 	-- Top level expr, so no interesting free vars, and
	-- discard occurence info returned
    snd (occurAnalyseExpr (\_ -> False) expr)
\end{code}

%************************************************************************
%*									*
\subsection[OccurAnal-main]{Counting occurrences: main function}
%*									*
%************************************************************************

Bindings
~~~~~~~~

\begin{code}
type Node details = (details, Int, [Int])	-- The Ints are gotten from the Unique,
						-- which is gotten from the Id.
type Details1	  = (Id, (UsageDetails, SimplifiableCoreExpr))
type Details2	  = ((Id, BinderInfo), SimplifiableCoreExpr)


occAnalBind :: OccEnv
	    -> CoreBinding
	    -> UsageDetails		-- Usage details of scope
	    -> (UsageDetails,		-- Of the whole let(rec)
		[SimplifiableCoreBinding])

occAnalBind env (NonRec binder rhs) body_usage
  | isNeeded env body_usage binder		-- It's mentioned in body
  = (final_body_usage `combineUsageDetails` rhs_usage,
     [NonRec tagged_binder rhs'])

  | otherwise			-- Not mentioned, so drop dead code
  = (body_usage, [])

  where
    binder'			      = nukeNoInlinePragma binder
    (rhs_usage, rhs')		      = occAnalRhs env binder' rhs
    (final_body_usage, tagged_binder) = tagBinder body_usage binder'
\end{code}

Dropping dead code for recursive bindings is done in a very simple way:

	the entire set of bindings is dropped if none of its binders are
	mentioned in its body; otherwise none are.

This seems to miss an obvious improvement.
@
	letrec  f = ...g...
		g = ...f...
	in
	...g...

===>

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

Now @f@ is unused. But dependency analysis will sort this out into a
@letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
It isn't easy to do a perfect job in one blow.  Consider

@
	letrec f = ...g...
	       g = ...h...
	       h = ...k...
	       k = ...m...
	       m = ...m...
	in
	...m...
@


\begin{code}
occAnalBind env (Rec pairs) body_usage
  = foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
  where
    pp_scc (CyclicSCC cycle) = hcat [text "Cyclic ", hcat (punctuate comma (map pp_item cycle))]
    pp_scc (AcyclicSCC item) = hcat [text "Acyclic ", pp_item item]
    pp_item (_, bndr, _)     = ppr PprDebug bndr

    binders = map fst pairs
    new_env = env `addNewCands` binders

    analysed_pairs :: [Details1]
    analysed_pairs  = [(nukeNoInlinePragma bndr, occAnalRhs new_env bndr rhs) | (bndr,rhs) <- pairs]

    sccs :: [SCC (Node Details1)]
    sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges


    ---- stuff for dependency analysis of binds -------------------------------
    edges :: [Node Details1]
    edges = _scc_ "occAnalBind.assoc"
	    [ (pair, IBOX(u2i (idUnique id)), edges_from rhs_usage)
	    | pair@(id, (rhs_usage, rhs)) <- analysed_pairs
	    ]

	-- (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 (lookupIdEnv rhs_usage bndr)]
	-- which has n**2 cost, and this meant that edges_from alone 
	-- consumed 10% of total runtime!
    edges_from :: UsageDetails -> [Int]
    edges_from rhs_usage = _scc_ "occAnalBind.edges_from"
			   keysUFM rhs_usage

    ---- stuff to "re-constitute" bindings from dependency-analysis info ------

	-- Non-recursive SCC
    do_final_bind (AcyclicSCC ((bndr, (rhs_usage, rhs')), _, _)) (body_usage, binds_so_far)
      | isNeeded env body_usage bndr
      = (combined_usage, new_bind : binds_so_far)	
      | otherwise
      = (body_usage, binds_so_far)			-- Dead code
      where
	total_usage       	      = combineUsageDetails body_usage rhs_usage
	(combined_usage, tagged_bndr) = tagBinder total_usage bndr
	new_bind		      = NonRec tagged_bndr rhs'

	-- Recursive SCC
    do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far)
      | any (isNeeded env body_usage) bndrs
      = (combined_usage, final_bind:binds_so_far)
      | otherwise
      = (body_usage, binds_so_far)			-- Dead code
      where
	pairs 				 = [pair      | (pair, _, _) <- cycle]
	bndrs				 = [bndr      | (bndr, _)           <- pairs]
	rhs_usages		         = [rhs_usage | (_, (rhs_usage, _)) <- pairs]
	total_usage		         = foldr combineUsageDetails body_usage rhs_usages
	(combined_usage, tagged_binders) = tagBinders total_usage bndrs
	final_bind			 = Rec (reOrderRec env new_cycle)

	new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_binders cycle)
	mk_new_bind tagged_bndr ((_, (_, rhs')), key, keys) = ((tagged_bndr, rhs'), key, keys)
\end{code}

@reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
strongly connected component (there's guaranteed to be a cycle).  It returns the
same pairs, but 
	a) in a better order,
	b) with some of the Ids having a IMustNotBeINLINEd pragma

The "no-inline" 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.

Here's a case that bit me:

	letrec
		a = b
		b = \x. BIG
	in
	...a...a...a....

Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
(The first binding was a var-rhs; the second was a one-occ.)  So the simplifier looped.
My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
Perhaps something cleverer would suffice.

\begin{code}
reOrderRec
	:: OccEnv
	-> SCC (Node Details2)
	-> [Details2]
			-- Sorted into a plausible order.  Enough of the Ids have
			--	dontINLINE pragmas that there are no loops left.

	-- Non-recursive case
reOrderRec env (AcyclicSCC (pair, _, _)) = [pair]

	-- Common case of simple self-recursion
reOrderRec env (CyclicSCC [bind])
  = [((addNoInlinePragma bndr, occ_info), rhs)]
  where
    (((bndr,occ_info), rhs), _, _) = bind<commit_msg>[project @ 1997-09-04 20:07:13 by sof] doc update<commit_after>%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%************************************************************************
%*									*
\section[OccurAnal]{Occurrence analysis pass}
%*									*
%************************************************************************

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

\begin{code}
#include "HsVersions.h"

module OccurAnal (
	occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr
    ) where

IMP_Ubiq(){-uitous-}
IMPORT_1_3(List(partition))

import BinderInfo
import CmdLineOpts	( opt_D_dump_occur_anal, SimplifierSwitch(..) )
import CoreSyn
import Digraph		( stronglyConnComp, stronglyConnCompR, SCC(..) )
import Id		( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
			  idType, idUnique, SYN_IE(Id),
			  emptyIdSet, unionIdSets, mkIdSet,
			  unitIdSet, elementOfIdSet,
			  addOneToIdSet, SYN_IE(IdSet),
			  nullIdEnv, unitIdEnv, combineIdEnvs,
			  delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv, 
			  mapIdEnv, lookupIdEnv, SYN_IE(IdEnv), 
			  GenId{-instance Eq-}
			)
import Name		( isExported, isLocallyDefined )
import Type		( getFunTy_maybe, splitForAllTy )
import Maybes		( maybeToBool )
import Outputable	( PprStyle(..), Outputable(..){-instance * (,) -} )
import PprCore
import PprType		( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
import Pretty		( Doc, vcat, ptext, nest, punctuate, comma, hcat, text )
import TyVar		( GenTyVar{-instance Eq-} )
import Unique		( Unique{-instance Eq-}, u2i )
import UniqFM		( keysUFM ) 
import Util		( assoc, zipEqual, zipWithEqual, Ord3(..)
			, pprTrace, panic 
#ifdef DEBUG
			, assertPanic
#endif
			)

isSpecPragmaId_maybe x = Nothing -- ToDo:!trace "OccurAnal.isSpecPragmaId_maybe"
\end{code}


%************************************************************************
%*									*
\subsection[OccurAnal-types]{Data types}
%*									*
%************************************************************************

\begin{code}
data OccEnv =
  OccEnv
    Bool	-- Keep-unused-bindings flag
		-- False <=> OK to chuck away binding
		-- 	     and ignore occurrences within it
    Bool	-- Keep-spec-pragma-ids flag
		-- False <=> OK to chuck away spec pragma bindings
		-- 	     and ignore occurrences within it
    Bool	-- Keep-conjurable flag
		-- False <=> OK to throw away *dead*
		-- "conjurable" Ids; at the moment, that
		-- *only* means constant methods, which
		-- are top-level.  A use of a "conjurable"
		-- Id may appear out of thin air -- e.g.,
		-- specialiser conjuring up refs to const methods.
    Bool	-- IgnoreINLINEPragma flag
		-- False <=> OK to use INLINEPragma information
		-- True  <=> ignore INLINEPragma information

    (Id -> IdSet -> Bool)	-- Tells whether an Id occurrence is interesting,
				-- given the set of in-scope variables

    IdSet	-- In-scope Ids


addNewCands :: OccEnv -> [Id] -> OccEnv
addNewCands (OccEnv kd ks kc ip ifun cands) ids
  = OccEnv kd ks kc ip ifun (cands `unionIdSets` mkIdSet ids)

addNewCand :: OccEnv -> Id -> OccEnv
addNewCand (OccEnv ks kd kc ip ifun cands) id
  = OccEnv kd ks kc ip ifun (addOneToIdSet cands id)

isCandidate :: OccEnv -> Id -> Bool
isCandidate (OccEnv _ _ _ _ ifun cands) id = ifun id cands

inlineMe :: OccEnv -> Id -> Bool
inlineMe env id
  = {-	See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs 
	not ignore_inline_prag && 
    -}
    idWantsToBeINLINEd id

keepUnusedBinding :: OccEnv -> Id -> Bool
keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _ _) binder
  = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder))

keepBecauseConjurable :: OccEnv -> Id -> Bool
keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _ _) binder
  = False
    {- keep_conjurable && isConstMethodId binder -}

type UsageDetails = IdEnv BinderInfo	-- A finite map from ids to their usage

combineUsageDetails, combineAltsUsageDetails
	:: UsageDetails -> UsageDetails -> UsageDetails

combineUsageDetails usage1 usage2
  = combineIdEnvs addBinderInfo usage1 usage2

combineAltsUsageDetails usage1 usage2
  = combineIdEnvs orBinderInfo usage1 usage2

addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
addOneOcc usage id info
  = combineIdEnvs addBinderInfo usage (unitIdEnv id info)
	-- ToDo: make this more efficient

emptyDetails = (nullIdEnv :: UsageDetails)

unitDetails id info = (unitIdEnv id info :: UsageDetails)

tagBinders :: UsageDetails	    -- Of scope
	   -> [Id]		    -- Binders
	   -> (UsageDetails, 	    -- Details with binders removed
	      [(Id,BinderInfo)])    -- Tagged binders

tagBinders usage binders =
 let
  usage' = usage `delManyFromIdEnv` binders
  uss    = [ (binder, usage_of usage binder) | binder <- binders ]
 in
 if isNullIdEnv usage' then
    (usage', uss)
 else
    (usage', uss)
{-
  = (usage `delManyFromIdEnv` binders,
     [ (binder, usage_of usage binder) | binder <- binders ]
    )
-}
tagBinder :: UsageDetails	    -- Of scope
	  -> Id			    -- Binders
	  -> (UsageDetails, 	    -- Details with binders removed
	      (Id,BinderInfo))	    -- Tagged binders

tagBinder usage binder =
 let
   usage'  = usage `delOneFromIdEnv` binder
   us      = usage_of usage binder 
   cont =
    if isNullIdEnv usage' then  -- bogus test to force evaluation.
       (usage', (binder, us))
    else
       (usage', (binder, us))
 in
 case us of { DeadCode -> cont; _ -> cont }

--   (binder, usage_of usage binder)


usage_of usage binder
  | isExported binder = ManyOcc 0 -- Visible-elsewhere things count as many
  | otherwise
  = case (lookupIdEnv usage binder) of
      Nothing   -> DeadCode
      Just info -> info

isNeeded env usage binder
  = case (usage_of usage binder) of
      DeadCode  -> keepUnusedBinding env binder	-- Maybe keep it anyway
      other     -> True
\end{code}


%************************************************************************
%*									*
\subsection[OccurAnal-main]{Counting occurrences: main function}
%*									*
%************************************************************************

Here's the externally-callable interface:

\begin{code}
occurAnalyseBinds
	:: [CoreBinding]		-- input
	-> (SimplifierSwitch -> Bool)
	-> [SimplifiableCoreBinding]	-- output

occurAnalyseBinds binds simplifier_sw_chkr
  | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
				     (vcat (map ppr_bind binds'))
				     binds'
  | otherwise		  = binds'
  where
    (_, binds') = doo initial_env binds

    initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
			 (simplifier_sw_chkr KeepSpecPragmaIds)
			 (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
			 (simplifier_sw_chkr IgnoreINLINEPragma)
			 (\id in_scope -> isLocallyDefined id)	-- Anything local is interesting
			 emptyIdSet				-- Not actually used

    doo env [] = (emptyDetails, [])
    doo env (bind:binds)
      = (final_usage, new_binds ++ the_rest)
      where
	new_env			 = env `addNewCands` (bindersOf bind)
	(binds_usage, the_rest)  = doo new_env binds
	(final_usage, new_binds) = occAnalBind env bind binds_usage

	-- This really ought to be done properly by PprCore, but
	-- it isn't.  pprCoreBinding only works on Id binders, and
	-- the general case is complicated by the fact that it has to work
	-- for interface files too.  Sigh

ppr_bind bind@(NonRec binder expr)
  = ppr PprDebug bind

ppr_bind bind@(Rec binds)
  = vcat [ptext SLIT("Rec {"),
	      nest 2 (ppr PprDebug bind),
	      ptext SLIT("end Rec }")]
\end{code}

\begin{code}
occurAnalyseExpr :: (Id -> Bool)	-- Tells if a variable is interesting
		 -> CoreExpr
		 -> (IdEnv BinderInfo,	-- Occ info for interesting free vars
		     SimplifiableCoreExpr)

occurAnalyseExpr interesting expr
  = occAnal initial_env expr
  where
    initial_env = OccEnv False {- Drop unused bindings -}
			 False {- Drop SpecPragmaId bindings -}
			 True  {- Keep conjurable Ids -}
			 False {- Do not ignore INLINE Pragma -}
			 (\id locals -> interesting id || elementOfIdSet id locals)
			 emptyIdSet

occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
occurAnalyseGlobalExpr expr
  = 	-- Top level expr, so no interesting free vars, and
	-- discard occurence info returned
    snd (occurAnalyseExpr (\_ -> False) expr)
\end{code}

%************************************************************************
%*									*
\subsection[OccurAnal-main]{Counting occurrences: main function}
%*									*
%************************************************************************

Bindings
~~~~~~~~

\begin{code}
type Node details = (details, Int, [Int])	-- The Ints are gotten from the Unique,
						-- which is gotten from the Id.
type Details1	  = (Id, (UsageDetails, SimplifiableCoreExpr))
type Details2	  = ((Id, BinderInfo), SimplifiableCoreExpr)


occAnalBind :: OccEnv
	    -> CoreBinding
	    -> UsageDetails		-- Usage details of scope
	    -> (UsageDetails,		-- Of the whole let(rec)
		[SimplifiableCoreBinding])

occAnalBind env (NonRec binder rhs) body_usage
  | isNeeded env body_usage binder		-- It's mentioned in body
  = (final_body_usage `combineUsageDetails` rhs_usage,
     [NonRec tagged_binder rhs'])

  | otherwise			-- Not mentioned, so drop dead code
  = (body_usage, [])

  where
    binder'			      = nukeNoInlinePragma binder
    (rhs_usage, rhs')		      = occAnalRhs env binder' rhs
    (final_body_usage, tagged_binder) = tagBinder body_usage binder'
\end{code}

Dropping dead code for recursive bindings is done in a very simple way:

	the entire set of bindings is dropped if none of its binders are
	mentioned in its body; otherwise none are.

This seems to miss an obvious improvement.
@
	letrec  f = ...g...
		g = ...f...
	in
	...g...

===>

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

Now @f@ is unused. But dependency analysis will sort this out into a
@letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
It isn't easy to do a perfect job in one blow.  Consider

@
	letrec f = ...g...
	       g = ...h...
	       h = ...k...
	       k = ...m...
	       m = ...m...
	in
	...m...
@


\begin{code}
occAnalBind env (Rec pairs) body_usage
  = foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
  where
    pp_scc (CyclicSCC cycle) = hcat [text "Cyclic ", hcat (punctuate comma (map pp_item cycle))]
    pp_scc (AcyclicSCC item) = hcat [text "Acyclic ", pp_item item]
    pp_item (_, bndr, _)     = ppr PprDebug bndr

    binders = map fst pairs
    new_env = env `addNewCands` binders

    analysed_pairs :: [Details1]
    analysed_pairs  = [(nukeNoInlinePragma bndr, occAnalRhs new_env bndr rhs) | (bndr,rhs) <- pairs]

    sccs :: [SCC (Node Details1)]
    sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges


    ---- stuff for dependency analysis of binds -------------------------------
    edges :: [Node Details1]
    edges = _scc_ "occAnalBind.assoc"
	    [ (pair, IBOX(u2i (idUnique id)), edges_from rhs_usage)
	    | pair@(id, (rhs_usage, rhs)) <- analysed_pairs
	    ]

	-- (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 (lookupIdEnv rhs_usage bndr)]
	-- which has n**2 cost, and this meant that edges_from alone 
	-- consumed 10% of total runtime!
    edges_from :: UsageDetails -> [Int]
    edges_from rhs_usage = _scc_ "occAnalBind.edges_from"
			   keysUFM rhs_usage

    ---- stuff to "re-constitute" bindings from dependency-analysis info ------

	-- Non-recursive SCC
    do_final_bind (AcyclicSCC ((bndr, (rhs_usage, rhs')), _, _)) (body_usage, binds_so_far)
      | isNeeded env body_usage bndr
      = (combined_usage, new_bind : binds_so_far)	
      | otherwise
      = (body_usage, binds_so_far)			-- Dead code
      where
	total_usage       	      = combineUsageDetails body_usage rhs_usage
	(combined_usage, tagged_bndr) = tagBinder total_usage bndr
	new_bind		      = NonRec tagged_bndr rhs'

	-- Recursive SCC
    do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far)
      | any (isNeeded env body_usage) bndrs
      = (combined_usage, final_bind:binds_so_far)
      | otherwise
      = (body_usage, binds_so_far)			-- Dead code
      where
	pairs 				 = [pair      | (pair, _, _) <- cycle]
	bndrs				 = [bndr      | (bndr, _)           <- pairs]
	rhs_usages		         = [rhs_usage | (_, (rhs_usage, _)) <- pairs]
	total_usage		         = foldr combineUsageDetails body_usage rhs_usages
	(combined_usage, tagged_binders) = tagBinders total_usage bndrs
	final_bind			 = Rec (reOrderRec env new_cycle)

	new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_binders cycle)
	mk_new_bind tagged_bndr ((_, (_, rhs')), key, keys) = ((tagged_bndr, rhs'), key, keys)
\end{code}

@reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
strongly connected component (there's guaranteed to be a cycle).  It returns the
same pairs, but 
	a) in a better order,
	b) with some of the Ids having a IMustNotBeINLINEd pragma

The "no-inline" 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.

Here's a case that bit me:

	letrec
		a = b
		b = \x. BIG
	in
	...a...a...a....

Re-ordering doesn't change the order of bindings, but there was no loop-breaker.

My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
Perhaps something cleverer would suffice.

You might think that you can prevent non-termination simply by making
sure that we simplify a recursive binding's RHS in an environment that
simply clones the recursive Id.  But no.  Consider

		letrec f = \x -> let z = f x' in ...

		in
		let n = f y
		in
		case n of { ... }

We bind n to its *simplified* RHS, we then *re-simplify* it when
we inline n.  Then we may well inline f; and then the same thing
happens with z!

I don't think it's possible to prevent non-termination by environment
manipulation in this way.  Apart from anything else, successive
iterations of the simplifier may unroll recursive loops in cases like
that above.  The idea of beaking every recursive loop with an
IMustNotBeINLINEd pragma is much much better.


\begin{code}
reOrderRec
	:: OccEnv
	-> SCC (Node Details2)
	-> [Details2]
			-- Sorted into a plausible order.  Enough of the Ids have
			--	dontINLINE pragmas that there are no loops left.

	-- Non-recursive case
reOrderRec env (AcyclicSCC (pair, _, _)) = [pair]

	-- Common case of simple self-recursion
reOrderRec env (CyclicSCC [bind])
  = [((addNoInlinePragma bndr, occ_info), rhs)]
  where
    (((bndr,occ_info), rhs), _, _) = bind
{'fraction_non_alphanumeric': 0.13762609280430396, 'fraction_numerical': 0.0026899798251513113, 'mean_word_length': 3.242048209955784, 'pattern_counts': {'":': 0, '<': 29, '<?xml version=': 0, '>': 108, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4994518', 'n_tokens_mistral': 10498, 'n_tokens_neox': 9568, 'n_words': 3094}