{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Iface.Tidy (
mkBootModDetailsTc, tidyProgram
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Ppr
import GHC.Driver.Env
import GHC.Tc.Types
import GHC.Core
import GHC.Core.Unfold
import GHC.Core.Unfold.Make
import GHC.Core.FVs
import GHC.Core.Tidy
import GHC.Core.Opt.Monad
import GHC.Core.Stats (coreBindsStats, CoreStats(..))
import GHC.Core.Seq (seqBinds)
import GHC.Core.Lint
import GHC.Core.Rules
import GHC.Core.Opt.Arity ( exprArity, exprBotStrictness_maybe )
import GHC.Core.InstEnv
import GHC.Core.Type ( tidyTopType )
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Class
import GHC.Iface.Tidy.StaticPtrTable
import GHC.Iface.Env
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Misc( filterOut )
import GHC.Utils.Panic
import GHC.Utils.Logger as Logger
import qualified GHC.Utils.Error as Err
import GHC.Types.ForeignStubs
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Make ( mkDictSelRhs )
import GHC.Types.Id.Info
import GHC.Types.Demand ( isDeadEndAppSig, isTopSig, isDeadEndSig )
import GHC.Types.Cpr ( mkCprSig, botCpr )
import GHC.Types.Basic
import GHC.Types.Name hiding (varName)
import GHC.Types.Name.Set
import GHC.Types.Name.Cache
import GHC.Types.Name.Ppr
import GHC.Types.Avail
import GHC.Types.Unique.Supply
import GHC.Types.Tickish
import GHC.Types.TypeEnv
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.Deps
import GHC.Data.Maybe
import Control.Monad
import Data.Function
import Data.List ( sortBy, mapAccumL )
import Data.IORef ( atomicModifyIORef' )
mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc HscEnv
hsc_env
TcGblEnv{ tcg_exports :: TcGblEnv -> [AvailInfo]
tcg_exports = [AvailInfo]
exports,
tcg_type_env :: TcGblEnv -> TypeEnv
tcg_type_env = TypeEnv
type_env,
tcg_tcs :: TcGblEnv -> [TyCon]
tcg_tcs = [TyCon]
tcs,
tcg_patsyns :: TcGblEnv -> [PatSyn]
tcg_patsyns = [PatSyn]
pat_syns,
tcg_insts :: TcGblEnv -> [ClsInst]
tcg_insts = [ClsInst]
insts,
tcg_fam_insts :: TcGblEnv -> [FamInst]
tcg_fam_insts = [FamInst]
fam_insts,
tcg_complete_matches :: TcGblEnv -> CompleteMatches
tcg_complete_matches = CompleteMatches
complete_matches,
tcg_mod :: TcGblEnv -> Module
tcg_mod = Module
this_mod
}
=
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
Err.withTiming Logger
logger DynFlags
dflags
(String -> SDoc
text String
"CoreTidy"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(forall a b. a -> b -> a
const ()) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. Monad m => a -> m a
return (ModDetails { md_types :: TypeEnv
md_types = TypeEnv
type_env'
, md_insts :: [ClsInst]
md_insts = [ClsInst]
insts'
, md_fam_insts :: [FamInst]
md_fam_insts = [FamInst]
fam_insts
, md_rules :: [CoreRule]
md_rules = []
, md_anns :: [Annotation]
md_anns = []
, md_exports :: [AvailInfo]
md_exports = [AvailInfo]
exports
, md_complete_matches :: CompleteMatches
md_complete_matches = CompleteMatches
complete_matches
})
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
final_ids :: [Id]
final_ids = [ Id -> Id
globaliseAndTidyBootId Id
id
| Id
id <- TypeEnv -> [Id]
typeEnvIds TypeEnv
type_env
, Id -> Bool
keep_it Id
id ]
final_tcs :: [TyCon]
final_tcs = forall a. (a -> Bool) -> [a] -> [a]
filterOut forall thing. NamedThing thing => thing -> Bool
isWiredIn [TyCon]
tcs
type_env' :: TypeEnv
type_env' = [Id] -> [TyCon] -> [PatSyn] -> [FamInst] -> TypeEnv
typeEnvFromEntities [Id]
final_ids [TyCon]
final_tcs [PatSyn]
pat_syns [FamInst]
fam_insts
insts' :: [ClsInst]
insts' = TypeEnv -> [ClsInst] -> [ClsInst]
mkFinalClsInsts TypeEnv
type_env' [ClsInst]
insts
keep_it :: Id -> Bool
keep_it Id
id | Name -> Bool
isWiredInName Name
id_name = Bool
False
| Id -> Bool
isExportedId Id
id = Bool
True
| Name
id_name Name -> NameSet -> Bool
`elemNameSet` NameSet
exp_names = Bool
True
| Bool
otherwise = Bool
False
where
id_name :: Name
id_name = Id -> Name
idName Id
id
exp_names :: NameSet
exp_names = [AvailInfo] -> NameSet
availsToNameSet [AvailInfo]
exports
lookupFinalId :: TypeEnv -> Id -> Id
lookupFinalId :: TypeEnv -> Id -> Id
lookupFinalId TypeEnv
type_env Id
id
= case TypeEnv -> Name -> Maybe TyThing
lookupTypeEnv TypeEnv
type_env (Id -> Name
idName Id
id) of
Just (AnId Id
id') -> Id
id'
Maybe TyThing
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"lookup_final_id" (forall a. Outputable a => a -> SDoc
ppr Id
id)
mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst]
mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst]
mkFinalClsInsts TypeEnv
env = forall a b. (a -> b) -> [a] -> [b]
map ((Id -> Id) -> ClsInst -> ClsInst
updateClsInstDFun (TypeEnv -> Id -> Id
lookupFinalId TypeEnv
env))
globaliseAndTidyBootId :: Id -> Id
globaliseAndTidyBootId :: Id -> Id
globaliseAndTidyBootId Id
id
= (Type -> Type) -> Id -> Id
updateIdTypeAndMult Type -> Type
tidyTopType (Id -> Id
globaliseId Id
id)
Id -> Unfolding -> Id
`setIdUnfolding` Unfolding
BootUnfolding
tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram HscEnv
hsc_env (ModGuts { mg_module :: ModGuts -> Module
mg_module = Module
mod
, mg_exports :: ModGuts -> [AvailInfo]
mg_exports = [AvailInfo]
exports
, mg_rdr_env :: ModGuts -> GlobalRdrEnv
mg_rdr_env = GlobalRdrEnv
rdr_env
, mg_tcs :: ModGuts -> [TyCon]
mg_tcs = [TyCon]
tcs
, mg_insts :: ModGuts -> [ClsInst]
mg_insts = [ClsInst]
cls_insts
, mg_fam_insts :: ModGuts -> [FamInst]
mg_fam_insts = [FamInst]
fam_insts
, mg_binds :: ModGuts -> CoreProgram
mg_binds = CoreProgram
binds
, mg_patsyns :: ModGuts -> [PatSyn]
mg_patsyns = [PatSyn]
patsyns
, mg_rules :: ModGuts -> [CoreRule]
mg_rules = [CoreRule]
imp_rules
, mg_anns :: ModGuts -> [Annotation]
mg_anns = [Annotation]
anns
, mg_complete_matches :: ModGuts -> CompleteMatches
mg_complete_matches = CompleteMatches
complete_matches
, mg_deps :: ModGuts -> Dependencies
mg_deps = Dependencies
deps
, mg_foreign :: ModGuts -> ForeignStubs
mg_foreign = ForeignStubs
foreign_stubs
, mg_foreign_files :: ModGuts -> [(ForeignSrcLang, String)]
mg_foreign_files = [(ForeignSrcLang, String)]
foreign_files
, mg_hpc_info :: ModGuts -> HpcInfo
mg_hpc_info = HpcInfo
hpc_info
, mg_modBreaks :: ModGuts -> Maybe ModBreaks
mg_modBreaks = Maybe ModBreaks
modBreaks
})
= forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
Err.withTiming Logger
logger DynFlags
dflags
(String -> SDoc
text String
"CoreTidy"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (forall a. Outputable a => a -> SDoc
ppr Module
mod))
(forall a b. a -> b -> a
const ()) forall a b. (a -> b) -> a -> b
$
do { let { omit_prags :: Bool
omit_prags = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_OmitInterfacePragmas DynFlags
dflags
; expose_all :: Bool
expose_all = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ExposeAllUnfoldings DynFlags
dflags
; print_unqual :: PrintUnqualified
print_unqual = UnitEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) GlobalRdrEnv
rdr_env
; implicit_binds :: CoreProgram
implicit_binds = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyCon -> CoreProgram
getImplicitBinds [TyCon]
tcs
}
; (UnfoldEnv
unfold_env, TidyOccEnv
tidy_occ_env)
<- HscEnv
-> Module
-> Bool
-> Bool
-> CoreProgram
-> CoreProgram
-> [CoreRule]
-> IO (UnfoldEnv, TidyOccEnv)
chooseExternalIds HscEnv
hsc_env Module
mod Bool
omit_prags Bool
expose_all
CoreProgram
binds CoreProgram
implicit_binds [CoreRule]
imp_rules
; let { (CoreProgram
trimmed_binds, [CoreRule]
trimmed_rules)
= Bool
-> CoreProgram
-> [CoreRule]
-> UnfoldEnv
-> (CoreProgram, [CoreRule])
findExternalRules Bool
omit_prags CoreProgram
binds [CoreRule]
imp_rules UnfoldEnv
unfold_env }
; let uf_opts :: UnfoldingOpts
uf_opts = DynFlags -> UnfoldingOpts
unfoldingOpts DynFlags
dflags
; (TidyEnv
tidy_env, CoreProgram
tidy_binds)
<- UnfoldingOpts
-> UnfoldEnv
-> TidyOccEnv
-> CoreProgram
-> IO (TidyEnv, CoreProgram)
tidyTopBinds UnfoldingOpts
uf_opts UnfoldEnv
unfold_env TidyOccEnv
tidy_occ_env CoreProgram
trimmed_binds
; ([SptEntry]
spt_entries, CoreProgram
tidy_binds') <-
HscEnv -> Module -> CoreProgram -> IO ([SptEntry], CoreProgram)
sptCreateStaticBinds HscEnv
hsc_env Module
mod CoreProgram
tidy_binds
; let { platform :: Platform
platform = DynFlags -> Platform
targetPlatform (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
; spt_init_code :: CStub
spt_init_code = Platform -> Module -> [SptEntry] -> CStub
sptModuleInitCode Platform
platform Module
mod [SptEntry]
spt_entries
; add_spt_init_code :: ForeignStubs -> ForeignStubs
add_spt_init_code =
case DynFlags -> Backend
backend DynFlags
dflags of
Backend
Interpreter -> forall a. a -> a
id
Backend
_ -> (ForeignStubs -> CStub -> ForeignStubs
`appendStubC` CStub
spt_init_code)
; final_ids :: [Id]
final_ids = [ Bool -> Id -> Id
trimId Bool
omit_prags Id
id
| Id
id <- forall b. [Bind b] -> [b]
bindersOfBinds CoreProgram
tidy_binds
, Name -> Bool
isExternalName (Id -> Name
idName Id
id)
, Bool -> Bool
not (forall thing. NamedThing thing => thing -> Bool
isWiredIn Id
id)
]
; final_tcs :: [TyCon]
final_tcs = forall a. (a -> Bool) -> [a] -> [a]
filterOut forall thing. NamedThing thing => thing -> Bool
isWiredIn [TyCon]
tcs
; tidy_type_env :: TypeEnv
tidy_type_env = [Id] -> [TyCon] -> [PatSyn] -> [FamInst] -> TypeEnv
typeEnvFromEntities [Id]
final_ids [TyCon]
final_tcs [PatSyn]
patsyns [FamInst]
fam_insts
; tidy_cls_insts :: [ClsInst]
tidy_cls_insts = TypeEnv -> [ClsInst] -> [ClsInst]
mkFinalClsInsts TypeEnv
tidy_type_env [ClsInst]
cls_insts
; tidy_rules :: [CoreRule]
tidy_rules = TidyEnv -> [CoreRule] -> [CoreRule]
tidyRules TidyEnv
tidy_env [CoreRule]
trimmed_rules
;
all_tidy_binds :: CoreProgram
all_tidy_binds = CoreProgram
implicit_binds forall a. [a] -> [a] -> [a]
++ CoreProgram
tidy_binds'
; alg_tycons :: [TyCon]
alg_tycons = forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isAlgTyCon [TyCon]
tcs
}
; HscEnv
-> PrintUnqualified
-> CoreToDo
-> CoreProgram
-> [CoreRule]
-> IO ()
endPassIO HscEnv
hsc_env PrintUnqualified
print_unqual CoreToDo
CoreTidy CoreProgram
all_tidy_binds [CoreRule]
tidy_rules
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_simpl DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
Logger.dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_rules
(DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (forall a. Outputable a => a -> SDoc
ppr CoreToDo
CoreTidy SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"rules"))
DumpFormat
FormatText
([CoreRule] -> SDoc
pprRulesForUser [CoreRule]
tidy_rules)
; let cs :: CoreStats
cs = CoreProgram -> CoreStats
coreBindsStats CoreProgram
tidy_binds
; Logger
-> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
Logger.dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_core_stats String
"Core Stats"
DumpFormat
FormatText
(String -> SDoc
text String
"Tidy size (terms,types,coercions)"
SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall unit. GenModule unit -> ModuleName
moduleName Module
mod) SDoc -> SDoc -> SDoc
<> SDoc
colon
SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int (CoreStats -> Int
cs_tm CoreStats
cs)
SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int (CoreStats -> Int
cs_ty CoreStats
cs)
SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int (CoreStats -> Int
cs_co CoreStats
cs) )
; forall (m :: * -> *) a. Monad m => a -> m a
return (CgGuts { cg_module :: Module
cg_module = Module
mod,
cg_tycons :: [TyCon]
cg_tycons = [TyCon]
alg_tycons,
cg_binds :: CoreProgram
cg_binds = CoreProgram
all_tidy_binds,
cg_foreign :: ForeignStubs
cg_foreign = ForeignStubs -> ForeignStubs
add_spt_init_code ForeignStubs
foreign_stubs,
cg_foreign_files :: [(ForeignSrcLang, String)]
cg_foreign_files = [(ForeignSrcLang, String)]
foreign_files,
cg_dep_pkgs :: [UnitId]
cg_dep_pkgs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Dependencies -> [(UnitId, Bool)]
dep_pkgs Dependencies
deps,
cg_hpc_info :: HpcInfo
cg_hpc_info = HpcInfo
hpc_info,
cg_modBreaks :: Maybe ModBreaks
cg_modBreaks = Maybe ModBreaks
modBreaks,
cg_spt_entries :: [SptEntry]
cg_spt_entries = [SptEntry]
spt_entries },
ModDetails { md_types :: TypeEnv
md_types = TypeEnv
tidy_type_env,
md_rules :: [CoreRule]
md_rules = [CoreRule]
tidy_rules,
md_insts :: [ClsInst]
md_insts = [ClsInst]
tidy_cls_insts,
md_fam_insts :: [FamInst]
md_fam_insts = [FamInst]
fam_insts,
md_exports :: [AvailInfo]
md_exports = [AvailInfo]
exports,
md_anns :: [Annotation]
md_anns = [Annotation]
anns,
md_complete_matches :: CompleteMatches
md_complete_matches = CompleteMatches
complete_matches
})
}
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
trimId :: Bool -> Id -> Id
trimId :: Bool -> Id -> Id
trimId Bool
omit_prags Id
id
| Bool
omit_prags, Bool -> Bool
not (Id -> Bool
isImplicitId Id
id)
= Id
id Id -> IdInfo -> Id
`setIdInfo` IdInfo
vanillaIdInfo
Id -> Unfolding -> Id
`setIdUnfolding` Id -> Unfolding
idUnfolding Id
id
| Bool
otherwise
= Id
id
getImplicitBinds :: TyCon -> [CoreBind]
getImplicitBinds :: TyCon -> CoreProgram
getImplicitBinds TyCon
tc = CoreProgram
cls_binds forall a. [a] -> [a] -> [a]
++ TyCon -> CoreProgram
getTyConImplicitBinds TyCon
tc
where
cls_binds :: CoreProgram
cls_binds = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Class -> CoreProgram
getClassImplicitBinds (TyCon -> Maybe Class
tyConClass_maybe TyCon
tc)
getTyConImplicitBinds :: TyCon -> [CoreBind]
getTyConImplicitBinds :: TyCon -> CoreProgram
getTyConImplicitBinds TyCon
tc
| TyCon -> Bool
isNewTyCon TyCon
tc = []
| Bool
otherwise = forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreBind
get_defn (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DataCon -> Maybe Id
dataConWrapId_maybe (TyCon -> [DataCon]
tyConDataCons TyCon
tc))
getClassImplicitBinds :: Class -> [CoreBind]
getClassImplicitBinds :: Class -> CoreProgram
getClassImplicitBinds Class
cls
= [ forall b. b -> Expr b -> Bind b
NonRec Id
op (Class -> Int -> CoreExpr
mkDictSelRhs Class
cls Int
val_index)
| (Id
op, Int
val_index) <- Class -> [Id]
classAllSelIds Class
cls forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0..] ]
get_defn :: Id -> CoreBind
get_defn :: Id -> CoreBind
get_defn Id
id = forall b. b -> Expr b -> Bind b
NonRec Id
id (Unfolding -> CoreExpr
unfoldingTemplate (Id -> Unfolding
realIdUnfolding Id
id))
type UnfoldEnv = IdEnv (Name, Bool )
chooseExternalIds :: HscEnv
-> Module
-> Bool -> Bool
-> [CoreBind]
-> [CoreBind]
-> [CoreRule]
-> IO (UnfoldEnv, TidyOccEnv)
chooseExternalIds :: HscEnv
-> Module
-> Bool
-> Bool
-> CoreProgram
-> CoreProgram
-> [CoreRule]
-> IO (UnfoldEnv, TidyOccEnv)
chooseExternalIds HscEnv
hsc_env Module
mod Bool
omit_prags Bool
expose_all CoreProgram
binds CoreProgram
implicit_binds [CoreRule]
imp_id_rules
= do { (UnfoldEnv
unfold_env1,TidyOccEnv
occ_env1) <- [(Id, Id)] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
search [(Id, Id)]
init_work_list forall a. VarEnv a
emptyVarEnv TidyOccEnv
init_occ_env
; let internal_ids :: [Id]
internal_ids = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Id -> VarEnv a -> Bool
`elemVarEnv` UnfoldEnv
unfold_env1)) [Id]
binders
; [Id] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
tidy_internal [Id]
internal_ids UnfoldEnv
unfold_env1 TidyOccEnv
occ_env1 }
where
nc_var :: IORef NameCache
nc_var = HscEnv -> IORef NameCache
hsc_NC HscEnv
hsc_env
init_work_list :: [(Id, Id)]
init_work_list = forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
init_ext_ids [Id]
init_ext_ids
init_ext_ids :: [Id]
init_ext_ids = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a. NamedThing a => a -> OccName
getOccName) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
is_external [Id]
binders
is_external :: Id -> Bool
is_external Id
id = Id -> Bool
isExportedId Id
id Bool -> Bool -> Bool
|| Id
id Id -> VarSet -> Bool
`elemVarSet` VarSet
rule_rhs_vars
rule_rhs_vars :: VarSet
rule_rhs_vars = forall a. (a -> VarSet) -> [a] -> VarSet
mapUnionVarSet CoreRule -> VarSet
ruleRhsFreeVars [CoreRule]
imp_id_rules
binders :: [Id]
binders = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall b. [Bind b] -> [(b, Expr b)]
flattenBinds CoreProgram
binds
implicit_binders :: [Id]
implicit_binders = forall b. [Bind b] -> [b]
bindersOfBinds CoreProgram
implicit_binds
binder_set :: VarSet
binder_set = [Id] -> VarSet
mkVarSet [Id]
binders
avoids :: [OccName]
avoids = [forall a. NamedThing a => a -> OccName
getOccName Name
name | Id
bndr <- [Id]
binders forall a. [a] -> [a] -> [a]
++ [Id]
implicit_binders,
let name :: Name
name = Id -> Name
idName Id
bndr,
Name -> Bool
isExternalName Name
name ]
init_occ_env :: TidyOccEnv
init_occ_env = [OccName] -> TidyOccEnv
initTidyOccEnv [OccName]
avoids
search :: [(Id,Id)]
-> UnfoldEnv
-> TidyOccEnv
-> IO (UnfoldEnv, TidyOccEnv)
search :: [(Id, Id)] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
search [] UnfoldEnv
unfold_env TidyOccEnv
occ_env = forall (m :: * -> *) a. Monad m => a -> m a
return (UnfoldEnv
unfold_env, TidyOccEnv
occ_env)
search ((Id
idocc,Id
referrer) : [(Id, Id)]
rest) UnfoldEnv
unfold_env TidyOccEnv
occ_env
| Id
idocc forall a. Id -> VarEnv a -> Bool
`elemVarEnv` UnfoldEnv
unfold_env = [(Id, Id)] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
search [(Id, Id)]
rest UnfoldEnv
unfold_env TidyOccEnv
occ_env
| Bool
otherwise = do
(TidyOccEnv
occ_env', Name
name') <- Module
-> IORef NameCache
-> Maybe Id
-> TidyOccEnv
-> Id
-> IO (TidyOccEnv, Name)
tidyTopName Module
mod IORef NameCache
nc_var (forall a. a -> Maybe a
Just Id
referrer) TidyOccEnv
occ_env Id
idocc
let
([Id]
new_ids, Bool
show_unfold) = Bool -> Bool -> Id -> ([Id], Bool)
addExternal Bool
omit_prags Bool
expose_all Id
refined_id
refined_id :: Id
refined_id = case VarSet -> Id -> Maybe Id
lookupVarSet VarSet
binder_set Id
idocc of
Just Id
id -> Id
id
Maybe Id
Nothing -> WARN( True, ppr idocc ) idocc
unfold_env' :: UnfoldEnv
unfold_env' = forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv UnfoldEnv
unfold_env Id
idocc (Name
name',Bool
show_unfold)
referrer' :: Id
referrer' | Id -> Bool
isExportedId Id
refined_id = Id
refined_id
| Bool
otherwise = Id
referrer
[(Id, Id)] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
search (forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
new_ids (forall a. a -> [a]
repeat Id
referrer') forall a. [a] -> [a] -> [a]
++ [(Id, Id)]
rest) UnfoldEnv
unfold_env' TidyOccEnv
occ_env'
tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv
-> IO (UnfoldEnv, TidyOccEnv)
tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
tidy_internal [] UnfoldEnv
unfold_env TidyOccEnv
occ_env = forall (m :: * -> *) a. Monad m => a -> m a
return (UnfoldEnv
unfold_env,TidyOccEnv
occ_env)
tidy_internal (Id
id:[Id]
ids) UnfoldEnv
unfold_env TidyOccEnv
occ_env = do
(TidyOccEnv
occ_env', Name
name') <- Module
-> IORef NameCache
-> Maybe Id
-> TidyOccEnv
-> Id
-> IO (TidyOccEnv, Name)
tidyTopName Module
mod IORef NameCache
nc_var forall a. Maybe a
Nothing TidyOccEnv
occ_env Id
id
let unfold_env' :: UnfoldEnv
unfold_env' = forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv UnfoldEnv
unfold_env Id
id (Name
name',Bool
False)
[Id] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
tidy_internal [Id]
ids UnfoldEnv
unfold_env' TidyOccEnv
occ_env'
addExternal :: Bool -> Bool -> Id -> ([Id], Bool)
addExternal :: Bool -> Bool -> Id -> ([Id], Bool)
addExternal Bool
omit_prags Bool
expose_all Id
id
| Bool
omit_prags
, Bool -> Bool
not (Unfolding -> Bool
isCompulsoryUnfolding Unfolding
unfolding)
= ([], Bool
False)
| Bool
otherwise
= ([Id]
new_needed_ids, Bool
show_unfold)
where
new_needed_ids :: [Id]
new_needed_ids = Bool -> Id -> [Id]
bndrFvsInOrder Bool
show_unfold Id
id
idinfo :: IdInfo
idinfo = HasDebugCallStack => Id -> IdInfo
idInfo Id
id
unfolding :: Unfolding
unfolding = IdInfo -> Unfolding
unfoldingInfo IdInfo
idinfo
show_unfold :: Bool
show_unfold = Unfolding -> Bool
show_unfolding Unfolding
unfolding
never_active :: Bool
never_active = Activation -> Bool
isNeverActive (InlinePragma -> Activation
inlinePragmaActivation (IdInfo -> InlinePragma
inlinePragInfo IdInfo
idinfo))
loop_breaker :: Bool
loop_breaker = OccInfo -> Bool
isStrongLoopBreaker (IdInfo -> OccInfo
occInfo IdInfo
idinfo)
bottoming_fn :: Bool
bottoming_fn = StrictSig -> Bool
isDeadEndSig (IdInfo -> StrictSig
strictnessInfo IdInfo
idinfo)
show_unfolding :: Unfolding -> Bool
show_unfolding (CoreUnfolding { uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src, uf_guidance :: Unfolding -> UnfoldingGuidance
uf_guidance = UnfoldingGuidance
guidance })
= Bool
expose_all
Bool -> Bool -> Bool
|| UnfoldingSource -> Bool
isStableSource UnfoldingSource
src
Bool -> Bool -> Bool
|| Bool -> Bool
not (Bool
bottoming_fn
Bool -> Bool -> Bool
|| Bool
never_active
Bool -> Bool -> Bool
|| Bool
loop_breaker
Bool -> Bool -> Bool
|| UnfoldingGuidance -> Bool
neverUnfoldGuidance UnfoldingGuidance
guidance)
show_unfolding (DFunUnfolding {}) = Bool
True
show_unfolding Unfolding
_ = Bool
False
bndrFvsInOrder :: Bool -> Id -> [Id]
bndrFvsInOrder :: Bool -> Id -> [Id]
bndrFvsInOrder Bool
show_unfold Id
id
= DFFV () -> [Id]
run (Bool -> Id -> DFFV ()
dffvLetBndr Bool
show_unfold Id
id)
run :: DFFV () -> [Id]
run :: DFFV () -> [Id]
run (DFFV VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), ())
m) = case VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), ())
m VarSet
emptyVarSet (VarSet
emptyVarSet, []) of
((VarSet
_,[Id]
ids),()
_) -> [Id]
ids
newtype DFFV a
= DFFV (VarSet
-> (VarSet, [Var])
-> ((VarSet,[Var]),a))
deriving (forall a b. a -> DFFV b -> DFFV a
forall a b. (a -> b) -> DFFV a -> DFFV b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> DFFV b -> DFFV a
$c<$ :: forall a b. a -> DFFV b -> DFFV a
fmap :: forall a b. (a -> b) -> DFFV a -> DFFV b
$cfmap :: forall a b. (a -> b) -> DFFV a -> DFFV b
Functor)
instance Applicative DFFV where
pure :: forall a. a -> DFFV a
pure a
a = forall a.
(VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)) -> DFFV a
DFFV forall a b. (a -> b) -> a -> b
$ \VarSet
_ (VarSet, [Id])
st -> ((VarSet, [Id])
st, a
a)
<*> :: forall a b. DFFV (a -> b) -> DFFV a -> DFFV b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad DFFV where
(DFFV VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)
m) >>= :: forall a b. DFFV a -> (a -> DFFV b) -> DFFV b
>>= a -> DFFV b
k = forall a.
(VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)) -> DFFV a
DFFV forall a b. (a -> b) -> a -> b
$ \VarSet
env (VarSet, [Id])
st ->
case VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)
m VarSet
env (VarSet, [Id])
st of
((VarSet, [Id])
st',a
a) -> case a -> DFFV b
k a
a of
DFFV VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), b)
f -> VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), b)
f VarSet
env (VarSet, [Id])
st'
extendScope :: Var -> DFFV a -> DFFV a
extendScope :: forall a. Id -> DFFV a -> DFFV a
extendScope Id
v (DFFV VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)
f) = forall a.
(VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)) -> DFFV a
DFFV (\VarSet
env (VarSet, [Id])
st -> VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)
f (VarSet -> Id -> VarSet
extendVarSet VarSet
env Id
v) (VarSet, [Id])
st)
extendScopeList :: [Var] -> DFFV a -> DFFV a
extendScopeList :: forall a. [Id] -> DFFV a -> DFFV a
extendScopeList [Id]
vs (DFFV VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)
f) = forall a.
(VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)) -> DFFV a
DFFV (\VarSet
env (VarSet, [Id])
st -> VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)
f (VarSet -> [Id] -> VarSet
extendVarSetList VarSet
env [Id]
vs) (VarSet, [Id])
st)
insert :: Var -> DFFV ()
insert :: Id -> DFFV ()
insert Id
v = forall a.
(VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)) -> DFFV a
DFFV forall a b. (a -> b) -> a -> b
$ \ VarSet
env (VarSet
set, [Id]
ids) ->
let keep_me :: Bool
keep_me = Id -> Bool
isLocalId Id
v Bool -> Bool -> Bool
&&
Bool -> Bool
not (Id
v Id -> VarSet -> Bool
`elemVarSet` VarSet
env) Bool -> Bool -> Bool
&&
Bool -> Bool
not (Id
v Id -> VarSet -> Bool
`elemVarSet` VarSet
set)
in if Bool
keep_me
then ((VarSet -> Id -> VarSet
extendVarSet VarSet
set Id
v, Id
vforall a. a -> [a] -> [a]
:[Id]
ids), ())
else ((VarSet
set, [Id]
ids), ())
dffvExpr :: CoreExpr -> DFFV ()
dffvExpr :: CoreExpr -> DFFV ()
dffvExpr (Var Id
v) = Id -> DFFV ()
insert Id
v
dffvExpr (App CoreExpr
e1 CoreExpr
e2) = CoreExpr -> DFFV ()
dffvExpr CoreExpr
e1 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CoreExpr -> DFFV ()
dffvExpr CoreExpr
e2
dffvExpr (Lam Id
v CoreExpr
e) = forall a. Id -> DFFV a -> DFFV a
extendScope Id
v (CoreExpr -> DFFV ()
dffvExpr CoreExpr
e)
dffvExpr (Tick (Breakpoint XBreakpoint 'TickishPassCore
_ Int
_ [XTickishId 'TickishPassCore]
ids) CoreExpr
e) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Id -> DFFV ()
insert [XTickishId 'TickishPassCore]
ids forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CoreExpr -> DFFV ()
dffvExpr CoreExpr
e
dffvExpr (Tick GenTickish 'TickishPassCore
_other CoreExpr
e) = CoreExpr -> DFFV ()
dffvExpr CoreExpr
e
dffvExpr (Cast CoreExpr
e CoercionR
_) = CoreExpr -> DFFV ()
dffvExpr CoreExpr
e
dffvExpr (Let (NonRec Id
x CoreExpr
r) CoreExpr
e) = (Id, CoreExpr) -> DFFV ()
dffvBind (Id
x,CoreExpr
r) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Id -> DFFV a -> DFFV a
extendScope Id
x (CoreExpr -> DFFV ()
dffvExpr CoreExpr
e)
dffvExpr (Let (Rec [(Id, CoreExpr)]
prs) CoreExpr
e) = forall a. [Id] -> DFFV a -> DFFV a
extendScopeList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
prs) forall a b. (a -> b) -> a -> b
$
(forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Id, CoreExpr) -> DFFV ()
dffvBind [(Id, CoreExpr)]
prs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CoreExpr -> DFFV ()
dffvExpr CoreExpr
e)
dffvExpr (Case CoreExpr
e Id
b Type
_ [Alt Id]
as) = CoreExpr -> DFFV ()
dffvExpr CoreExpr
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Id -> DFFV a -> DFFV a
extendScope Id
b (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Alt Id -> DFFV ()
dffvAlt [Alt Id]
as)
dffvExpr CoreExpr
_other = forall (m :: * -> *) a. Monad m => a -> m a
return ()
dffvAlt :: CoreAlt -> DFFV ()
dffvAlt :: Alt Id -> DFFV ()
dffvAlt (Alt AltCon
_ [Id]
xs CoreExpr
r) = forall a. [Id] -> DFFV a -> DFFV a
extendScopeList [Id]
xs (CoreExpr -> DFFV ()
dffvExpr CoreExpr
r)
dffvBind :: (Id, CoreExpr) -> DFFV ()
dffvBind :: (Id, CoreExpr) -> DFFV ()
dffvBind(Id
x,CoreExpr
r)
| Bool -> Bool
not (Id -> Bool
isId Id
x) = CoreExpr -> DFFV ()
dffvExpr CoreExpr
r
| Bool
otherwise = Bool -> Id -> DFFV ()
dffvLetBndr Bool
False Id
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CoreExpr -> DFFV ()
dffvExpr CoreExpr
r
dffvLetBndr :: Bool -> Id -> DFFV ()
dffvLetBndr :: Bool -> Id -> DFFV ()
dffvLetBndr Bool
vanilla_unfold Id
id
= do { Unfolding -> DFFV ()
go_unf (IdInfo -> Unfolding
unfoldingInfo IdInfo
idinfo)
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CoreRule -> DFFV ()
go_rule (RuleInfo -> [CoreRule]
ruleInfoRules (IdInfo -> RuleInfo
ruleInfo IdInfo
idinfo)) }
where
idinfo :: IdInfo
idinfo = HasDebugCallStack => Id -> IdInfo
idInfo Id
id
go_unf :: Unfolding -> DFFV ()
go_unf (CoreUnfolding { uf_tmpl :: Unfolding -> CoreExpr
uf_tmpl = CoreExpr
rhs, uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src })
= case UnfoldingSource
src of
UnfoldingSource
InlineRhs | Bool
vanilla_unfold -> CoreExpr -> DFFV ()
dffvExpr CoreExpr
rhs
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
UnfoldingSource
_ -> CoreExpr -> DFFV ()
dffvExpr CoreExpr
rhs
go_unf (DFunUnfolding { df_bndrs :: Unfolding -> [Id]
df_bndrs = [Id]
bndrs, df_args :: Unfolding -> [CoreExpr]
df_args = [CoreExpr]
args })
= forall a. [Id] -> DFFV a -> DFFV a
extendScopeList [Id]
bndrs forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CoreExpr -> DFFV ()
dffvExpr [CoreExpr]
args
go_unf Unfolding
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
go_rule :: CoreRule -> DFFV ()
go_rule (BuiltinRule {}) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
go_rule (Rule { ru_bndrs :: CoreRule -> [Id]
ru_bndrs = [Id]
bndrs, ru_rhs :: CoreRule -> CoreExpr
ru_rhs = CoreExpr
rhs })
= forall a. [Id] -> DFFV a -> DFFV a
extendScopeList [Id]
bndrs (CoreExpr -> DFFV ()
dffvExpr CoreExpr
rhs)
findExternalRules :: Bool
-> [CoreBind]
-> [CoreRule]
-> UnfoldEnv
-> ([CoreBind], [CoreRule])
findExternalRules :: Bool
-> CoreProgram
-> [CoreRule]
-> UnfoldEnv
-> (CoreProgram, [CoreRule])
findExternalRules Bool
omit_prags CoreProgram
binds [CoreRule]
imp_id_rules UnfoldEnv
unfold_env
= (CoreProgram
trimmed_binds, forall a. (a -> Bool) -> [a] -> [a]
filter CoreRule -> Bool
keep_rule [CoreRule]
all_rules)
where
imp_rules :: [CoreRule]
imp_rules = forall a. (a -> Bool) -> [a] -> [a]
filter CoreRule -> Bool
expose_rule [CoreRule]
imp_id_rules
imp_user_rule_fvs :: VarSet
imp_user_rule_fvs = forall a. (a -> VarSet) -> [a] -> VarSet
mapUnionVarSet CoreRule -> VarSet
user_rule_rhs_fvs [CoreRule]
imp_rules
user_rule_rhs_fvs :: CoreRule -> VarSet
user_rule_rhs_fvs CoreRule
rule | CoreRule -> Bool
isAutoRule CoreRule
rule = VarSet
emptyVarSet
| Bool
otherwise = CoreRule -> VarSet
ruleRhsFreeVars CoreRule
rule
(CoreProgram
trimmed_binds, VarSet
local_bndrs, VarSet
_, [CoreRule]
all_rules) = CoreProgram -> (CoreProgram, VarSet, VarSet, [CoreRule])
trim_binds CoreProgram
binds
keep_rule :: CoreRule -> Bool
keep_rule CoreRule
rule = CoreRule -> VarSet
ruleFreeVars CoreRule
rule VarSet -> VarSet -> Bool
`subVarSet` VarSet
local_bndrs
expose_rule :: CoreRule -> Bool
expose_rule CoreRule
rule
| Bool
omit_prags = Bool
False
| Bool
otherwise = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Id -> Bool
is_external_id (CoreRule -> [Id]
ruleLhsFreeIdsList CoreRule
rule)
is_external_id :: Id -> Bool
is_external_id Id
id = case forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv UnfoldEnv
unfold_env Id
id of
Just (Name
name, Bool
_) -> Name -> Bool
isExternalName Name
name
Maybe (Name, Bool)
Nothing -> Bool
False
trim_binds :: [CoreBind]
-> ( [CoreBind]
, VarSet
, VarSet
, [CoreRule])
trim_binds :: CoreProgram -> (CoreProgram, VarSet, VarSet, [CoreRule])
trim_binds []
= ([], VarSet
emptyVarSet, VarSet
imp_user_rule_fvs, [CoreRule]
imp_rules)
trim_binds (CoreBind
bind:CoreProgram
binds)
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
needed [Id]
bndrs
= ( CoreBind
bind forall a. a -> [a] -> [a]
: CoreProgram
binds', VarSet
bndr_set', VarSet
needed_fvs', [CoreRule]
local_rules forall a. [a] -> [a] -> [a]
++ [CoreRule]
rules )
| Bool
otherwise
= (CoreProgram, VarSet, VarSet, [CoreRule])
stuff
where
stuff :: (CoreProgram, VarSet, VarSet, [CoreRule])
stuff@(CoreProgram
binds', VarSet
bndr_set, VarSet
needed_fvs, [CoreRule]
rules)
= CoreProgram -> (CoreProgram, VarSet, VarSet, [CoreRule])
trim_binds CoreProgram
binds
needed :: Id -> Bool
needed Id
bndr = Id -> Bool
isExportedId Id
bndr Bool -> Bool -> Bool
|| Id
bndr Id -> VarSet -> Bool
`elemVarSet` VarSet
needed_fvs
bndrs :: [Id]
bndrs = forall b. Bind b -> [b]
bindersOf CoreBind
bind
rhss :: [CoreExpr]
rhss = forall b. Bind b -> [Expr b]
rhssOfBind CoreBind
bind
bndr_set' :: VarSet
bndr_set' = VarSet
bndr_set VarSet -> [Id] -> VarSet
`extendVarSetList` [Id]
bndrs
needed_fvs' :: VarSet
needed_fvs' = VarSet
needed_fvs VarSet -> VarSet -> VarSet
`unionVarSet`
forall a. (a -> VarSet) -> [a] -> VarSet
mapUnionVarSet Id -> VarSet
idUnfoldingVars [Id]
bndrs VarSet -> VarSet -> VarSet
`unionVarSet`
forall a. (a -> VarSet) -> [a] -> VarSet
mapUnionVarSet CoreExpr -> VarSet
exprFreeVars [CoreExpr]
rhss VarSet -> VarSet -> VarSet
`unionVarSet`
forall a. (a -> VarSet) -> [a] -> VarSet
mapUnionVarSet CoreRule -> VarSet
user_rule_rhs_fvs [CoreRule]
local_rules
local_rules :: [CoreRule]
local_rules = [ CoreRule
rule
| Id
id <- [Id]
bndrs
, Id -> Bool
is_external_id Id
id
, CoreRule
rule <- Id -> [CoreRule]
idCoreRules Id
id
, CoreRule -> Bool
expose_rule CoreRule
rule ]
tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv
-> Id -> IO (TidyOccEnv, Name)
tidyTopName :: Module
-> IORef NameCache
-> Maybe Id
-> TidyOccEnv
-> Id
-> IO (TidyOccEnv, Name)
tidyTopName Module
mod IORef NameCache
nc_var Maybe Id
maybe_ref TidyOccEnv
occ_env Id
id
| Bool
global Bool -> Bool -> Bool
&& Bool
internal = forall (m :: * -> *) a. Monad m => a -> m a
return (TidyOccEnv
occ_env, Name -> Name
localiseName Name
name)
| Bool
global Bool -> Bool -> Bool
&& Bool
external = forall (m :: * -> *) a. Monad m => a -> m a
return (TidyOccEnv
occ_env, Name
name)
| Bool
local Bool -> Bool -> Bool
&& Bool
internal = do { Name
new_local_name <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef NameCache
nc_var NameCache -> (NameCache, Name)
mk_new_local
; forall (m :: * -> *) a. Monad m => a -> m a
return (TidyOccEnv
occ_env', Name
new_local_name) }
| Bool
local Bool -> Bool -> Bool
&& Bool
external = do { Name
new_external_name <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef NameCache
nc_var NameCache -> (NameCache, Name)
mk_new_external
; forall (m :: * -> *) a. Monad m => a -> m a
return (TidyOccEnv
occ_env', Name
new_external_name) }
| Bool
otherwise = forall a. String -> a
panic String
"tidyTopName"
where
name :: Name
name = Id -> Name
idName Id
id
external :: Bool
external = forall a. Maybe a -> Bool
isJust Maybe Id
maybe_ref
global :: Bool
global = Name -> Bool
isExternalName Name
name
local :: Bool
local = Bool -> Bool
not Bool
global
internal :: Bool
internal = Bool -> Bool
not Bool
external
loc :: SrcSpan
loc = Name -> SrcSpan
nameSrcSpan Name
name
old_occ :: OccName
old_occ = Name -> OccName
nameOccName Name
name
new_occ :: OccName
new_occ | Just Id
ref <- Maybe Id
maybe_ref
, Id
ref forall a. Eq a => a -> a -> Bool
/= Id
id
= NameSpace -> String -> OccName
mkOccName (OccName -> NameSpace
occNameSpace OccName
old_occ) forall a b. (a -> b) -> a -> b
$
let
ref_str :: String
ref_str = OccName -> String
occNameString (forall a. NamedThing a => a -> OccName
getOccName Id
ref)
occ_str :: String
occ_str = OccName -> String
occNameString OccName
old_occ
in
case String
occ_str of
Char
'$':Char
'w':String
_ -> String
occ_str
String
_other | Name -> Bool
isSystemName Name
name -> String
ref_str
| Bool
otherwise -> String
ref_str forall a. [a] -> [a] -> [a]
++ Char
'_' forall a. a -> [a] -> [a]
: String
occ_str
| Bool
otherwise = OccName
old_occ
(TidyOccEnv
occ_env', OccName
occ') = TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
tidyOccName TidyOccEnv
occ_env OccName
new_occ
mk_new_local :: NameCache -> (NameCache, Name)
mk_new_local NameCache
nc = (NameCache
nc { nsUniqs :: UniqSupply
nsUniqs = UniqSupply
us }, Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ' SrcSpan
loc)
where
(Unique
uniq, UniqSupply
us) = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (NameCache -> UniqSupply
nsUniqs NameCache
nc)
mk_new_external :: NameCache -> (NameCache, Name)
mk_new_external NameCache
nc = NameCache -> Module -> OccName -> SrcSpan -> (NameCache, Name)
allocateGlobalBinder NameCache
nc Module
mod OccName
occ' SrcSpan
loc
tidyTopBinds :: UnfoldingOpts
-> UnfoldEnv
-> TidyOccEnv
-> CoreProgram
-> IO (TidyEnv, CoreProgram)
tidyTopBinds :: UnfoldingOpts
-> UnfoldEnv
-> TidyOccEnv
-> CoreProgram
-> IO (TidyEnv, CoreProgram)
tidyTopBinds UnfoldingOpts
uf_opts UnfoldEnv
unfold_env TidyOccEnv
init_occ_env CoreProgram
binds
= do let result :: (TidyEnv, CoreProgram)
result = TidyEnv -> CoreProgram -> (TidyEnv, CoreProgram)
tidy TidyEnv
init_env CoreProgram
binds
CoreProgram -> ()
seqBinds (forall a b. (a, b) -> b
snd (TidyEnv, CoreProgram)
result) seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv, CoreProgram)
result
where
init_env :: TidyEnv
init_env = (TidyOccEnv
init_occ_env, forall a. VarEnv a
emptyVarEnv)
tidy :: TidyEnv -> CoreProgram -> (TidyEnv, CoreProgram)
tidy = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (UnfoldingOpts
-> UnfoldEnv -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind)
tidyTopBind UnfoldingOpts
uf_opts UnfoldEnv
unfold_env)
tidyTopBind :: UnfoldingOpts
-> UnfoldEnv
-> TidyEnv
-> CoreBind
-> (TidyEnv, CoreBind)
tidyTopBind :: UnfoldingOpts
-> UnfoldEnv -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind)
tidyTopBind UnfoldingOpts
uf_opts UnfoldEnv
unfold_env
(TidyOccEnv
occ_env,VarEnv Id
subst1) (NonRec Id
bndr CoreExpr
rhs)
= (TidyEnv
tidy_env2, forall b. b -> Expr b -> Bind b
NonRec Id
bndr' CoreExpr
rhs')
where
Just (Name
name',Bool
show_unfold) = forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv UnfoldEnv
unfold_env Id
bndr
(Id
bndr', CoreExpr
rhs') = UnfoldingOpts
-> Bool -> TidyEnv -> Name -> (Id, CoreExpr) -> (Id, CoreExpr)
tidyTopPair UnfoldingOpts
uf_opts Bool
show_unfold TidyEnv
tidy_env2 Name
name' (Id
bndr, CoreExpr
rhs)
subst2 :: VarEnv Id
subst2 = forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv VarEnv Id
subst1 Id
bndr Id
bndr'
tidy_env2 :: TidyEnv
tidy_env2 = (TidyOccEnv
occ_env, VarEnv Id
subst2)
tidyTopBind UnfoldingOpts
uf_opts UnfoldEnv
unfold_env (TidyOccEnv
occ_env, VarEnv Id
subst1) (Rec [(Id, CoreExpr)]
prs)
= (TidyEnv
tidy_env2, forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CoreExpr)]
prs')
where
prs' :: [(Id, CoreExpr)]
prs' = [ UnfoldingOpts
-> Bool -> TidyEnv -> Name -> (Id, CoreExpr) -> (Id, CoreExpr)
tidyTopPair UnfoldingOpts
uf_opts Bool
show_unfold TidyEnv
tidy_env2 Name
name' (Id
id,CoreExpr
rhs)
| (Id
id,CoreExpr
rhs) <- [(Id, CoreExpr)]
prs,
let (Name
name',Bool
show_unfold) =
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"tidyTopBind" forall a b. (a -> b) -> a -> b
$ forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv UnfoldEnv
unfold_env Id
id
]
subst2 :: VarEnv Id
subst2 = forall a. VarEnv a -> [(Id, a)] -> VarEnv a
extendVarEnvList VarEnv Id
subst1 ([Id]
bndrs forall a b. [a] -> [b] -> [(a, b)]
`zip` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
prs')
tidy_env2 :: TidyEnv
tidy_env2 = (TidyOccEnv
occ_env, VarEnv Id
subst2)
bndrs :: [Id]
bndrs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
prs
tidyTopPair :: UnfoldingOpts
-> Bool
-> TidyEnv
-> Name
-> (Id, CoreExpr)
-> (Id, CoreExpr)
tidyTopPair :: UnfoldingOpts
-> Bool -> TidyEnv -> Name -> (Id, CoreExpr) -> (Id, CoreExpr)
tidyTopPair UnfoldingOpts
uf_opts Bool
show_unfold TidyEnv
rhs_tidy_env Name
name' (Id
bndr, CoreExpr
rhs)
= (Id
bndr1, CoreExpr
rhs1)
where
bndr1 :: Id
bndr1 = IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId IdDetails
details Name
name' Type
ty' IdInfo
idinfo'
details :: IdDetails
details = Id -> IdDetails
idDetails Id
bndr
ty' :: Type
ty' = Type -> Type
tidyTopType (Id -> Type
idType Id
bndr)
rhs1 :: CoreExpr
rhs1 = TidyEnv -> CoreExpr -> CoreExpr
tidyExpr TidyEnv
rhs_tidy_env CoreExpr
rhs
idinfo' :: IdInfo
idinfo' = UnfoldingOpts
-> TidyEnv
-> Name
-> CoreExpr
-> CoreExpr
-> IdInfo
-> Bool
-> IdInfo
tidyTopIdInfo UnfoldingOpts
uf_opts TidyEnv
rhs_tidy_env Name
name' CoreExpr
rhs CoreExpr
rhs1 (HasDebugCallStack => Id -> IdInfo
idInfo Id
bndr)
Bool
show_unfold
tidyTopIdInfo :: UnfoldingOpts -> TidyEnv -> Name -> CoreExpr -> CoreExpr
-> IdInfo -> Bool -> IdInfo
tidyTopIdInfo :: UnfoldingOpts
-> TidyEnv
-> Name
-> CoreExpr
-> CoreExpr
-> IdInfo
-> Bool
-> IdInfo
tidyTopIdInfo UnfoldingOpts
uf_opts TidyEnv
rhs_tidy_env Name
name CoreExpr
orig_rhs CoreExpr
tidy_rhs IdInfo
idinfo Bool
show_unfold
| Bool -> Bool
not Bool
is_external
= IdInfo
vanillaIdInfo
IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
final_sig
IdInfo -> CprSig -> IdInfo
`setCprInfo` CprSig
final_cpr
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
minimal_unfold_info
| Bool
otherwise
= IdInfo
vanillaIdInfo
IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
final_sig
IdInfo -> CprSig -> IdInfo
`setCprInfo` CprSig
final_cpr
IdInfo -> OccInfo -> IdInfo
`setOccInfo` OccInfo
robust_occ_info
IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` (IdInfo -> InlinePragma
inlinePragInfo IdInfo
idinfo)
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
unfold_info
where
is_external :: Bool
is_external = Name -> Bool
isExternalName Name
name
robust_occ_info :: OccInfo
robust_occ_info = OccInfo -> OccInfo
zapFragileOcc (IdInfo -> OccInfo
occInfo IdInfo
idinfo)
mb_bot_str :: Maybe (Int, StrictSig)
mb_bot_str = CoreExpr -> Maybe (Int, StrictSig)
exprBotStrictness_maybe CoreExpr
orig_rhs
sig :: StrictSig
sig = IdInfo -> StrictSig
strictnessInfo IdInfo
idinfo
final_sig :: StrictSig
final_sig | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ StrictSig -> Bool
isTopSig StrictSig
sig
= WARN( _bottom_hidden sig , ppr name ) sig
| Just (Int
_, StrictSig
nsig) <- Maybe (Int, StrictSig)
mb_bot_str = StrictSig
nsig
| Bool
otherwise = StrictSig
sig
cpr :: CprSig
cpr = IdInfo -> CprSig
cprInfo IdInfo
idinfo
final_cpr :: CprSig
final_cpr | Just (Int, StrictSig)
_ <- Maybe (Int, StrictSig)
mb_bot_str
= Int -> Cpr -> CprSig
mkCprSig Int
arity Cpr
botCpr
| Bool
otherwise
= CprSig
cpr
_bottom_hidden :: StrictSig -> Bool
_bottom_hidden StrictSig
id_sig = case Maybe (Int, StrictSig)
mb_bot_str of
Maybe (Int, StrictSig)
Nothing -> Bool
False
Just (Int
arity, StrictSig
_) -> Bool -> Bool
not (StrictSig -> Int -> Bool
isDeadEndAppSig StrictSig
id_sig Int
arity)
unf_info :: Unfolding
unf_info = IdInfo -> Unfolding
unfoldingInfo IdInfo
idinfo
unfold_info :: Unfolding
unfold_info
| Unfolding -> Bool
isCompulsoryUnfolding Unfolding
unf_info Bool -> Bool -> Bool
|| Bool
show_unfold
= TidyEnv -> Unfolding -> Unfolding -> Unfolding
tidyUnfolding TidyEnv
rhs_tidy_env Unfolding
unf_info Unfolding
unf_from_rhs
| Bool
otherwise
= Unfolding
minimal_unfold_info
minimal_unfold_info :: Unfolding
minimal_unfold_info = Unfolding -> Unfolding
zapUnfolding Unfolding
unf_info
unf_from_rhs :: Unfolding
unf_from_rhs = UnfoldingOpts
-> UnfoldingSource -> StrictSig -> CoreExpr -> Unfolding
mkFinalUnfolding UnfoldingOpts
uf_opts UnfoldingSource
InlineRhs StrictSig
final_sig CoreExpr
tidy_rhs
arity :: Int
arity = CoreExpr -> Int
exprArity CoreExpr
orig_rhs