{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# LANGUAGE NamedFieldPuns #-}
module GHC.Iface.Tidy
( TidyOpts (..)
, UnfoldingExposure (..)
, tidyProgram
, mkBootModDetailsTc
)
where
import GHC.Prelude
import GHC.Tc.Types
import GHC.Tc.Utils.Env
import GHC.Core
import GHC.Core.Unfold
import GHC.Core.FVs
import GHC.Core.Tidy
import GHC.Core.Seq ( seqBinds )
import GHC.Core.Opt.Arity ( exprArity, typeArity, exprBotStrictness_maybe )
import GHC.Core.InstEnv
import GHC.Core.Type
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Class
import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )
import GHC.Iface.Tidy.StaticPtrTable
import GHC.Iface.Env
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.DefaultEnv ( emptyDefaultEnv )
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, isNopSig, nopSig, isDeadEndSig )
import GHC.Types.Basic
import GHC.Types.Name hiding (varName)
import GHC.Types.Name.Set
import GHC.Types.Name.Cache
import GHC.Types.Avail
import GHC.Types.Tickish
import GHC.Types.TypeEnv
import GHC.Tc.Utils.TcType (tcSplitNestedSigmaTys)
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 qualified Data.Set as S
import GHC.Types.CostCentre
mkBootModDetailsTc :: Logger -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc :: Logger -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc Logger
logger
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
}
=
Logger
-> SDoc -> (ModDetails -> ()) -> IO ModDetails -> IO ModDetails
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
Err.withTiming Logger
logger
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CoreTidy"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
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
$
ModDetails -> IO ModDetails
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ModDetails { md_types :: TypeEnv
md_types = TypeEnv
type_env'
, md_defaults :: DefaultEnv
md_defaults = DefaultEnv
emptyDefaultEnv
, md_insts :: InstEnv
md_insts = InstEnv
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
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 = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filterOut TyCon -> Bool
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' :: InstEnv
insts' = TypeEnv -> InstEnv -> InstEnv
mkFinalClsInsts TypeEnv
type_env' (InstEnv -> InstEnv) -> InstEnv -> InstEnv
forall a b. (a -> b) -> a -> b
$ [ClsInst] -> InstEnv
mkInstEnv [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
_ -> String -> SDoc -> Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"lookup_final_id" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id)
mkFinalClsInsts :: TypeEnv -> InstEnv -> InstEnv
mkFinalClsInsts :: TypeEnv -> InstEnv -> InstEnv
mkFinalClsInsts TypeEnv
env = (Id -> Id) -> InstEnv -> InstEnv
updateClsInstDFuns (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
data UnfoldingExposure
= ExposeNone
| ExposeSome
| ExposeOverloaded
| ExposeAll
deriving (Arity -> UnfoldingExposure -> ShowS
[UnfoldingExposure] -> ShowS
UnfoldingExposure -> String
(Arity -> UnfoldingExposure -> ShowS)
-> (UnfoldingExposure -> String)
-> ([UnfoldingExposure] -> ShowS)
-> Show UnfoldingExposure
forall a.
(Arity -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Arity -> UnfoldingExposure -> ShowS
showsPrec :: Arity -> UnfoldingExposure -> ShowS
$cshow :: UnfoldingExposure -> String
show :: UnfoldingExposure -> String
$cshowList :: [UnfoldingExposure] -> ShowS
showList :: [UnfoldingExposure] -> ShowS
Show,UnfoldingExposure -> UnfoldingExposure -> Bool
(UnfoldingExposure -> UnfoldingExposure -> Bool)
-> (UnfoldingExposure -> UnfoldingExposure -> Bool)
-> Eq UnfoldingExposure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnfoldingExposure -> UnfoldingExposure -> Bool
== :: UnfoldingExposure -> UnfoldingExposure -> Bool
$c/= :: UnfoldingExposure -> UnfoldingExposure -> Bool
/= :: UnfoldingExposure -> UnfoldingExposure -> Bool
Eq,Eq UnfoldingExposure
Eq UnfoldingExposure =>
(UnfoldingExposure -> UnfoldingExposure -> Ordering)
-> (UnfoldingExposure -> UnfoldingExposure -> Bool)
-> (UnfoldingExposure -> UnfoldingExposure -> Bool)
-> (UnfoldingExposure -> UnfoldingExposure -> Bool)
-> (UnfoldingExposure -> UnfoldingExposure -> Bool)
-> (UnfoldingExposure -> UnfoldingExposure -> UnfoldingExposure)
-> (UnfoldingExposure -> UnfoldingExposure -> UnfoldingExposure)
-> Ord UnfoldingExposure
UnfoldingExposure -> UnfoldingExposure -> Bool
UnfoldingExposure -> UnfoldingExposure -> Ordering
UnfoldingExposure -> UnfoldingExposure -> UnfoldingExposure
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: UnfoldingExposure -> UnfoldingExposure -> Ordering
compare :: UnfoldingExposure -> UnfoldingExposure -> Ordering
$c< :: UnfoldingExposure -> UnfoldingExposure -> Bool
< :: UnfoldingExposure -> UnfoldingExposure -> Bool
$c<= :: UnfoldingExposure -> UnfoldingExposure -> Bool
<= :: UnfoldingExposure -> UnfoldingExposure -> Bool
$c> :: UnfoldingExposure -> UnfoldingExposure -> Bool
> :: UnfoldingExposure -> UnfoldingExposure -> Bool
$c>= :: UnfoldingExposure -> UnfoldingExposure -> Bool
>= :: UnfoldingExposure -> UnfoldingExposure -> Bool
$cmax :: UnfoldingExposure -> UnfoldingExposure -> UnfoldingExposure
max :: UnfoldingExposure -> UnfoldingExposure -> UnfoldingExposure
$cmin :: UnfoldingExposure -> UnfoldingExposure -> UnfoldingExposure
min :: UnfoldingExposure -> UnfoldingExposure -> UnfoldingExposure
Ord)
data TidyOpts = TidyOpts
{ TidyOpts -> NameCache
opt_name_cache :: !NameCache
, TidyOpts -> Bool
opt_collect_ccs :: !Bool
, TidyOpts -> UnfoldingOpts
opt_unfolding_opts :: !UnfoldingOpts
, TidyOpts -> UnfoldingExposure
opt_expose_unfoldings :: !UnfoldingExposure
, TidyOpts -> Bool
opt_trim_ids :: !Bool
, TidyOpts -> Bool
opt_expose_rules :: !Bool
, TidyOpts -> Maybe StaticPtrOpts
opt_static_ptr_opts :: !(Maybe StaticPtrOpts)
, TidyOpts -> Bool
opt_keep_auto_rules :: !Bool
}
tidyProgram :: TidyOpts -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram :: TidyOpts -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram TidyOpts
opts (ModGuts { mg_module :: ModGuts -> Module
mg_module = Module
mod
, mg_exports :: ModGuts -> [AvailInfo]
mg_exports = [AvailInfo]
exports
, mg_tcs :: ModGuts -> [TyCon]
mg_tcs = [TyCon]
tcs
, mg_defaults :: ModGuts -> DefaultEnv
mg_defaults = DefaultEnv
cls_defaults
, 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
, mg_boot_exports :: ModGuts -> NameSet
mg_boot_exports = NameSet
boot_exports
}) = do
let implicit_binds :: CoreProgram
implicit_binds = (TyCon -> CoreProgram) -> [TyCon] -> CoreProgram
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyCon -> CoreProgram
getImplicitBinds [TyCon]
tcs
all_binds :: CoreProgram
all_binds = CoreProgram
implicit_binds CoreProgram -> CoreProgram -> CoreProgram
forall a. [a] -> [a] -> [a]
++ CoreProgram
binds
(unfold_env, tidy_occ_env) <- TidyOpts
-> Module
-> CoreProgram
-> [CoreRule]
-> IO (UnfoldEnv, TidyOccEnv)
chooseExternalIds TidyOpts
opts Module
mod CoreProgram
all_binds [CoreRule]
imp_rules
let (trimmed_binds, trimmed_rules) = findExternalRules opts all_binds imp_rules unfold_env
(tidy_env, tidy_binds) <- tidyTopBinds unfold_env boot_exports tidy_occ_env trimmed_binds
(spt_entries, mcstub, tidy_binds') <- case opt_static_ptr_opts opts of
Maybe StaticPtrOpts
Nothing -> ([SptEntry], Maybe CStub, CoreProgram)
-> IO ([SptEntry], Maybe CStub, CoreProgram)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Maybe CStub
forall a. Maybe a
Nothing, CoreProgram
tidy_binds)
Just StaticPtrOpts
sopts -> StaticPtrOpts
-> Module
-> CoreProgram
-> IO ([SptEntry], Maybe CStub, CoreProgram)
sptCreateStaticBinds StaticPtrOpts
sopts Module
mod CoreProgram
tidy_binds
let all_foreign_stubs = case Maybe CStub
mcstub of
Maybe CStub
Nothing -> ForeignStubs
foreign_stubs
Just CStub
cstub -> ForeignStubs
foreign_stubs ForeignStubs -> CStub -> ForeignStubs
`appendStubC` CStub
cstub
final_ids = [ Bool -> Id -> Id
trimId (TidyOpts -> Bool
opt_trim_ids TidyOpts
opts) Id
id
| Id
id <- CoreProgram -> [Id]
forall b. [Bind b] -> [b]
bindersOfBinds CoreProgram
tidy_binds
, Name -> Bool
isExternalName (Id -> Name
idName Id
id)
, Bool -> Bool
not (Id -> Bool
forall thing. NamedThing thing => thing -> Bool
isWiredIn Id
id)
]
final_tcs = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filterOut TyCon -> Bool
forall thing. NamedThing thing => thing -> Bool
isWiredIn [TyCon]
tcs
tidy_type_env = [Id] -> [TyCon] -> [PatSyn] -> [FamInst] -> TypeEnv
typeEnvFromEntities [Id]
final_ids [TyCon]
final_tcs [PatSyn]
patsyns [FamInst]
fam_insts
tidy_cls_insts = TypeEnv -> InstEnv -> InstEnv
mkFinalClsInsts TypeEnv
tidy_type_env (InstEnv -> InstEnv) -> InstEnv -> InstEnv
forall a b. (a -> b) -> a -> b
$ [ClsInst] -> InstEnv
mkInstEnv [ClsInst]
cls_insts
tidy_rules = TidyEnv -> [CoreRule] -> [CoreRule]
tidyRules TidyEnv
tidy_env [CoreRule]
trimmed_rules
all_tidy_binds = CoreProgram
tidy_binds'
alg_tycons = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isAlgTyCon [TyCon]
tcs
local_ccs
| TidyOpts -> Bool
opt_collect_ccs TidyOpts
opts
= Module -> CoreProgram -> [CoreRule] -> Set CostCentre
collectCostCentres Module
mod CoreProgram
all_tidy_binds [CoreRule]
tidy_rules
| Bool
otherwise
= Set CostCentre
forall a. Set a
S.empty
return (CgGuts { cg_module = mod
, cg_tycons = alg_tycons
, cg_binds = all_tidy_binds
, cg_ccs = S.toList local_ccs
, cg_foreign = all_foreign_stubs
, cg_foreign_files = foreign_files
, cg_dep_pkgs = dep_direct_pkgs deps
, cg_hpc_info = hpc_info
, cg_modBreaks = modBreaks
, cg_spt_entries = spt_entries
}
, ModDetails { md_types = tidy_type_env
, md_rules = tidy_rules
, md_defaults = cls_defaults
, md_insts = tidy_cls_insts
, md_fam_insts = fam_insts
, md_exports = exports
, md_anns = anns
, md_complete_matches = complete_matches
}
)
collectCostCentres :: Module -> CoreProgram -> [CoreRule] -> S.Set CostCentre
collectCostCentres :: Module -> CoreProgram -> [CoreRule] -> Set CostCentre
collectCostCentres Module
mod_name CoreProgram
binds [CoreRule]
rules
= {-# SCC collectCostCentres #-} (Set CostCentre -> CoreBind -> Set CostCentre)
-> Set CostCentre -> CoreProgram -> Set CostCentre
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set CostCentre -> CoreBind -> Set CostCentre
go_bind (Set CostCentre -> Set CostCentre
go_rules Set CostCentre
forall a. Set a
S.empty) CoreProgram
binds
where
go :: Set CostCentre -> Expr Id -> Set CostCentre
go Set CostCentre
cs Expr Id
e = case Expr Id
e of
Var{} -> Set CostCentre
cs
Lit{} -> Set CostCentre
cs
App Expr Id
e1 Expr Id
e2 -> Set CostCentre -> Expr Id -> Set CostCentre
go (Set CostCentre -> Expr Id -> Set CostCentre
go Set CostCentre
cs Expr Id
e1) Expr Id
e2
Lam Id
_ Expr Id
e -> Set CostCentre -> Expr Id -> Set CostCentre
go Set CostCentre
cs Expr Id
e
Let CoreBind
b Expr Id
e -> Set CostCentre -> Expr Id -> Set CostCentre
go (Set CostCentre -> CoreBind -> Set CostCentre
go_bind Set CostCentre
cs CoreBind
b) Expr Id
e
Case Expr Id
scrt Id
_ Type
_ [Alt Id]
alts -> Set CostCentre -> [Alt Id] -> Set CostCentre
go_alts (Set CostCentre -> Expr Id -> Set CostCentre
go Set CostCentre
cs Expr Id
scrt) [Alt Id]
alts
Cast Expr Id
e CoercionR
_ -> Set CostCentre -> Expr Id -> Set CostCentre
go Set CostCentre
cs Expr Id
e
Tick (ProfNote CostCentre
cc Bool
_ Bool
_) Expr Id
e ->
Set CostCentre -> Expr Id -> Set CostCentre
go (if CostCentre -> Module -> Bool
ccFromThisModule CostCentre
cc Module
mod_name then CostCentre -> Set CostCentre -> Set CostCentre
forall a. Ord a => a -> Set a -> Set a
S.insert CostCentre
cc Set CostCentre
cs else Set CostCentre
cs) Expr Id
e
Tick GenTickish 'TickishPassCore
_ Expr Id
e -> Set CostCentre -> Expr Id -> Set CostCentre
go Set CostCentre
cs Expr Id
e
Type{} -> Set CostCentre
cs
Coercion{} -> Set CostCentre
cs
go_alts :: Set CostCentre -> [Alt Id] -> Set CostCentre
go_alts = (Set CostCentre -> Alt Id -> Set CostCentre)
-> Set CostCentre -> [Alt Id] -> Set CostCentre
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Set CostCentre
cs (Alt AltCon
_con [Id]
_bndrs Expr Id
e) -> Set CostCentre -> Expr Id -> Set CostCentre
go Set CostCentre
cs Expr Id
e)
go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre
go_bind :: Set CostCentre -> CoreBind -> Set CostCentre
go_bind Set CostCentre
cs (NonRec Id
b Expr Id
e) =
Set CostCentre -> Expr Id -> Set CostCentre
go (Set CostCentre -> Id -> Set CostCentre
do_binder Set CostCentre
cs Id
b) Expr Id
e
go_bind Set CostCentre
cs (Rec [(Id, Expr Id)]
bs) =
(Set CostCentre -> (Id, Expr Id) -> Set CostCentre)
-> Set CostCentre -> [(Id, Expr Id)] -> Set CostCentre
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Set CostCentre
cs' (Id
b, Expr Id
e) -> Set CostCentre -> Expr Id -> Set CostCentre
go (Set CostCentre -> Id -> Set CostCentre
do_binder Set CostCentre
cs' Id
b) Expr Id
e) Set CostCentre
cs [(Id, Expr Id)]
bs
do_binder :: Set CostCentre -> Id -> Set CostCentre
do_binder Set CostCentre
cs Id
b = Set CostCentre
-> (Expr Id -> Set CostCentre) -> Maybe (Expr Id) -> Set CostCentre
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set CostCentre
cs (Set CostCentre -> Expr Id -> Set CostCentre
go Set CostCentre
cs) (Id -> Maybe (Expr Id)
get_unf Id
b)
get_unf :: Id -> Maybe (Expr Id)
get_unf = Unfolding -> Maybe (Expr Id)
maybeUnfoldingTemplate (Unfolding -> Maybe (Expr Id))
-> (Id -> Unfolding) -> Id -> Maybe (Expr Id)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Unfolding
realIdUnfolding
go_rules :: Set CostCentre -> Set CostCentre
go_rules Set CostCentre
cs = (Set CostCentre -> Expr Id -> Set CostCentre)
-> Set CostCentre -> [Expr Id] -> Set CostCentre
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set CostCentre -> Expr Id -> Set CostCentre
go Set CostCentre
cs ((CoreRule -> Maybe (Expr Id)) -> [CoreRule] -> [Expr Id]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe CoreRule -> Maybe (Expr Id)
get_rhs [CoreRule]
rules)
get_rhs :: CoreRule -> Maybe (Expr Id)
get_rhs Rule { Expr Id
ru_rhs :: Expr Id
ru_rhs :: CoreRule -> Expr Id
ru_rhs } = Expr Id -> Maybe (Expr Id)
forall a. a -> Maybe a
Just Expr Id
ru_rhs
get_rhs BuiltinRule {} = Maybe (Expr Id)
forall a. Maybe a
Nothing
trimId :: Bool -> Id -> Id
trimId :: Bool -> Id -> Id
trimId Bool
do_trim Id
id
| Bool
do_trim, 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 CoreProgram -> CoreProgram -> CoreProgram
forall a. [a] -> [a] -> [a]
++ TyCon -> CoreProgram
getTyConImplicitBinds TyCon
tc
where
cls_binds :: CoreProgram
cls_binds = CoreProgram -> (Class -> CoreProgram) -> Maybe Class -> CoreProgram
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
isDataTyCon TyCon
tc = [ Id -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
wrap_id Expr Id
rhs
| DataCon
dc <- TyCon -> [DataCon]
tyConDataCons TyCon
tc
, let wrap_id :: Id
wrap_id = DataCon -> Id
dataConWrapId DataCon
dc
, Just Expr Id
rhs <- [Id -> Maybe (Expr Id)
dataConWrapUnfolding_maybe Id
wrap_id] ]
| Bool
otherwise = []
getClassImplicitBinds :: Class -> [CoreBind]
getClassImplicitBinds :: Class -> CoreProgram
getClassImplicitBinds Class
cls
= [ Id -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
op (Class -> Arity -> Expr Id
mkDictSelRhs Class
cls Arity
val_index)
| (Id
op, Arity
val_index) <- Class -> [Id]
classAllSelIds Class
cls [Id] -> [Arity] -> [(Id, Arity)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Arity
0..] ]
type UnfoldEnv = IdEnv (Name, Bool )
chooseExternalIds :: TidyOpts
-> Module
-> [CoreBind]
-> [CoreRule]
-> IO (UnfoldEnv, TidyOccEnv)
chooseExternalIds :: TidyOpts
-> Module
-> CoreProgram
-> [CoreRule]
-> IO (UnfoldEnv, TidyOccEnv)
chooseExternalIds TidyOpts
opts Module
mod CoreProgram
binds [CoreRule]
imp_id_rules
= do { (unfold_env1,occ_env1) <- [(Id, Id)] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
search [(Id, Id)]
init_work_list UnfoldEnv
forall a. VarEnv a
emptyVarEnv TidyOccEnv
init_occ_env
; let internal_ids = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Id -> Bool) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id -> UnfoldEnv -> Bool
forall a. Id -> VarEnv a -> Bool
`elemVarEnv` UnfoldEnv
unfold_env1)) [Id]
binders
; tidy_internal internal_ids unfold_env1 occ_env1 }
where
name_cache :: NameCache
name_cache = TidyOpts -> NameCache
opt_name_cache TidyOpts
opts
init_work_list :: [(Id, Id)]
init_work_list = [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
init_ext_ids [Id]
init_ext_ids
init_ext_ids :: [Id]
init_ext_ids = (Id -> Id -> Ordering) -> [Id] -> [Id]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (OccName -> OccName -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (OccName -> OccName -> Ordering)
-> (Id -> OccName) -> Id -> Id -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName) ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ (Id -> Bool) -> [Id] -> [Id]
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
True
| TidyOpts -> Bool
opt_expose_rules TidyOpts
opts = Id
id Id -> VarSet -> Bool
`elemVarSet` VarSet
rule_rhs_vars
| Bool
otherwise = Bool
False
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 :: [Id]
binders = ((Id, Expr Id) -> Id) -> [(Id, Expr Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Expr Id) -> Id
forall a b. (a, b) -> a
fst ([(Id, Expr Id)] -> [Id]) -> [(Id, Expr Id)] -> [Id]
forall a b. (a -> b) -> a -> b
$ CoreProgram -> [(Id, Expr Id)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds CoreProgram
binds
binder_set :: VarSet
binder_set = [Id] -> VarSet
mkVarSet [Id]
binders
avoids :: [OccName]
avoids = [Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
name | Id
bndr <- [Id]
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 = (UnfoldEnv, TidyOccEnv) -> IO (UnfoldEnv, TidyOccEnv)
forall a. a -> IO a
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 Id -> UnfoldEnv -> Bool
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
(occ_env', name') <- Module
-> NameCache
-> Maybe Id
-> TidyOccEnv
-> Id
-> IO (TidyOccEnv, Name)
tidyTopName Module
mod NameCache
name_cache (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
referrer) TidyOccEnv
occ_env Id
idocc
let
(new_ids, show_unfold) = addExternal opts refined_id
refined_id = case VarSet -> Id -> Maybe Id
lookupVarSet VarSet
binder_set Id
idocc of
Just Id
id -> Id
id
Maybe Id
Nothing -> Bool -> String -> SDoc -> Id -> Id
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace Bool
True String
"chooseExternalIds" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
idocc) Id
idocc
unfold_env' = UnfoldEnv -> Id -> (Name, Bool) -> UnfoldEnv
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv UnfoldEnv
unfold_env Id
idocc (Name
name',Bool
show_unfold)
referrer' | Id -> Bool
isExportedId Id
refined_id = Id
refined_id
| Bool
otherwise = Id
referrer
search (zip new_ids (repeat referrer') ++ rest) unfold_env' 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 = (UnfoldEnv, TidyOccEnv) -> IO (UnfoldEnv, TidyOccEnv)
forall a. a -> IO a
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
(occ_env', name') <- Module
-> NameCache
-> Maybe Id
-> TidyOccEnv
-> Id
-> IO (TidyOccEnv, Name)
tidyTopName Module
mod NameCache
name_cache Maybe Id
forall a. Maybe a
Nothing TidyOccEnv
occ_env Id
id
let unfold_env' = UnfoldEnv -> Id -> (Name, Bool) -> UnfoldEnv
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv UnfoldEnv
unfold_env Id
id (Name
name',Bool
False)
tidy_internal ids unfold_env' occ_env'
addExternal :: TidyOpts -> Id -> ([Id], Bool)
addExternal :: TidyOpts -> Id -> ([Id], Bool)
addExternal TidyOpts
opts Id
id
| UnfoldingExposure
ExposeNone <- TidyOpts -> UnfoldingExposure
opt_expose_unfoldings TidyOpts
opts
, 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
Id -> IdInfo
idInfo Id
id
unfolding :: Unfolding
unfolding = IdInfo -> Unfolding
realUnfoldingInfo 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 = DmdSig -> Bool
isDeadEndSig (IdInfo -> DmdSig
dmdSigInfo 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
stable Bool -> Bool -> Bool
|| Bool
profitable Bool -> Bool -> Bool
|| Bool
explicitly_requested
where
stable :: Bool
stable = UnfoldingSource -> Bool
isStableSource UnfoldingSource
src
profitable :: Bool
profitable
| Bool
never_active = Bool
False
| Bool
loop_breaker = Bool
False
| Bool
otherwise =
case UnfoldingGuidance
guidance of
UnfWhen {} -> Bool
True
UnfIfGoodArgs {} -> Bool -> Bool
not Bool
bottoming_fn
UnfoldingGuidance
UnfNever -> Bool
False
explicitly_requested :: Bool
explicitly_requested =
case TidyOpts -> UnfoldingExposure
opt_expose_unfoldings TidyOpts
opts of
UnfoldingExposure
ExposeAll -> Bool
True
UnfoldingExposure
ExposeOverloaded ->
Bool -> Bool
not Bool
bottoming_fn Bool -> Bool -> Bool
&& Id -> Bool
isOverloaded Id
id
UnfoldingExposure
ExposeSome -> Bool
False
UnfoldingExposure
ExposeNone -> Bool
False
show_unfolding (DFunUnfolding {}) = Bool
True
show_unfolding Unfolding
_ = Bool
False
isOverloaded :: Id -> Bool
isOverloaded :: Id -> Bool
isOverloaded Id
fn =
let fun_type :: Type
fun_type = Id -> Type
idType Id
fn
([Id]
_ty_vars, ThetaType
constraints, Type
_ty) = Type -> ([Id], ThetaType, Type)
tcSplitNestedSigmaTys Type
fun_type
in Bool -> Bool
not (Bool -> Bool) -> (ThetaType -> Bool) -> ThetaType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThetaType -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ThetaType -> Bool) -> ThetaType -> Bool
forall a b. (a -> b) -> a -> b
$ ThetaType
constraints
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 -> b) -> DFFV a -> DFFV b)
-> (forall a b. a -> DFFV b -> DFFV a) -> Functor DFFV
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
$cfmap :: forall a b. (a -> b) -> DFFV a -> DFFV b
fmap :: forall a b. (a -> b) -> DFFV a -> DFFV b
$c<$ :: forall a b. a -> DFFV b -> DFFV a
<$ :: forall a b. a -> DFFV b -> DFFV a
Functor)
instance Applicative DFFV where
pure :: forall a. a -> DFFV a
pure a
a = (VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)) -> DFFV a
forall a.
(VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)) -> DFFV a
DFFV ((VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)) -> DFFV a)
-> (VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)) -> DFFV a
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
(<*>) = 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 = (VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), b)) -> DFFV b
forall a.
(VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)) -> DFFV a
DFFV ((VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), b)) -> DFFV b)
-> (VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), b)) -> DFFV b
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) = (VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)) -> DFFV a
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) = (VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)) -> DFFV a
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 = (VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), ())) -> DFFV ()
forall a.
(VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), a)) -> DFFV a
DFFV ((VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), ())) -> DFFV ())
-> (VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), ())) -> 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
vId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
ids), ())
else ((VarSet
set, [Id]
ids), ())
dffvExpr :: CoreExpr -> DFFV ()
dffvExpr :: Expr Id -> DFFV ()
dffvExpr (Var Id
v) = Id -> DFFV ()
insert Id
v
dffvExpr (App Expr Id
e1 Expr Id
e2) = Expr Id -> DFFV ()
dffvExpr Expr Id
e1 DFFV () -> DFFV () -> DFFV ()
forall a b. DFFV a -> DFFV b -> DFFV b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr Id -> DFFV ()
dffvExpr Expr Id
e2
dffvExpr (Lam Id
v Expr Id
e) = Id -> DFFV () -> DFFV ()
forall a. Id -> DFFV a -> DFFV a
extendScope Id
v (Expr Id -> DFFV ()
dffvExpr Expr Id
e)
dffvExpr (Tick (Breakpoint XBreakpoint 'TickishPassCore
_ Arity
_ [XTickishId 'TickishPassCore]
ids Module
_) Expr Id
e) = (Id -> DFFV ()) -> [Id] -> DFFV ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Id -> DFFV ()
insert [Id]
[XTickishId 'TickishPassCore]
ids DFFV () -> DFFV () -> DFFV ()
forall a b. DFFV a -> DFFV b -> DFFV b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr Id -> DFFV ()
dffvExpr Expr Id
e
dffvExpr (Tick GenTickish 'TickishPassCore
_other Expr Id
e) = Expr Id -> DFFV ()
dffvExpr Expr Id
e
dffvExpr (Cast Expr Id
e CoercionR
_) = Expr Id -> DFFV ()
dffvExpr Expr Id
e
dffvExpr (Let (NonRec Id
x Expr Id
r) Expr Id
e) = (Id, Expr Id) -> DFFV ()
dffvBind (Id
x,Expr Id
r) DFFV () -> DFFV () -> DFFV ()
forall a b. DFFV a -> DFFV b -> DFFV b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Id -> DFFV () -> DFFV ()
forall a. Id -> DFFV a -> DFFV a
extendScope Id
x (Expr Id -> DFFV ()
dffvExpr Expr Id
e)
dffvExpr (Let (Rec [(Id, Expr Id)]
prs) Expr Id
e) = [Id] -> DFFV () -> DFFV ()
forall a. [Id] -> DFFV a -> DFFV a
extendScopeList (((Id, Expr Id) -> Id) -> [(Id, Expr Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Expr Id) -> Id
forall a b. (a, b) -> a
fst [(Id, Expr Id)]
prs) (DFFV () -> DFFV ()) -> DFFV () -> DFFV ()
forall a b. (a -> b) -> a -> b
$
(((Id, Expr Id) -> DFFV ()) -> [(Id, Expr Id)] -> DFFV ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Id, Expr Id) -> DFFV ()
dffvBind [(Id, Expr Id)]
prs DFFV () -> DFFV () -> DFFV ()
forall a b. DFFV a -> DFFV b -> DFFV b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr Id -> DFFV ()
dffvExpr Expr Id
e)
dffvExpr (Case Expr Id
e Id
b Type
_ [Alt Id]
as) = Expr Id -> DFFV ()
dffvExpr Expr Id
e DFFV () -> DFFV () -> DFFV ()
forall a b. DFFV a -> DFFV b -> DFFV b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Id -> DFFV () -> DFFV ()
forall a. Id -> DFFV a -> DFFV a
extendScope Id
b ((Alt Id -> DFFV ()) -> [Alt Id] -> DFFV ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Alt Id -> DFFV ()
dffvAlt [Alt Id]
as)
dffvExpr Expr Id
_other = () -> DFFV ()
forall a. a -> DFFV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
dffvAlt :: CoreAlt -> DFFV ()
dffvAlt :: Alt Id -> DFFV ()
dffvAlt (Alt AltCon
_ [Id]
xs Expr Id
r) = [Id] -> DFFV () -> DFFV ()
forall a. [Id] -> DFFV a -> DFFV a
extendScopeList [Id]
xs (Expr Id -> DFFV ()
dffvExpr Expr Id
r)
dffvBind :: (Id, CoreExpr) -> DFFV ()
dffvBind :: (Id, Expr Id) -> DFFV ()
dffvBind(Id
x,Expr Id
r)
| Bool -> Bool
not (Id -> Bool
isId Id
x) = Expr Id -> DFFV ()
dffvExpr Expr Id
r
| Bool
otherwise = Bool -> Id -> DFFV ()
dffvLetBndr Bool
False Id
x DFFV () -> DFFV () -> DFFV ()
forall a b. DFFV a -> DFFV b -> DFFV b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Expr Id -> DFFV ()
dffvExpr Expr Id
r
dffvLetBndr :: Bool -> Id -> DFFV ()
dffvLetBndr :: Bool -> Id -> DFFV ()
dffvLetBndr Bool
vanilla_unfold Id
id
= do { Unfolding -> DFFV ()
go_unf (IdInfo -> Unfolding
realUnfoldingInfo 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 => Id -> IdInfo
Id -> IdInfo
idInfo Id
id
go_unf :: Unfolding -> DFFV ()
go_unf (CoreUnfolding { uf_tmpl :: Unfolding -> Expr Id
uf_tmpl = Expr Id
rhs, uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src })
| UnfoldingSource -> Bool
isStableSource UnfoldingSource
src = Expr Id -> DFFV ()
dffvExpr Expr Id
rhs
| Bool
vanilla_unfold = Expr Id -> DFFV ()
dffvExpr Expr Id
rhs
| Bool
otherwise = () -> DFFV ()
forall a. a -> DFFV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go_unf (DFunUnfolding { df_bndrs :: Unfolding -> [Id]
df_bndrs = [Id]
bndrs, df_args :: Unfolding -> [Expr Id]
df_args = [Expr Id]
args })
= [Id] -> DFFV () -> DFFV ()
forall a. [Id] -> DFFV a -> DFFV a
extendScopeList [Id]
bndrs (DFFV () -> DFFV ()) -> DFFV () -> DFFV ()
forall a b. (a -> b) -> a -> b
$ (Expr Id -> DFFV ()) -> [Expr Id] -> DFFV ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Expr Id -> DFFV ()
dffvExpr [Expr Id]
args
go_unf Unfolding
_ = () -> DFFV ()
forall a. a -> DFFV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go_rule :: CoreRule -> DFFV ()
go_rule (BuiltinRule {}) = () -> DFFV ()
forall a. a -> DFFV a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go_rule (Rule { ru_bndrs :: CoreRule -> [Id]
ru_bndrs = [Id]
bndrs, ru_rhs :: CoreRule -> Expr Id
ru_rhs = Expr Id
rhs })
= [Id] -> DFFV () -> DFFV ()
forall a. [Id] -> DFFV a -> DFFV a
extendScopeList [Id]
bndrs (Expr Id -> DFFV ()
dffvExpr Expr Id
rhs)
findExternalRules :: TidyOpts
-> [CoreBind]
-> [CoreRule]
-> UnfoldEnv
-> ([CoreBind], [CoreRule])
findExternalRules :: TidyOpts
-> CoreProgram
-> [CoreRule]
-> UnfoldEnv
-> (CoreProgram, [CoreRule])
findExternalRules TidyOpts
opts CoreProgram
binds [CoreRule]
imp_id_rules 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 | TidyOpts -> Bool
opt_expose_rules TidyOpts
opts = (CoreRule -> Bool) -> [CoreRule] -> [CoreRule]
forall a. (a -> Bool) -> [a] -> [a]
filter CoreRule -> Bool
expose_rule [CoreRule]
imp_id_rules
| Bool
otherwise = []
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 CoreRule
rule | CoreRule -> Bool
isAutoRule CoreRule
rule Bool -> Bool -> Bool
&& Bool -> Bool
not (TidyOpts -> Bool
opt_keep_auto_rules TidyOpts
opts)
= 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 = (Id -> Bool) -> [Id] -> Bool
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 UnfoldEnv -> Id -> Maybe (Name, Bool)
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv UnfoldEnv
unfold_env Id
id of
Just (Name
name, Bool
_) -> Name -> Bool
isExternalName Name
name Bool -> Bool -> Bool
&& Bool -> Bool
not (Id -> Bool
isImplicitId Id
id)
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)
| (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Id -> Bool
needed [Id]
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@(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 = CoreBind -> [Id]
forall b. Bind b -> [b]
bindersOf CoreBind
bind
rhss :: [Expr Id]
rhss = CoreBind -> [Expr Id]
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`
(Id -> VarSet) -> [Id] -> VarSet
forall a. (a -> VarSet) -> [a] -> VarSet
mapUnionVarSet Id -> VarSet
idUnfoldingVars [Id]
bndrs VarSet -> VarSet -> VarSet
`unionVarSet`
(Expr Id -> VarSet) -> [Expr Id] -> VarSet
forall a. (a -> VarSet) -> [a] -> VarSet
mapUnionVarSet Expr Id -> VarSet
exprFreeVars [Expr Id]
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
| TidyOpts -> Bool
opt_expose_rules TidyOpts
opts
, 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 -> NameCache -> Maybe Id -> TidyOccEnv
-> Id -> IO (TidyOccEnv, Name)
tidyTopName :: Module
-> NameCache
-> Maybe Id
-> TidyOccEnv
-> Id
-> IO (TidyOccEnv, Name)
tidyTopName Module
mod NameCache
name_cache Maybe Id
maybe_ref TidyOccEnv
occ_env Id
id
| Bool
global Bool -> Bool -> Bool
&& Bool
internal = (TidyOccEnv, Name) -> IO (TidyOccEnv, Name)
forall a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyOccEnv
occ_env, Name
name)
| Bool
local Bool -> Bool -> Bool
&& Bool
internal = do uniq <- NameCache -> IO Unique
takeUniqFromNameCache NameCache
name_cache
let new_local_name = OccName
occ' OccName -> Name -> Name
forall a b. a -> b -> b
`seq` Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ' SrcSpan
loc
return (occ_env', new_local_name)
| Bool
local Bool -> Bool -> Bool
&& Bool
external = do new_external_name <- NameCache -> Module -> OccName -> SrcSpan -> IO Name
allocateGlobalBinder NameCache
name_cache Module
mod OccName
occ' SrcSpan
loc
return (occ_env', new_external_name)
| Bool
otherwise = String -> IO (TidyOccEnv, Name)
forall a. HasCallStack => String -> a
panic String
"tidyTopName"
where
!name :: Name
name = Id -> Name
idName Id
id
external :: Bool
external = Maybe Id -> Bool
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 Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
/= Id
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 (Id -> OccName
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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'_' Char -> ShowS
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
tidyTopBinds :: UnfoldEnv
-> NameSet
-> TidyOccEnv
-> CoreProgram
-> IO (TidyEnv, CoreProgram)
tidyTopBinds :: UnfoldEnv
-> NameSet
-> TidyOccEnv
-> CoreProgram
-> IO (TidyEnv, CoreProgram)
tidyTopBinds UnfoldEnv
unfold_env NameSet
boot_exports TidyOccEnv
init_occ_env CoreProgram
binds
= do let result :: (TidyEnv, CoreProgram)
result = TidyEnv -> CoreProgram -> (TidyEnv, CoreProgram)
tidy TidyEnv
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv, CoreProgram)
result
where
init_env :: TidyEnv
init_env = (TidyOccEnv
init_occ_env, VarEnv Id
forall a. VarEnv a
emptyVarEnv)
tidy :: TidyEnv -> CoreProgram -> (TidyEnv, CoreProgram)
tidy = (TidyEnv -> CoreBind -> (TidyEnv, CoreBind))
-> TidyEnv -> CoreProgram -> (TidyEnv, CoreProgram)
forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (UnfoldEnv -> NameSet -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind)
tidyTopBind UnfoldEnv
unfold_env NameSet
boot_exports)
tidyTopBind :: UnfoldEnv
-> NameSet
-> TidyEnv
-> CoreBind
-> (TidyEnv, CoreBind)
tidyTopBind :: UnfoldEnv -> NameSet -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind)
tidyTopBind UnfoldEnv
unfold_env NameSet
boot_exports
(TidyOccEnv
occ_env,VarEnv Id
subst1) (NonRec Id
bndr Expr Id
rhs)
= (TidyEnv
tidy_env2, Id -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
bndr' Expr Id
rhs')
where
(Id
bndr', Expr Id
rhs') = UnfoldEnv -> NameSet -> TidyEnv -> (Id, Expr Id) -> (Id, Expr Id)
tidyTopPair UnfoldEnv
unfold_env NameSet
boot_exports TidyEnv
tidy_env2 (Id
bndr, Expr Id
rhs)
subst2 :: VarEnv Id
subst2 = VarEnv Id -> Id -> Id -> VarEnv Id
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 UnfoldEnv
unfold_env NameSet
boot_exports (TidyOccEnv
occ_env, VarEnv Id
subst1) (Rec [(Id, Expr Id)]
prs)
= (TidyEnv
tidy_env2, [(Id, Expr Id)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, Expr Id)]
prs')
where
prs' :: [(Id, Expr Id)]
prs' = ((Id, Expr Id) -> (Id, Expr Id))
-> [(Id, Expr Id)] -> [(Id, Expr Id)]
forall a b. (a -> b) -> [a] -> [b]
map (UnfoldEnv -> NameSet -> TidyEnv -> (Id, Expr Id) -> (Id, Expr Id)
tidyTopPair UnfoldEnv
unfold_env NameSet
boot_exports TidyEnv
tidy_env2) [(Id, Expr Id)]
prs
subst2 :: VarEnv Id
subst2 = VarEnv Id -> [(Id, Id)] -> VarEnv Id
forall a. VarEnv a -> [(Id, a)] -> VarEnv a
extendVarEnvList VarEnv Id
subst1 (((Id, Expr Id) -> Id) -> [(Id, Expr Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Expr Id) -> Id
forall a b. (a, b) -> a
fst [(Id, Expr Id)]
prs [Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` ((Id, Expr Id) -> Id) -> [(Id, Expr Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, Expr Id) -> Id
forall a b. (a, b) -> a
fst [(Id, Expr Id)]
prs')
tidy_env2 :: TidyEnv
tidy_env2 = (TidyOccEnv
occ_env, VarEnv Id
subst2)
tidyTopPair :: UnfoldEnv
-> NameSet
-> TidyEnv
-> (Id, CoreExpr)
-> (Id, CoreExpr)
tidyTopPair :: UnfoldEnv -> NameSet -> TidyEnv -> (Id, Expr Id) -> (Id, Expr Id)
tidyTopPair UnfoldEnv
unfold_env NameSet
boot_exports TidyEnv
rhs_tidy_env (Id
bndr, Expr Id
rhs)
=
(Id
bndr1, Expr Id
rhs1)
where
Just (Name
name',Bool
show_unfold) = UnfoldEnv -> Id -> Maybe (Name, Bool)
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv UnfoldEnv
unfold_env Id
bndr
!cbv_bndr :: Id
cbv_bndr = HasDebugCallStack => NameSet -> Id -> Expr Id -> Id
NameSet -> Id -> Expr Id -> Id
tidyCbvInfoTop NameSet
boot_exports Id
bndr Expr Id
rhs
bndr1 :: Id
bndr1 = IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId IdDetails
details Name
name' Type
ty' IdInfo
idinfo'
details :: IdDetails
details = Id -> IdDetails
idDetails Id
cbv_bndr
ty' :: Type
ty' = Type -> Type
tidyTopType (Id -> Type
idType Id
cbv_bndr)
rhs1 :: Expr Id
rhs1 = TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
rhs_tidy_env Expr Id
rhs
idinfo' :: IdInfo
idinfo' = TidyEnv
-> Name -> Type -> Expr Id -> Expr Id -> IdInfo -> Bool -> IdInfo
tidyTopIdInfo TidyEnv
rhs_tidy_env Name
name' Type
ty'
Expr Id
rhs Expr Id
rhs1 (HasDebugCallStack => Id -> IdInfo
Id -> IdInfo
idInfo Id
cbv_bndr) Bool
show_unfold
tidyTopIdInfo :: TidyEnv -> Name -> Type
-> CoreExpr -> CoreExpr -> IdInfo -> Bool -> IdInfo
tidyTopIdInfo :: TidyEnv
-> Name -> Type -> Expr Id -> Expr Id -> IdInfo -> Bool -> IdInfo
tidyTopIdInfo TidyEnv
rhs_tidy_env Name
name Type
rhs_ty Expr Id
orig_rhs Expr Id
tidy_rhs IdInfo
idinfo Bool
show_unfold
| Bool -> Bool
not Bool
is_external
= IdInfo
vanillaIdInfo
IdInfo -> Arity -> IdInfo
`setArityInfo` Arity
arity
IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo` DmdSig
final_sig
IdInfo -> CprSig -> IdInfo
`setCprSigInfo` CprSig
final_cpr
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
minimal_unfold_info
| Bool
otherwise
= IdInfo
vanillaIdInfo
IdInfo -> Arity -> IdInfo
`setArityInfo` Arity
arity
IdInfo -> DmdSig -> IdInfo
`setDmdSigInfo` DmdSig
final_sig
IdInfo -> CprSig -> IdInfo
`setCprSigInfo` 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 (Arity, DmdSig, CprSig)
mb_bot_str = Expr Id -> Maybe (Arity, DmdSig, CprSig)
exprBotStrictness_maybe Expr Id
orig_rhs
sig :: DmdSig
sig = IdInfo -> DmdSig
dmdSigInfo IdInfo
idinfo
final_sig :: DmdSig
final_sig | Bool -> Bool
not (DmdSig -> Bool
isNopSig DmdSig
sig)
= Bool -> String -> SDoc -> DmdSig -> DmdSig
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace (DmdSig -> Bool
_bottom_hidden DmdSig
sig) String
"tidyTopIdInfo" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) DmdSig
sig
| Just (Arity
_, DmdSig
bot_str_sig, CprSig
_) <- Maybe (Arity, DmdSig, CprSig)
mb_bot_str
= DmdSig
bot_str_sig
| Bool
otherwise = DmdSig
nopSig
cpr :: CprSig
cpr = IdInfo -> CprSig
cprSigInfo IdInfo
idinfo
final_cpr :: CprSig
final_cpr | Just (Arity
_, DmdSig
_, CprSig
bot_cpr_sig) <- Maybe (Arity, DmdSig, CprSig)
mb_bot_str
= CprSig
bot_cpr_sig
| Bool
otherwise
= CprSig
cpr
_bottom_hidden :: DmdSig -> Bool
_bottom_hidden DmdSig
id_sig
= case Maybe (Arity, DmdSig, CprSig)
mb_bot_str of
Maybe (Arity, DmdSig, CprSig)
Nothing -> Bool
False
Just (Arity
arity, DmdSig
_, CprSig
_) -> Bool -> Bool
not (DmdSig -> Arity -> Bool
isDeadEndAppSig DmdSig
id_sig Arity
arity)
unf_info :: Unfolding
unf_info = IdInfo -> Unfolding
realUnfoldingInfo IdInfo
idinfo
!minimal_unfold_info :: Unfolding
minimal_unfold_info = Unfolding -> Unfolding
trimUnfolding Unfolding
unf_info
!unfold_info :: Unfolding
unfold_info | Unfolding -> Bool
isCompulsoryUnfolding Unfolding
unf_info Bool -> Bool -> Bool
|| Bool
show_unfold
= TidyEnv -> Expr Id -> Unfolding -> Unfolding
tidyTopUnfolding TidyEnv
rhs_tidy_env Expr Id
tidy_rhs Unfolding
unf_info
| Bool
otherwise
= Unfolding
minimal_unfold_info
arity :: Arity
arity = Expr Id -> Arity
exprArity Expr Id
orig_rhs Arity -> Arity -> Arity
forall a. Ord a => a -> a -> a
`min` Type -> Arity
typeArity Type
rhs_ty
tidyTopUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding
tidyTopUnfolding :: TidyEnv -> Expr Id -> Unfolding -> Unfolding
tidyTopUnfolding TidyEnv
_ Expr Id
_ Unfolding
NoUnfolding = Unfolding
NoUnfolding
tidyTopUnfolding TidyEnv
_ Expr Id
_ Unfolding
BootUnfolding = Unfolding
BootUnfolding
tidyTopUnfolding TidyEnv
_ Expr Id
_ (OtherCon {}) = Unfolding
evaldUnfolding
tidyTopUnfolding TidyEnv
tidy_env Expr Id
_ df :: Unfolding
df@(DFunUnfolding { df_bndrs :: Unfolding -> [Id]
df_bndrs = [Id]
bndrs, df_args :: Unfolding -> [Expr Id]
df_args = [Expr Id]
args })
= Unfolding
df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }
where
(TidyEnv
tidy_env', [Id]
bndrs') = TidyEnv -> [Id] -> (TidyEnv, [Id])
tidyBndrs TidyEnv
tidy_env [Id]
bndrs
tidyTopUnfolding TidyEnv
tidy_env Expr Id
tidy_rhs
unf :: Unfolding
unf@(CoreUnfolding { uf_tmpl :: Unfolding -> Expr Id
uf_tmpl = Expr Id
unf_rhs, uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src })
=
Unfolding
unf { uf_tmpl = tidy_unf_rhs }
where
tidy_unf_rhs :: Expr Id
tidy_unf_rhs | UnfoldingSource -> Bool
isStableSource UnfoldingSource
src
= TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
tidy_env Expr Id
unf_rhs
| Bool
otherwise
= Expr Id -> Expr Id
occurAnalyseExpr Expr Id
tidy_rhs