getImplicitBinds :: TypeEnv -> [CoreBind]
getImplicitBinds type_env
  = map get_defn (concatMap implicit_ids (typeEnvElts type_env))
  where
    implicit_ids (ATyCon tc)  = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
    implicit_ids (AClass cls) = classAllSelIds cls
    implicit_ids _            = []
    
    get_defn :: Id -> CoreBind
    get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))

type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})
  -- Maps each top-level Id to its new Name (the Id is tidied in step 2)
  -- The Unique is unchanged.  If the new Name is external, it will be
  -- visible in the interface file.  
  --
  -- Bool => expose unfolding or not.

chooseExternalIds :: HscEnv
                  -> Module
                  -> Bool -> Bool
		  -> [CoreBind]
                  -> [CoreBind]
		  -> [CoreRule]
                  -> IO (UnfoldEnv, TidyOccEnv)
	-- Step 1 from the notes above

chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules
  = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env
       ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders
       ; tidy_internal internal_ids unfold_env1 occ_env1 }
 where
  nc_var = hsc_NC hsc_env 

  -- init_ext_ids is the intial list of Ids that should be
  -- externalised.  It serves as the starting point for finding a
  -- deterministic, tidy, renaming for all external Ids in this
  -- module.
  -- 
  -- It is sorted, so that it has adeterministic order (i.e. it's the
  -- same list every time this module is compiled), in contrast to the
  -- bindings, which are ordered non-deterministically.
  init_work_list = zip init_ext_ids init_ext_ids
  init_ext_ids   = sortBy (compare `on` getOccName) $
                   filter is_external binders

  -- An Id should be external if either (a) it is exported or
  -- (b) it appears in the RHS of a local rule for an imported Id.   
  -- See Note [Which rules to expose]
  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars
  rule_rhs_vars = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet imp_id_rules

  binders          = bindersOfBinds binds
  implicit_binders = bindersOfBinds implicit_binds
  binder_set       = mkVarSet binders

  avoids   = [getOccName name | bndr <- binders ++ implicit_binders,
                                let name = idName bndr,
                                isExternalName name ]
		-- In computing our "avoids" list, we must include
		--	all implicit Ids
		--	all things with global names (assigned once and for
		--					all by the renamer)
		-- since their names are "taken".
		-- The type environment is a convenient source of such things.
                -- In particular, the set of binders doesn't include
                -- implicit Ids at this stage.

	-- We also make sure to avoid any exported binders.  Consider
	--	f{-u1-} = 1	-- Local decl
	--	...
	--	f{-u2-} = 2	-- Exported decl
	--
	-- The second exported decl must 'get' the name 'f', so we
	-- have to put 'f' in the avoids list before we get to the first
	-- decl.  tidyTopId then does a no-op on exported binders.
  init_occ_env = initTidyOccEnv avoids


  search :: [(Id,Id)]    -- The work-list: (external id, referrring id)
  	    		 -- Make a tidy, external Name for the external id,
                         --   add it to the UnfoldEnv, and do the same for the
                         --   transitive closure of Ids it refers to
  	    		 -- The referring id is used to generate a tidy
			 ---  name for the external id
         -> UnfoldEnv    -- id -> (new Name, show_unfold)
         -> TidyOccEnv   -- occ env for choosing new Names
         -> IO (UnfoldEnv, TidyOccEnv)

  search [] unfold_env occ_env = return (unfold_env, occ_env)

  search ((idocc,referrer) : rest) unfold_env occ_env
    | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env
    | otherwise = do
      (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc
      let 
          (new_ids, show_unfold)
                | omit_prags = ([], False)
                | otherwise  = addExternal expose_all refined_id

		-- 'idocc' is an *occurrence*, but we need to see the
		-- unfolding in the *definition*; so look up in binder_set
          refined_id = case lookupVarSet binder_set idocc of
                         Just id -> id
                         Nothing -> WARN( True, ppr idocc ) idocc

          unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)
          referrer' | isExportedId refined_id = refined_id
                    | otherwise               = referrer
      --
      search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env'

  tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv
                -> IO (UnfoldEnv, TidyOccEnv)
  tidy_internal []       unfold_env occ_env = return (unfold_env,occ_env)
  tidy_internal (id:ids) unfold_env occ_env = do
      (occ_env', name') <- tidyTopName mod nc_var Nothing occ_env id
      let unfold_env' = extendVarEnv unfold_env id (name',False)
      tidy_internal ids unfold_env' occ_env'

addExternal :: Bool -> Id -> ([Id],Bool)
addExternal expose_all id = (new_needed_ids, show_unfold)
  where
    new_needed_ids = unfold_ids ++
                     filter (\id -> isLocalId id &&
                                    not (id `elemVarSet` unfold_set))
                       (varSetElems spec_ids) -- XXX non-det ordering

    idinfo	   = idInfo id
    never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))
    loop_breaker   = isNonRuleLoopBreaker (occInfo idinfo)
    bottoming_fn   = isBottomingSig (strictnessInfo idinfo `orElse` topSig)
    spec_ids	   = specInfoFreeVars (specInfo idinfo)

	-- Stuff to do with the Id's unfolding
	-- We leave the unfolding there even if there is a worker
	-- In GHCI the unfolding is used by importers
    show_unfold = isJust mb_unfold_ids
    (unfold_set, unfold_ids) = mb_unfold_ids `orElse` (emptyVarSet, [])

    mb_unfold_ids :: Maybe (IdSet, [Id])	-- Nothing => don't unfold
    mb_unfold_ids = case unfoldingInfo idinfo of
		      CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_guidance = guide } 
					    | show_unfolding src guide
					    -> Just (unf_ext_ids src unf_rhs)
                      DFunUnfolding _ _ ops -> Just (exprsFvsInOrder (dfunArgExprs ops))
		      _                     -> Nothing
                  where
                    unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v])
                    unf_ext_ids _           unf_rhs = exprFvsInOrder unf_rhs
		    -- For a wrapper, externalise the wrapper id rather than the
		    -- fvs of the rhs.  The two usually come down to the same thing
		    -- but I've seen cases where we had a wrapper id $w but a
		    -- rhs where $w had been inlined; see Trac #3922

    show_unfolding unf_source unf_guidance
       =  expose_all 	     -- 'expose_all' says to expose all 
			     -- unfoldings willy-nilly

       || isStableSource unf_source	     -- Always expose things whose 
       	  		     		     -- source is an inline rule

       || not (bottoming_fn	 -- No need to inline bottom functions
	   || never_active	 -- Or ones that say not to
	   || loop_breaker	 -- Or that are loop breakers
	   || neverUnfoldGuidance unf_guidance)

-- We want a deterministic free-variable list.  exprFreeVars gives us
-- a VarSet, which is in a non-deterministic order when converted to a
-- list.  Hence, here we define a free-variable finder that returns
-- the free variables in the order that they are encountered.
--
-- Note [choosing external names]

exprFvsInOrder :: CoreExpr -> (VarSet, [Id])
exprFvsInOrder e = run (dffvExpr e)

exprsFvsInOrder :: [CoreExpr] -> (VarSet, [Id])
exprsFvsInOrder es = run (mapM_ dffvExpr es)

run :: DFFV () -> (VarSet, [Id])
run (DFFV m) = case m emptyVarSet [] of
                 (set,ids,_) -> (set,ids)

newtype DFFV a = DFFV (VarSet -> [Var] -> (VarSet,[Var],a))

instance Monad DFFV where
  return a = DFFV $ \set ids -> (set, ids, a)
  (DFFV m) >>= k = DFFV $ \set ids ->
    case m set ids of
       (set',ids',a) -> case k a of
                          DFFV f -> f set' ids' 

insert :: Var -> DFFV ()
insert v = DFFV $ \ set ids  -> case () of 
 _ | v `elemVarSet` set -> (set,ids,())
   | otherwise          -> (extendVarSet set v, v:ids, ())

dffvExpr :: CoreExpr -> DFFV ()
dffvExpr e = go emptyVarSet e
  where
    go scope e = case e of
      Var v | isLocalId v && not (v `elemVarSet` scope) -> insert v
      App e1 e2          -> do go scope e1; go scope e2
      Lam v e            -> go (extendVarSet scope v) e
      Note _ e           -> go scope e
      Cast e _           -> go scope e
      Let (NonRec x r) e -> do go scope r; go (extendVarSet scope x) e
      Let (Rec prs) e    -> do let scope' = extendVarSetList scope (map fst prs)
                               mapM_ (go scope') (map snd prs)
                               go scope' e
      Case e b _ as      -> do go scope e
                               mapM_ (go_alt (extendVarSet scope b)) as
      _other             -> return ()

    go_alt scope (_,xs,r) = go (extendVarSetList scope xs) r

tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv
	    -> Id -> IO (TidyOccEnv, Name)
tidyTopName mod nc_var maybe_ref occ_env id
  | global && internal = return (occ_env, localiseName name)

  | global && external = return (occ_env, name)
	-- Global names are assumed to have been allocated by the renamer,
	-- so they already have the "right" unique
	-- And it's a system-wide unique too

  -- Now we get to the real reason that all this is in the IO Monad:
  -- we have to update the name cache in a nice atomic fashion

  | local  && internal = do { nc <- readIORef nc_var
			    ; let (nc', new_local_name) = mk_new_local nc
			    ; writeIORef nc_var nc'
			    ; return (occ_env', new_local_name) }
	-- Even local, internal names must get a unique occurrence, because
	-- if we do -split-objs we externalise the name later, in the code generator
	--
	-- Similarly, we must make sure it has a system-wide Unique, because
	-- the byte-code generator builds a system-wide Name->BCO symbol table

  | local  && external = do { nc <- readIORef nc_var
			    ; let (nc', new_external_name) = mk_new_external nc
			    ; writeIORef nc_var nc'
			    ; return (occ_env', new_external_name) }

  | otherwise = panic "tidyTopName"
  where
    name	= idName id
    external    = isJust maybe_ref
    global	= isExternalName name
    local	= not global
    internal	= not external
    loc		= nameSrcSpan name

    old_occ     = nameOccName name
    new_occ
      | Just ref <- maybe_ref, ref /= id = 
          mkOccName (occNameSpace old_occ) $
             let
                 ref_str = occNameString (getOccName ref)
                 occ_str = occNameString old_occ
             in
             case occ_str of
               '$':'w':_ -> occ_str
                  -- workers: the worker for a function already
                  -- includes the occname for its parent, so there's
                  -- no need to prepend the referrer.
               _other | isSystemName name -> ref_str
                      | otherwise         -> ref_str ++ '_' : occ_str
                  -- If this name was system-generated, then don't bother
                  -- to retain its OccName, just use the referrer.  These
                  -- system-generated names will become "f1", "f2", etc. for
                  -- a referrer "f".
      | otherwise = old_occ

    (occ_env', occ') = tidyOccName occ_env new_occ

    mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc)
 		    where
		      (us1, us2) = splitUniqSupply (nsUniqs nc)
		      uniq	 = uniqFromSupply us1

    mk_new_external nc = allocateGlobalBinder nc mod occ' loc
	-- If we want to externalise a currently-local name, check
	-- whether we have already assigned a unique for it.
	-- If so, use it; if not, extend the table.
	-- All this is done by allcoateGlobalBinder.
	-- This is needed when *re*-compiling a module in GHCi; we must
	-- use the same name for externally-visible things as we did before.

findExternalRules :: Bool	-- Omit pragmas
                  -> [CoreBind]
		  -> [CoreRule]	-- Local rules for imported fns
	          -> UnfoldEnv	-- Ids that are exported, so we need their rules
	          -> [CoreRule]
  -- The complete rules are gotten by combining
  --	a) local rules for imported Ids
  --	b) rules embedded in the top-level Ids
findExternalRules omit_prags binds imp_id_rules unfold_env
  | omit_prags = []
  | otherwise  = filterOut internal_rule (imp_id_rules ++ local_rules)
  where
    local_rules  = [ rule
 		   | id <- bindersOfBinds binds,
                     external_id id,
		     rule <- idCoreRules id
		   ]

    internal_rule rule
	=  any (not . external_id) (varSetElems (ruleLhsFreeIds rule))
		-- Don't export a rule whose LHS mentions a locally-defined
		--  Id that is completely internal (i.e. not visible to an
		-- importing module)

    external_id id
      | Just (name,_) <- lookupVarEnv unfold_env id = isExternalName name
      | otherwise = False

-- TopTidyEnv: when tidying we need to know
--   * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.  
--	  These may have arisen because the
--	  renamer read in an interface file mentioning M.$wf, say,
--	  and assigned it unique r77.  If, on this compilation, we've
--	  invented an Id whose name is $wf (but with a different unique)
--	  we want to rename it to have unique r77, so that we can do easy
--	  comparisons with stuff from the interface file
--
--   * occ_env: The TidyOccEnv, which tells us which local occurrences 
--     are 'used'
--
--   * subst_env: A Var->Var mapping that substitutes the new Var for the old

tidyTopBinds :: HscEnv
	     -> UnfoldEnv
             -> TidyOccEnv
	     -> [CoreBind]
	     -> (TidyEnv, [CoreBind])

tidyTopBinds hsc_env unfold_env init_occ_env binds
  = tidy init_env binds
  where
    init_env = (init_occ_env, emptyVarEnv)

    this_pkg = thisPackage (hsc_dflags hsc_env)

    tidy env []     = (env, [])
    tidy env (b:bs) = let (env1, b')  = tidyTopBind this_pkg unfold_env env b
			  (env2, bs') = tidy env1 bs
                      in
			  (env2, b':bs')

------------------------
tidyTopBind  :: PackageId
             -> UnfoldEnv
	     -> TidyEnv
             -> CoreBind
	     -> (TidyEnv, CoreBind)

tidyTopBind this_pkg unfold_env (occ_env,subst1) (NonRec bndr rhs)
  = (tidy_env2,  NonRec bndr' rhs')
  where
    Just (name',show_unfold) = lookupVarEnv unfold_env bndr
    caf_info      = hasCafRefs this_pkg subst1 (idArity bndr) rhs
    (bndr', rhs') = tidyTopPair show_unfold tidy_env2 caf_info name' (bndr, rhs)
    subst2        = extendVarEnv subst1 bndr bndr'
    tidy_env2     = (occ_env, subst2)

tidyTopBind this_pkg unfold_env (occ_env,subst1) (Rec prs)
  = (tidy_env2, Rec prs')
  where
    prs' = [ tidyTopPair show_unfold tidy_env2 caf_info name' (id,rhs)
           | (id,rhs) <- prs,
             let (name',show_unfold) = 
                    expectJust "tidyTopBind" $ lookupVarEnv unfold_env id
           ]

    subst2    = extendVarEnvList subst1 (bndrs `zip` map fst prs')
    tidy_env2 = (occ_env, subst2)

    bndrs = map fst prs

	-- the CafInfo for a recursive group says whether *any* rhs in
	-- the group may refer indirectly to a CAF (because then, they all do).
    caf_info 
	| or [ mayHaveCafRefs (hasCafRefs this_pkg subst1 (idArity bndr) rhs)
	     | (bndr,rhs) <- prs ] = MayHaveCafRefs
	| otherwise 		   = NoCafRefs

-----------------------------------------------------------
tidyTopPair :: Bool  -- show unfolding
	    -> TidyEnv 	-- The TidyEnv is used to tidy the IdInfo
			-- It is knot-tied: don't look at it!
	    -> CafInfo
	    -> Name		-- New name
	    -> (Id, CoreExpr) 	-- Binder and RHS before tidying
	    -> (Id, CoreExpr)
	-- This function is the heart of Step 2
	-- The rec_tidy_env is the one to use for the IdInfo
	-- It's necessary because when we are dealing with a recursive
	-- group, a variable late in the group might be mentioned
	-- in the IdInfo of one early in the group

tidyTopPair show_unfold rhs_tidy_env caf_info name' (bndr, rhs)
  = (bndr1, rhs1)
  where
    bndr1    = mkGlobalId details name' ty' idinfo'
    details  = idDetails bndr	-- Preserve the IdDetails
    ty'	     = tidyTopType (idType bndr)
    rhs1     = tidyExpr rhs_tidy_env rhs
    idinfo'  = tidyTopIdInfo rhs_tidy_env name' rhs rhs1 (idInfo bndr) 
                             show_unfold caf_info

-- tidyTopIdInfo creates the final IdInfo for top-level
-- binders.  There are two delicate pieces:
--
--  * Arity.  After CoreTidy, this arity must not change any more.
--	Indeed, CorePrep must eta expand where necessary to make
--	the manifest arity equal to the claimed arity.
--
--  * CAF info.  This must also remain valid through to code generation.
-- 	We add the info here so that it propagates to all
-- 	occurrences of the binders in RHSs, and hence to occurrences in
-- 	unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
--	CoreToStg makes use of this when constructing SRTs.
tidyTopIdInfo :: TidyEnv -> Name -> CoreExpr -> CoreExpr 
              -> IdInfo -> Bool -> CafInfo -> IdInfo
tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info
  | not is_external	-- For internal Ids (not externally visible)
  = vanillaIdInfo	-- we only need enough info for code generation
			-- Arity and strictness info are enough;
			--	c.f. CoreTidy.tidyLetBndr
	`setCafInfo` 	    caf_info
	`setArityInfo`	    arity
	`setStrictnessInfo` final_sig

  | otherwise		-- Externally-visible Ids get the whole lot
  = vanillaIdInfo
	`setCafInfo` 	       caf_info
	`setArityInfo`	       arity
	`setStrictnessInfo`    final_sig
        `setOccInfo`           robust_occ_info
	`setInlinePragInfo`    (inlinePragInfo idinfo)
	`setUnfoldingInfo`     unfold_info
		-- NB: we throw away the Rules
		-- They have already been extracted by findExternalRules
  where
    is_external = isExternalName name

    --------- OccInfo ------------
    robust_occ_info = zapFragileOcc (occInfo idinfo)
    -- It's important to keep loop-breaker information
    -- when we are doing -fexpose-all-unfoldings

    --------- Strictness ------------
    final_sig | Just sig <- strictnessInfo idinfo
              = WARN( _bottom_hidden sig, ppr name ) Just sig
              | Just (_, sig) <- mb_bot_str = Just sig
              | otherwise                   = Nothing

    -- If the cheap-and-cheerful bottom analyser can see that
    -- the RHS is bottom, it should jolly well be exposed
    _bottom_hidden id_sig = case mb_bot_str of
                               Nothing         -> False
                               Just (arity, _) -> not (appIsBottom id_sig arity)

    mb_bot_str = exprBotStrictness_maybe orig_rhs

    --------- Unfolding ------------
    unf_info = unfoldingInfo idinfo
    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
		| otherwise   = noUnfolding
    unf_from_rhs = mkTopUnfolding is_bot tidy_rhs
    is_bot = case final_sig of 
                Just sig -> isBottomingSig sig
                Nothing  -> False
    -- NB: do *not* expose the worker if show_unfold is off,
    --     because that means this thing is a loop breaker or
    --     marked NOINLINE or something like that
    -- This is important: if you expose the worker for a loop-breaker
    -- then you can make the simplifier go into an infinite loop, because
    -- in effect the unfolding is exposed.  See Trac #1709
    -- 
    -- You might think that if show_unfold is False, then the thing should
    -- not be w/w'd in the first place.  But a legitimate reason is this:
    -- 	  the function returns bottom
    -- In this case, show_unfold will be false (we don't expose unfoldings
    -- for bottoming functions), but we might still have a worker/wrapper
    -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.lhs

    --------- Arity ------------
    -- Usually the Id will have an accurate arity on it, because
    -- the simplifier has just run, but not always. 
    -- One case I found was when the last thing the simplifier
    -- did was to let-bind a non-atomic argument and then float
    -- it to the top level. So it seems more robust just to
    -- fix it here.
    arity = exprArity orig_rhs

hasCafRefs  :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
hasCafRefs this_pkg p arity expr 
  | is_caf || mentions_cafs = MayHaveCafRefs
  | otherwise 		    = NoCafRefs
 where
  mentions_cafs = isFastTrue (cafRefs p expr)
  is_dynamic_name = isDllName this_pkg 
  is_caf = not (arity > 0 || rhsIsStatic is_dynamic_name expr)

  -- NB. we pass in the arity of the expression, which is expected
  -- to be calculated by exprArity.  This is because exprArity
  -- knows how much eta expansion is going to be done by 
  -- CorePrep later on, and we don't want to duplicate that
  -- knowledge in rhsIsStatic below.

cafRefs :: VarEnv Id -> Expr a -> FastBool
cafRefs p (Var id)
	-- imported Ids first:
  | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id))
	-- now Ids local to this module:
  | otherwise =
     case lookupVarEnv p id of
	Just id' -> fastBool (mayHaveCafRefs (idCafInfo id'))
	Nothing  -> fastBool False

cafRefs _ (Lit _) 	       = fastBool False
cafRefs p (App f a) 	       = fastOr (cafRefs p f) (cafRefs p) a
cafRefs p (Lam _ e) 	       = cafRefs p e
cafRefs p (Let b e) 	       = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
cafRefs p (Case e _bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts)
cafRefs p (Note _n e) 	       = cafRefs p e
cafRefs p (Cast e _co)         = cafRefs p e
cafRefs _ (Type _) 	       = fastBool False

cafRefss :: VarEnv Id -> [Expr a] -> FastBool
cafRefss _ [] 	  = fastBool False
cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es

fastOr :: FastBool -> (a -> FastBool) -> a -> FastBool
-- hack for lazy-or over FastBool.
fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))