coreSyn/CoreFVs.hs

    {-
    (c) The University of Glasgow 2006
    (c) The GRASP/AQUA Project, Glasgow University, 1992-1998

    Taken quite directly from the Peyton Jones/Lester paper.
    -}

    {-# LANGUAGE CPP #-}

    -- | A module concerned with finding the free variables of an expression.
    module CoreFVs (
            -- * Free variables of expressions and binding groups
            exprFreeVars,
            exprFreeVarsDSet,
            exprFreeVarsList,
            exprFreeIds,
            exprFreeIdsDSet,
            exprFreeIdsList,
            exprsFreeIdsDSet,
            exprsFreeIdsList,
            exprsFreeVars,
            exprsFreeVarsList,
            bindFreeVars,

            -- * Selective free variables of expressions
            InterestingVarFun,
            exprSomeFreeVars, exprsSomeFreeVars,
            exprSomeFreeVarsList, exprsSomeFreeVarsList,

            -- * Free variables of Rules, Vars and Ids
            varTypeTyCoVars,
            varTypeTyCoFVs,
            idUnfoldingVars, idFreeVars, dIdFreeVars,
            bndrRuleAndUnfoldingVarsDSet,
            idFVs,
            idRuleVars, idRuleRhsVars, stableUnfoldingVars,
            ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
            rulesFreeVarsDSet,
            ruleLhsFreeIds, ruleLhsFreeIdsList,
            vectsFreeVars,

            expr_fvs,

            -- * Orphan names
            orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom,
            orphNamesOfTypes, orphNamesOfCoCon,
            exprsOrphNames, orphNamesOfFamInst,

            -- * Core syntax tree annotation with free variables
            FVAnn,                  -- annotation, abstract
            CoreExprWithFVs,        -- = AnnExpr Id FVAnn
            CoreExprWithFVs',       -- = AnnExpr' Id FVAnn
            CoreBindWithFVs,        -- = AnnBind Id FVAnn
            CoreAltWithFVs,         -- = AnnAlt Id FVAnn
            freeVars,               -- CoreExpr -> CoreExprWithFVs
            freeVarsBind,           -- CoreBind -> DVarSet -> (DVarSet, CoreBindWithFVs)
            freeVarsOf,             -- CoreExprWithFVs -> DIdSet
            freeVarsOfType,         -- CoreExprWithFVs -> TyCoVarSet
            freeVarsOfAnn, freeVarsOfTypeAnn,
            exprTypeFV              -- CoreExprWithFVs -> Type
        ) where

    #include "HsVersions.h"

    import CoreSyn
    import Id
    import IdInfo
    import NameSet
    import UniqSet
    import Unique (Uniquable (..))
    import Literal ( literalType )
    import Name
    import VarSet
    import Var
    import Type
    import TyCoRep
    import TyCon
    import CoAxiom
    import FamInstEnv
    import TysPrim( funTyConName )
    import Coercion
    import Maybes( orElse )
    import Util
    import BasicTypes( Activation )
    import Outputable
    import FV

    {-
    ************************************************************************
    *                                                                      *
    \section{Finding the free variables of an expression}
    *                                                                      *
    ************************************************************************

    This function simply finds the free variables of an expression.
    So far as type variables are concerned, it only finds tyvars that are

            * free in type arguments,
            * free in the type of a binder,

    but not those that are free in the type of variable occurrence.
    -}

    -- | Find all locally-defined free Ids or type variables in an expression
    -- returning a non-deterministic set.
    exprFreeVars :: CoreExpr -> VarSet
    exprFreeVars = fvVarSet . exprFVs

    -- | Find all locally-defined free Ids or type variables in an expression
    -- returning a composable FV computation. See Note [FV naming conventions] in FV
    -- for why export it.
    exprFVs :: CoreExpr -> FV
    exprFVs = filterFV isLocalVar . expr_fvs

    -- | Find all locally-defined free Ids or type variables in an expression
    -- returning a deterministic set.
    exprFreeVarsDSet :: CoreExpr -> DVarSet
    exprFreeVarsDSet = fvDVarSet . exprFVs

    -- | Find all locally-defined free Ids or type variables in an expression
    -- returning a deterministically ordered list.
    exprFreeVarsList :: CoreExpr -> [Var]
    exprFreeVarsList = fvVarList . exprFVs

    -- | Find all locally-defined free Ids in an expression
    exprFreeIds :: CoreExpr -> IdSet        -- Find all locally-defined free Ids
    exprFreeIds = exprSomeFreeVars isLocalId

    -- | Find all locally-defined free Ids in an expression
    -- returning a deterministic set.
    exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids
    exprFreeIdsDSet = exprSomeFreeVarsDSet isLocalId

    -- | Find all locally-defined free Ids in an expression
    -- returning a deterministically ordered list.
    exprFreeIdsList :: CoreExpr -> [Id] -- Find all locally-defined free Ids
    exprFreeIdsList = exprSomeFreeVarsList isLocalId

    -- | Find all locally-defined free Ids in several expressions
    -- returning a deterministic set.
    exprsFreeIdsDSet :: [CoreExpr] -> DIdSet -- Find all locally-defined free Ids
    exprsFreeIdsDSet = exprsSomeFreeVarsDSet isLocalId

    -- | Find all locally-defined free Ids in several expressions
    -- returning a deterministically ordered list.
    exprsFreeIdsList :: [CoreExpr] -> [Id]   -- Find all locally-defined free Ids
    exprsFreeIdsList = exprsSomeFreeVarsList isLocalId

    -- | Find all locally-defined free Ids or type variables in several expressions
    -- returning a non-deterministic set.
    exprsFreeVars :: [CoreExpr] -> VarSet
    exprsFreeVars = fvVarSet . exprsFVs

    -- | Find all locally-defined free Ids or type variables in several expressions
    -- returning a composable FV computation. See Note [FV naming conventions] in FV
    -- for why export it.
    exprsFVs :: [CoreExpr] -> FV
    exprsFVs exprs = mapUnionFV exprFVs exprs

    -- | Find all locally-defined free Ids or type variables in several expressions
    -- returning a deterministically ordered list.
    exprsFreeVarsList :: [CoreExpr] -> [Var]
    exprsFreeVarsList = fvVarList . exprsFVs

    -- | Find all locally defined free Ids in a binding group
    bindFreeVars :: CoreBind -> VarSet
    bindFreeVars (NonRec b r) = fvVarSet $ filterFV isLocalVar $ rhs_fvs (b,r)
    bindFreeVars (Rec prs)    = fvVarSet $ filterFV isLocalVar $
                                    addBndrs (map fst prs)
                                         (mapUnionFV rhs_fvs prs)

    -- | Finds free variables in an expression selected by a predicate
    exprSomeFreeVars :: InterestingVarFun   -- ^ Says which 'Var's are interesting
                     -> CoreExpr
                     -> VarSet
    exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ expr_fvs e

    -- | Finds free variables in an expression selected by a predicate
    -- returning a deterministically ordered list.
    exprSomeFreeVarsList :: InterestingVarFun -- ^ Says which 'Var's are interesting
                         -> CoreExpr
                         -> [Var]
    exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ expr_fvs e

    -- | Finds free variables in an expression selected by a predicate
    -- returning a deterministic set.
    exprSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting
                         -> CoreExpr
                         -> DVarSet
    exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ expr_fvs e

    -- | Finds free variables in several expressions selected by a predicate
    exprsSomeFreeVars :: InterestingVarFun  -- Says which 'Var's are interesting
                      -> [CoreExpr]
                      -> VarSet
    exprsSomeFreeVars fv_cand es =
      fvVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs es

    -- | Finds free variables in several expressions selected by a predicate
    -- returning a deterministically ordered list.
    exprsSomeFreeVarsList :: InterestingVarFun  -- Says which 'Var's are interesting
                          -> [CoreExpr]
                          -> [Var]
    exprsSomeFreeVarsList fv_cand es =
      fvVarList $ filterFV fv_cand $ mapUnionFV expr_fvs es

    -- | Finds free variables in several expressions selected by a predicate
    -- returning a deterministic set.
    exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting
                          -> [CoreExpr]
                          -> DVarSet
    exprsSomeFreeVarsDSet fv_cand e =
      fvDVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs e

    --      Comment about obselete code
    -- We used to gather the free variables the RULES at a variable occurrence
    -- with the following cryptic comment:
    --     "At a variable occurrence, add in any free variables of its rule rhss
    --     Curiously, we gather the Id's free *type* variables from its binding
    --     site, but its free *rule-rhs* variables from its usage sites.  This
    --     is a little weird.  The reason is that the former is more efficient,
    --     but the latter is more fine grained, and a makes a difference when
    --     a variable mentions itself one of its own rule RHSs"
    -- Not only is this "weird", but it's also pretty bad because it can make
    -- a function seem more recursive than it is.  Suppose
    --      f  = ...g...
    --      g  = ...
    --         RULE g x = ...f...
    -- Then f is not mentioned in its own RHS, and needn't be a loop breaker
    -- (though g may be).  But if we collect the rule fvs from g's occurrence,
    -- it looks as if f mentions itself.  (This bites in the eftInt/eftIntFB
    -- code in GHC.Enum.)
    --
    -- Anyway, it seems plain wrong.  The RULE is like an extra RHS for the
    -- function, so its free variables belong at the definition site.
    --
    -- Deleted code looked like
    --     foldVarSet add_rule_var var_itself_set (idRuleVars var)
    --     add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var
    --                          | otherwise                    = set
    --      SLPJ Feb06

    addBndr :: CoreBndr -> FV -> FV
    addBndr bndr fv fv_cand in_scope acc
      = (varTypeTyCoFVs bndr `unionFV`
            -- Include type variables in the binder's type
            --      (not just Ids; coercion variables too!)
         FV.delFV bndr fv) fv_cand in_scope acc

    addBndrs :: [CoreBndr] -> FV -> FV
    addBndrs bndrs fv = foldr addBndr fv bndrs

    expr_fvs :: CoreExpr -> FV
    expr_fvs (Type ty) fv_cand in_scope acc =
      tyCoFVsOfType ty fv_cand in_scope acc
    expr_fvs (Coercion co) fv_cand in_scope acc =
      tyCoFVsOfCo co fv_cand in_scope acc
    expr_fvs (Var var) fv_cand in_scope acc = FV.unitFV var fv_cand in_scope acc
    expr_fvs (Lit _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc
    expr_fvs (Tick t expr) fv_cand in_scope acc =
      (tickish_fvs t `unionFV` expr_fvs expr) fv_cand in_scope acc
    expr_fvs (App fun arg) fv_cand in_scope acc =
      (expr_fvs fun `unionFV` expr_fvs arg) fv_cand in_scope acc
    expr_fvs (Lam bndr body) fv_cand in_scope acc =
      addBndr bndr (expr_fvs body) fv_cand in_scope acc
    expr_fvs (Cast expr co) fv_cand in_scope acc =
      (expr_fvs expr `unionFV` tyCoFVsOfCo co) fv_cand in_scope acc

    expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc
      = (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr
          (mapUnionFV alt_fvs alts)) fv_cand in_scope acc
      where
        alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)

    expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc
      = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body))
          fv_cand in_scope acc

    expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc
      = addBndrs (map fst pairs)
                 (mapUnionFV rhs_fvs pairs `unionFV` expr_fvs body)
                   fv_cand in_scope acc

    ---------
    rhs_fvs :: (Id, CoreExpr) -> FV
    rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV`
                          bndrRuleAndUnfoldingFVs bndr
            -- Treat any RULES as extra RHSs of the binding

    ---------
    exprs_fvs :: [CoreExpr] -> FV
    exprs_fvs exprs = mapUnionFV expr_fvs exprs

    tickish_fvs :: Tickish Id -> FV
    tickish_fvs (Breakpoint _ ids) = FV.mkFVs ids
    tickish_fvs _ = emptyFV

    {-
    ************************************************************************
    *                                                                      *
    \section{Free names}
    *                                                                      *
    ************************************************************************
    -}

    -- | Finds the free /external/ names of an expression, notably
    -- including the names of type constructors (which of course do not show
    -- up in 'exprFreeVars').
    exprOrphNames :: CoreExpr -> NameSet
    -- There's no need to delete local binders, because they will all
    -- be /internal/ names.
    exprOrphNames e
      = go e
      where
        go (Var v)
          | isExternalName n    = unitNameSet n
          | otherwise           = emptyNameSet
          where n = idName v
        go (Lit _)              = emptyNameSet
        go (Type ty)            = orphNamesOfType ty        -- Don't need free tyvars
        go (Coercion co)        = orphNamesOfCo co
        go (App e1 e2)          = go e1 `unionNameSet` go e2
        go (Lam v e)            = go e `delFromNameSet` idName v
        go (Tick _ e)           = go e
        go (Cast e co)          = go e `unionNameSet` orphNamesOfCo co
        go (Let (NonRec _ r) e) = go e `unionNameSet` go r
        go (Let (Rec prs) e)    = exprsOrphNames (map snd prs) `unionNameSet` go e
        go (Case e _ ty as)     = go e `unionNameSet` orphNamesOfType ty
                                  `unionNameSet` unionNameSets (map go_alt as)

        go_alt (_,_,r) = go r

    -- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details
    exprsOrphNames :: [CoreExpr] -> NameSet
    exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es

    {- **********************************************************************
    %*                                                                      *
                        orphNamesXXX

    %*                                                                      *
    %********************************************************************* -}

    orphNamesOfTyCon :: TyCon -> NameSet
    orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of
        Nothing  -> emptyNameSet
        Just cls -> unitNameSet (getName cls)

    orphNamesOfType :: Type -> NameSet
    orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty'
                    -- Look through type synonyms (Trac #4912)
    orphNamesOfType (TyVarTy _)          = emptyNameSet
    orphNamesOfType (LitTy {})           = emptyNameSet
    orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon
                                           `unionNameSet` orphNamesOfTypes tys
    orphNamesOfType (ForAllTy bndr res)  = orphNamesOfType (binderKind bndr)
                                           `unionNameSet` orphNamesOfType res
    orphNamesOfType (FunTy arg res)      = unitNameSet funTyConName    -- NB!  See Trac #8535
                                           `unionNameSet` orphNamesOfType arg
                                           `unionNameSet` orphNamesOfType res
    orphNamesOfType (AppTy fun arg)      = orphNamesOfType fun `unionNameSet` orphNamesOfType arg
    orphNamesOfType (CastTy ty co)       = orphNamesOfType ty `unionNameSet` orphNamesOfCo co
    orphNamesOfType (CoercionTy co)      = orphNamesOfCo co

    orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet
    orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet

    orphNamesOfTypes :: [Type] -> NameSet
    orphNamesOfTypes = orphNamesOfThings orphNamesOfType

    orphNamesOfCo :: Coercion -> NameSet
    orphNamesOfCo (Refl _ ty)           = orphNamesOfType ty
    orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos
    orphNamesOfCo (AppCo co1 co2)       = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
    orphNamesOfCo (ForAllCo _ kind_co co)
      = orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co
    orphNamesOfCo (FunCo _ co1 co2)     = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
    orphNamesOfCo (CoVarCo _)           = emptyNameSet
    orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos
    orphNamesOfCo (UnivCo p _ t1 t2)    = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2
    orphNamesOfCo (SymCo co)            = orphNamesOfCo co
    orphNamesOfCo (TransCo co1 co2)     = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
    orphNamesOfCo (NthCo _ co)          = orphNamesOfCo co
    orphNamesOfCo (LRCo  _ co)          = orphNamesOfCo co
    orphNamesOfCo (InstCo co arg)       = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg
    orphNamesOfCo (CoherenceCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2
    orphNamesOfCo (KindCo co)           = orphNamesOfCo co
    orphNamesOfCo (SubCo co)            = orphNamesOfCo co
    orphNamesOfCo (AxiomRuleCo _ cs)    = orphNamesOfCos cs

    orphNamesOfProv :: UnivCoProvenance -> NameSet
    orphNamesOfProv UnsafeCoerceProv    = emptyNameSet
    orphNamesOfProv (PhantomProv co)    = orphNamesOfCo co
    orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co
    orphNamesOfProv (PluginProv _)      = emptyNameSet
    orphNamesOfProv (HoleProv _)        = emptyNameSet

    orphNamesOfCos :: [Coercion] -> NameSet
    orphNamesOfCos = orphNamesOfThings orphNamesOfCo

    orphNamesOfCoCon :: CoAxiom br -> NameSet
    orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches })
      = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches

    orphNamesOfAxiom :: CoAxiom br -> NameSet
    orphNamesOfAxiom axiom
      = orphNamesOfTypes (concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom)
        `extendNameSet` getName (coAxiomTyCon axiom)

    orphNamesOfCoAxBranches :: Branches br -> NameSet
    orphNamesOfCoAxBranches
      = foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches

    orphNamesOfCoAxBranch :: CoAxBranch -> NameSet
    orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
      = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs

    -- | orphNamesOfAxiom collects the names of the concrete types and
    -- type constructors that make up the LHS of a type family instance,
    -- including the family name itself.
    --
    -- For instance, given `type family Foo a b`:
    -- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H]
    --
    -- Used in the implementation of ":info" in GHCi.
    orphNamesOfFamInst :: FamInst -> NameSet
    orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst)

    {-
    ************************************************************************
    *                                                                      *
    \section[freevars-everywhere]{Attaching free variables to every sub-expression}
    *                                                                      *
    ************************************************************************
    -}

    -- | Those variables free in the right hand side of a rule returned as a
    -- non-deterministic set
    ruleRhsFreeVars :: CoreRule -> VarSet
    ruleRhsFreeVars (BuiltinRule {}) = noFVs
    ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs })
      = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
          -- See Note [Rule free var hack]

    -- | Those variables free in the both the left right hand sides of a rule
    -- returned as a non-deterministic set
    ruleFreeVars :: CoreRule -> VarSet
    ruleFreeVars = fvVarSet . ruleFVs

    -- | Those variables free in the both the left right hand sides of a rule
    -- returned as FV computation
    ruleFVs :: CoreRule -> FV
    ruleFVs (BuiltinRule {}) = emptyFV
    ruleFVs (Rule { ru_fn = _do_not_include
                      -- See Note [Rule free var hack]
                  , ru_bndrs = bndrs
                  , ru_rhs = rhs, ru_args = args })
      = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args))

    -- | Those variables free in the both the left right hand sides of rules
    -- returned as FV computation
    rulesFVs :: [CoreRule] -> FV
    rulesFVs = mapUnionFV ruleFVs

    -- | Those variables free in the both the left right hand sides of rules
    -- returned as a deterministic set
    rulesFreeVarsDSet :: [CoreRule] -> DVarSet
    rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules

    idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet
    -- Just the variables free on the *rhs* of a rule
    idRuleRhsVars is_active id
      = mapUnionVarSet get_fvs (idCoreRules id)
      where
        get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs
                      , ru_rhs = rhs, ru_act = act })
          | is_active act
                -- See Note [Finding rule RHS free vars] in OccAnal.hs
          = delOneFromUniqSet_Directly fvs (getUnique fn)
                -- Note [Rule free var hack]
          where
            fvs = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)
        get_fvs _ = noFVs

    -- | Those variables free in the right hand side of several rules
    rulesFreeVars :: [CoreRule] -> VarSet
    rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules

    ruleLhsFreeIds :: CoreRule -> VarSet
    -- ^ This finds all locally-defined free Ids on the left hand side of a rule
    -- and returns them as a non-deterministic set
    ruleLhsFreeIds = fvVarSet . ruleLhsFVIds

    ruleLhsFreeIdsList :: CoreRule -> [Var]
    -- ^ This finds all locally-defined free Ids on the left hand side of a rule
    -- and returns them as a determinisitcally ordered list
    ruleLhsFreeIdsList = fvVarList . ruleLhsFVIds

    ruleLhsFVIds :: CoreRule -> FV
    -- ^ This finds all locally-defined free Ids on the left hand side of a rule
    -- and returns an FV computation
    ruleLhsFVIds (BuiltinRule {}) = emptyFV
    ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args })
      = filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)

    {-
    Note [Rule free var hack]  (Not a hack any more)
    ~~~~~~~~~~~~~~~~~~~~~~~~~
    We used not to include the Id in its own rhs free-var set.
    Otherwise the occurrence analyser makes bindings recursive:
            f x y = x+y
            RULE:  f (f x y) z  ==>  f x (f y z)
    However, the occurrence analyser distinguishes "non-rule loop breakers"
    from "rule-only loop breakers" (see BasicTypes.OccInfo).  So it will
    put this 'f' in a Rec block, but will mark the binding as a non-rule loop
    breaker, which is perfectly inlinable.
    -}

    -- |Free variables of a vectorisation declaration
    vectsFreeVars :: [CoreVect] -> VarSet
    vectsFreeVars = mapUnionVarSet vectFreeVars
      where
        vectFreeVars (Vect   _ rhs)   = fvVarSet $ filterFV isLocalId $ expr_fvs rhs
        vectFreeVars (NoVect _)       = noFVs
        vectFreeVars (VectType _ _ _) = noFVs
        vectFreeVars (VectClass _)    = noFVs
        vectFreeVars (VectInst _)     = noFVs
          -- this function is only concerned with values, not types

    {-
    ************************************************************************
    *                                                                      *
    \section[freevars-everywhere]{Attaching free variables to every sub-expression}
    *                                                                      *
    ************************************************************************

    The free variable pass annotates every node in the expression with its
    NON-GLOBAL free variables and type variables.
    -}

    data FVAnn = FVAnn { fva_fvs    :: DVarSet   -- free in expression
                       , fva_ty_fvs :: DVarSet   -- free only in expression's type
                       , fva_ty     :: Type      -- expression's type
                       }

    -- | Every node in a binding group annotated with its
    -- (non-global) free variables, both Ids and TyVars, and type.
    type CoreBindWithFVs = AnnBind Id FVAnn
    -- | Every node in an expression annotated with its
    -- (non-global) free variables, both Ids and TyVars, and type.
    type CoreExprWithFVs  = AnnExpr Id FVAnn
    type CoreExprWithFVs' = AnnExpr' Id FVAnn

    -- | Every node in an expression annotated with its
    -- (non-global) free variables, both Ids and TyVars, and type.
    type CoreAltWithFVs = AnnAlt Id FVAnn

    freeVarsOf :: CoreExprWithFVs -> DIdSet
    -- ^ Inverse function to 'freeVars'
    freeVarsOf (FVAnn { fva_fvs = fvs }, _) = fvs

    -- | Extract the vars free in an annotated expression's type
    freeVarsOfType :: CoreExprWithFVs -> DTyCoVarSet
    freeVarsOfType (FVAnn { fva_ty_fvs = ty_fvs }, _) = ty_fvs

    -- | Extract the type of an annotated expression. (This is cheap.)
    exprTypeFV :: CoreExprWithFVs -> Type
    exprTypeFV (FVAnn { fva_ty = ty }, _) = ty

    -- | Extract the vars reported in a FVAnn
    freeVarsOfAnn :: FVAnn -> DIdSet
    freeVarsOfAnn = fva_fvs

    -- | Extract the type-level vars reported in a FVAnn
    freeVarsOfTypeAnn :: FVAnn -> DTyCoVarSet
    freeVarsOfTypeAnn = fva_ty_fvs

    noFVs :: VarSet
    noFVs = emptyVarSet

    aFreeVar :: Var -> DVarSet
    aFreeVar = unitDVarSet

    unionFVs :: DVarSet -> DVarSet -> DVarSet
    unionFVs = unionDVarSet

    unionFVss :: [DVarSet] -> DVarSet
    unionFVss = unionDVarSets

    delBindersFV :: [Var] -> DVarSet -> DVarSet
    delBindersFV bs fvs = foldr delBinderFV fvs bs

    delBinderFV :: Var -> DVarSet -> DVarSet
    -- This way round, so we can do it multiple times using foldr

    -- (b `delBinderFV` s) removes the binder b from the free variable set s,
    -- but *adds* to s
    --
    --      the free variables of b's type
    --
    -- This is really important for some lambdas:
    --      In (\x::a -> x) the only mention of "a" is in the binder.
    --
    -- Also in
    --      let x::a = b in ...
    -- we should really note that "a" is free in this expression.
    -- It'll be pinned inside the /\a by the binding for b, but
    -- it seems cleaner to make sure that a is in the free-var set
    -- when it is mentioned.
    --
    -- This also shows up in recursive bindings.  Consider:
    --      /\a -> letrec x::a = x in E
    -- Now, there are no explicit free type variables in the RHS of x,
    -- but nevertheless "a" is free in its definition.  So we add in
    -- the free tyvars of the types of the binders, and include these in the
    -- free vars of the group, attached to the top level of each RHS.
    --
    -- This actually happened in the defn of errorIO in IOBase.hs:
    --      errorIO (ST io) = case (errorIO# io) of
    --                          _ -> bottom
    --                        where
    --                          bottom = bottom -- Never evaluated

    delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyCoVars b
            -- Include coercion variables too!

    varTypeTyCoVars :: Var -> TyCoVarSet
    -- Find the type/kind variables free in the type of the id/tyvar
    varTypeTyCoVars var = fvVarSet $ varTypeTyCoFVs var

    dVarTypeTyCoVars :: Var -> DTyCoVarSet
    -- Find the type/kind/coercion variables free in the type of the id/tyvar
    dVarTypeTyCoVars var = fvDVarSet $ varTypeTyCoFVs var

    varTypeTyCoFVs :: Var -> FV
    varTypeTyCoFVs var = tyCoFVsOfType (varType var)

    idFreeVars :: Id -> VarSet
    idFreeVars id = ASSERT( isId id) fvVarSet $ idFVs id

    dIdFreeVars :: Id -> DVarSet
    dIdFreeVars id = fvDVarSet $ idFVs id

    idFVs :: Id -> FV
    -- Type variables, rule variables, and inline variables
    idFVs id = ASSERT( isId id)
               varTypeTyCoFVs id `unionFV`
               bndrRuleAndUnfoldingFVs id

    bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet
    bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id

    bndrRuleAndUnfoldingFVs :: Id -> FV
    bndrRuleAndUnfoldingFVs id
      | isId id   = idRuleFVs id `unionFV` idUnfoldingFVs id
      | otherwise = emptyFV

    idRuleVars ::Id -> VarSet  -- Does *not* include CoreUnfolding vars
    idRuleVars id = fvVarSet $ idRuleFVs id

    idRuleFVs :: Id -> FV
    idRuleFVs id = ASSERT( isId id)
      FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id))

    idUnfoldingVars :: Id -> VarSet
    -- Produce free vars for an unfolding, but NOT for an ordinary
    -- (non-inline) unfolding, since it is a dup of the rhs
    -- and we'll get exponential behaviour if we look at both unf and rhs!
    -- But do look at the *real* unfolding, even for loop breakers, else
    -- we might get out-of-scope variables
    idUnfoldingVars id = fvVarSet $ idUnfoldingFVs id

    idUnfoldingFVs :: Id -> FV
    idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV

    stableUnfoldingVars :: Unfolding -> Maybe VarSet
    stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf

    stableUnfoldingFVs :: Unfolding -> Maybe FV
    stableUnfoldingFVs unf
      = case unf of
          CoreUnfolding { uf_tmpl = rhs, uf_src = src }
             | isStableSource src
             -> Just (filterFV isLocalVar $ expr_fvs rhs)
          DFunUnfolding { df_bndrs = bndrs, df_args = args }
             -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprs_fvs args)
                -- DFuns are top level, so no fvs from types of bndrs
          _other -> Nothing

    {-
    ************************************************************************
    *                                                                      *
    \subsection{Free variables (and types)}
    *                                                                      *
    ************************************************************************
    -}

    freeVarsBind :: CoreBind
                 -> DVarSet                     -- Free vars of scope of binding
                 -> (CoreBindWithFVs, DVarSet)  -- Return free vars of binding + scope
    freeVarsBind (NonRec binder rhs) body_fvs
      = ( AnnNonRec binder rhs2
        , freeVarsOf rhs2 `unionFVs` body_fvs2
                          `unionFVs` bndrRuleAndUnfoldingVarsDSet binder )
        where
          rhs2      = freeVars rhs
          body_fvs2 = binder `delBinderFV` body_fvs

    freeVarsBind (Rec binds) body_fvs
      = ( AnnRec (binders `zip` rhss2)
        , delBindersFV binders all_fvs )
      where
        (binders, rhss) = unzip binds
        rhss2        = map freeVars rhss
        rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2
        binders_fvs  = fvDVarSet $ mapUnionFV bndrRuleAndUnfoldingFVs binders
        all_fvs      = rhs_body_fvs `unionFVs` binders_fvs
                -- The "delBinderFV" happens after adding the idSpecVars,
                -- since the latter may add some of the binders as fvs

    freeVars :: CoreExpr -> CoreExprWithFVs
    -- ^ Annotate a 'CoreExpr' with its (non-global) free type and value variables at every tree node
    freeVars = go
      where
        go :: CoreExpr -> CoreExprWithFVs
        go (Var v)
          = (FVAnn fvs ty_fvs (idType v), AnnVar v)
          where
                -- ToDo: insert motivating example for why we *need*
                -- to include the idSpecVars in the FV list.
                --      Actually [June 98] I don't think it's necessary
                -- fvs = fvs_v `unionVarSet` idSpecVars v

            (fvs, ty_fvs)
                | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs, dVarTypeTyCoVars v)
                | otherwise    = (emptyDVarSet, emptyDVarSet)

        go (Lit lit) = (FVAnn emptyDVarSet emptyDVarSet (literalType lit), AnnLit lit)
        go (Lam b body)
          = ( FVAnn { fva_fvs    = b_fvs `unionFVs` (b `delBinderFV` body_fvs)
                    , fva_ty_fvs = b_fvs `unionFVs` (b `delBinderFV` body_ty_fvs)
                    , fva_ty     = mkFunTy b_ty body_ty }
            , AnnLam b body' )
          where
            body'@(FVAnn { fva_fvs = body_fvs, fva_ty_fvs = body_ty_fvs
                         , fva_ty = body_ty }, _) = go body
            b_ty  = idType b
            b_fvs = tyCoVarsOfTypeDSet b_ty

        go (App fun arg)
          = ( FVAnn { fva_fvs    = freeVarsOf fun' `unionFVs` freeVarsOf arg'
                    , fva_ty_fvs = tyCoVarsOfTypeDSet res_ty
                    , fva_ty     = res_ty }
            , AnnApp fun' arg' )
          where
            fun'   = go fun
            fun_ty = exprTypeFV fun'
            arg'   = go arg
            res_ty = applyTypeToArg fun_ty arg

        go (Case scrut bndr ty alts)
          = ( FVAnn { fva_fvs = (bndr `delBinderFV` alts_fvs)
                                `unionFVs` freeVarsOf scrut2
                                `unionFVs` tyCoVarsOfTypeDSet ty
                               -- don't need to look at (idType bndr)
                               -- b/c that's redundant with scrut
                    , fva_ty_fvs = tyCoVarsOfTypeDSet ty
                    , fva_ty     = ty }
            , AnnCase scrut2 bndr ty alts2 )
          where
            scrut2 = go scrut

            (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
            alts_fvs            = unionFVss alts_fvs_s

            fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),
                                     (con, args, rhs2))
                                  where
                                     rhs2 = go rhs

        go (Let bind body)
          = ( FVAnn { fva_fvs    = bind_fvs
                    , fva_ty_fvs = freeVarsOfType body2
                    , fva_ty     = exprTypeFV body2 }
            , AnnLet bind2 body2 )
          where
            (bind2, bind_fvs) = freeVarsBind bind (freeVarsOf body2)
            body2             = go body

        go (Cast expr co)
          = ( FVAnn (freeVarsOf expr2 `unionFVs` cfvs) (tyCoVarsOfTypeDSet to_ty) to_ty
            , AnnCast expr2 (c_ann, co) )
          where
            expr2 = go expr
            cfvs  = tyCoVarsOfCoDSet co
            c_ann = FVAnn cfvs (tyCoVarsOfTypeDSet co_ki) co_ki
            co_ki = coercionType co
            Just (_, to_ty) = splitCoercionType_maybe co_ki

        go (Tick tickish expr)
          = ( FVAnn { fva_fvs    = tickishFVs tickish `unionFVs` freeVarsOf expr2
                    , fva_ty_fvs = freeVarsOfType expr2
                    , fva_ty     = exprTypeFV expr2 }
            , AnnTick tickish expr2 )
          where
            expr2 = go expr
            tickishFVs (Breakpoint _ ids) = mkDVarSet ids
            tickishFVs _                  = emptyDVarSet

        go (Type ty) = ( FVAnn (tyCoVarsOfTypeDSet ty)
                               (tyCoVarsOfTypeDSet ki)
                               ki
                       , AnnType ty)
          where
            ki = typeKind ty

        go (Coercion co) = ( FVAnn (tyCoVarsOfCoDSet co)
                                   (tyCoVarsOfTypeDSet ki)
                                   ki
                           , AnnCoercion co)
          where
            ki = coercionType co