{-# LANGUAGE CPP, ViewPatterns #-}
module TidyPgm (
mkBootModDetailsTc, tidyProgram, globaliseAndTidyId
) where
#include "HsVersions.h"
import GhcPrelude
import TcRnTypes
import DynFlags
import CoreSyn
import CoreUnfold
import CoreFVs
import CoreTidy
import CoreMonad
import CorePrep
import CoreUtils (rhsIsStatic)
import CoreStats (coreBindsStats, CoreStats(..))
import CoreSeq (seqBinds)
import CoreLint
import Literal
import Rules
import PatSyn
import ConLike
import CoreArity ( exprArity, exprBotStrictness_maybe )
import StaticPtrTable
import VarEnv
import VarSet
import Var
import Id
import MkId ( mkDictSelRhs )
import IdInfo
import InstEnv
import FamInstEnv
import Type ( tidyTopType )
import Demand ( appIsBottom, isTopSig, isBottomingSig )
import BasicTypes
import Name hiding (varName)
import NameSet
import NameEnv
import NameCache
import Avail
import IfaceEnv
import TcEnv
import TcRnMonad
import DataCon
import TyCon
import Class
import Module
import Packages( isDllName )
import HscTypes
import Maybes
import UniqSupply
import Outputable
import qualified ErrUtils as Err
import Control.Monad
import Data.Function
import Data.List ( sortBy )
import Data.IORef ( atomicModifyIORef' )
mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc hsc_env :: 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_mod :: TcGblEnv -> Module
tcg_mod = Module
this_mod
}
=
IO DynFlags
-> SDoc -> (ModDetails -> ()) -> IO ModDetails -> IO ModDetails
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
Err.withTiming (DynFlags -> IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure DynFlags
dflags)
(String -> SDoc
text "CoreTidy"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(() -> ModDetails -> ()
forall a b. a -> b -> a
const ()) (IO ModDetails -> IO ModDetails) -> IO ModDetails -> IO ModDetails
forall a b. (a -> b) -> a -> b
$
do { let { insts' :: [ClsInst]
insts' = (ClsInst -> ClsInst) -> [ClsInst] -> [ClsInst]
forall a b. (a -> b) -> [a] -> [b]
map ((DFunId -> DFunId) -> ClsInst -> ClsInst
tidyClsInstDFun DFunId -> DFunId
globaliseAndTidyId) [ClsInst]
insts
; pat_syns' :: [PatSyn]
pat_syns' = (PatSyn -> PatSyn) -> [PatSyn] -> [PatSyn]
forall a b. (a -> b) -> [a] -> [b]
map ((DFunId -> DFunId) -> PatSyn -> PatSyn
tidyPatSynIds DFunId -> DFunId
globaliseAndTidyId) [PatSyn]
pat_syns
; type_env1 :: TypeEnv
type_env1 = NameSet -> [DFunId] -> [TyCon] -> [FamInst] -> TypeEnv
mkBootTypeEnv ([AvailInfo] -> NameSet
availsToNameSet [AvailInfo]
exports)
(TypeEnv -> [DFunId]
typeEnvIds TypeEnv
type_env) [TyCon]
tcs [FamInst]
fam_insts
; type_env2 :: TypeEnv
type_env2 = [PatSyn] -> TypeEnv -> TypeEnv
extendTypeEnvWithPatSyns [PatSyn]
pat_syns' TypeEnv
type_env1
; dfun_ids :: [DFunId]
dfun_ids = (ClsInst -> DFunId) -> [ClsInst] -> [DFunId]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> DFunId
instanceDFunId [ClsInst]
insts'
; type_env' :: TypeEnv
type_env' = TypeEnv -> [DFunId] -> TypeEnv
extendTypeEnvWithIds TypeEnv
type_env2 [DFunId]
dfun_ids
}
; ModDetails -> IO ModDetails
forall (m :: * -> *) a. Monad m => a -> m a
return ($WModDetails :: [AvailInfo]
-> TypeEnv
-> [ClsInst]
-> [FamInst]
-> [CoreRule]
-> [Annotation]
-> [CompleteMatch]
-> ModDetails
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_sigs :: [CompleteMatch]
md_complete_sigs = []
})
}
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv
mkBootTypeEnv :: NameSet -> [DFunId] -> [TyCon] -> [FamInst] -> TypeEnv
mkBootTypeEnv exports :: NameSet
exports ids :: [DFunId]
ids tcs :: [TyCon]
tcs fam_insts :: [FamInst]
fam_insts
= Bool -> TypeEnv -> TypeEnv
tidyTypeEnv Bool
True (TypeEnv -> TypeEnv) -> TypeEnv -> TypeEnv
forall a b. (a -> b) -> a -> b
$
[DFunId] -> [TyCon] -> [FamInst] -> TypeEnv
typeEnvFromEntities [DFunId]
final_ids [TyCon]
tcs [FamInst]
fam_insts
where
final_ids :: [DFunId]
final_ids = [ (if DFunId -> Bool
isLocalId DFunId
id then DFunId -> DFunId
globaliseAndTidyId DFunId
id
else DFunId
id)
DFunId -> Unfolding -> DFunId
`setIdUnfolding` Unfolding
BootUnfolding
| DFunId
id <- [DFunId]
ids
, DFunId -> Bool
keep_it DFunId
id ]
keep_it :: DFunId -> Bool
keep_it id :: DFunId
id = DFunId -> Bool
isExportedId DFunId
id Bool -> Bool -> Bool
|| DFunId -> Name
idName DFunId
id Name -> NameSet -> Bool
`elemNameSet` NameSet
exports
globaliseAndTidyId :: Id -> Id
globaliseAndTidyId :: DFunId -> DFunId
globaliseAndTidyId id :: DFunId
id
= DFunId -> Type -> DFunId
Id.setIdType (DFunId -> DFunId
globaliseId DFunId
id) Type
tidy_type
where
tidy_type :: Type
tidy_type = Type -> Type
tidyTopType (DFunId -> Type
idType DFunId
id)
tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram hsc_env :: 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_sigs :: ModGuts -> [CompleteMatch]
mg_complete_sigs = [CompleteMatch]
complete_sigs
, 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
})
= IO DynFlags
-> SDoc
-> ((CgGuts, ModDetails) -> ())
-> IO (CgGuts, ModDetails)
-> IO (CgGuts, ModDetails)
forall (m :: * -> *) a.
MonadIO m =>
m DynFlags -> SDoc -> (a -> ()) -> m a -> m a
Err.withTiming (DynFlags -> IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure DynFlags
dflags)
(String -> SDoc
text "CoreTidy"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod))
(() -> (CgGuts, ModDetails) -> ()
forall a b. a -> b -> a
const ()) (IO (CgGuts, ModDetails) -> IO (CgGuts, ModDetails))
-> IO (CgGuts, ModDetails) -> IO (CgGuts, ModDetails)
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 = DynFlags -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified DynFlags
dflags GlobalRdrEnv
rdr_env
}
; let { type_env :: TypeEnv
type_env = [DFunId] -> [TyCon] -> [FamInst] -> TypeEnv
typeEnvFromEntities [] [TyCon]
tcs [FamInst]
fam_insts
; implicit_binds :: CoreProgram
implicit_binds
= (Class -> CoreProgram) -> [Class] -> CoreProgram
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Class -> CoreProgram
getClassImplicitBinds (TypeEnv -> [Class]
typeEnvClasses TypeEnv
type_env) CoreProgram -> CoreProgram -> CoreProgram
forall a. [a] -> [a] -> [a]
++
(TyCon -> CoreProgram) -> [TyCon] -> CoreProgram
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyCon -> CoreProgram
getTyConImplicitBinds (TypeEnv -> [TyCon]
typeEnvTyCons TypeEnv
type_env)
}
; (unfold_env :: UnfoldEnv
unfold_env, tidy_occ_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 { (trimmed_binds :: CoreProgram
trimmed_binds, trimmed_rules :: [CoreRule]
trimmed_rules)
= Bool
-> CoreProgram
-> [CoreRule]
-> UnfoldEnv
-> (CoreProgram, [CoreRule])
findExternalRules Bool
omit_prags CoreProgram
binds [CoreRule]
imp_rules UnfoldEnv
unfold_env }
; (tidy_env :: TidyEnv
tidy_env, tidy_binds :: CoreProgram
tidy_binds)
<- HscEnv
-> Module
-> UnfoldEnv
-> TidyOccEnv
-> CoreProgram
-> IO (TidyEnv, CoreProgram)
tidyTopBinds HscEnv
hsc_env Module
mod UnfoldEnv
unfold_env TidyOccEnv
tidy_occ_env CoreProgram
trimmed_binds
; let { final_ids :: [DFunId]
final_ids = [ DFunId
id | DFunId
id <- CoreProgram -> [DFunId]
forall b. [Bind b] -> [b]
bindersOfBinds CoreProgram
tidy_binds,
Name -> Bool
isExternalName (DFunId -> Name
idName DFunId
id)]
; type_env1 :: TypeEnv
type_env1 = TypeEnv -> [DFunId] -> TypeEnv
extendTypeEnvWithIds TypeEnv
type_env [DFunId]
final_ids
; tidy_cls_insts :: [ClsInst]
tidy_cls_insts = (ClsInst -> ClsInst) -> [ClsInst] -> [ClsInst]
forall a b. (a -> b) -> [a] -> [b]
map ((DFunId -> DFunId) -> ClsInst -> ClsInst
tidyClsInstDFun (TidyEnv -> DFunId -> DFunId
tidyVarOcc TidyEnv
tidy_env)) [ClsInst]
cls_insts
; tidy_rules :: [CoreRule]
tidy_rules = TidyEnv -> [CoreRule] -> [CoreRule]
tidyRules TidyEnv
tidy_env [CoreRule]
trimmed_rules
; tidy_patsyns :: [PatSyn]
tidy_patsyns = (PatSyn -> PatSyn) -> [PatSyn] -> [PatSyn]
forall a b. (a -> b) -> [a] -> [b]
map ((DFunId -> DFunId) -> PatSyn -> PatSyn
tidyPatSynIds (TidyEnv -> DFunId -> DFunId
tidyVarOcc TidyEnv
tidy_env)) [PatSyn]
patsyns
; type_env2 :: TypeEnv
type_env2 = [PatSyn] -> TypeEnv -> TypeEnv
extendTypeEnvWithPatSyns [PatSyn]
tidy_patsyns TypeEnv
type_env1
; tidy_type_env :: TypeEnv
tidy_type_env = Bool -> TypeEnv -> TypeEnv
tidyTypeEnv Bool
omit_prags TypeEnv
type_env2
}
; (spt_entries :: [SptEntry]
spt_entries, tidy_binds' :: CoreProgram
tidy_binds') <-
HscEnv -> Module -> CoreProgram -> IO ([SptEntry], CoreProgram)
sptCreateStaticBinds HscEnv
hsc_env Module
mod CoreProgram
tidy_binds
; let { spt_init_code :: SDoc
spt_init_code = Module -> [SptEntry] -> SDoc
sptModuleInitCode Module
mod [SptEntry]
spt_entries
; add_spt_init_code :: ForeignStubs -> ForeignStubs
add_spt_init_code =
case DynFlags -> HscTarget
hscTarget DynFlags
dflags of
HscInterpreted -> ForeignStubs -> ForeignStubs
forall a. a -> a
id
_ -> (ForeignStubs -> SDoc -> ForeignStubs
`appendStubC` SDoc
spt_init_code)
}
; let {
all_tidy_binds :: CoreProgram
all_tidy_binds = CoreProgram
implicit_binds CoreProgram -> CoreProgram -> CoreProgram
forall a. [a] -> [a] -> [a]
++ CoreProgram
tidy_binds'
; alg_tycons :: [TyCon]
alg_tycons = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isAlgTyCon (TypeEnv -> [TyCon]
typeEnvTyCons TypeEnv
type_env)
}
; HscEnv
-> PrintUnqualified
-> CoreToDo
-> CoreProgram
-> [CoreRule]
-> IO ()
endPassIO HscEnv
hsc_env PrintUnqualified
print_unqual CoreToDo
CoreTidy CoreProgram
all_tidy_binds [CoreRule]
tidy_rules
; Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_simpl DynFlags
dflags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
DynFlags -> DumpFlag -> String -> SDoc -> IO ()
Err.dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_rules
(DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (CoreToDo -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreToDo
CoreTidy SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "rules"))
(DynFlags -> [CoreRule] -> SDoc
pprRulesForUser DynFlags
dflags [CoreRule]
tidy_rules)
; let cs :: CoreStats
cs = CoreProgram -> CoreStats
coreBindsStats CoreProgram
tidy_binds
; DynFlags -> DumpFlag -> String -> SDoc -> IO ()
Err.dumpIfSet_dyn DynFlags
dflags DumpFlag
Opt_D_dump_core_stats "Core Stats"
(String -> SDoc
text "Tidy size (terms,types,coercions)"
SDoc -> SDoc -> SDoc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> 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) )
; (CgGuts, ModDetails) -> IO (CgGuts, ModDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ($WCgGuts :: Module
-> [TyCon]
-> CoreProgram
-> ForeignStubs
-> [(ForeignSrcLang, String)]
-> [InstalledUnitId]
-> HpcInfo
-> Maybe ModBreaks
-> [SptEntry]
-> CgGuts
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 :: [InstalledUnitId]
cg_dep_pkgs = ((InstalledUnitId, Bool) -> InstalledUnitId)
-> [(InstalledUnitId, Bool)] -> [InstalledUnitId]
forall a b. (a -> b) -> [a] -> [b]
map (InstalledUnitId, Bool) -> InstalledUnitId
forall a b. (a, b) -> a
fst ([(InstalledUnitId, Bool)] -> [InstalledUnitId])
-> [(InstalledUnitId, Bool)] -> [InstalledUnitId]
forall a b. (a -> b) -> a -> b
$ Dependencies -> [(InstalledUnitId, 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 },
$WModDetails :: [AvailInfo]
-> TypeEnv
-> [ClsInst]
-> [FamInst]
-> [CoreRule]
-> [Annotation]
-> [CompleteMatch]
-> ModDetails
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_sigs :: [CompleteMatch]
md_complete_sigs = [CompleteMatch]
complete_sigs
})
}
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
tidyTypeEnv :: Bool
-> TypeEnv -> TypeEnv
tidyTypeEnv :: Bool -> TypeEnv -> TypeEnv
tidyTypeEnv omit_prags :: Bool
omit_prags type_env :: TypeEnv
type_env
= let
type_env1 :: TypeEnv
type_env1 = (TyThing -> Bool) -> TypeEnv -> TypeEnv
forall elt. (elt -> Bool) -> NameEnv elt -> NameEnv elt
filterNameEnv (Bool -> Bool
not (Bool -> Bool) -> (TyThing -> Bool) -> TyThing -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Bool
isWiredInName (Name -> Bool) -> (TyThing -> Name) -> TyThing -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyThing -> Name
forall a. NamedThing a => a -> Name
getName) TypeEnv
type_env
type_env2 :: TypeEnv
type_env2 | Bool
omit_prags = (TyThing -> TyThing) -> TypeEnv -> TypeEnv
forall elt1 elt2. (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
mapNameEnv TyThing -> TyThing
trimThing TypeEnv
type_env1
| Bool
otherwise = TypeEnv
type_env1
in
TypeEnv
type_env2
trimThing :: TyThing -> TyThing
trimThing :: TyThing -> TyThing
trimThing (AnId id :: DFunId
id)
| Bool -> Bool
not (DFunId -> Bool
isImplicitId DFunId
id)
= DFunId -> TyThing
AnId (DFunId
id DFunId -> IdInfo -> DFunId
`setIdInfo` IdInfo
vanillaIdInfo)
trimThing other_thing :: TyThing
other_thing
= TyThing
other_thing
extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv
extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv
extendTypeEnvWithPatSyns tidy_patsyns :: [PatSyn]
tidy_patsyns type_env :: TypeEnv
type_env
= TypeEnv -> [TyThing] -> TypeEnv
extendTypeEnvList TypeEnv
type_env [ConLike -> TyThing
AConLike (PatSyn -> ConLike
PatSynCon PatSyn
ps) | PatSyn
ps <- [PatSyn]
tidy_patsyns ]
getTyConImplicitBinds :: TyCon -> [CoreBind]
getTyConImplicitBinds :: TyCon -> CoreProgram
getTyConImplicitBinds tc :: TyCon
tc = (DFunId -> CoreBind) -> [DFunId] -> CoreProgram
forall a b. (a -> b) -> [a] -> [b]
map DFunId -> CoreBind
get_defn ((DataCon -> Maybe DFunId) -> [DataCon] -> [DFunId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DataCon -> Maybe DFunId
dataConWrapId_maybe (TyCon -> [DataCon]
tyConDataCons TyCon
tc))
getClassImplicitBinds :: Class -> [CoreBind]
getClassImplicitBinds :: Class -> CoreProgram
getClassImplicitBinds cls :: Class
cls
= [ DFunId -> Expr DFunId -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec DFunId
op (Class -> Int -> Expr DFunId
mkDictSelRhs Class
cls Int
val_index)
| (op :: DFunId
op, val_index :: Int
val_index) <- Class -> [DFunId]
classAllSelIds Class
cls [DFunId] -> [Int] -> [(DFunId, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [0..] ]
get_defn :: Id -> CoreBind
get_defn :: DFunId -> CoreBind
get_defn id :: DFunId
id = DFunId -> Expr DFunId -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec DFunId
id (Unfolding -> Expr DFunId
unfoldingTemplate (DFunId -> Unfolding
realIdUnfolding DFunId
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 hsc_env :: HscEnv
hsc_env mod :: Module
mod omit_prags :: Bool
omit_prags expose_all :: Bool
expose_all binds :: CoreProgram
binds implicit_binds :: CoreProgram
implicit_binds imp_id_rules :: [CoreRule]
imp_id_rules
= do { (unfold_env1 :: UnfoldEnv
unfold_env1,occ_env1 :: TidyOccEnv
occ_env1) <- [(DFunId, DFunId)]
-> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
search [(DFunId, DFunId)]
init_work_list UnfoldEnv
forall a. VarEnv a
emptyVarEnv TidyOccEnv
init_occ_env
; let internal_ids :: [DFunId]
internal_ids = (DFunId -> Bool) -> [DFunId] -> [DFunId]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (DFunId -> Bool) -> DFunId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DFunId -> UnfoldEnv -> Bool
forall a. DFunId -> VarEnv a -> Bool
`elemVarEnv` UnfoldEnv
unfold_env1)) [DFunId]
binders
; [DFunId] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
tidy_internal [DFunId]
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 :: [(DFunId, DFunId)]
init_work_list = [DFunId] -> [DFunId] -> [(DFunId, DFunId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [DFunId]
init_ext_ids [DFunId]
init_ext_ids
init_ext_ids :: [DFunId]
init_ext_ids = (DFunId -> DFunId -> Ordering) -> [DFunId] -> [DFunId]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (OccName -> OccName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (OccName -> OccName -> Ordering)
-> (DFunId -> OccName) -> DFunId -> DFunId -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` DFunId -> OccName
forall a. NamedThing a => a -> OccName
getOccName) ([DFunId] -> [DFunId]) -> [DFunId] -> [DFunId]
forall a b. (a -> b) -> a -> b
$ (DFunId -> Bool) -> [DFunId] -> [DFunId]
forall a. (a -> Bool) -> [a] -> [a]
filter DFunId -> Bool
is_external [DFunId]
binders
is_external :: DFunId -> Bool
is_external id :: DFunId
id = DFunId -> Bool
isExportedId DFunId
id Bool -> Bool -> Bool
|| DFunId
id DFunId -> VarSet -> Bool
`elemVarSet` VarSet
rule_rhs_vars
rule_rhs_vars :: VarSet
rule_rhs_vars = (CoreRule -> VarSet) -> [CoreRule] -> VarSet
forall a. (a -> VarSet) -> [a] -> VarSet
mapUnionVarSet CoreRule -> VarSet
ruleRhsFreeVars [CoreRule]
imp_id_rules
binders :: [DFunId]
binders = ((DFunId, Expr DFunId) -> DFunId)
-> [(DFunId, Expr DFunId)] -> [DFunId]
forall a b. (a -> b) -> [a] -> [b]
map (DFunId, Expr DFunId) -> DFunId
forall a b. (a, b) -> a
fst ([(DFunId, Expr DFunId)] -> [DFunId])
-> [(DFunId, Expr DFunId)] -> [DFunId]
forall a b. (a -> b) -> a -> b
$ CoreProgram -> [(DFunId, Expr DFunId)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds CoreProgram
binds
implicit_binders :: [DFunId]
implicit_binders = CoreProgram -> [DFunId]
forall b. [Bind b] -> [b]
bindersOfBinds CoreProgram
implicit_binds
binder_set :: VarSet
binder_set = [DFunId] -> VarSet
mkVarSet [DFunId]
binders
avoids :: [OccName]
avoids = [Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
name | DFunId
bndr <- [DFunId]
binders [DFunId] -> [DFunId] -> [DFunId]
forall a. [a] -> [a] -> [a]
++ [DFunId]
implicit_binders,
let name :: Name
name = DFunId -> Name
idName DFunId
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 :: [(DFunId, DFunId)]
-> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
search [] unfold_env :: UnfoldEnv
unfold_env occ_env :: TidyOccEnv
occ_env = (UnfoldEnv, TidyOccEnv) -> IO (UnfoldEnv, TidyOccEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnfoldEnv
unfold_env, TidyOccEnv
occ_env)
search ((idocc :: DFunId
idocc,referrer :: DFunId
referrer) : rest :: [(DFunId, DFunId)]
rest) unfold_env :: UnfoldEnv
unfold_env occ_env :: TidyOccEnv
occ_env
| DFunId
idocc DFunId -> UnfoldEnv -> Bool
forall a. DFunId -> VarEnv a -> Bool
`elemVarEnv` UnfoldEnv
unfold_env = [(DFunId, DFunId)]
-> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
search [(DFunId, DFunId)]
rest UnfoldEnv
unfold_env TidyOccEnv
occ_env
| Bool
otherwise = do
(occ_env' :: TidyOccEnv
occ_env', name' :: Name
name') <- Module
-> IORef NameCache
-> Maybe DFunId
-> TidyOccEnv
-> DFunId
-> IO (TidyOccEnv, Name)
tidyTopName Module
mod IORef NameCache
nc_var (DFunId -> Maybe DFunId
forall a. a -> Maybe a
Just DFunId
referrer) TidyOccEnv
occ_env DFunId
idocc
let
(new_ids :: [DFunId]
new_ids, show_unfold :: Bool
show_unfold)
| Bool
omit_prags = ([], Bool
False)
| Bool
otherwise = Bool -> DFunId -> ([DFunId], Bool)
addExternal Bool
expose_all DFunId
refined_id
refined_id :: DFunId
refined_id = case VarSet -> DFunId -> Maybe DFunId
lookupVarSet VarSet
binder_set DFunId
idocc of
Just id :: DFunId
id -> DFunId
id
Nothing -> WARN( True, ppr idocc ) idocc
unfold_env' :: UnfoldEnv
unfold_env' = UnfoldEnv -> DFunId -> (Name, Bool) -> UnfoldEnv
forall a. VarEnv a -> DFunId -> a -> VarEnv a
extendVarEnv UnfoldEnv
unfold_env DFunId
idocc (Name
name',Bool
show_unfold)
referrer' :: DFunId
referrer' | DFunId -> Bool
isExportedId DFunId
refined_id = DFunId
refined_id
| Bool
otherwise = DFunId
referrer
[(DFunId, DFunId)]
-> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
search ([DFunId] -> [DFunId] -> [(DFunId, DFunId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [DFunId]
new_ids (DFunId -> [DFunId]
forall a. a -> [a]
repeat DFunId
referrer') [(DFunId, DFunId)] -> [(DFunId, DFunId)] -> [(DFunId, DFunId)]
forall a. [a] -> [a] -> [a]
++ [(DFunId, DFunId)]
rest) UnfoldEnv
unfold_env' TidyOccEnv
occ_env'
tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv
-> IO (UnfoldEnv, TidyOccEnv)
tidy_internal :: [DFunId] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
tidy_internal [] unfold_env :: UnfoldEnv
unfold_env occ_env :: TidyOccEnv
occ_env = (UnfoldEnv, TidyOccEnv) -> IO (UnfoldEnv, TidyOccEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnfoldEnv
unfold_env,TidyOccEnv
occ_env)
tidy_internal (id :: DFunId
id:ids :: [DFunId]
ids) unfold_env :: UnfoldEnv
unfold_env occ_env :: TidyOccEnv
occ_env = do
(occ_env' :: TidyOccEnv
occ_env', name' :: Name
name') <- Module
-> IORef NameCache
-> Maybe DFunId
-> TidyOccEnv
-> DFunId
-> IO (TidyOccEnv, Name)
tidyTopName Module
mod IORef NameCache
nc_var Maybe DFunId
forall a. Maybe a
Nothing TidyOccEnv
occ_env DFunId
id
let unfold_env' :: UnfoldEnv
unfold_env' = UnfoldEnv -> DFunId -> (Name, Bool) -> UnfoldEnv
forall a. VarEnv a -> DFunId -> a -> VarEnv a
extendVarEnv UnfoldEnv
unfold_env DFunId
id (Name
name',Bool
False)
[DFunId] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
tidy_internal [DFunId]
ids UnfoldEnv
unfold_env' TidyOccEnv
occ_env'
addExternal :: Bool -> Id -> ([Id], Bool)
addExternal :: Bool -> DFunId -> ([DFunId], Bool)
addExternal expose_all :: Bool
expose_all id :: DFunId
id = ([DFunId]
new_needed_ids, Bool
show_unfold)
where
new_needed_ids :: [DFunId]
new_needed_ids = Bool -> DFunId -> [DFunId]
bndrFvsInOrder Bool
show_unfold DFunId
id
idinfo :: IdInfo
idinfo = HasDebugCallStack => DFunId -> IdInfo
DFunId -> IdInfo
idInfo DFunId
id
show_unfold :: Bool
show_unfold = Unfolding -> Bool
show_unfolding (IdInfo -> Unfolding
unfoldingInfo IdInfo
idinfo)
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
isBottomingSig (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 _ = Bool
False
bndrFvsInOrder :: Bool -> Id -> [Id]
bndrFvsInOrder :: Bool -> DFunId -> [DFunId]
bndrFvsInOrder show_unfold :: Bool
show_unfold id :: DFunId
id
= DFFV () -> [DFunId]
run (Bool -> DFunId -> DFFV ()
dffvLetBndr Bool
show_unfold DFunId
id)
run :: DFFV () -> [Id]
run :: DFFV () -> [DFunId]
run (DFFV m :: VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), ())
m) = case VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), ())
m VarSet
emptyVarSet (VarSet
emptyVarSet, []) of
((_,ids :: [DFunId]
ids),_) -> [DFunId]
ids
newtype DFFV a
= DFFV (VarSet
-> (VarSet, [Var])
-> ((VarSet,[Var]),a))
instance Functor DFFV where
fmap :: (a -> b) -> DFFV a -> DFFV b
fmap = (a -> b) -> DFFV a -> DFFV b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative DFFV where
pure :: a -> DFFV a
pure a :: a
a = (VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), a)) -> DFFV a
forall a.
(VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), a)) -> DFFV a
DFFV ((VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), a))
-> DFFV a)
-> (VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), a))
-> DFFV a
forall a b. (a -> b) -> a -> b
$ \_ st :: (VarSet, [DFunId])
st -> ((VarSet, [DFunId])
st, a
a)
<*> :: DFFV (a -> b) -> DFFV a -> DFFV 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 m :: VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), a)
m) >>= :: DFFV a -> (a -> DFFV b) -> DFFV b
>>= k :: a -> DFFV b
k = (VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), b)) -> DFFV b
forall a.
(VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), a)) -> DFFV a
DFFV ((VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), b))
-> DFFV b)
-> (VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), b))
-> DFFV b
forall a b. (a -> b) -> a -> b
$ \env :: VarSet
env st :: (VarSet, [DFunId])
st ->
case VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), a)
m VarSet
env (VarSet, [DFunId])
st of
(st' :: (VarSet, [DFunId])
st',a :: a
a) -> case a -> DFFV b
k a
a of
DFFV f :: VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), b)
f -> VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), b)
f VarSet
env (VarSet, [DFunId])
st'
extendScope :: Var -> DFFV a -> DFFV a
extendScope :: DFunId -> DFFV a -> DFFV a
extendScope v :: DFunId
v (DFFV f :: VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), a)
f) = (VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), a)) -> DFFV a
forall a.
(VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), a)) -> DFFV a
DFFV (\env :: VarSet
env st :: (VarSet, [DFunId])
st -> VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), a)
f (VarSet -> DFunId -> VarSet
extendVarSet VarSet
env DFunId
v) (VarSet, [DFunId])
st)
extendScopeList :: [Var] -> DFFV a -> DFFV a
extendScopeList :: [DFunId] -> DFFV a -> DFFV a
extendScopeList vs :: [DFunId]
vs (DFFV f :: VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), a)
f) = (VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), a)) -> DFFV a
forall a.
(VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), a)) -> DFFV a
DFFV (\env :: VarSet
env st :: (VarSet, [DFunId])
st -> VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), a)
f (VarSet -> [DFunId] -> VarSet
extendVarSetList VarSet
env [DFunId]
vs) (VarSet, [DFunId])
st)
insert :: Var -> DFFV ()
insert :: DFunId -> DFFV ()
insert v :: DFunId
v = (VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), ()))
-> DFFV ()
forall a.
(VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), a)) -> DFFV a
DFFV ((VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), ()))
-> DFFV ())
-> (VarSet -> (VarSet, [DFunId]) -> ((VarSet, [DFunId]), ()))
-> DFFV ()
forall a b. (a -> b) -> a -> b
$ \ env :: VarSet
env (set :: VarSet
set, ids :: [DFunId]
ids) ->
let keep_me :: Bool
keep_me = DFunId -> Bool
isLocalId DFunId
v Bool -> Bool -> Bool
&&
Bool -> Bool
not (DFunId
v DFunId -> VarSet -> Bool
`elemVarSet` VarSet
env) Bool -> Bool -> Bool
&&
Bool -> Bool
not (DFunId
v DFunId -> VarSet -> Bool
`elemVarSet` VarSet
set)
in if Bool
keep_me
then ((VarSet -> DFunId -> VarSet
extendVarSet VarSet
set DFunId
v, DFunId
vDFunId -> [DFunId] -> [DFunId]
forall a. a -> [a] -> [a]
:[DFunId]
ids), ())
else ((VarSet
set, [DFunId]
ids), ())
dffvExpr :: CoreExpr -> DFFV ()
dffvExpr :: Expr DFunId -> DFFV ()
dffvExpr (Var v :: DFunId
v) = DFunId -> DFFV ()
insert DFunId
v
dffvExpr (App e1 :: Expr DFunId
e1 e2 :: Expr DFunId
e2) = Expr DFunId -> DFFV ()
dffvExpr Expr DFunId
e1 DFFV () -> DFFV () -> DFFV ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr DFunId -> DFFV ()
dffvExpr Expr DFunId
e2
dffvExpr (Lam v :: DFunId
v e :: Expr DFunId
e) = DFunId -> DFFV () -> DFFV ()
forall a. DFunId -> DFFV a -> DFFV a
extendScope DFunId
v (Expr DFunId -> DFFV ()
dffvExpr Expr DFunId
e)
dffvExpr (Tick (Breakpoint _ ids :: [DFunId]
ids) e :: Expr DFunId
e) = (DFunId -> DFFV ()) -> [DFunId] -> DFFV ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DFunId -> DFFV ()
insert [DFunId]
ids DFFV () -> DFFV () -> DFFV ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr DFunId -> DFFV ()
dffvExpr Expr DFunId
e
dffvExpr (Tick _other :: Tickish DFunId
_other e :: Expr DFunId
e) = Expr DFunId -> DFFV ()
dffvExpr Expr DFunId
e
dffvExpr (Cast e :: Expr DFunId
e _) = Expr DFunId -> DFFV ()
dffvExpr Expr DFunId
e
dffvExpr (Let (NonRec x :: DFunId
x r :: Expr DFunId
r) e :: Expr DFunId
e) = (DFunId, Expr DFunId) -> DFFV ()
dffvBind (DFunId
x,Expr DFunId
r) DFFV () -> DFFV () -> DFFV ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DFunId -> DFFV () -> DFFV ()
forall a. DFunId -> DFFV a -> DFFV a
extendScope DFunId
x (Expr DFunId -> DFFV ()
dffvExpr Expr DFunId
e)
dffvExpr (Let (Rec prs :: [(DFunId, Expr DFunId)]
prs) e :: Expr DFunId
e) = [DFunId] -> DFFV () -> DFFV ()
forall a. [DFunId] -> DFFV a -> DFFV a
extendScopeList (((DFunId, Expr DFunId) -> DFunId)
-> [(DFunId, Expr DFunId)] -> [DFunId]
forall a b. (a -> b) -> [a] -> [b]
map (DFunId, Expr DFunId) -> DFunId
forall a b. (a, b) -> a
fst [(DFunId, Expr DFunId)]
prs) (DFFV () -> DFFV ()) -> DFFV () -> DFFV ()
forall a b. (a -> b) -> a -> b
$
(((DFunId, Expr DFunId) -> DFFV ())
-> [(DFunId, Expr DFunId)] -> DFFV ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DFunId, Expr DFunId) -> DFFV ()
dffvBind [(DFunId, Expr DFunId)]
prs DFFV () -> DFFV () -> DFFV ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr DFunId -> DFFV ()
dffvExpr Expr DFunId
e)
dffvExpr (Case e :: Expr DFunId
e b :: DFunId
b _ as :: [Alt DFunId]
as) = Expr DFunId -> DFFV ()
dffvExpr Expr DFunId
e DFFV () -> DFFV () -> DFFV ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DFunId -> DFFV () -> DFFV ()
forall a. DFunId -> DFFV a -> DFFV a
extendScope DFunId
b ((Alt DFunId -> DFFV ()) -> [Alt DFunId] -> DFFV ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Alt DFunId -> DFFV ()
forall t. (t, [DFunId], Expr DFunId) -> DFFV ()
dffvAlt [Alt DFunId]
as)
dffvExpr _other :: Expr DFunId
_other = () -> DFFV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
dffvAlt :: (t, [Var], CoreExpr) -> DFFV ()
dffvAlt :: (t, [DFunId], Expr DFunId) -> DFFV ()
dffvAlt (_,xs :: [DFunId]
xs,r :: Expr DFunId
r) = [DFunId] -> DFFV () -> DFFV ()
forall a. [DFunId] -> DFFV a -> DFFV a
extendScopeList [DFunId]
xs (Expr DFunId -> DFFV ()
dffvExpr Expr DFunId
r)
dffvBind :: (Id, CoreExpr) -> DFFV ()
dffvBind :: (DFunId, Expr DFunId) -> DFFV ()
dffvBind(x :: DFunId
x,r :: Expr DFunId
r)
| Bool -> Bool
not (DFunId -> Bool
isId DFunId
x) = Expr DFunId -> DFFV ()
dffvExpr Expr DFunId
r
| Bool
otherwise = Bool -> DFunId -> DFFV ()
dffvLetBndr Bool
False DFunId
x DFFV () -> DFFV () -> DFFV ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr DFunId -> DFFV ()
dffvExpr Expr DFunId
r
dffvLetBndr :: Bool -> Id -> DFFV ()
dffvLetBndr :: Bool -> DFunId -> DFFV ()
dffvLetBndr vanilla_unfold :: Bool
vanilla_unfold id :: DFunId
id
= do { Unfolding -> DFFV ()
go_unf (IdInfo -> Unfolding
unfoldingInfo IdInfo
idinfo)
; (CoreRule -> DFFV ()) -> [CoreRule] -> DFFV ()
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 => DFunId -> IdInfo
DFunId -> IdInfo
idInfo DFunId
id
go_unf :: Unfolding -> DFFV ()
go_unf (CoreUnfolding { uf_tmpl :: Unfolding -> Expr DFunId
uf_tmpl = Expr DFunId
rhs, uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src })
= case UnfoldingSource
src of
InlineRhs | Bool
vanilla_unfold -> Expr DFunId -> DFFV ()
dffvExpr Expr DFunId
rhs
| Bool
otherwise -> () -> DFFV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
_ -> Expr DFunId -> DFFV ()
dffvExpr Expr DFunId
rhs
go_unf (DFunUnfolding { df_bndrs :: Unfolding -> [DFunId]
df_bndrs = [DFunId]
bndrs, df_args :: Unfolding -> [Expr DFunId]
df_args = [Expr DFunId]
args })
= [DFunId] -> DFFV () -> DFFV ()
forall a. [DFunId] -> DFFV a -> DFFV a
extendScopeList [DFunId]
bndrs (DFFV () -> DFFV ()) -> DFFV () -> DFFV ()
forall a b. (a -> b) -> a -> b
$ (Expr DFunId -> DFFV ()) -> [Expr DFunId] -> DFFV ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Expr DFunId -> DFFV ()
dffvExpr [Expr DFunId]
args
go_unf _ = () -> DFFV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go_rule :: CoreRule -> DFFV ()
go_rule (BuiltinRule {}) = () -> DFFV ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go_rule (Rule { ru_bndrs :: CoreRule -> [DFunId]
ru_bndrs = [DFunId]
bndrs, ru_rhs :: CoreRule -> Expr DFunId
ru_rhs = Expr DFunId
rhs })
= [DFunId] -> DFFV () -> DFFV ()
forall a. [DFunId] -> DFFV a -> DFFV a
extendScopeList [DFunId]
bndrs (Expr DFunId -> DFFV ()
dffvExpr Expr DFunId
rhs)
findExternalRules :: Bool
-> [CoreBind]
-> [CoreRule]
-> UnfoldEnv
-> ([CoreBind], [CoreRule])
findExternalRules :: Bool
-> CoreProgram
-> [CoreRule]
-> UnfoldEnv
-> (CoreProgram, [CoreRule])
findExternalRules omit_prags :: Bool
omit_prags binds :: CoreProgram
binds imp_id_rules :: [CoreRule]
imp_id_rules unfold_env :: UnfoldEnv
unfold_env
= (CoreProgram
trimmed_binds, (CoreRule -> Bool) -> [CoreRule] -> [CoreRule]
forall a. (a -> Bool) -> [a] -> [a]
filter CoreRule -> Bool
keep_rule [CoreRule]
all_rules)
where
imp_rules :: [CoreRule]
imp_rules = (CoreRule -> Bool) -> [CoreRule] -> [CoreRule]
forall a. (a -> Bool) -> [a] -> [a]
filter CoreRule -> Bool
expose_rule [CoreRule]
imp_id_rules
imp_user_rule_fvs :: VarSet
imp_user_rule_fvs = (CoreRule -> VarSet) -> [CoreRule] -> VarSet
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 rule :: CoreRule
rule | CoreRule -> Bool
isAutoRule CoreRule
rule = VarSet
emptyVarSet
| Bool
otherwise = CoreRule -> VarSet
ruleRhsFreeVars CoreRule
rule
(trimmed_binds :: CoreProgram
trimmed_binds, local_bndrs :: VarSet
local_bndrs, _, all_rules :: [CoreRule]
all_rules) = CoreProgram -> (CoreProgram, VarSet, VarSet, [CoreRule])
trim_binds CoreProgram
binds
keep_rule :: CoreRule -> Bool
keep_rule rule :: CoreRule
rule = CoreRule -> VarSet
ruleFreeVars CoreRule
rule VarSet -> VarSet -> Bool
`subVarSet` VarSet
local_bndrs
expose_rule :: CoreRule -> Bool
expose_rule rule :: CoreRule
rule
| Bool
omit_prags = Bool
False
| Bool
otherwise = (DFunId -> Bool) -> [DFunId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all DFunId -> Bool
is_external_id (CoreRule -> [DFunId]
ruleLhsFreeIdsList CoreRule
rule)
is_external_id :: DFunId -> Bool
is_external_id id :: DFunId
id = case UnfoldEnv -> DFunId -> Maybe (Name, Bool)
forall a. VarEnv a -> DFunId -> Maybe a
lookupVarEnv UnfoldEnv
unfold_env DFunId
id of
Just (name :: Name
name, _) -> Name -> Bool
isExternalName Name
name
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 (bind :: CoreBind
bind:binds :: CoreProgram
binds)
| (DFunId -> Bool) -> [DFunId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any DFunId -> Bool
needed [DFunId]
bndrs
= ( CoreBind
bind CoreBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
: CoreProgram
binds', VarSet
bndr_set', VarSet
needed_fvs', [CoreRule]
local_rules [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
++ [CoreRule]
rules )
| Bool
otherwise
= (CoreProgram, VarSet, VarSet, [CoreRule])
stuff
where
stuff :: (CoreProgram, VarSet, VarSet, [CoreRule])
stuff@(binds' :: CoreProgram
binds', bndr_set :: VarSet
bndr_set, needed_fvs :: VarSet
needed_fvs, rules :: [CoreRule]
rules)
= CoreProgram -> (CoreProgram, VarSet, VarSet, [CoreRule])
trim_binds CoreProgram
binds
needed :: DFunId -> Bool
needed bndr :: DFunId
bndr = DFunId -> Bool
isExportedId DFunId
bndr Bool -> Bool -> Bool
|| DFunId
bndr DFunId -> VarSet -> Bool
`elemVarSet` VarSet
needed_fvs
bndrs :: [DFunId]
bndrs = CoreBind -> [DFunId]
forall b. Bind b -> [b]
bindersOf CoreBind
bind
rhss :: [Expr DFunId]
rhss = CoreBind -> [Expr DFunId]
forall b. Bind b -> [Expr b]
rhssOfBind CoreBind
bind
bndr_set' :: VarSet
bndr_set' = VarSet
bndr_set VarSet -> [DFunId] -> VarSet
`extendVarSetList` [DFunId]
bndrs
needed_fvs' :: VarSet
needed_fvs' = VarSet
needed_fvs VarSet -> VarSet -> VarSet
`unionVarSet`
(DFunId -> VarSet) -> [DFunId] -> VarSet
forall a. (a -> VarSet) -> [a] -> VarSet
mapUnionVarSet DFunId -> VarSet
idUnfoldingVars [DFunId]
bndrs VarSet -> VarSet -> VarSet
`unionVarSet`
(Expr DFunId -> VarSet) -> [Expr DFunId] -> VarSet
forall a. (a -> VarSet) -> [a] -> VarSet
mapUnionVarSet Expr DFunId -> VarSet
exprFreeVars [Expr DFunId]
rhss VarSet -> VarSet -> VarSet
`unionVarSet`
(CoreRule -> VarSet) -> [CoreRule] -> VarSet
forall a. (a -> VarSet) -> [a] -> VarSet
mapUnionVarSet CoreRule -> VarSet
user_rule_rhs_fvs [CoreRule]
local_rules
local_rules :: [CoreRule]
local_rules = [ CoreRule
rule
| DFunId
id <- [DFunId]
bndrs
, DFunId -> Bool
is_external_id DFunId
id
, CoreRule
rule <- DFunId -> [CoreRule]
idCoreRules DFunId
id
, CoreRule -> Bool
expose_rule CoreRule
rule ]
tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv
-> Id -> IO (TidyOccEnv, Name)
tidyTopName :: Module
-> IORef NameCache
-> Maybe DFunId
-> TidyOccEnv
-> DFunId
-> IO (TidyOccEnv, Name)
tidyTopName mod :: Module
mod nc_var :: IORef NameCache
nc_var maybe_ref :: Maybe DFunId
maybe_ref occ_env :: TidyOccEnv
occ_env id :: DFunId
id
| Bool
global Bool -> Bool -> Bool
&& Bool
internal = (TidyOccEnv, Name) -> IO (TidyOccEnv, Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyOccEnv
occ_env, Name -> Name
localiseName Name
name)
| Bool
global Bool -> Bool -> Bool
&& Bool
external = (TidyOccEnv, Name) -> IO (TidyOccEnv, Name)
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 <- IORef NameCache -> (NameCache -> (NameCache, Name)) -> IO Name
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef NameCache
nc_var NameCache -> (NameCache, Name)
mk_new_local
; (TidyOccEnv, Name) -> IO (TidyOccEnv, Name)
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 <- IORef NameCache -> (NameCache -> (NameCache, Name)) -> IO Name
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef NameCache
nc_var NameCache -> (NameCache, Name)
mk_new_external
; (TidyOccEnv, Name) -> IO (TidyOccEnv, Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyOccEnv
occ_env', Name
new_external_name) }
| Bool
otherwise = String -> IO (TidyOccEnv, Name)
forall a. String -> a
panic "tidyTopName"
where
name :: Name
name = DFunId -> Name
idName DFunId
id
external :: Bool
external = Maybe DFunId -> Bool
forall a. Maybe a -> Bool
isJust Maybe DFunId
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 ref :: DFunId
ref <- Maybe DFunId
maybe_ref
, DFunId
ref DFunId -> DFunId -> Bool
forall a. Eq a => a -> a -> Bool
/= DFunId
id
= NameSpace -> String -> OccName
mkOccName (OccName -> NameSpace
occNameSpace OccName
old_occ) (String -> OccName) -> String -> OccName
forall a b. (a -> b) -> a -> b
$
let
ref_str :: String
ref_str = OccName -> String
occNameString (DFunId -> OccName
forall a. NamedThing a => a -> OccName
getOccName DFunId
ref)
occ_str :: String
occ_str = OccName -> String
occNameString OccName
old_occ
in
case String
occ_str of
'$':'w':_ -> String
occ_str
_other :: String
_other | Name -> Bool
isSystemName Name
name -> String
ref_str
| Bool
otherwise -> String
ref_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ '_' Char -> String -> String
forall a. a -> [a] -> [a]
: String
occ_str
| Bool
otherwise = OccName
old_occ
(occ_env' :: TidyOccEnv
occ_env', occ' :: OccName
occ') = TidyOccEnv -> OccName -> (TidyOccEnv, OccName)
tidyOccName TidyOccEnv
occ_env OccName
new_occ
mk_new_local :: NameCache -> (NameCache, Name)
mk_new_local nc :: NameCache
nc = (NameCache
nc { nsUniqs :: UniqSupply
nsUniqs = UniqSupply
us }, Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ' SrcSpan
loc)
where
(uniq :: Unique
uniq, us :: UniqSupply
us) = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (NameCache -> UniqSupply
nsUniqs NameCache
nc)
mk_new_external :: NameCache -> (NameCache, Name)
mk_new_external nc :: NameCache
nc = NameCache -> Module -> OccName -> SrcSpan -> (NameCache, Name)
allocateGlobalBinder NameCache
nc Module
mod OccName
occ' SrcSpan
loc
tidyTopBinds :: HscEnv
-> Module
-> UnfoldEnv
-> TidyOccEnv
-> CoreProgram
-> IO (TidyEnv, CoreProgram)
tidyTopBinds :: HscEnv
-> Module
-> UnfoldEnv
-> TidyOccEnv
-> CoreProgram
-> IO (TidyEnv, CoreProgram)
tidyTopBinds hsc_env :: HscEnv
hsc_env this_mod :: Module
this_mod unfold_env :: UnfoldEnv
unfold_env init_occ_env :: TidyOccEnv
init_occ_env binds :: CoreProgram
binds
= do DFunId
mkIntegerId <- DynFlags -> HscEnv -> IO DFunId
lookupMkIntegerName DynFlags
dflags HscEnv
hsc_env
DFunId
mkNaturalId <- DynFlags -> HscEnv -> IO DFunId
lookupMkNaturalName DynFlags
dflags HscEnv
hsc_env
Maybe DataCon
integerSDataCon <- DynFlags -> HscEnv -> IO (Maybe DataCon)
lookupIntegerSDataConName DynFlags
dflags HscEnv
hsc_env
Maybe DataCon
naturalSDataCon <- DynFlags -> HscEnv -> IO (Maybe DataCon)
lookupNaturalSDataConName DynFlags
dflags HscEnv
hsc_env
let cvt_literal :: LitNumType -> Integer -> Maybe (Expr DFunId)
cvt_literal nt :: LitNumType
nt i :: Integer
i = case LitNumType
nt of
LitNumInteger -> Expr DFunId -> Maybe (Expr DFunId)
forall a. a -> Maybe a
Just (DynFlags -> DFunId -> Maybe DataCon -> Integer -> Expr DFunId
cvtLitInteger DynFlags
dflags DFunId
mkIntegerId Maybe DataCon
integerSDataCon Integer
i)
LitNumNatural -> Expr DFunId -> Maybe (Expr DFunId)
forall a. a -> Maybe a
Just (DynFlags -> DFunId -> Maybe DataCon -> Integer -> Expr DFunId
cvtLitNatural DynFlags
dflags DFunId
mkNaturalId Maybe DataCon
naturalSDataCon Integer
i)
_ -> Maybe (Expr DFunId)
forall a. Maybe a
Nothing
result :: (TidyEnv, CoreProgram)
result = (LitNumType -> Integer -> Maybe (Expr DFunId))
-> TidyEnv -> CoreProgram -> (TidyEnv, CoreProgram)
tidy LitNumType -> Integer -> Maybe (Expr DFunId)
cvt_literal TidyEnv
forall a. (TidyOccEnv, VarEnv a)
init_env CoreProgram
binds
CoreProgram -> ()
seqBinds ((TidyEnv, CoreProgram) -> CoreProgram
forall a b. (a, b) -> b
snd (TidyEnv, CoreProgram)
result) () -> IO (TidyEnv, CoreProgram) -> IO (TidyEnv, CoreProgram)
forall a b. a -> b -> b
`seq` (TidyEnv, CoreProgram) -> IO (TidyEnv, CoreProgram)
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv, CoreProgram)
result
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
init_env :: (TidyOccEnv, VarEnv a)
init_env = (TidyOccEnv
init_occ_env, VarEnv a
forall a. VarEnv a
emptyVarEnv)
tidy :: (LitNumType -> Integer -> Maybe (Expr DFunId))
-> TidyEnv -> CoreProgram -> (TidyEnv, CoreProgram)
tidy _ env :: TidyEnv
env [] = (TidyEnv
env, [])
tidy cvt_literal :: LitNumType -> Integer -> Maybe (Expr DFunId)
cvt_literal env :: TidyEnv
env (b :: CoreBind
b:bs :: CoreProgram
bs)
= let (env1 :: TidyEnv
env1, b' :: CoreBind
b') = DynFlags
-> Module
-> (LitNumType -> Integer -> Maybe (Expr DFunId))
-> UnfoldEnv
-> TidyEnv
-> CoreBind
-> (TidyEnv, CoreBind)
tidyTopBind DynFlags
dflags Module
this_mod LitNumType -> Integer -> Maybe (Expr DFunId)
cvt_literal UnfoldEnv
unfold_env
TidyEnv
env CoreBind
b
(env2 :: TidyEnv
env2, bs' :: CoreProgram
bs') = (LitNumType -> Integer -> Maybe (Expr DFunId))
-> TidyEnv -> CoreProgram -> (TidyEnv, CoreProgram)
tidy LitNumType -> Integer -> Maybe (Expr DFunId)
cvt_literal TidyEnv
env1 CoreProgram
bs
in (TidyEnv
env2, CoreBind
b'CoreBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
:CoreProgram
bs')
tidyTopBind :: DynFlags
-> Module
-> (LitNumType -> Integer -> Maybe CoreExpr)
-> UnfoldEnv
-> TidyEnv
-> CoreBind
-> (TidyEnv, CoreBind)
tidyTopBind :: DynFlags
-> Module
-> (LitNumType -> Integer -> Maybe (Expr DFunId))
-> UnfoldEnv
-> TidyEnv
-> CoreBind
-> (TidyEnv, CoreBind)
tidyTopBind dflags :: DynFlags
dflags this_mod :: Module
this_mod cvt_literal :: LitNumType -> Integer -> Maybe (Expr DFunId)
cvt_literal unfold_env :: UnfoldEnv
unfold_env
(occ_env :: TidyOccEnv
occ_env,subst1 :: VarEnv DFunId
subst1) (NonRec bndr :: DFunId
bndr rhs :: Expr DFunId
rhs)
= (TidyEnv
tidy_env2, DFunId -> Expr DFunId -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec DFunId
bndr' Expr DFunId
rhs')
where
Just (name' :: Name
name',show_unfold :: Bool
show_unfold) = UnfoldEnv -> DFunId -> Maybe (Name, Bool)
forall a. VarEnv a -> DFunId -> Maybe a
lookupVarEnv UnfoldEnv
unfold_env DFunId
bndr
caf_info :: CafInfo
caf_info = DynFlags -> Module -> CafRefEnv -> Int -> Expr DFunId -> CafInfo
hasCafRefs DynFlags
dflags Module
this_mod
(VarEnv DFunId
subst1, LitNumType -> Integer -> Maybe (Expr DFunId)
cvt_literal)
(DFunId -> Int
idArity DFunId
bndr) Expr DFunId
rhs
(bndr' :: DFunId
bndr', rhs' :: Expr DFunId
rhs') = DynFlags
-> Bool
-> TidyEnv
-> CafInfo
-> Name
-> (DFunId, Expr DFunId)
-> (DFunId, Expr DFunId)
tidyTopPair DynFlags
dflags Bool
show_unfold TidyEnv
tidy_env2 CafInfo
caf_info Name
name'
(DFunId
bndr, Expr DFunId
rhs)
subst2 :: VarEnv DFunId
subst2 = VarEnv DFunId -> DFunId -> DFunId -> VarEnv DFunId
forall a. VarEnv a -> DFunId -> a -> VarEnv a
extendVarEnv VarEnv DFunId
subst1 DFunId
bndr DFunId
bndr'
tidy_env2 :: TidyEnv
tidy_env2 = (TidyOccEnv
occ_env, VarEnv DFunId
subst2)
tidyTopBind dflags :: DynFlags
dflags this_mod :: Module
this_mod cvt_literal :: LitNumType -> Integer -> Maybe (Expr DFunId)
cvt_literal unfold_env :: UnfoldEnv
unfold_env
(occ_env :: TidyOccEnv
occ_env, subst1 :: VarEnv DFunId
subst1) (Rec prs :: [(DFunId, Expr DFunId)]
prs)
= (TidyEnv
tidy_env2, [(DFunId, Expr DFunId)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(DFunId, Expr DFunId)]
prs')
where
prs' :: [(DFunId, Expr DFunId)]
prs' = [ DynFlags
-> Bool
-> TidyEnv
-> CafInfo
-> Name
-> (DFunId, Expr DFunId)
-> (DFunId, Expr DFunId)
tidyTopPair DynFlags
dflags Bool
show_unfold TidyEnv
tidy_env2 CafInfo
caf_info Name
name' (DFunId
id,Expr DFunId
rhs)
| (id :: DFunId
id,rhs :: Expr DFunId
rhs) <- [(DFunId, Expr DFunId)]
prs,
let (name' :: Name
name',show_unfold :: Bool
show_unfold) =
String -> Maybe (Name, Bool) -> (Name, Bool)
forall a. HasCallStack => String -> Maybe a -> a
expectJust "tidyTopBind" (Maybe (Name, Bool) -> (Name, Bool))
-> Maybe (Name, Bool) -> (Name, Bool)
forall a b. (a -> b) -> a -> b
$ UnfoldEnv -> DFunId -> Maybe (Name, Bool)
forall a. VarEnv a -> DFunId -> Maybe a
lookupVarEnv UnfoldEnv
unfold_env DFunId
id
]
subst2 :: VarEnv DFunId
subst2 = VarEnv DFunId -> [(DFunId, DFunId)] -> VarEnv DFunId
forall a. VarEnv a -> [(DFunId, a)] -> VarEnv a
extendVarEnvList VarEnv DFunId
subst1 ([DFunId]
bndrs [DFunId] -> [DFunId] -> [(DFunId, DFunId)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` ((DFunId, Expr DFunId) -> DFunId)
-> [(DFunId, Expr DFunId)] -> [DFunId]
forall a b. (a -> b) -> [a] -> [b]
map (DFunId, Expr DFunId) -> DFunId
forall a b. (a, b) -> a
fst [(DFunId, Expr DFunId)]
prs')
tidy_env2 :: TidyEnv
tidy_env2 = (TidyOccEnv
occ_env, VarEnv DFunId
subst2)
bndrs :: [DFunId]
bndrs = ((DFunId, Expr DFunId) -> DFunId)
-> [(DFunId, Expr DFunId)] -> [DFunId]
forall a b. (a -> b) -> [a] -> [b]
map (DFunId, Expr DFunId) -> DFunId
forall a b. (a, b) -> a
fst [(DFunId, Expr DFunId)]
prs
caf_info :: CafInfo
caf_info
| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ CafInfo -> Bool
mayHaveCafRefs (DynFlags -> Module -> CafRefEnv -> Int -> Expr DFunId -> CafInfo
hasCafRefs DynFlags
dflags Module
this_mod
(VarEnv DFunId
subst1, LitNumType -> Integer -> Maybe (Expr DFunId)
cvt_literal)
(DFunId -> Int
idArity DFunId
bndr) Expr DFunId
rhs)
| (bndr :: DFunId
bndr,rhs :: Expr DFunId
rhs) <- [(DFunId, Expr DFunId)]
prs ] = CafInfo
MayHaveCafRefs
| Bool
otherwise = CafInfo
NoCafRefs
tidyTopPair :: DynFlags
-> Bool
-> TidyEnv
-> CafInfo
-> Name
-> (Id, CoreExpr)
-> (Id, CoreExpr)
tidyTopPair :: DynFlags
-> Bool
-> TidyEnv
-> CafInfo
-> Name
-> (DFunId, Expr DFunId)
-> (DFunId, Expr DFunId)
tidyTopPair dflags :: DynFlags
dflags show_unfold :: Bool
show_unfold rhs_tidy_env :: TidyEnv
rhs_tidy_env caf_info :: CafInfo
caf_info name' :: Name
name' (bndr :: DFunId
bndr, rhs :: Expr DFunId
rhs)
= (DFunId
bndr1, Expr DFunId
rhs1)
where
bndr1 :: DFunId
bndr1 = IdDetails -> Name -> Type -> IdInfo -> DFunId
mkGlobalId IdDetails
details Name
name' Type
ty' IdInfo
idinfo'
details :: IdDetails
details = DFunId -> IdDetails
idDetails DFunId
bndr
ty' :: Type
ty' = Type -> Type
tidyTopType (DFunId -> Type
idType DFunId
bndr)
rhs1 :: Expr DFunId
rhs1 = TidyEnv -> Expr DFunId -> Expr DFunId
tidyExpr TidyEnv
rhs_tidy_env Expr DFunId
rhs
idinfo' :: IdInfo
idinfo' = DynFlags
-> TidyEnv
-> Name
-> Expr DFunId
-> Expr DFunId
-> IdInfo
-> Bool
-> CafInfo
-> IdInfo
tidyTopIdInfo DynFlags
dflags TidyEnv
rhs_tidy_env Name
name' Expr DFunId
rhs Expr DFunId
rhs1 (HasDebugCallStack => DFunId -> IdInfo
DFunId -> IdInfo
idInfo DFunId
bndr)
Bool
show_unfold CafInfo
caf_info
tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr
-> IdInfo -> Bool -> CafInfo -> IdInfo
tidyTopIdInfo :: DynFlags
-> TidyEnv
-> Name
-> Expr DFunId
-> Expr DFunId
-> IdInfo
-> Bool
-> CafInfo
-> IdInfo
tidyTopIdInfo dflags :: DynFlags
dflags rhs_tidy_env :: TidyEnv
rhs_tidy_env name :: Name
name orig_rhs :: Expr DFunId
orig_rhs tidy_rhs :: Expr DFunId
tidy_rhs idinfo :: IdInfo
idinfo show_unfold :: Bool
show_unfold caf_info :: CafInfo
caf_info
| Bool -> Bool
not Bool
is_external
= IdInfo
vanillaIdInfo
IdInfo -> CafInfo -> IdInfo
`setCafInfo` CafInfo
caf_info
IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
final_sig
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
minimal_unfold_info
| Bool
otherwise
= IdInfo
vanillaIdInfo
IdInfo -> CafInfo -> IdInfo
`setCafInfo` CafInfo
caf_info
IdInfo -> Int -> IdInfo
`setArityInfo` Int
arity
IdInfo -> StrictSig -> IdInfo
`setStrictnessInfo` StrictSig
final_sig
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 = Expr DFunId -> Maybe (Int, StrictSig)
exprBotStrictness_maybe Expr DFunId
orig_rhs
sig :: StrictSig
sig = IdInfo -> StrictSig
strictnessInfo IdInfo
idinfo
final_sig :: StrictSig
final_sig | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ StrictSig -> Bool
isTopSig StrictSig
sig
= WARN( _bottom_hidden sig , ppr name ) sig
| Just (_, nsig :: StrictSig
nsig) <- Maybe (Int, StrictSig)
mb_bot_str = StrictSig
nsig
| Bool
otherwise = StrictSig
sig
_bottom_hidden :: StrictSig -> Bool
_bottom_hidden id_sig :: StrictSig
id_sig = case Maybe (Int, StrictSig)
mb_bot_str of
Nothing -> Bool
False
Just (arity :: Int
arity, _) -> Bool -> Bool
not (StrictSig -> Int -> Bool
appIsBottom StrictSig
id_sig Int
arity)
unf_info :: Unfolding
unf_info = IdInfo -> Unfolding
unfoldingInfo IdInfo
idinfo
unfold_info :: Unfolding
unfold_info | 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 = DynFlags -> Bool -> Expr DFunId -> Unfolding
mkTopUnfolding DynFlags
dflags Bool
is_bot Expr DFunId
tidy_rhs
is_bot :: Bool
is_bot = StrictSig -> Bool
isBottomingSig StrictSig
final_sig
arity :: Int
arity = Expr DFunId -> Int
exprArity Expr DFunId
orig_rhs
type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr)
hasCafRefs :: DynFlags -> Module
-> CafRefEnv -> Arity -> CoreExpr
-> CafInfo
hasCafRefs :: DynFlags -> Module -> CafRefEnv -> Int -> Expr DFunId -> CafInfo
hasCafRefs dflags :: DynFlags
dflags this_mod :: Module
this_mod (subst :: VarEnv DFunId
subst, cvt_literal :: LitNumType -> Integer -> Maybe (Expr DFunId)
cvt_literal) arity :: Int
arity expr :: Expr DFunId
expr
| Bool
is_caf Bool -> Bool -> Bool
|| Bool
mentions_cafs = CafInfo
MayHaveCafRefs
| Bool
otherwise = CafInfo
NoCafRefs
where
mentions_cafs :: Bool
mentions_cafs = Expr DFunId -> Bool
forall a. Expr a -> Bool
cafRefsE Expr DFunId
expr
is_dynamic_name :: Name -> Bool
is_dynamic_name = DynFlags -> Module -> Name -> Bool
isDllName DynFlags
dflags Module
this_mod
is_caf :: Bool
is_caf = Bool -> Bool
not (Int
arity Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 Bool -> Bool -> Bool
|| Platform
-> (Name -> Bool)
-> (LitNumType -> Integer -> Maybe (Expr DFunId))
-> Expr DFunId
-> Bool
rhsIsStatic (DynFlags -> Platform
targetPlatform DynFlags
dflags) Name -> Bool
is_dynamic_name
LitNumType -> Integer -> Maybe (Expr DFunId)
cvt_literal Expr DFunId
expr)
cafRefsE :: Expr a -> Bool
cafRefsE :: Expr a -> Bool
cafRefsE (Var id :: DFunId
id) = DFunId -> Bool
cafRefsV DFunId
id
cafRefsE (Lit lit :: Literal
lit) = Literal -> Bool
cafRefsL Literal
lit
cafRefsE (App f :: Expr a
f a :: Expr a
a) = Expr a -> Bool
forall a. Expr a -> Bool
cafRefsE Expr a
f Bool -> Bool -> Bool
|| Expr a -> Bool
forall a. Expr a -> Bool
cafRefsE Expr a
a
cafRefsE (Lam _ e :: Expr a
e) = Expr a -> Bool
forall a. Expr a -> Bool
cafRefsE Expr a
e
cafRefsE (Let b :: Bind a
b e :: Expr a
e) = [Expr a] -> Bool
forall a. [Expr a] -> Bool
cafRefsEs (Bind a -> [Expr a]
forall b. Bind b -> [Expr b]
rhssOfBind Bind a
b) Bool -> Bool -> Bool
|| Expr a -> Bool
forall a. Expr a -> Bool
cafRefsE Expr a
e
cafRefsE (Case e :: Expr a
e _ _ alts :: [Alt a]
alts) = Expr a -> Bool
forall a. Expr a -> Bool
cafRefsE Expr a
e Bool -> Bool -> Bool
|| [Expr a] -> Bool
forall a. [Expr a] -> Bool
cafRefsEs ([Alt a] -> [Expr a]
forall b. [Alt b] -> [Expr b]
rhssOfAlts [Alt a]
alts)
cafRefsE (Tick _n :: Tickish DFunId
_n e :: Expr a
e) = Expr a -> Bool
forall a. Expr a -> Bool
cafRefsE Expr a
e
cafRefsE (Cast e :: Expr a
e _co :: Coercion
_co) = Expr a -> Bool
forall a. Expr a -> Bool
cafRefsE Expr a
e
cafRefsE (Type _) = Bool
False
cafRefsE (Coercion _) = Bool
False
cafRefsEs :: [Expr a] -> Bool
cafRefsEs :: [Expr a] -> Bool
cafRefsEs [] = Bool
False
cafRefsEs (e :: Expr a
e:es :: [Expr a]
es) = Expr a -> Bool
forall a. Expr a -> Bool
cafRefsE Expr a
e Bool -> Bool -> Bool
|| [Expr a] -> Bool
forall a. [Expr a] -> Bool
cafRefsEs [Expr a]
es
cafRefsL :: Literal -> Bool
cafRefsL :: Literal -> Bool
cafRefsL (LitNumber nt :: LitNumType
nt i :: Integer
i _) = case LitNumType -> Integer -> Maybe (Expr DFunId)
cvt_literal LitNumType
nt Integer
i of
Just e :: Expr DFunId
e -> Expr DFunId -> Bool
forall a. Expr a -> Bool
cafRefsE Expr DFunId
e
Nothing -> Bool
False
cafRefsL _ = Bool
False
cafRefsV :: Id -> Bool
cafRefsV :: DFunId -> Bool
cafRefsV id :: DFunId
id
| Bool -> Bool
not (DFunId -> Bool
isLocalId DFunId
id) = CafInfo -> Bool
mayHaveCafRefs (DFunId -> CafInfo
idCafInfo DFunId
id)
| Just id' :: DFunId
id' <- VarEnv DFunId -> DFunId -> Maybe DFunId
forall a. VarEnv a -> DFunId -> Maybe a
lookupVarEnv VarEnv DFunId
subst DFunId
id = CafInfo -> Bool
mayHaveCafRefs (DFunId -> CafInfo
idCafInfo DFunId
id')
| Bool
otherwise = Bool
False