-%
+
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section{Tidying up Core}
\begin{code}
-module TidyPgm( mkBootModDetails, tidyProgram ) where
+module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc, tidyProgram ) where
#include "HsVersions.h"
-import DynFlags ( DynFlag(..), DynFlags(..), dopt )
+import TcRnTypes
+import FamInstEnv
+import DynFlags
import CoreSyn
-import CoreUnfold ( noUnfolding, mkTopUnfolding )
-import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars )
-import CoreTidy ( tidyExpr, tidyVarOcc, tidyRules )
-import PprCore ( pprRules )
-import CoreLint ( showPass, endPass )
-import CoreUtils ( exprArity, rhsIsStatic )
+import CoreUnfold
+import CoreFVs
+import CoreTidy
+import PprCore
+import CoreLint
+import CoreUtils
import VarEnv
import VarSet
-import Var ( Id, Var )
-import Id ( idType, idInfo, idName, idCoreRules, isGlobalId,
- isExportedId, mkVanillaGlobal, isLocalId, isNaughtyRecordSelector,
- idArity, idCafInfo, idUnfolding, isImplicitId, setIdInfo
- )
-import IdInfo {- loads of stuff -}
-import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId )
-import NewDemand ( isBottomingSig, topSig )
-import BasicTypes ( Arity, isNeverActive )
-import Name ( Name, getOccName, nameOccName, mkInternalName,
- localiseName, isExternalName, nameSrcLoc, nameParent_maybe,
- isWiredInName, getName
- )
-import NameSet ( NameSet, elemNameSet )
-import IfaceEnv ( allocateGlobalBinder )
-import NameEnv ( filterNameEnv, mapNameEnv )
-import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
-import Type ( tidyTopType )
-import TcType ( isFFITy )
-import DataCon ( dataConName, dataConFieldLabels, dataConWrapId_maybe )
-import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon,
- newTyConRep, tyConSelIds, isAlgTyCon, isEnumerationTyCon )
-import Class ( classSelIds )
-import Module ( Module )
-import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..),
- TypeEnv, typeEnvIds, typeEnvElts, typeEnvTyCons,
- extendTypeEnvWithIds, lookupTypeEnv,
- ModGuts(..), TyThing(..), ModDetails(..), Dependencies(..)
- )
-import Maybes ( orElse, mapCatMaybes )
-import ErrUtils ( showPass, dumpIfSet_core )
-import PackageConfig ( PackageId )
-import UniqSupply ( splitUniqSupply, uniqFromSupply )
-import List ( partition )
-import Maybe ( isJust )
+import Var hiding( mkGlobalId )
+import Id
+import IdInfo
+import InstEnv
+import NewDemand
+import BasicTypes
+import Name
+import NameSet
+import IfaceEnv
+import NameEnv
+import OccName
+import TcType
+import DataCon
+import TyCon
+import Module
+import HscTypes
+import Maybes
+import ErrUtils
+import UniqSupply
import Outputable
-import DATA_IOREF ( IORef, readIORef, writeIORef )
-import FastTypes hiding ( fastOr )
+import FastBool hiding ( fastOr )
+
+import Data.List ( partition )
+import Data.Maybe ( isJust )
+import Data.IORef ( IORef, readIORef, writeIORef )
\end{code}
distinct OccNames in case of object-file splitting
\begin{code}
-mkBootModDetails :: HscEnv -> ModGuts -> IO ModDetails
-- This is Plan A: make a small type env when typechecking only,
-- or when compiling a hs-boot file, or simply when not using -O
--
-- We don't look at the bindings at all -- there aren't any
-- for hs-boot files
-mkBootModDetails hsc_env (ModGuts { mg_module = mod,
- mg_exports = exports,
- mg_types = type_env,
- mg_insts = ispecs })
+mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails
+mkBootModDetailsTc hsc_env
+ TcGblEnv{ tcg_exports = exports,
+ tcg_type_env = type_env,
+ tcg_insts = insts,
+ tcg_fam_insts = fam_insts
+ }
+ = mkBootModDetails hsc_env exports type_env insts fam_insts
+
+mkBootModDetailsDs :: HscEnv -> ModGuts -> IO ModDetails
+mkBootModDetailsDs hsc_env
+ ModGuts{ mg_exports = exports,
+ mg_types = type_env,
+ mg_insts = insts,
+ mg_fam_insts = fam_insts
+ }
+ = mkBootModDetails hsc_env exports type_env insts fam_insts
+
+mkBootModDetails :: HscEnv -> [AvailInfo] -> NameEnv TyThing
+ -> [Instance] -> [FamInstEnv.FamInst] -> IO ModDetails
+mkBootModDetails hsc_env exports type_env insts fam_insts
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Tidy [hoot] type env"
- ; let { ispecs' = tidyInstances tidyExternalId ispecs
- ; type_env1 = filterNameEnv (not . isWiredInThing) type_env
- ; type_env2 = mapNameEnv tidyBootThing type_env1
- ; type_env' = extendTypeEnvWithIds type_env2
- (map instanceDFunId ispecs')
+ ; let { insts' = tidyInstances tidyExternalId insts
+ ; dfun_ids = map instanceDFunId insts'
+ ; type_env1 = tidyBootTypeEnv (availsToNameSet exports) type_env
+ ; type_env' = extendTypeEnvWithIds type_env1 dfun_ids
}
- ; return (ModDetails { md_types = type_env',
- md_insts = ispecs',
- md_rules = [],
- md_exports = exports })
+ ; return (ModDetails { md_types = type_env'
+ , md_insts = insts'
+ , md_fam_insts = fam_insts
+ , md_rules = []
+ , md_exports = exports
+ , md_vect_info = noVectInfo
+ })
}
where
-isWiredInThing :: TyThing -> Bool
-isWiredInThing thing = isWiredInName (getName thing)
+tidyBootTypeEnv :: NameSet -> TypeEnv -> TypeEnv
+tidyBootTypeEnv exports type_env
+ = tidyTypeEnv True exports type_env final_ids
+ where
+ -- Find the LocalIds in the type env that are exported
+ -- Make them into GlobalIds, and tidy their types
+ --
+ -- It's very important to remove the non-exported ones
+ -- because we don't tidy the OccNames, and if we don't remove
+ -- the non-exported ones we'll get many things with the
+ -- same name in the interface file, giving chaos.
+ final_ids = [ tidyExternalId id
+ | id <- typeEnvIds type_env
+ , isLocalId id
+ , keep_it id ]
+
+ -- default methods have their export flag set, but everything
+ -- else doesn't (yet), because this is pre-desugaring, so we
+ -- must test both.
+ keep_it id = isExportedId id || idName id `elemNameSet` exports
-tidyBootThing :: TyThing -> TyThing
--- Just externalise the Ids; keep everything
-tidyBootThing (AnId id) | isLocalId id = AnId (tidyExternalId id)
-tidyBootThing thing = thing
tidyExternalId :: Id -> Id
-- Takes an LocalId with an External Name,
\begin{code}
tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram hsc_env
- mod_impl@(ModGuts { mg_module = mod, mg_exports = exports,
- mg_types = type_env, mg_insts = insts_tc,
+ (ModGuts { mg_module = mod, mg_exports = exports,
+ mg_types = type_env,
+ mg_insts = insts, mg_fam_insts = fam_insts,
mg_binds = binds,
mg_rules = imp_rules,
- mg_dir_imps = dir_imps, mg_deps = deps,
- mg_foreign = foreign_stubs })
+ mg_vect_info = vect_info,
+ mg_dir_imps = dir_imps,
+ mg_deps = deps,
+ mg_foreign = foreign_stubs,
+ mg_hpc_info = hpc_info,
+ mg_modBreaks = modBreaks })
= do { let dflags = hsc_dflags hsc_env
; showPass dflags "Tidy Core"
-- (It's a sort of mutual recursion.)
}
- ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids binds
+ ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids
+ binds
- ; let { tidy_type_env = tidyTypeEnv omit_prags exports type_env tidy_binds
- ; tidy_ispecs = tidyInstances (lookup_dfun tidy_type_env) insts_tc
+ ; let { export_set = availsToNameSet exports
+ ; final_ids = [ id | id <- bindersOfBinds tidy_binds,
+ isExternalName (idName id)]
+ ; tidy_type_env = tidyTypeEnv omit_prags export_set type_env
+ final_ids
+ ; tidy_insts = tidyInstances (lookup_dfun tidy_type_env) insts
-- A DFunId will have a binding in tidy_binds, and so
-- will now be in final_env, replete with IdInfo
-- Its name will be unchanged since it was born, but
- -- we want Global, IdInfo-rich (or not) DFunId in the tidy_ispecs
+ -- we want Global, IdInfo-rich (or not) DFunId in the
+ -- tidy_insts
; tidy_rules = tidyRules tidy_env ext_rules
-- You might worry that the tidy_env contains IdInfo-rich stuff
- -- and indeed it does, but if omit_prags is on, ext_rules is empty
+ -- and indeed it does, but if omit_prags is on, ext_rules is
+ -- empty
- ; implicit_binds = getImplicitBinds type_env
- ; all_tidy_binds = implicit_binds ++ tidy_binds
; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
}
- ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds
+ ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
; dumpIfSet_core dflags Opt_D_dump_simpl
"Tidy Core Rules"
(pprRules tidy_rules)
+ ; let dir_imp_mods = moduleEnvKeys dir_imps
+
; return (CgGuts { cg_module = mod,
cg_tycons = alg_tycons,
- cg_binds = all_tidy_binds,
- cg_dir_imps = dir_imps,
+ cg_binds = tidy_binds,
+ cg_dir_imps = dir_imp_mods,
cg_foreign = foreign_stubs,
- cg_dep_pkgs = dep_pkgs deps },
-
- ModDetails { md_types = tidy_type_env,
- md_rules = tidy_rules,
- md_insts = tidy_ispecs,
- md_exports = exports })
+ cg_dep_pkgs = dep_pkgs deps,
+ cg_hpc_info = hpc_info,
+ cg_modBreaks = modBreaks },
+
+ ModDetails { md_types = tidy_type_env,
+ md_rules = tidy_rules,
+ md_insts = tidy_insts,
+ md_fam_insts = fam_insts,
+ md_exports = exports,
+ md_vect_info = vect_info -- is already tidy
+ })
}
+lookup_dfun :: TypeEnv -> Var -> Id
lookup_dfun type_env dfun_id
= case lookupTypeEnv type_env (idName dfun_id) of
Just (AnId dfun_id') -> dfun_id'
- other -> pprPanic "lookup_dfun" (ppr dfun_id)
+ _other -> pprPanic "lookup_dfun" (ppr dfun_id)
-tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv
+--------------------------
+tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [Id] -> TypeEnv
-- The competed type environment is gotten from
-- Dropping any wired-in things, and then
-- This truncates the type environment to include only the
-- exported Ids and things needed from them, which saves space
-tidyTypeEnv omit_prags exports type_env tidy_binds
+tidyTypeEnv omit_prags exports type_env final_ids
= let type_env1 = filterNameEnv keep_it type_env
type_env2 = extendTypeEnvWithIds type_env1 final_ids
- type_env3 | omit_prags = mapNameEnv trim_thing type_env2
+ type_env3 | omit_prags = mapNameEnv (trimThing exports) type_env2
| otherwise = type_env2
in
type_env3
where
- final_ids = [ id | id <- bindersOfBinds tidy_binds,
- isExternalName (idName id)]
-
-- We keep GlobalIds, because they won't appear
-- in the bindings from which final_ids are derived!
-- (The bindings bind LocalIds.)
keep_it thing | isWiredInThing thing = False
keep_it (AnId id) = isGlobalId id -- Keep GlobalIds (e.g. class ops)
- keep_it other = True -- Keep all TyCons, DataCons, and Classes
+ keep_it _other = True -- Keep all TyCons, DataCons, and Classes
- trim_thing thing
- = case thing of
- ATyCon tc | mustExposeTyCon exports tc -> thing
- | otherwise -> ATyCon (makeTyConAbstract tc)
+--------------------------
+isWiredInThing :: TyThing -> Bool
+isWiredInThing thing = isWiredInName (getName thing)
+
+--------------------------
+trimThing :: NameSet -> TyThing -> TyThing
+-- Trim off inessentials, for boot files and no -O
+trimThing exports (ATyCon tc)
+ | not (mustExposeTyCon exports tc)
+ = ATyCon (makeTyConAbstract tc)
+
+trimThing _exports (AnId id)
+ | not (isImplicitId id)
+ = AnId (id `setIdInfo` vanillaIdInfo)
- AnId id | isImplicitId id -> thing
- | otherwise -> AnId (id `setIdInfo` vanillaIdInfo)
+trimThing _exports other_thing
+ = other_thing
- other -> thing
mustExposeTyCon :: NameSet -- Exports
-> TyCon -- The tycon
| isEnumerationTyCon tc -- For an enumeration, exposing the constructors
= True -- won't lead to the need for further exposure
-- (This includes data types with no constructors.)
+ | isOpenTyCon tc -- Open type family
+ = True
+
| otherwise -- Newtype, datatype
= any exported_con (tyConDataCons tc)
-- Expose rep if any datacon or field is exported
- || (isNewTyCon tc && isFFITy (snd (newTyConRep tc)))
+ || (isNewTyCon tc && isFFITy (snd (newTyConRhs tc)))
-- Expose the rep for newtypes if the rep is an FFI type.
-- For a very annoying reason. 'Foreign import' is meant to
-- be able to look through newtypes transparently, but it
where
tidy ispec = setInstanceDFunId ispec $
tidy_dfun (instanceDFunId ispec)
-
-getImplicitBinds :: TypeEnv -> [CoreBind]
-getImplicitBinds type_env
- = map get_defn (concatMap implicit_con_ids (typeEnvTyCons type_env)
- ++ concatMap other_implicit_ids (typeEnvElts type_env))
- -- Put the constructor wrappers first, because
- -- other implicit bindings (notably the fromT functions arising
- -- from generics) use the constructor wrappers. At least that's
- -- what External Core likes
- where
- implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
-
- other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc)
- -- The "naughty" ones are not real functions at all
- -- They are there just so we can get decent error messages
- -- See Note [Naughty record selectors] in MkId.lhs
- other_implicit_ids (AClass cl) = classSelIds cl
- other_implicit_ids other = []
-
- get_defn :: Id -> CoreBind
- get_defn id = NonRec id (tidyExpr emptyTidyEnv rhs)
- where
- rhs = unfoldingTemplate (idUnfolding id)
- -- Don't forget to tidy the body ! Otherwise you get silly things like
- -- \ tpl -> case tpl of tpl -> (tpl,tpl) -> tpl
\end{code}
-- interface file emissions. If the Id isn't in this set, and isn't
-- exported, there's no need to emit anything
need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id
- need_pr needed_set (id,rhs) = need_id needed_set id
+ need_pr needed_set (id,_) = need_id needed_set id
addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
-- The Id is needed; extend the needed set
= extendVarEnv (foldVarSet add_occ needed new_needed_ids)
id show_unfold
where
- add_occ id needed = extendVarEnv needed id False
+ add_occ id needed | id `elemVarEnv` needed = needed
+ | otherwise = extendVarEnv needed id False
-- "False" because we don't know we need the Id's unfolding
- -- We'll override it later when we find the binding site
+ -- Don't override existing bindings; we might have already set it to True
new_needed_ids = worker_ids `unionVarSet`
unfold_ids `unionVarSet`
idinfo = idInfo id
dont_inline = isNeverActive (inlinePragInfo idinfo)
- loop_breaker = isLoopBreaker (occInfo idinfo)
+ loop_breaker = isNonRuleLoopBreaker (occInfo idinfo)
bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
spec_ids = specInfoFreeVars (specInfo idinfo)
worker_info = workerInfo idinfo
worker_ids = case worker_info of
HasWorker work_id _ -> unitVarSet work_id
- otherwise -> emptyVarSet
+ _otherwise -> emptyVarSet
\end{code}
-> TidyEnv -> CoreBind
-> IO (TidyEnv, CoreBind)
-tidyTopBind this_pkg mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs)
+tidyTopBind this_pkg mod nc_var ext_ids (occ_env1,subst1) (NonRec bndr rhs)
= do { (occ_env2, name') <- tidyTopName mod nc_var ext_ids occ_env1 bndr
; let { (bndr', rhs') = tidyTopPair ext_ids tidy_env2 caf_info name' (bndr, rhs)
; subst2 = extendVarEnv subst1 bndr bndr'
where
caf_info = hasCafRefs this_pkg subst1 (idArity bndr) rhs
-tidyTopBind this_pkg mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs)
+tidyTopBind this_pkg mod nc_var ext_ids (occ_env1,subst1) (Rec prs)
= do { (occ_env2, names') <- tidyTopNames mod nc_var ext_ids occ_env1 bndrs
; let { prs' = zipWith (tidyTopPair ext_ids tidy_env2 caf_info)
names' prs
-- externally visible (see comment at the top of this module). If the name
-- was previously local, we have to give it a unique occurrence name if
-- we intend to externalise it.
-tidyTopNames mod nc_var ext_ids occ_env [] = return (occ_env, [])
+tidyTopNames :: Module -> IORef NameCache -> VarEnv Bool -> TidyOccEnv
+ -> [Id] -> IO (TidyOccEnv, [Name])
+tidyTopNames _mod _nc_var _ext_ids occ_env [] = return (occ_env, [])
tidyTopNames mod nc_var ext_ids occ_env (id:ids)
= do { (occ_env1, name) <- tidyTopName mod nc_var ext_ids occ_env id
; (occ_env2, names) <- tidyTopNames mod nc_var ext_ids occ_env1 ids
; 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 = id `elemVarEnv` ext_ids
global = isExternalName name
local = not global
internal = not external
- mb_parent = nameParent_maybe name
- loc = nameSrcLoc name
+ loc = nameSrcSpan name
(occ_env', occ') = tidyOccName occ_env (nameOccName name)
(us1, us2) = splitUniqSupply (nsUniqs nc)
uniq = uniqFromSupply us1
- mk_new_external nc = allocateGlobalBinder nc mod occ' mb_parent loc
+ 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.
-- in the IdInfo of one early in the group
tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs)
- | isGlobalId bndr -- Injected binding for record selector, etc
- = (bndr, tidyExpr rhs_tidy_env rhs)
- | otherwise
= (bndr', rhs')
where
- bndr' = mkVanillaGlobal name' ty' idinfo'
+ bndr' = mkGlobalId details name' ty' idinfo'
+ -- Preserve the GlobalIdDetails of existing global-ids
+ details = case globalIdDetails bndr of
+ NotGlobalId -> VanillaGlobal
+ old_details -> old_details
ty' = tidyTopType (idType bndr)
rhs' = tidyExpr rhs_tidy_env rhs
- idinfo' = tidyTopIdInfo rhs_tidy_env (isJust maybe_external)
- (idInfo bndr) unfold_info arity
- caf_info
+ idinfo = idInfo bndr
+ idinfo' = tidyTopIdInfo (isJust maybe_external)
+ idinfo unfold_info worker_info
+ arity caf_info
-- Expose an unfolding if ext_ids tells us to
-- Remember that ext_ids maps an Id to a Bool:
show_unfold = maybe_external `orElse` False
unfold_info | show_unfold = mkTopUnfolding rhs'
| otherwise = noUnfolding
+ worker_info = tidyWorker rhs_tidy_env show_unfold (workerInfo idinfo)
-- Usually the Id will have an accurate arity on it, because
-- the simplifier has just run, but not always.
-- 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 tidy_env is_external idinfo unfold_info arity caf_info
+tidyTopIdInfo :: Bool -> IdInfo -> Unfolding
+ -> WorkerInfo -> ArityInfo -> CafInfo
+ -> IdInfo
+tidyTopIdInfo is_external idinfo unfold_info worker_info arity 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;
`setAllStrictnessInfo` newStrictnessInfo idinfo
`setInlinePragInfo` inlinePragInfo idinfo
`setUnfoldingInfo` unfold_info
- `setWorkerInfo` tidyWorker tidy_env (workerInfo idinfo)
+ `setWorkerInfo` worker_info
-- NB: we throw away the Rules
-- They have already been extracted by findExternalRules
------------ Worker --------------
-tidyWorker tidy_env (HasWorker work_id wrap_arity)
- = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
-tidyWorker tidy_env other
+tidyWorker :: TidyEnv -> Bool -> WorkerInfo -> WorkerInfo
+tidyWorker _tidy_env _show_unfold NoWorker
= NoWorker
+tidyWorker tidy_env show_unfold (HasWorker work_id wrap_arity)
+ | show_unfold = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
+ | otherwise = NoWorker
+ -- 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
\end{code}
%************************************************************************
\begin{code}
hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
hasCafRefs this_pkg p arity expr
- | is_caf || mentions_cafs = MayHaveCafRefs
+ | is_caf || mentions_cafs
+ = MayHaveCafRefs
| otherwise = NoCafRefs
where
mentions_cafs = isFastTrue (cafRefs p expr)
is_caf = not (arity > 0 || rhsIsStatic this_pkg 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))
Just id' -> fastBool (mayHaveCafRefs (idCafInfo id'))
Nothing -> fastBool False
-cafRefs p (Lit l) = fastBool False
+cafRefs _ (Lit _) = fastBool False
cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
-cafRefs p (Lam x e) = cafRefs p e
+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 (Type t) = fastBool False
+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 p [] = 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))
\end{code}