{-# 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, exprBotStrictness_maybe, typeArity )
import GHC.Core.InstEnv
import GHC.Core.Type ( tidyTopType, Type )
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Class
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.Trace
import GHC.Utils.Logger as Logger
import qualified GHC.Utils.Error as Err
import GHC.Types.ForeignStubs
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Var
import GHC.Types.Id
import GHC.Types.Id.Make ( mkDictSelRhs )
import GHC.Types.Id.Info
import GHC.Types.Demand ( isDeadEndAppSig, isNopSig, isDeadEndSig )
import GHC.Types.Cpr ( mkCprSig, botCpr )
import GHC.Types.Basic
import GHC.Types.Name hiding (varName)
import GHC.Types.Name.Set
import GHC.Types.Name.Cache
import GHC.Types.Avail
import GHC.Types.Tickish
import GHC.Types.TypeEnv
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.Deps
import GHC.Data.Maybe
import Control.Monad
import Data.Function
import Data.List ( sortBy, mapAccumL )
import qualified Data.Set as S
import GHC.Types.CostCentre
import GHC.Core.Opt.OccurAnal (occurAnalyseExpr)
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
text String
"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
$
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_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
| 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)
}
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_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
(UnfoldEnv
unfold_env, TidyOccEnv
tidy_occ_env) <- TidyOpts
-> Module
-> CoreProgram
-> CoreProgram
-> [CoreRule]
-> IO (UnfoldEnv, TidyOccEnv)
chooseExternalIds TidyOpts
opts Module
mod CoreProgram
binds CoreProgram
implicit_binds [CoreRule]
imp_rules
let (CoreProgram
trimmed_binds, [CoreRule]
trimmed_rules) = TidyOpts
-> CoreProgram
-> [CoreRule]
-> UnfoldEnv
-> (CoreProgram, [CoreRule])
findExternalRules TidyOpts
opts CoreProgram
binds [CoreRule]
imp_rules UnfoldEnv
unfold_env
(TidyEnv
tidy_env, CoreProgram
tidy_binds) <- UnfoldEnv
-> NameSet
-> TidyOccEnv
-> CoreProgram
-> IO (TidyEnv, CoreProgram)
tidyTopBinds UnfoldEnv
unfold_env NameSet
boot_exports TidyOccEnv
tidy_occ_env CoreProgram
trimmed_binds
([SptEntry]
spt_entries, Maybe CStub
mcstub, CoreProgram
tidy_binds') <- case TidyOpts -> Maybe StaticPtrOpts
opt_static_ptr_opts TidyOpts
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 :: ForeignStubs
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 :: [Id]
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]
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 :: TypeEnv
tidy_type_env = [Id] -> [TyCon] -> [PatSyn] -> [FamInst] -> TypeEnv
typeEnvFromEntities [Id]
final_ids [TyCon]
final_tcs [PatSyn]
patsyns [FamInst]
fam_insts
tidy_cls_insts :: InstEnv
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 :: [CoreRule]
tidy_rules = TidyEnv -> [CoreRule] -> [CoreRule]
tidyRules TidyEnv
tidy_env [CoreRule]
trimmed_rules
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 [TyCon]
tcs
local_ccs :: Set CostCentre
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
(CgGuts, ModDetails) -> IO (CgGuts, ModDetails)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CgGuts { cg_module :: Module
cg_module = Module
mod
, cg_tycons :: [TyCon]
cg_tycons = [TyCon]
alg_tycons
, cg_binds :: CoreProgram
cg_binds = CoreProgram
all_tidy_binds
, cg_ccs :: [CostCentre]
cg_ccs = Set CostCentre -> [CostCentre]
forall a. Set a -> [a]
S.toList Set CostCentre
local_ccs
, cg_foreign :: ForeignStubs
cg_foreign = ForeignStubs
all_foreign_stubs
, cg_foreign_files :: [(ForeignSrcLang, String)]
cg_foreign_files = [(ForeignSrcLang, String)]
foreign_files
, cg_dep_pkgs :: Set UnitId
cg_dep_pkgs = Dependencies -> Set UnitId
dep_direct_pkgs Dependencies
deps
, cg_hpc_info :: HpcInfo
cg_hpc_info = HpcInfo
hpc_info
, cg_modBreaks :: Maybe ModBreaks
cg_modBreaks = Maybe ModBreaks
modBreaks
, cg_spt_entries :: [SptEntry]
cg_spt_entries = [SptEntry]
spt_entries
}
, ModDetails { md_types :: TypeEnv
md_types = TypeEnv
tidy_type_env
, md_rules :: [CoreRule]
md_rules = [CoreRule]
tidy_rules
, md_insts :: InstEnv
md_insts = InstEnv
tidy_cls_insts
, md_fam_insts :: [FamInst]
md_fam_insts = [FamInst]
fam_insts
, md_exports :: [AvailInfo]
md_exports = [AvailInfo]
exports
, md_anns :: [Annotation]
md_anns = [Annotation]
anns
, md_complete_matches :: CompleteMatches
md_complete_matches = CompleteMatches
complete_matches
}
)
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
isNewTyCon TyCon
tc = []
| Bool
otherwise = (Id -> CoreBind) -> [Id] -> CoreProgram
forall a b. (a -> b) -> [a] -> [b]
map Id -> CoreBind
get_defn ((DataCon -> Maybe Id) -> [DataCon] -> [Id]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DataCon -> Maybe Id
dataConWrapId_maybe (TyCon -> [DataCon]
tyConDataCons TyCon
tc))
getClassImplicitBinds :: Class -> [CoreBind]
getClassImplicitBinds :: Class -> CoreProgram
getClassImplicitBinds Class
cls
= [ 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..] ]
get_defn :: Id -> CoreBind
get_defn :: Id -> CoreBind
get_defn Id
id = Id -> Expr Id -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
id (Unfolding -> Expr Id
unfoldingTemplate (Id -> Unfolding
realIdUnfolding Id
id))
type UnfoldEnv = IdEnv (Name, Bool )
chooseExternalIds :: TidyOpts
-> Module
-> [CoreBind]
-> [CoreBind]
-> [CoreRule]
-> IO (UnfoldEnv, TidyOccEnv)
chooseExternalIds :: TidyOpts
-> Module
-> CoreProgram
-> CoreProgram
-> [CoreRule]
-> IO (UnfoldEnv, TidyOccEnv)
chooseExternalIds TidyOpts
opts Module
mod CoreProgram
binds CoreProgram
implicit_binds [CoreRule]
imp_id_rules
= do { (UnfoldEnv
unfold_env1,TidyOccEnv
occ_env1) <- [(Id, Id)] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
search [(Id, Id)]
init_work_list UnfoldEnv
forall a. VarEnv a
emptyVarEnv TidyOccEnv
init_occ_env
; let internal_ids :: [Id]
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
; [Id] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
tidy_internal [Id]
internal_ids UnfoldEnv
unfold_env1 TidyOccEnv
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
implicit_binders :: [Id]
implicit_binders = CoreProgram -> [Id]
forall b. [Bind b] -> [b]
bindersOfBinds CoreProgram
implicit_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 [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
implicit_binders,
let name :: Name
name = Id -> Name
idName Id
bndr,
Name -> Bool
isExternalName Name
name ]
init_occ_env :: TidyOccEnv
init_occ_env = [OccName] -> TidyOccEnv
initTidyOccEnv [OccName]
avoids
search :: [(Id,Id)]
-> UnfoldEnv
-> TidyOccEnv
-> IO (UnfoldEnv, TidyOccEnv)
search :: [(Id, Id)] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
search [] UnfoldEnv
unfold_env TidyOccEnv
occ_env = (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
(TidyOccEnv
occ_env', Name
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
([Id]
new_ids, Bool
show_unfold) = TidyOpts -> Id -> ([Id], Bool)
addExternal TidyOpts
opts Id
refined_id
refined_id :: Id
refined_id = case VarSet -> Id -> Maybe Id
lookupVarSet VarSet
binder_set Id
idocc of
Just Id
id -> Id
id
Maybe Id
Nothing -> 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
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
referrer' | Id -> Bool
isExportedId Id
refined_id = Id
refined_id
| Bool
otherwise = Id
referrer
[(Id, Id)] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
search ([Id] -> [Id] -> [(Id, Id)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
new_ids (Id -> [Id]
forall a. a -> [a]
repeat Id
referrer') [(Id, Id)] -> [(Id, Id)] -> [(Id, Id)]
forall a. [a] -> [a] -> [a]
++ [(Id, Id)]
rest) UnfoldEnv
unfold_env' TidyOccEnv
occ_env'
tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv
-> IO (UnfoldEnv, TidyOccEnv)
tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
tidy_internal [] UnfoldEnv
unfold_env TidyOccEnv
occ_env = (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
(TidyOccEnv
occ_env', Name
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
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)
[Id] -> UnfoldEnv -> TidyOccEnv -> IO (UnfoldEnv, TidyOccEnv)
tidy_internal [Id]
ids UnfoldEnv
unfold_env' TidyOccEnv
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 = (() :: Constraint) => 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 })
= TidyOpts -> UnfoldingExposure
opt_expose_unfoldings TidyOpts
opts UnfoldingExposure -> UnfoldingExposure -> Bool
forall a. Eq a => a -> a -> Bool
== UnfoldingExposure
ExposeAll
Bool -> Bool -> Bool
|| UnfoldingSource -> Bool
isStableSource UnfoldingSource
src
Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
dont_inline
where
dont_inline :: Bool
dont_inline
| Bool
never_active = Bool
True
| Bool
loop_breaker = Bool
True
| Bool
otherwise = case UnfoldingGuidance
guidance of
UnfWhen {} -> Bool
False
UnfIfGoodArgs {} -> Bool
bottoming_fn
UnfNever {} -> Bool
True
show_unfolding (DFunUnfolding {}) = Bool
True
show_unfolding Unfolding
_ = Bool
False
bndrFvsInOrder :: Bool -> Id -> [Id]
bndrFvsInOrder :: Bool -> Id -> [Id]
bndrFvsInOrder Bool
show_unfold Id
id
= DFFV () -> [Id]
run (Bool -> Id -> DFFV ()
dffvLetBndr Bool
show_unfold Id
id)
run :: DFFV () -> [Id]
run :: DFFV () -> [Id]
run (DFFV VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), ())
m) = case VarSet -> (VarSet, [Id]) -> ((VarSet, [Id]), ())
m VarSet
emptyVarSet (VarSet
emptyVarSet, []) of
((VarSet
_,[Id]
ids),()
_) -> [Id]
ids
newtype DFFV a
= DFFV (VarSet
-> (VarSet, [Var])
-> ((VarSet,[Var]),a))
deriving ((forall a b. (a -> 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) 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 = (() :: Constraint) => 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 })
= case UnfoldingSource
src of
UnfoldingSource
InlineRhs | 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 ()
UnfoldingSource
_ -> Expr Id -> DFFV ()
dffvExpr Expr Id
rhs
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 = (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 CoreRule
rule | CoreRule -> Bool
isAutoRule CoreRule
rule = VarSet
emptyVarSet
| Bool
otherwise = CoreRule -> VarSet
ruleRhsFreeVars CoreRule
rule
(CoreProgram
trimmed_binds, VarSet
local_bndrs, VarSet
_, [CoreRule]
all_rules) = CoreProgram -> (CoreProgram, VarSet, VarSet, [CoreRule])
trim_binds CoreProgram
binds
keep_rule :: CoreRule -> Bool
keep_rule CoreRule
rule = CoreRule -> VarSet
ruleFreeVars CoreRule
rule VarSet -> VarSet -> Bool
`subVarSet` VarSet
local_bndrs
expose_rule :: CoreRule -> Bool
expose_rule CoreRule
rule
| Bool -> Bool
not (TidyOpts -> Bool
opt_expose_rules TidyOpts
opts) = Bool
False
| Bool
otherwise = (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
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
| 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 Unique
uniq <- NameCache -> IO Unique
takeUniqFromNameCache NameCache
name_cache
let new_local_name :: Name
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
(TidyOccEnv, Name) -> IO (TidyOccEnv, Name)
forall a. a -> IO a
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 <- NameCache -> Module -> OccName -> SrcSpan -> IO Name
allocateGlobalBinder NameCache
name_cache Module
mod OccName
occ' SrcSpan
loc
(TidyOccEnv, Name) -> IO (TidyOccEnv, Name)
forall a. a -> IO a
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 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 = (() :: Constraint) => 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 ((() :: Constraint) => 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)
mb_bot_str = Expr Id -> Maybe (Arity, DmdSig)
exprBotStrictness_maybe Expr Id
orig_rhs
sig :: DmdSig
sig = IdInfo -> DmdSig
dmdSigInfo IdInfo
idinfo
final_sig :: DmdSig
final_sig | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ 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
nsig) <- Maybe (Arity, DmdSig)
mb_bot_str = DmdSig
nsig
| Bool
otherwise = DmdSig
sig
cpr :: CprSig
cpr = IdInfo -> CprSig
cprSigInfo IdInfo
idinfo
final_cpr :: CprSig
final_cpr | Just (Arity, DmdSig)
_ <- Maybe (Arity, DmdSig)
mb_bot_str
= Arity -> Cpr -> CprSig
mkCprSig Arity
arity Cpr
botCpr
| Bool
otherwise
= CprSig
cpr
_bottom_hidden :: DmdSig -> Bool
_bottom_hidden DmdSig
id_sig = case Maybe (Arity, DmdSig)
mb_bot_str of
Maybe (Arity, DmdSig)
Nothing -> Bool
False
Just (Arity
arity, DmdSig
_) -> 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` ([OneShotInfo] -> Arity
forall a. [a] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length ([OneShotInfo] -> Arity) -> [OneShotInfo] -> Arity
forall a b. (a -> b) -> a -> b
$ Type -> [OneShotInfo]
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 :: [Id]
df_bndrs = [Id]
bndrs', df_args :: [Expr Id]
df_args = (Expr Id -> Expr Id) -> [Expr Id] -> [Expr Id]
forall a b. (a -> b) -> [a] -> [b]
map (TidyEnv -> Expr Id -> Expr Id
tidyExpr TidyEnv
tidy_env') [Expr Id]
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 :: Expr Id
uf_tmpl = Expr Id
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