getTyConImplicitBinds :: TyCon -> [CoreBind]
getTyConImplicitBinds tc = map get_defn (mapCatMaybes dataConWrapId_maybe (tyConDataCons tc))

getClassImplicitBinds :: Class -> [CoreBind]
getClassImplicitBinds cls = map get_defn (classAllSelIds cls)

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]
                  -> VarEnv (Var, Var)
                  -> IO (UnfoldEnv, TidyOccEnv)
                  -- Step 1 from the notes above

chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules vect_vars
  = 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,
  -- (b) it appears in the RHS of a local rule for an imported Id, or
  -- (c) it is the vectorised version of an imported Id
  -- See Note [Which rules to expose]
  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars || id `elemVarSet` vect_var_vs
  rule_rhs_vars  = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet imp_id_rules
  vect_var_vs    = mkVarSet [var_v | (var, var_v) <- nameEnvElts vect_vars, isGlobalId var]

  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

                -- add vectorised version if any exists
          new_ids' = new_ids ++ maybeToList (fmap snd $ lookupVarEnv vect_vars idocc)
          
                -- '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 = bndrFvsInOrder show_unfold id
    idinfo         = idInfo id
    show_unfold    = show_unfolding (unfoldingInfo idinfo)
    never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))
    loop_breaker   = isStrongLoopBreaker (occInfo idinfo)
    bottoming_fn   = isBottomingSig (strictnessInfo 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_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })
       =  expose_all         -- 'expose_all' says to expose all
                             -- unfoldings willy-nilly

       || isStableSource src     -- 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 guidance)
    show_unfolding (DFunUnfolding {}) = True
    show_unfolding _                  = False

bndrFvsInOrder :: Bool -> Id -> [Id]
bndrFvsInOrder show_unfold id
  = run (dffvLetBndr show_unfold id)

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

newtype DFFV a
  = DFFV (VarSet              -- Envt: non-top-level things that are in scope
                              -- we don't want to record these as free vars
      -> (VarSet, [Var])      -- Input State: (set, list) of free vars so far
      -> ((VarSet,[Var]),a))  -- Output state

instance Functor DFFV where
    fmap = liftM

instance Applicative DFFV where
    pure = return
    (<*>) = ap

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

extendScope :: Var -> DFFV a -> DFFV a
extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st)

extendScopeList :: [Var] -> DFFV a -> DFFV a
extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st)

insert :: Var -> DFFV ()
insert v = DFFV $ \ env (set, ids) ->
           let keep_me = isLocalId v &&
                         not (v `elemVarSet` env) &&
                           not (v `elemVarSet` set)
           in if keep_me
              then ((extendVarSet set v, v:ids), ())
              else ((set,                ids),   ())


dffvExpr :: CoreExpr -> DFFV ()
dffvExpr (Var v)              = insert v
dffvExpr (App e1 e2)          = dffvExpr e1 >> dffvExpr e2
dffvExpr (Lam v e)            = extendScope v (dffvExpr e)
dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e
dffvExpr (Tick _other e)    = dffvExpr e
dffvExpr (Cast e _)           = dffvExpr e
dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e)
dffvExpr (Let (Rec prs) e)    = extendScopeList (map fst prs) $
                                (mapM_ dffvBind prs >> dffvExpr e)
dffvExpr (Case e b _ as)      = dffvExpr e >> extendScope b (mapM_ dffvAlt as)
dffvExpr _other               = return ()

dffvAlt :: (t, [Var], CoreExpr) -> DFFV ()
dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r)

dffvBind :: (Id, CoreExpr) -> DFFV ()
dffvBind(x,r)
  | not (isId x) = dffvExpr r
  | otherwise    = dffvLetBndr False x >> dffvExpr r
                -- Pass False because we are doing the RHS right here
                -- If you say True you'll get *exponential* behaviour!

dffvLetBndr :: Bool -> Id -> DFFV ()
-- Gather the free vars of the RULES and unfolding of a binder
-- We always get the free vars of a *stable* unfolding, but
-- for a *vanilla* one (InlineRhs), the flag controls what happens:
--   True <=> get fvs of even a *vanilla* unfolding
--   False <=> ignore an InlineRhs
-- For nested bindings (call from dffvBind) we always say "False" because
--       we are taking the fvs of the RHS anyway
-- For top-level bindings (call from addExternal, via bndrFvsInOrder)
--       we say "True" if we are exposing that unfolding
dffvLetBndr vanilla_unfold id
  = do { go_unf (unfoldingInfo idinfo)
       ; mapM_ go_rule (specInfoRules (specInfo idinfo)) }
  where
    idinfo = idInfo id

    go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
       = case src of
           InlineRhs | vanilla_unfold -> dffvExpr rhs
                     | otherwise      -> return ()
           _                          -> dffvExpr rhs

    go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) 
             = extendScopeList bndrs $ mapM_ dffvExpr args
    go_unf _ = return ()

    go_rule (BuiltinRule {}) = return ()
    go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs })
      = extendScopeList bndrs (dffvExpr rhs)

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 { new_local_name <- atomicModifyIORef nc_var mk_new_local
                            ; 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 { new_external_name <- atomicModifyIORef nc_var mk_new_external
                            ; 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 = us }, mkInternalName uniq occ' loc)
                    where
                      (uniq, us) = takeUniqFromSupply (nsUniqs nc)

    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
             -> Module
             -> UnfoldEnv
             -> TidyOccEnv
             -> CoreProgram
             -> IO (TidyEnv, CoreProgram)

tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
  = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
       return $ tidy mkIntegerId init_env binds
  where
    dflags = hsc_dflags hsc_env

    init_env = (init_occ_env, emptyVarEnv)

    this_pkg = thisPackage dflags

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

------------------------
tidyTopBind  :: DynFlags
             -> PackageId
             -> Module
             -> Id
             -> UnfoldEnv
             -> TidyEnv
             -> CoreBind
             -> (TidyEnv, CoreBind)

tidyTopBind dflags this_pkg this_mod mkIntegerId 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 dflags this_pkg this_mod (mkIntegerId, subst1) (idArity bndr) rhs
    (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' (bndr, rhs)
    subst2        = extendVarEnv subst1 bndr bndr'
    tidy_env2     = (occ_env, subst2)

tidyTopBind dflags this_pkg this_mod mkIntegerId unfold_env (occ_env,subst1) (Rec prs)
  = (tidy_env2, Rec prs')
  where
    prs' = [ tidyTopPair dflags 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 dflags this_pkg this_mod (mkIntegerId, subst1) (idArity bndr) rhs)
             | (bndr,rhs) <- prs ] = MayHaveCafRefs
        | otherwise                = NoCafRefs

-----------------------------------------------------------
tidyTopPair :: DynFlags
            -> 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 dflags 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 dflags 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 :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr
              -> IdInfo -> Bool -> CafInfo -> IdInfo
tidyTopIdInfo dflags 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 ------------
    mb_bot_str = exprBotStrictness_maybe orig_rhs

    sig = strictnessInfo idinfo
    final_sig | not $ isNopSig sig
                 = WARN( _bottom_hidden sig , ppr name ) sig 
                 -- try a cheap-and-cheerful bottom analyser
                 | Just (_, nsig) <- mb_bot_str = nsig
                 | otherwise                    = sig

    _bottom_hidden id_sig = case mb_bot_str of
                                  Nothing         -> False
                                  Just (arity, _) -> not (appIsBottom id_sig arity)

    --------- Unfolding ------------
    unf_info = unfoldingInfo idinfo
    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
                | otherwise   = noUnfolding
    unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs
    is_bot = isBottomingSig final_sig
    -- 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 :: DynFlags -> PackageId -> Module
           -> (Id, VarEnv Var) -> Arity -> CoreExpr
           -> CafInfo
hasCafRefs dflags this_pkg this_mod p arity expr
  | is_caf || mentions_cafs = MayHaveCafRefs
  | otherwise               = NoCafRefs
 where
  mentions_cafs = isFastTrue (cafRefsE dflags p expr)
  is_dynamic_name = isDllName dflags this_pkg this_mod
  is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) 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.

cafRefsE :: DynFlags -> (Id, VarEnv Id) -> Expr a -> FastBool
cafRefsE _      p (Var id)            = cafRefsV p id
cafRefsE dflags p (Lit lit)           = cafRefsL dflags p lit
cafRefsE dflags p (App f a)           = fastOr (cafRefsE dflags p f) (cafRefsE dflags p) a
cafRefsE dflags p (Lam _ e)           = cafRefsE dflags p e
cafRefsE dflags p (Let b e)           = fastOr (cafRefsEs dflags p (rhssOfBind b)) (cafRefsE dflags p) e
cafRefsE dflags p (Case e _bndr _ alts) = fastOr (cafRefsE dflags p e) (cafRefsEs dflags p) (rhssOfAlts alts)
cafRefsE dflags p (Tick _n e)         = cafRefsE dflags p e
cafRefsE dflags p (Cast e _co)        = cafRefsE dflags p e
cafRefsE _      _ (Type _)            = fastBool False
cafRefsE _      _ (Coercion _)        = fastBool False

cafRefsEs :: DynFlags -> (Id, VarEnv Id) -> [Expr a] -> FastBool
cafRefsEs _      _ []     = fastBool False
cafRefsEs dflags p (e:es) = fastOr (cafRefsE dflags p e) (cafRefsEs dflags p) es

cafRefsL :: DynFlags -> (Id, VarEnv Id) -> Literal -> FastBool
-- Don't forget that mk_integer id might have Caf refs!
-- We first need to convert the Integer into its final form, to
-- see whether mkInteger is used.
cafRefsL dflags p@(mk_integer, _) (LitInteger i _) = cafRefsE dflags p (cvtLitInteger dflags mk_integer i)
cafRefsL _      _ _                         = fastBool False

cafRefsV :: (Id, VarEnv Id) -> Id -> FastBool
cafRefsV (_, p) id
  | not (isLocalId id)            = fastBool (mayHaveCafRefs (idCafInfo id))
  | Just id' <- lookupVarEnv p id = fastBool (mayHaveCafRefs (idCafInfo id'))
  | otherwise                     = fastBool False

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