{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Config
import GHC.Driver.Env
import GHC.Tc.Utils.TcType hiding( substTy )
import GHC.Core.Type hiding( substTy, extendTvSubstList )
import GHC.Core.Multiplicity
import GHC.Core.Predicate
import GHC.Core.Coercion( Coercion )
import GHC.Core.Opt.Monad
import qualified GHC.Core.Subst as Core
import GHC.Core.Unfold.Make
import GHC.Core
import GHC.Core.Rules
import GHC.Core.Utils ( exprIsTrivial, getIdFromTrivialExpr_maybe
, mkCast, exprType )
import GHC.Core.FVs
import GHC.Core.TyCo.Rep (TyCoBinder (..))
import GHC.Core.Opt.Arity ( collectBindersPushingCo
, etaExpandToJoinPointRule )
import GHC.Builtin.Types ( unboxedUnitTy )
import GHC.Data.Maybe ( mapMaybe, maybeToList, isJust )
import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Types.Basic
import GHC.Types.Unique.Supply
import GHC.Types.Unique.DFM
import GHC.Types.Name
import GHC.Types.Tickish
import GHC.Types.Id.Make ( voidArgId, voidPrimId )
import GHC.Types.Var ( isLocalVar )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Id
import GHC.Utils.Monad ( foldlM )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Unit.Module( Module )
import GHC.Unit.Module.ModGuts
import GHC.Unit.External
specProgram :: ModGuts -> CoreM ModGuts
specProgram :: ModGuts -> CoreM ModGuts
specProgram guts :: ModGuts
guts@(ModGuts { mg_module :: ModGuts -> Module
mg_module = Module
this_mod
, mg_rules :: ModGuts -> [CoreRule]
mg_rules = [CoreRule]
local_rules
, mg_binds :: ModGuts -> CoreProgram
mg_binds = CoreProgram
binds })
= do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let top_env :: SpecEnv
top_env = SE { se_subst :: Subst
se_subst = InScopeSet -> Subst
Core.mkEmptySubst forall a b. (a -> b) -> a -> b
$ VarSet -> InScopeSet
mkInScopeSet forall a b. (a -> b) -> a -> b
$ [Id] -> VarSet
mkVarSet forall a b. (a -> b) -> a -> b
$
forall b. [Bind b] -> [b]
bindersOfBinds CoreProgram
binds
, se_interesting :: VarSet
se_interesting = VarSet
emptyVarSet
, se_module :: Module
se_module = Module
this_mod
, se_dflags :: DynFlags
se_dflags = DynFlags
dflags }
go :: CoreProgram -> UniqSM (CoreProgram, UsageDetails)
go [] = forall (m :: * -> *) a. Monad m => a -> m a
return ([], UsageDetails
emptyUDs)
go (CoreBind
bind:CoreProgram
binds) = do (CoreProgram
binds', UsageDetails
uds) <- CoreProgram -> UniqSM (CoreProgram, UsageDetails)
go CoreProgram
binds
(CoreProgram
bind', UsageDetails
uds') <- SpecEnv
-> CoreBind -> UsageDetails -> UniqSM (CoreProgram, UsageDetails)
specBind SpecEnv
top_env CoreBind
bind UsageDetails
uds
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreProgram
bind' forall a. [a] -> [a] -> [a]
++ CoreProgram
binds', UsageDetails
uds')
; (CoreProgram
binds', UsageDetails
uds) <- forall a. SpecM a -> CoreM a
runSpecM (CoreProgram -> UniqSM (CoreProgram, UsageDetails)
go CoreProgram
binds)
; ([CoreRule]
spec_rules, CoreProgram
spec_binds) <- SpecEnv
-> [CoreRule] -> UsageDetails -> CoreM ([CoreRule], CoreProgram)
specImports SpecEnv
top_env [CoreRule]
local_rules UsageDetails
uds
; forall (m :: * -> *) a. Monad m => a -> m a
return (ModGuts
guts { mg_binds :: CoreProgram
mg_binds = CoreProgram
spec_binds forall a. [a] -> [a] -> [a]
++ CoreProgram
binds'
, mg_rules :: [CoreRule]
mg_rules = [CoreRule]
spec_rules forall a. [a] -> [a] -> [a]
++ [CoreRule]
local_rules }) }
specImports :: SpecEnv
-> [CoreRule]
-> UsageDetails
-> CoreM ([CoreRule], [CoreBind])
specImports :: SpecEnv
-> [CoreRule] -> UsageDetails -> CoreM ([CoreRule], CoreProgram)
specImports SpecEnv
top_env [CoreRule]
local_rules
(MkUD { ud_binds :: UsageDetails -> Bag DictBind
ud_binds = Bag DictBind
dict_binds, ud_calls :: UsageDetails -> CallDetails
ud_calls = CallDetails
calls })
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CrossModuleSpecialise (SpecEnv -> DynFlags
se_dflags SpecEnv
top_env)
= forall (m :: * -> *) a. Monad m => a -> m a
return ([], Bag DictBind -> CoreProgram -> CoreProgram
wrapDictBinds Bag DictBind
dict_binds [])
| Bool
otherwise
= do { RuleBase
hpt_rules <- CoreM RuleBase
getRuleBase
; let rule_base :: RuleBase
rule_base = RuleBase -> [CoreRule] -> RuleBase
extendRuleBaseList RuleBase
hpt_rules [CoreRule]
local_rules
; ([CoreRule]
spec_rules, CoreProgram
spec_binds) <- SpecEnv
-> [Id]
-> RuleBase
-> Bag DictBind
-> CallDetails
-> CoreM ([CoreRule], CoreProgram)
spec_imports SpecEnv
top_env [] RuleBase
rule_base
Bag DictBind
dict_binds CallDetails
calls
; let final_binds :: CoreProgram
final_binds
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null CoreProgram
spec_binds = Bag DictBind -> CoreProgram -> CoreProgram
wrapDictBinds Bag DictBind
dict_binds []
| Bool
otherwise = [forall b. [(b, Expr b)] -> Bind b
Rec forall a b. (a -> b) -> a -> b
$ forall b. [Bind b] -> [(b, Expr b)]
flattenBinds forall a b. (a -> b) -> a -> b
$
Bag DictBind -> CoreProgram -> CoreProgram
wrapDictBinds Bag DictBind
dict_binds CoreProgram
spec_binds]
; forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreRule]
spec_rules, CoreProgram
final_binds)
}
spec_imports :: SpecEnv
-> [Id]
-> RuleBase
-> Bag DictBind
-> CallDetails
-> CoreM ( [CoreRule]
, [CoreBind] )
spec_imports :: SpecEnv
-> [Id]
-> RuleBase
-> Bag DictBind
-> CallDetails
-> CoreM ([CoreRule], CoreProgram)
spec_imports SpecEnv
top_env [Id]
callers RuleBase
rule_base Bag DictBind
dict_binds CallDetails
calls
= do { let import_calls :: [CallInfoSet]
import_calls = forall a. DVarEnv a -> [a]
dVarEnvElts CallDetails
calls
; ([CoreRule]
rules, CoreProgram
spec_binds) <- RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], CoreProgram)
go RuleBase
rule_base [CallInfoSet]
import_calls
; forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreRule]
rules, CoreProgram
spec_binds) }
where
go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind])
go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], CoreProgram)
go RuleBase
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
go RuleBase
rb (CallInfoSet
cis : [CallInfoSet]
other_calls)
= do {
; ([CoreRule]
rules1, CoreProgram
spec_binds1) <- SpecEnv
-> [Id]
-> RuleBase
-> Bag DictBind
-> CallInfoSet
-> CoreM ([CoreRule], CoreProgram)
spec_import SpecEnv
top_env [Id]
callers RuleBase
rb Bag DictBind
dict_binds CallInfoSet
cis
; ([CoreRule]
rules2, CoreProgram
spec_binds2) <- RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], CoreProgram)
go (RuleBase -> [CoreRule] -> RuleBase
extendRuleBaseList RuleBase
rb [CoreRule]
rules1) [CallInfoSet]
other_calls
; forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreRule]
rules1 forall a. [a] -> [a] -> [a]
++ [CoreRule]
rules2, CoreProgram
spec_binds1 forall a. [a] -> [a] -> [a]
++ CoreProgram
spec_binds2) }
spec_import :: SpecEnv
-> [Id]
-> RuleBase
-> Bag DictBind
-> CallInfoSet
-> CoreM ( [CoreRule]
, [CoreBind] )
spec_import :: SpecEnv
-> [Id]
-> RuleBase
-> Bag DictBind
-> CallInfoSet
-> CoreM ([CoreRule], CoreProgram)
spec_import SpecEnv
top_env [Id]
callers RuleBase
rb Bag DictBind
dict_binds cis :: CallInfoSet
cis@(CIS Id
fn Bag CallInfo
_)
| forall a. Eq a => String -> a -> [a] -> Bool
isIn String
"specImport" Id
fn [Id]
callers
= forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CallInfo]
good_calls
= forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
| Just CoreExpr
rhs <- DynFlags -> Id -> Maybe CoreExpr
canSpecImport DynFlags
dflags Id
fn
= do {
; HscEnv
hsc_env <- CoreM HscEnv
getHscEnv
; ExternalPackageState
eps <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
; ModuleSet
vis_orphs <- CoreM ModuleSet
getVisibleOrphanMods
; let full_rb :: RuleBase
full_rb = RuleBase -> RuleBase -> RuleBase
unionRuleBase RuleBase
rb (ExternalPackageState -> RuleBase
eps_rule_base ExternalPackageState
eps)
rules_for_fn :: [CoreRule]
rules_for_fn = RuleEnv -> Id -> [CoreRule]
getRules (RuleBase -> ModuleSet -> RuleEnv
RuleEnv RuleBase
full_rb ModuleSet
vis_orphs) Id
fn
; ([CoreRule]
rules1, [(Id, CoreExpr)]
spec_pairs, MkUD { ud_binds :: UsageDetails -> Bag DictBind
ud_binds = Bag DictBind
dict_binds1, ud_calls :: UsageDetails -> CallDetails
ud_calls = CallDetails
new_calls })
<-
(forall a. SpecM a -> CoreM a
runSpecM forall a b. (a -> b) -> a -> b
$ Bool
-> SpecEnv
-> [CoreRule]
-> [CallInfo]
-> Id
-> CoreExpr
-> SpecM ([CoreRule], [(Id, CoreExpr)], UsageDetails)
specCalls Bool
True SpecEnv
top_env [CoreRule]
rules_for_fn [CallInfo]
good_calls Id
fn CoreExpr
rhs)
; let spec_binds1 :: CoreProgram
spec_binds1 = [forall b. b -> Expr b -> Bind b
NonRec Id
b CoreExpr
r | (Id
b,CoreExpr
r) <- [(Id, CoreExpr)]
spec_pairs]
; ([CoreRule]
rules2, CoreProgram
spec_binds2) <- SpecEnv
-> [Id]
-> RuleBase
-> Bag DictBind
-> CallDetails
-> CoreM ([CoreRule], CoreProgram)
spec_imports SpecEnv
top_env
(Id
fnforall a. a -> [a] -> [a]
:[Id]
callers)
(RuleBase -> [CoreRule] -> RuleBase
extendRuleBaseList RuleBase
rb [CoreRule]
rules1)
(Bag DictBind
dict_binds forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag DictBind
dict_binds1)
CallDetails
new_calls
; let final_binds :: CoreProgram
final_binds = Bag DictBind -> CoreProgram -> CoreProgram
wrapDictBinds Bag DictBind
dict_binds1 forall a b. (a -> b) -> a -> b
$
CoreProgram
spec_binds2 forall a. [a] -> [a] -> [a]
++ CoreProgram
spec_binds1
; forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreRule]
rules2 forall a. [a] -> [a] -> [a]
++ [CoreRule]
rules1, CoreProgram
final_binds) }
| Bool
otherwise
= do { DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM ()
tryWarnMissingSpecs DynFlags
dflags [Id]
callers Id
fn [CallInfo]
good_calls
; forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])}
where
dflags :: DynFlags
dflags = SpecEnv -> DynFlags
se_dflags SpecEnv
top_env
good_calls :: [CallInfo]
good_calls = CallInfoSet -> Bag DictBind -> [CallInfo]
filterCalls CallInfoSet
cis Bag DictBind
dict_binds
canSpecImport :: DynFlags -> Id -> Maybe CoreExpr
canSpecImport :: DynFlags -> Id -> Maybe CoreExpr
canSpecImport DynFlags
dflags Id
fn
| CoreUnfolding { uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src, uf_tmpl :: Unfolding -> CoreExpr
uf_tmpl = CoreExpr
rhs } <- Unfolding
unf
, UnfoldingSource -> Bool
isStableSource UnfoldingSource
src
= forall a. a -> Maybe a
Just CoreExpr
rhs
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SpecialiseAggressively DynFlags
dflags
= Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate Unfolding
unf
| Bool
otherwise = forall a. Maybe a
Nothing
where
unf :: Unfolding
unf = Id -> Unfolding
realIdUnfolding Id
fn
tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM ()
tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM ()
tryWarnMissingSpecs DynFlags
dflags [Id]
callers Id
fn [CallInfo]
calls_for_fn
| Id -> Bool
isClassOpId Id
fn = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnMissedSpecs DynFlags
dflags
Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
callers)
Bool -> Bool -> Bool
&& Bool
allCallersInlined = WarnReason -> CoreM ()
doWarn forall a b. (a -> b) -> a -> b
$ WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissedSpecs
| WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnAllMissedSpecs DynFlags
dflags = WarnReason -> CoreM ()
doWarn forall a b. (a -> b) -> a -> b
$ WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnAllMissedSpecs
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
allCallersInlined :: Bool
allCallersInlined = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (InlinePragma -> Bool
isAnyInlinePragma forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> InlinePragma
idInlinePragma) [Id]
callers
doWarn :: WarnReason -> CoreM ()
doWarn WarnReason
reason =
WarnReason -> SDoc -> CoreM ()
warnMsg WarnReason
reason
([SDoc] -> SDoc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text (String
"Could not specialise imported function") SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Id
fn))
Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"when specialising" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Id
caller)
| Id
caller <- [Id]
callers])
, SDoc -> SDoc
whenPprDebug (String -> SDoc
text String
"calls:" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (Id -> CallInfo -> SDoc
pprCallInfo Id
fn) [CallInfo]
calls_for_fn))
, String -> SDoc
text String
"Probable fix: add INLINABLE pragma on" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Id
fn) ])
data SpecEnv
= SE { SpecEnv -> Subst
se_subst :: Core.Subst
, SpecEnv -> VarSet
se_interesting :: VarSet
, SpecEnv -> Module
se_module :: Module
, SpecEnv -> DynFlags
se_dflags :: DynFlags
}
instance Outputable SpecEnv where
ppr :: SpecEnv -> SDoc
ppr (SE { se_subst :: SpecEnv -> Subst
se_subst = Subst
subst, se_interesting :: SpecEnv -> VarSet
se_interesting = VarSet
interesting })
= String -> SDoc
text String
"SE" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
sep forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
[ String -> SDoc
text String
"subst =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Subst
subst
, String -> SDoc
text String
"interesting =" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr VarSet
interesting ])
specVar :: SpecEnv -> Id -> CoreExpr
specVar :: SpecEnv -> Id -> CoreExpr
specVar SpecEnv
env Id
v = HasDebugCallStack => Subst -> Id -> CoreExpr
Core.lookupIdSubst (SpecEnv -> Subst
se_subst SpecEnv
env) Id
v
specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr SpecEnv
env (Type Kind
ty) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Kind -> Expr b
Type (SpecEnv -> Kind -> Kind
substTy SpecEnv
env Kind
ty), UsageDetails
emptyUDs)
specExpr SpecEnv
env (Coercion Coercion
co) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Coercion -> Expr b
Coercion (SpecEnv -> Coercion -> Coercion
substCo SpecEnv
env Coercion
co), UsageDetails
emptyUDs)
specExpr SpecEnv
env (Var Id
v) = forall (m :: * -> *) a. Monad m => a -> m a
return (SpecEnv -> Id -> CoreExpr
specVar SpecEnv
env Id
v, UsageDetails
emptyUDs)
specExpr SpecEnv
_ (Lit Literal
lit) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Literal -> Expr b
Lit Literal
lit, UsageDetails
emptyUDs)
specExpr SpecEnv
env (Cast CoreExpr
e Coercion
co)
= do { (CoreExpr
e', UsageDetails
uds) <- SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr SpecEnv
env CoreExpr
e
; forall (m :: * -> *) a. Monad m => a -> m a
return ((CoreExpr -> Coercion -> CoreExpr
mkCast CoreExpr
e' (SpecEnv -> Coercion -> Coercion
substCo SpecEnv
env Coercion
co)), UsageDetails
uds) }
specExpr SpecEnv
env (Tick CoreTickish
tickish CoreExpr
body)
= do { (CoreExpr
body', UsageDetails
uds) <- SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr SpecEnv
env CoreExpr
body
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. CoreTickish -> Expr b -> Expr b
Tick (SpecEnv -> CoreTickish -> CoreTickish
specTickish SpecEnv
env CoreTickish
tickish) CoreExpr
body', UsageDetails
uds) }
specExpr SpecEnv
env expr :: CoreExpr
expr@(App {})
= CoreExpr -> [CoreExpr] -> SpecM (CoreExpr, UsageDetails)
go CoreExpr
expr []
where
go :: CoreExpr -> [CoreExpr] -> SpecM (CoreExpr, UsageDetails)
go (App CoreExpr
fun CoreExpr
arg) [CoreExpr]
args = do (CoreExpr
arg', UsageDetails
uds_arg) <- SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr SpecEnv
env CoreExpr
arg
(CoreExpr
fun', UsageDetails
uds_app) <- CoreExpr -> [CoreExpr] -> SpecM (CoreExpr, UsageDetails)
go CoreExpr
fun (CoreExpr
arg'forall a. a -> [a] -> [a]
:[CoreExpr]
args)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Expr b -> Expr b -> Expr b
App CoreExpr
fun' CoreExpr
arg', UsageDetails
uds_arg UsageDetails -> UsageDetails -> UsageDetails
`plusUDs` UsageDetails
uds_app)
go (Var Id
f) [CoreExpr]
args = case SpecEnv -> Id -> CoreExpr
specVar SpecEnv
env Id
f of
Var Id
f' -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Id -> Expr b
Var Id
f', SpecEnv -> Id -> [CoreExpr] -> UsageDetails
mkCallUDs SpecEnv
env Id
f' [CoreExpr]
args)
CoreExpr
e' -> forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
e', UsageDetails
emptyUDs)
go CoreExpr
other [CoreExpr]
_ = SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr SpecEnv
env CoreExpr
other
specExpr SpecEnv
env e :: CoreExpr
e@(Lam {})
= SpecEnv -> [Id] -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specLam SpecEnv
env' [Id]
bndrs' CoreExpr
body
where
([Id]
bndrs, CoreExpr
body) = forall b. Expr b -> ([b], Expr b)
collectBinders CoreExpr
e
(SpecEnv
env', [Id]
bndrs') = SpecEnv -> [Id] -> (SpecEnv, [Id])
substBndrs SpecEnv
env [Id]
bndrs
specExpr SpecEnv
env (Case CoreExpr
scrut Id
case_bndr Kind
ty [Alt Id]
alts)
= do { (CoreExpr
scrut', UsageDetails
scrut_uds) <- SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr SpecEnv
env CoreExpr
scrut
; (CoreExpr
scrut'', Id
case_bndr', [Alt Id]
alts', UsageDetails
alts_uds)
<- SpecEnv
-> CoreExpr
-> Id
-> [Alt Id]
-> SpecM (CoreExpr, Id, [Alt Id], UsageDetails)
specCase SpecEnv
env CoreExpr
scrut' Id
case_bndr [Alt Id]
alts
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Expr b -> b -> Kind -> [Alt b] -> Expr b
Case CoreExpr
scrut'' Id
case_bndr' (SpecEnv -> Kind -> Kind
substTy SpecEnv
env Kind
ty) [Alt Id]
alts'
, UsageDetails
scrut_uds UsageDetails -> UsageDetails -> UsageDetails
`plusUDs` UsageDetails
alts_uds) }
specExpr SpecEnv
env (Let CoreBind
bind CoreExpr
body)
= do {
(SpecEnv
rhs_env, SpecEnv
body_env, CoreBind
bind') <- SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind)
cloneBindSM SpecEnv
env CoreBind
bind
; (CoreExpr
body', UsageDetails
body_uds) <- SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr SpecEnv
body_env CoreExpr
body
; (CoreProgram
binds', UsageDetails
uds) <- SpecEnv
-> CoreBind -> UsageDetails -> UniqSM (CoreProgram, UsageDetails)
specBind SpecEnv
rhs_env CoreBind
bind' UsageDetails
body_uds
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b. Bind b -> Expr b -> Expr b
Let CoreExpr
body' CoreProgram
binds', UsageDetails
uds) }
specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails)
specLam :: SpecEnv -> [Id] -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specLam SpecEnv
env [Id]
bndrs CoreExpr
body
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bndrs
= SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr SpecEnv
env CoreExpr
body
| Bool
otherwise
= do { (CoreExpr
body', UsageDetails
uds) <- SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr SpecEnv
env CoreExpr
body
; let (UsageDetails
free_uds, Bag DictBind
dumped_dbs) = [Id] -> UsageDetails -> (UsageDetails, Bag DictBind)
dumpUDs [Id]
bndrs UsageDetails
uds
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. [b] -> Expr b -> Expr b
mkLams [Id]
bndrs (Bag DictBind -> CoreExpr -> CoreExpr
wrapDictBindsE Bag DictBind
dumped_dbs CoreExpr
body'), UsageDetails
free_uds) }
specTickish :: SpecEnv -> CoreTickish -> CoreTickish
specTickish :: SpecEnv -> CoreTickish -> CoreTickish
specTickish SpecEnv
env (Breakpoint XBreakpoint 'TickishPassCore
ext Int
ix [XTickishId 'TickishPassCore]
ids)
= forall (pass :: TickishPass).
XBreakpoint pass -> Int -> [XTickishId pass] -> GenTickish pass
Breakpoint XBreakpoint 'TickishPassCore
ext Int
ix [ Id
id' | Id
id <- [XTickishId 'TickishPassCore]
ids, Var Id
id' <- [SpecEnv -> Id -> CoreExpr
specVar SpecEnv
env Id
id]]
specTickish SpecEnv
_ CoreTickish
other_tickish = CoreTickish
other_tickish
specCase :: SpecEnv
-> CoreExpr
-> Id -> [CoreAlt]
-> SpecM ( CoreExpr
, Id
, [CoreAlt]
, UsageDetails)
specCase :: SpecEnv
-> CoreExpr
-> Id
-> [Alt Id]
-> SpecM (CoreExpr, Id, [Alt Id], UsageDetails)
specCase SpecEnv
env CoreExpr
scrut' Id
case_bndr [Alt AltCon
con [Id]
args CoreExpr
rhs]
| Id -> Bool
isDictId Id
case_bndr
, SpecEnv -> CoreExpr -> Bool
interestingDict SpecEnv
env CoreExpr
scrut'
, Bool -> Bool
not (Id -> Bool
isDeadBinder Id
case_bndr Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
sc_args')
= do { (Id
case_bndr_flt : [Id]
sc_args_flt) <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}. MonadUnique m => Id -> m Id
clone_me (Id
case_bndr' forall a. a -> [a] -> [a]
: [Id]
sc_args')
; let sc_rhss :: [CoreExpr]
sc_rhss = [ forall b. Expr b -> b -> Kind -> [Alt b] -> Expr b
Case (forall b. Id -> Expr b
Var Id
case_bndr_flt) Id
case_bndr' (Id -> Kind
idType Id
sc_arg')
[forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
args' (forall b. Id -> Expr b
Var Id
sc_arg')]
| Id
sc_arg' <- [Id]
sc_args' ]
mb_sc_flts :: [Maybe DictId]
mb_sc_flts :: [Maybe Id]
mb_sc_flts = forall a b. (a -> b) -> [a] -> [b]
map (forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv Id
clone_env) [Id]
args'
clone_env :: VarEnv Id
clone_env = forall a. [Id] -> [a] -> VarEnv a
zipVarEnv [Id]
sc_args' [Id]
sc_args_flt
subst_prs :: [(Id, CoreExpr)]
subst_prs = (Id
case_bndr, forall b. Id -> Expr b
Var Id
case_bndr_flt)
forall a. a -> [a] -> [a]
: [ (Id
arg, forall b. Id -> Expr b
Var Id
sc_flt)
| (Id
arg, Just Id
sc_flt) <- [Id]
args forall a b. [a] -> [b] -> [(a, b)]
`zip` [Maybe Id]
mb_sc_flts ]
env_rhs' :: SpecEnv
env_rhs' = SpecEnv
env_rhs { se_subst :: Subst
se_subst = Subst -> [(Id, CoreExpr)] -> Subst
Core.extendIdSubstList (SpecEnv -> Subst
se_subst SpecEnv
env_rhs) [(Id, CoreExpr)]
subst_prs
, se_interesting :: VarSet
se_interesting = SpecEnv -> VarSet
se_interesting SpecEnv
env_rhs VarSet -> [Id] -> VarSet
`extendVarSetList`
(Id
case_bndr_flt forall a. a -> [a] -> [a]
: [Id]
sc_args_flt) }
; (CoreExpr
rhs', UsageDetails
rhs_uds) <- SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr SpecEnv
env_rhs' CoreExpr
rhs
; let scrut_bind :: DictBind
scrut_bind = CoreBind -> DictBind
mkDB (forall b. b -> Expr b -> Bind b
NonRec Id
case_bndr_flt CoreExpr
scrut')
case_bndr_set :: VarSet
case_bndr_set = Id -> VarSet
unitVarSet Id
case_bndr_flt
sc_binds :: [DictBind]
sc_binds = [ DB { db_bind :: CoreBind
db_bind = forall b. b -> Expr b -> Bind b
NonRec Id
sc_arg_flt CoreExpr
sc_rhs
, db_fvs :: VarSet
db_fvs = VarSet
case_bndr_set }
| (Id
sc_arg_flt, CoreExpr
sc_rhs) <- [Id]
sc_args_flt forall a b. [a] -> [b] -> [(a, b)]
`zip` [CoreExpr]
sc_rhss ]
flt_binds :: [DictBind]
flt_binds = DictBind
scrut_bind forall a. a -> [a] -> [a]
: [DictBind]
sc_binds
(UsageDetails
free_uds, Bag DictBind
dumped_dbs) = [Id] -> UsageDetails -> (UsageDetails, Bag DictBind)
dumpUDs (Id
case_bndr'forall a. a -> [a] -> [a]
:[Id]
args') UsageDetails
rhs_uds
all_uds :: UsageDetails
all_uds = [DictBind]
flt_binds [DictBind] -> UsageDetails -> UsageDetails
`addDictBinds` UsageDetails
free_uds
alt' :: Alt Id
alt' = forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
args' (Bag DictBind -> CoreExpr -> CoreExpr
wrapDictBindsE Bag DictBind
dumped_dbs CoreExpr
rhs')
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Id -> Expr b
Var Id
case_bndr_flt, Id
case_bndr', [Alt Id
alt'], UsageDetails
all_uds) }
where
(SpecEnv
env_rhs, (Id
case_bndr':[Id]
args')) = SpecEnv -> [Id] -> (SpecEnv, [Id])
substBndrs SpecEnv
env (Id
case_bndrforall a. a -> [a] -> [a]
:[Id]
args)
sc_args' :: [Id]
sc_args' = forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
is_flt_sc_arg [Id]
args'
clone_me :: Id -> m Id
clone_me Id
bndr = do { Unique
uniq <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; forall (m :: * -> *) a. Monad m => a -> m a
return (OccName -> Unique -> Kind -> Kind -> SrcSpan -> Id
mkUserLocalOrCoVar OccName
occ Unique
uniq Kind
wght Kind
ty SrcSpan
loc) }
where
name :: Name
name = Id -> Name
idName Id
bndr
wght :: Kind
wght = Id -> Kind
idMult Id
bndr
ty :: Kind
ty = Id -> Kind
idType Id
bndr
occ :: OccName
occ = Name -> OccName
nameOccName Name
name
loc :: SrcSpan
loc = forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
name
arg_set :: VarSet
arg_set = [Id] -> VarSet
mkVarSet [Id]
args'
is_flt_sc_arg :: Id -> Bool
is_flt_sc_arg Id
var = Id -> Bool
isId Id
var
Bool -> Bool -> Bool
&& Bool -> Bool
not (Id -> Bool
isDeadBinder Id
var)
Bool -> Bool -> Bool
&& Kind -> Bool
isDictTy Kind
var_ty
Bool -> Bool -> Bool
&& Kind -> VarSet
tyCoVarsOfType Kind
var_ty VarSet -> VarSet -> Bool
`disjointVarSet` VarSet
arg_set
where
var_ty :: Kind
var_ty = Id -> Kind
idType Id
var
specCase SpecEnv
env CoreExpr
scrut Id
case_bndr [Alt Id]
alts
= do { ([Alt Id]
alts', UsageDetails
uds_alts) <- forall a b.
(a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM Alt Id -> UniqSM (Alt Id, UsageDetails)
spec_alt [Alt Id]
alts
; forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
scrut, Id
case_bndr', [Alt Id]
alts', UsageDetails
uds_alts) }
where
(SpecEnv
env_alt, Id
case_bndr') = SpecEnv -> Id -> (SpecEnv, Id)
substBndr SpecEnv
env Id
case_bndr
spec_alt :: Alt Id -> UniqSM (Alt Id, UsageDetails)
spec_alt (Alt AltCon
con [Id]
args CoreExpr
rhs) = do
(CoreExpr
rhs', UsageDetails
uds) <- SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr SpecEnv
env_rhs CoreExpr
rhs
let (UsageDetails
free_uds, Bag DictBind
dumped_dbs) = [Id] -> UsageDetails -> (UsageDetails, Bag DictBind)
dumpUDs (Id
case_bndr' forall a. a -> [a] -> [a]
: [Id]
args') UsageDetails
uds
forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
args' (Bag DictBind -> CoreExpr -> CoreExpr
wrapDictBindsE Bag DictBind
dumped_dbs CoreExpr
rhs'), UsageDetails
free_uds)
where
(SpecEnv
env_rhs, [Id]
args') = SpecEnv -> [Id] -> (SpecEnv, [Id])
substBndrs SpecEnv
env_alt [Id]
args
specBind :: SpecEnv
-> CoreBind
-> UsageDetails
-> SpecM ([CoreBind],
UsageDetails)
specBind :: SpecEnv
-> CoreBind -> UsageDetails -> UniqSM (CoreProgram, UsageDetails)
specBind SpecEnv
rhs_env (NonRec Id
fn CoreExpr
rhs) UsageDetails
body_uds
= do { (CoreExpr
rhs', UsageDetails
rhs_uds) <- SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr SpecEnv
rhs_env CoreExpr
rhs
; let zapped_fn :: Id
zapped_fn = Id -> Id
zapIdDemandInfo Id
fn
; (Id
fn', [(Id, CoreExpr)]
spec_defns, UsageDetails
body_uds1) <- SpecEnv
-> UsageDetails
-> Id
-> CoreExpr
-> SpecM (Id, [(Id, CoreExpr)], UsageDetails)
specDefn SpecEnv
rhs_env UsageDetails
body_uds Id
zapped_fn CoreExpr
rhs
; let pairs :: [(Id, CoreExpr)]
pairs = [(Id, CoreExpr)]
spec_defns forall a. [a] -> [a] -> [a]
++ [(Id
fn', CoreExpr
rhs')]
combined_uds :: UsageDetails
combined_uds = UsageDetails
body_uds1 UsageDetails -> UsageDetails -> UsageDetails
`plusUDs` UsageDetails
rhs_uds
(UsageDetails
free_uds, Bag DictBind
dump_dbs, Bool
float_all) = [Id] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)
dumpBindUDs [Id
fn] UsageDetails
combined_uds
final_binds :: [DictBind]
final_binds :: [DictBind]
final_binds
| Bool -> Bool
not (forall a. Bag a -> Bool
isEmptyBag Bag DictBind
dump_dbs)
, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Id, CoreExpr)]
spec_defns)
= [[(Id, CoreExpr)] -> Bag DictBind -> DictBind
recWithDumpedDicts [(Id, CoreExpr)]
pairs Bag DictBind
dump_dbs]
| Bool
otherwise
= [CoreBind -> DictBind
mkDB forall a b. (a -> b) -> a -> b
$ forall b. b -> Expr b -> Bind b
NonRec Id
b CoreExpr
r | (Id
b,CoreExpr
r) <- [(Id, CoreExpr)]
pairs]
forall a. [a] -> [a] -> [a]
++ forall a. Bag a -> [a]
bagToList Bag DictBind
dump_dbs
; if Bool
float_all then
forall (m :: * -> *) a. Monad m => a -> m a
return ([], UsageDetails
free_uds UsageDetails -> [DictBind] -> UsageDetails
`snocDictBinds` [DictBind]
final_binds)
else
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map DictBind -> CoreBind
db_bind [DictBind]
final_binds, UsageDetails
free_uds) }
specBind SpecEnv
rhs_env (Rec [(Id, CoreExpr)]
pairs) UsageDetails
body_uds
= do { let ([Id]
bndrs,[CoreExpr]
rhss) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, CoreExpr)]
pairs
; ([CoreExpr]
rhss', UsageDetails
rhs_uds) <- forall a b.
(a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM (SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr SpecEnv
rhs_env) [CoreExpr]
rhss
; let scope_uds :: UsageDetails
scope_uds = UsageDetails
body_uds UsageDetails -> UsageDetails -> UsageDetails
`plusUDs` UsageDetails
rhs_uds
; ([Id]
bndrs1, [(Id, CoreExpr)]
spec_defns1, UsageDetails
uds1) <- SpecEnv
-> UsageDetails
-> [(Id, CoreExpr)]
-> SpecM ([Id], [(Id, CoreExpr)], UsageDetails)
specDefns SpecEnv
rhs_env UsageDetails
scope_uds [(Id, CoreExpr)]
pairs
; ([Id]
bndrs3, [(Id, CoreExpr)]
spec_defns3, UsageDetails
uds3)
<- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Id, CoreExpr)]
spec_defns1
then forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
bndrs1, [], UsageDetails
uds1)
else do {
([Id]
bndrs2, [(Id, CoreExpr)]
spec_defns2, UsageDetails
uds2)
<- SpecEnv
-> UsageDetails
-> [(Id, CoreExpr)]
-> SpecM ([Id], [(Id, CoreExpr)], UsageDetails)
specDefns SpecEnv
rhs_env UsageDetails
uds1 ([Id]
bndrs1 forall a b. [a] -> [b] -> [(a, b)]
`zip` [CoreExpr]
rhss)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
bndrs2, [(Id, CoreExpr)]
spec_defns2 forall a. [a] -> [a] -> [a]
++ [(Id, CoreExpr)]
spec_defns1, UsageDetails
uds2) }
; let (UsageDetails
final_uds, Bag DictBind
dumped_dbs, Bool
float_all) = [Id] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)
dumpBindUDs [Id]
bndrs UsageDetails
uds3
final_bind :: DictBind
final_bind = [(Id, CoreExpr)] -> Bag DictBind -> DictBind
recWithDumpedDicts ([(Id, CoreExpr)]
spec_defns3 forall a. [a] -> [a] -> [a]
++ forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs3 [CoreExpr]
rhss')
Bag DictBind
dumped_dbs
; if Bool
float_all then
forall (m :: * -> *) a. Monad m => a -> m a
return ([], UsageDetails
final_uds UsageDetails -> DictBind -> UsageDetails
`snocDictBind` DictBind
final_bind)
else
forall (m :: * -> *) a. Monad m => a -> m a
return ([DictBind -> CoreBind
db_bind DictBind
final_bind], UsageDetails
final_uds) }
specDefns :: SpecEnv
-> UsageDetails
-> [(OutId,InExpr)]
-> SpecM ([OutId],
[(OutId,OutExpr)],
UsageDetails)
specDefns :: SpecEnv
-> UsageDetails
-> [(Id, CoreExpr)]
-> SpecM ([Id], [(Id, CoreExpr)], UsageDetails)
specDefns SpecEnv
_env UsageDetails
uds []
= forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], UsageDetails
uds)
specDefns SpecEnv
env UsageDetails
uds ((Id
bndr,CoreExpr
rhs):[(Id, CoreExpr)]
pairs)
= do { ([Id]
bndrs1, [(Id, CoreExpr)]
spec_defns1, UsageDetails
uds1) <- SpecEnv
-> UsageDetails
-> [(Id, CoreExpr)]
-> SpecM ([Id], [(Id, CoreExpr)], UsageDetails)
specDefns SpecEnv
env UsageDetails
uds [(Id, CoreExpr)]
pairs
; (Id
bndr1, [(Id, CoreExpr)]
spec_defns2, UsageDetails
uds2) <- SpecEnv
-> UsageDetails
-> Id
-> CoreExpr
-> SpecM (Id, [(Id, CoreExpr)], UsageDetails)
specDefn SpecEnv
env UsageDetails
uds1 Id
bndr CoreExpr
rhs
; forall (m :: * -> *) a. Monad m => a -> m a
return (Id
bndr1 forall a. a -> [a] -> [a]
: [Id]
bndrs1, [(Id, CoreExpr)]
spec_defns1 forall a. [a] -> [a] -> [a]
++ [(Id, CoreExpr)]
spec_defns2, UsageDetails
uds2) }
specDefn :: SpecEnv
-> UsageDetails
-> OutId -> InExpr
-> SpecM (Id,
[(Id,CoreExpr)],
UsageDetails)
specDefn :: SpecEnv
-> UsageDetails
-> Id
-> CoreExpr
-> SpecM (Id, [(Id, CoreExpr)], UsageDetails)
specDefn SpecEnv
env UsageDetails
body_uds Id
fn CoreExpr
rhs
= do { let (UsageDetails
body_uds_without_me, [CallInfo]
calls_for_me) = Id -> UsageDetails -> (UsageDetails, [CallInfo])
callsForMe Id
fn UsageDetails
body_uds
rules_for_me :: [CoreRule]
rules_for_me = Id -> [CoreRule]
idCoreRules Id
fn
; ([CoreRule]
rules, [(Id, CoreExpr)]
spec_defns, UsageDetails
spec_uds) <- Bool
-> SpecEnv
-> [CoreRule]
-> [CallInfo]
-> Id
-> CoreExpr
-> SpecM ([CoreRule], [(Id, CoreExpr)], UsageDetails)
specCalls Bool
False SpecEnv
env [CoreRule]
rules_for_me
[CallInfo]
calls_for_me Id
fn CoreExpr
rhs
; forall (m :: * -> *) a. Monad m => a -> m a
return ( Id
fn Id -> [CoreRule] -> Id
`addIdSpecialisations` [CoreRule]
rules
, [(Id, CoreExpr)]
spec_defns
, UsageDetails
body_uds_without_me UsageDetails -> UsageDetails -> UsageDetails
`plusUDs` UsageDetails
spec_uds) }
specCalls :: Bool
-> SpecEnv
-> [CoreRule]
-> [CallInfo]
-> OutId -> InExpr
-> SpecM SpecInfo
type SpecInfo = ( [CoreRule]
, [(Id,CoreExpr)]
, UsageDetails )
specCalls :: Bool
-> SpecEnv
-> [CoreRule]
-> [CallInfo]
-> Id
-> CoreExpr
-> SpecM ([CoreRule], [(Id, CoreExpr)], UsageDetails)
specCalls Bool
spec_imp SpecEnv
env [CoreRule]
existing_rules [CallInfo]
calls_for_me Id
fn CoreExpr
rhs
| forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [CallInfo]
calls_for_me
Bool -> Bool -> Bool
&& Bool -> Bool
not (Activation -> Bool
isNeverActive (Id -> Activation
idInlineActivation Id
fn))
=
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ([CoreRule], [(Id, CoreExpr)], UsageDetails)
-> CallInfo -> SpecM ([CoreRule], [(Id, CoreExpr)], UsageDetails)
spec_call ([], [], UsageDetails
emptyUDs) [CallInfo]
calls_for_me
| Bool
otherwise
= WARN( not (exprIsTrivial rhs) && notNull calls_for_me,
text "Missed specialisation opportunity for"
<+> ppr fn $$ _trace_doc )
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], UsageDetails
emptyUDs)
where
_trace_doc :: SDoc
_trace_doc = [SDoc] -> SDoc
sep [ forall a. Outputable a => a -> SDoc
ppr [Id]
rhs_bndrs, forall a. Outputable a => a -> SDoc
ppr (Id -> Activation
idInlineActivation Id
fn) ]
fn_type :: Kind
fn_type = Id -> Kind
idType Id
fn
fn_arity :: Int
fn_arity = Id -> Int
idArity Id
fn
fn_unf :: Unfolding
fn_unf = Id -> Unfolding
realIdUnfolding Id
fn
inl_prag :: InlinePragma
inl_prag = Id -> InlinePragma
idInlinePragma Id
fn
inl_act :: Activation
inl_act = InlinePragma -> Activation
inlinePragmaActivation InlinePragma
inl_prag
is_local :: Bool
is_local = Id -> Bool
isLocalId Id
fn
is_dfun :: Bool
is_dfun = Id -> Bool
isDFunId Id
fn
dflags :: DynFlags
dflags = SpecEnv -> DynFlags
se_dflags SpecEnv
env
ropts :: RuleOpts
ropts = DynFlags -> RuleOpts
initRuleOpts DynFlags
dflags
this_mod :: Module
this_mod = SpecEnv -> Module
se_module SpecEnv
env
([Id]
rhs_bndrs, CoreExpr
rhs_body) = CoreExpr -> ([Id], CoreExpr)
collectBindersPushingCo CoreExpr
rhs
in_scope :: InScopeSet
in_scope = Subst -> InScopeSet
Core.substInScope (SpecEnv -> Subst
se_subst SpecEnv
env)
already_covered :: RuleOpts -> [CoreRule] -> [CoreExpr] -> Bool
already_covered :: RuleOpts -> [CoreRule] -> [CoreExpr] -> Bool
already_covered RuleOpts
ropts [CoreRule]
new_rules [CoreExpr]
args
= forall a. Maybe a -> Bool
isJust (RuleOpts
-> InScopeEnv
-> (Activation -> Bool)
-> Id
-> [CoreExpr]
-> [CoreRule]
-> Maybe (CoreRule, CoreExpr)
lookupRule RuleOpts
ropts (InScopeSet
in_scope, Id -> Unfolding
realIdUnfolding)
(forall a b. a -> b -> a
const Bool
True) Id
fn [CoreExpr]
args
([CoreRule]
new_rules forall a. [a] -> [a] -> [a]
++ [CoreRule]
existing_rules))
spec_call :: SpecInfo
-> CallInfo
-> SpecM SpecInfo
spec_call :: ([CoreRule], [(Id, CoreExpr)], UsageDetails)
-> CallInfo -> SpecM ([CoreRule], [(Id, CoreExpr)], UsageDetails)
spec_call spec_acc :: ([CoreRule], [(Id, CoreExpr)], UsageDetails)
spec_acc@([CoreRule]
rules_acc, [(Id, CoreExpr)]
pairs_acc, UsageDetails
uds_acc) _ci :: CallInfo
_ci@(CI { ci_key :: CallInfo -> [SpecArg]
ci_key = [SpecArg]
call_args })
=
do { let all_call_args :: [SpecArg]
all_call_args | Bool
is_dfun = [SpecArg]
call_args forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat SpecArg
UnspecArg
| Bool
otherwise = [SpecArg]
call_args
; ( Bool
useful, SpecEnv
rhs_env2, [Id]
leftover_bndrs
, [Id]
rule_bndrs, [CoreExpr]
rule_lhs_args
, [Id]
spec_bndrs1, [DictBind]
dx_binds, [CoreExpr]
spec_args) <- SpecEnv
-> [Id]
-> [SpecArg]
-> SpecM
(Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
specHeader SpecEnv
env [Id]
rhs_bndrs [SpecArg]
all_call_args
; if Bool -> Bool
not Bool
useful
Bool -> Bool -> Bool
|| RuleOpts -> [CoreRule] -> [CoreExpr] -> Bool
already_covered RuleOpts
ropts [CoreRule]
rules_acc [CoreExpr]
rule_lhs_args
then forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreRule], [(Id, CoreExpr)], UsageDetails)
spec_acc
else
do {
; (CoreExpr
spec_rhs1, UsageDetails
rhs_uds) <- SpecEnv -> [Id] -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specLam SpecEnv
rhs_env2 ([Id]
spec_bndrs1 forall a. [a] -> [a] -> [a]
++ [Id]
leftover_bndrs) CoreExpr
rhs_body
; let spec_fn_ty1 :: Kind
spec_fn_ty1 = CoreExpr -> Kind
exprType CoreExpr
spec_rhs1
add_void_arg :: Bool
add_void_arg = HasDebugCallStack => Kind -> Bool
isUnliftedType Kind
spec_fn_ty1 Bool -> Bool -> Bool
&& Bool -> Bool
not (Id -> Bool
isJoinId Id
fn)
([Id]
spec_bndrs, CoreExpr
spec_rhs, Kind
spec_fn_ty)
| Bool
add_void_arg = ( Id
voidPrimId forall a. a -> [a] -> [a]
: [Id]
spec_bndrs1
, forall b. b -> Expr b -> Expr b
Lam Id
voidArgId CoreExpr
spec_rhs1
, Kind -> Kind -> Kind
mkVisFunTyMany Kind
unboxedUnitTy Kind
spec_fn_ty1)
| Bool
otherwise = ([Id]
spec_bndrs1, CoreExpr
spec_rhs1, Kind
spec_fn_ty1)
join_arity_decr :: Int
join_arity_decr = forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
rule_lhs_args forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
spec_bndrs
spec_join_arity :: Maybe Int
spec_join_arity | Just Int
orig_join_arity <- Id -> Maybe Int
isJoinId_maybe Id
fn
= forall a. a -> Maybe a
Just (Int
orig_join_arity forall a. Num a => a -> a -> a
- Int
join_arity_decr)
| Bool
otherwise
= forall a. Maybe a
Nothing
; Id
spec_fn <- Id -> Kind -> Maybe Int -> SpecM Id
newSpecIdSM Id
fn Kind
spec_fn_ty Maybe Int
spec_join_arity
; let
herald :: SDoc
herald | Bool
spec_imp =
String -> SDoc
text String
"SPEC/" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Module
this_mod
| Bool
otherwise =
String -> SDoc
text String
"SPEC"
rule_name :: FastString
rule_name = String -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags forall a b. (a -> b) -> a -> b
$
SDoc
herald SDoc -> SDoc -> SDoc
<+> FastString -> SDoc
ftext (OccName -> FastString
occNameFS (forall a. NamedThing a => a -> OccName
getOccName Id
fn))
SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
hsep (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SpecArg -> Maybe SDoc
ppr_call_key_ty [SpecArg]
call_args)
rule_wout_eta :: CoreRule
rule_wout_eta = Module
-> Bool
-> Bool
-> FastString
-> Activation
-> Name
-> [Id]
-> [CoreExpr]
-> CoreExpr
-> CoreRule
mkRule
Module
this_mod
Bool
True
Bool
is_local
FastString
rule_name
Activation
inl_act
(Id -> Name
idName Id
fn)
[Id]
rule_bndrs
[CoreExpr]
rule_lhs_args
(forall b. Expr b -> [Id] -> Expr b
mkVarApps (forall b. Id -> Expr b
Var Id
spec_fn) [Id]
spec_bndrs)
spec_rule :: CoreRule
spec_rule
= case Id -> Maybe Int
isJoinId_maybe Id
fn of
Just Int
join_arity -> Int -> CoreRule -> CoreRule
etaExpandToJoinPointRule Int
join_arity CoreRule
rule_wout_eta
Maybe Int
Nothing -> CoreRule
rule_wout_eta
spec_uds :: UsageDetails
spec_uds = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DictBind -> UsageDetails -> UsageDetails
consDictBind UsageDetails
rhs_uds [DictBind]
dx_binds
simpl_opts :: SimpleOpts
simpl_opts = DynFlags -> SimpleOpts
initSimpleOpts DynFlags
dflags
(InlinePragma
spec_inl_prag, Unfolding
spec_unf)
| Bool -> Bool
not Bool
is_local Bool -> Bool -> Bool
&& OccInfo -> Bool
isStrongLoopBreaker (Id -> OccInfo
idOccInfo Id
fn)
= (InlinePragma
neverInlinePragma, Unfolding
noUnfolding)
| InlinePragma { inl_inline :: InlinePragma -> InlineSpec
inl_inline = InlineSpec
Inlinable } <- InlinePragma
inl_prag
= (InlinePragma
inl_prag { inl_inline :: InlineSpec
inl_inline = InlineSpec
NoUserInlinePrag }, Unfolding
noUnfolding)
| Bool
otherwise
= (InlinePragma
inl_prag, SimpleOpts
-> [Id]
-> (CoreExpr -> CoreExpr)
-> [CoreExpr]
-> Unfolding
-> Unfolding
specUnfolding SimpleOpts
simpl_opts [Id]
spec_bndrs (forall b. Expr b -> [Expr b] -> Expr b
`mkApps` [CoreExpr]
spec_args)
[CoreExpr]
rule_lhs_args Unfolding
fn_unf)
arity_decr :: Int
arity_decr = forall a. (a -> Bool) -> [a] -> Int
count forall b. Expr b -> Bool
isValArg [CoreExpr]
rule_lhs_args forall a. Num a => a -> a -> a
- forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
spec_bndrs
spec_f_w_arity :: Id
spec_f_w_arity = Id
spec_fn Id -> Int -> Id
`setIdArity` forall a. Ord a => a -> a -> a
max Int
0 (Int
fn_arity forall a. Num a => a -> a -> a
- Int
arity_decr)
Id -> InlinePragma -> Id
`setInlinePragma` InlinePragma
spec_inl_prag
Id -> Unfolding -> Id
`setIdUnfolding` Unfolding
spec_unf
Id -> Maybe Int -> Id
`asJoinId_maybe` Maybe Int
spec_join_arity
_rule_trace_doc :: SDoc
_rule_trace_doc = [SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr Id
fn SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Kind
fn_type
, forall a. Outputable a => a -> SDoc
ppr Id
spec_fn SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Kind
spec_fn_ty
, forall a. Outputable a => a -> SDoc
ppr [Id]
rhs_bndrs, forall a. Outputable a => a -> SDoc
ppr [SpecArg]
call_args
, forall a. Outputable a => a -> SDoc
ppr CoreRule
spec_rule
]
;
forall (m :: * -> *) a. Monad m => a -> m a
return ( CoreRule
spec_rule forall a. a -> [a] -> [a]
: [CoreRule]
rules_acc
, (Id
spec_f_w_arity, CoreExpr
spec_rhs) forall a. a -> [a] -> [a]
: [(Id, CoreExpr)]
pairs_acc
, UsageDetails
spec_uds UsageDetails -> UsageDetails -> UsageDetails
`plusUDs` UsageDetails
uds_acc
) } }
data SpecArg
=
SpecType Type
| UnspecType
| SpecDict DictExpr
| UnspecArg
instance Outputable SpecArg where
ppr :: SpecArg -> SDoc
ppr (SpecType Kind
t) = String -> SDoc
text String
"SpecType" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Kind
t
ppr SpecArg
UnspecType = String -> SDoc
text String
"UnspecType"
ppr (SpecDict CoreExpr
d) = String -> SDoc
text String
"SpecDict" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr CoreExpr
d
ppr SpecArg
UnspecArg = String -> SDoc
text String
"UnspecArg"
specArgFreeVars :: SpecArg -> VarSet
specArgFreeVars :: SpecArg -> VarSet
specArgFreeVars (SpecType Kind
ty) = Kind -> VarSet
tyCoVarsOfType Kind
ty
specArgFreeVars (SpecDict CoreExpr
dx) = CoreExpr -> VarSet
exprFreeVars CoreExpr
dx
specArgFreeVars SpecArg
UnspecType = VarSet
emptyVarSet
specArgFreeVars SpecArg
UnspecArg = VarSet
emptyVarSet
isSpecDict :: SpecArg -> Bool
isSpecDict :: SpecArg -> Bool
isSpecDict (SpecDict {}) = Bool
True
isSpecDict SpecArg
_ = Bool
False
specHeader
:: SpecEnv
-> [InBndr]
-> [SpecArg]
-> SpecM ( Bool
, SpecEnv
, [OutBndr]
, [OutBndr]
, [OutExpr]
, [OutBndr]
, [DictBind]
, [OutExpr]
)
SpecEnv
env (Id
bndr : [Id]
bndrs) (SpecType Kind
t : [SpecArg]
args)
= do { let env' :: SpecEnv
env' = SpecEnv -> [(Id, Kind)] -> SpecEnv
extendTvSubstList SpecEnv
env [(Id
bndr, Kind
t)]
; (Bool
useful, SpecEnv
env'', [Id]
leftover_bndrs, [Id]
rule_bs, [CoreExpr]
rule_es, [Id]
bs', [DictBind]
dx, [CoreExpr]
spec_args)
<- SpecEnv
-> [Id]
-> [SpecArg]
-> SpecM
(Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
specHeader SpecEnv
env' [Id]
bndrs [SpecArg]
args
; forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Bool
useful
, SpecEnv
env''
, [Id]
leftover_bndrs
, [Id]
rule_bs
, forall b. Kind -> Expr b
Type Kind
t forall a. a -> [a] -> [a]
: [CoreExpr]
rule_es
, [Id]
bs'
, [DictBind]
dx
, forall b. Kind -> Expr b
Type Kind
t forall a. a -> [a] -> [a]
: [CoreExpr]
spec_args
)
}
specHeader SpecEnv
env (Id
bndr : [Id]
bndrs) (SpecArg
UnspecType : [SpecArg]
args)
= do { let (SpecEnv
env', Id
bndr') = SpecEnv -> Id -> (SpecEnv, Id)
substBndr SpecEnv
env Id
bndr
; (Bool
useful, SpecEnv
env'', [Id]
leftover_bndrs, [Id]
rule_bs, [CoreExpr]
rule_es, [Id]
bs', [DictBind]
dx, [CoreExpr]
spec_args)
<- SpecEnv
-> [Id]
-> [SpecArg]
-> SpecM
(Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
specHeader SpecEnv
env' [Id]
bndrs [SpecArg]
args
; forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Bool
useful
, SpecEnv
env''
, [Id]
leftover_bndrs
, Id
bndr' forall a. a -> [a] -> [a]
: [Id]
rule_bs
, forall b. Id -> Expr b
varToCoreExpr Id
bndr' forall a. a -> [a] -> [a]
: [CoreExpr]
rule_es
, Id
bndr' forall a. a -> [a] -> [a]
: [Id]
bs'
, [DictBind]
dx
, forall b. Id -> Expr b
varToCoreExpr Id
bndr' forall a. a -> [a] -> [a]
: [CoreExpr]
spec_args
)
}
specHeader SpecEnv
env (Id
bndr : [Id]
bndrs) (SpecDict CoreExpr
d : [SpecArg]
args)
= do { Id
bndr' <- SpecEnv -> Id -> SpecM Id
newDictBndr SpecEnv
env Id
bndr
; let (SpecEnv
env', Maybe DictBind
dx_bind, CoreExpr
spec_dict) = SpecEnv
-> Id -> Id -> CoreExpr -> (SpecEnv, Maybe DictBind, CoreExpr)
bindAuxiliaryDict SpecEnv
env Id
bndr Id
bndr' CoreExpr
d
; (Bool
_, SpecEnv
env'', [Id]
leftover_bndrs, [Id]
rule_bs, [CoreExpr]
rule_es, [Id]
bs', [DictBind]
dx, [CoreExpr]
spec_args)
<- SpecEnv
-> [Id]
-> [SpecArg]
-> SpecM
(Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
specHeader SpecEnv
env' [Id]
bndrs [SpecArg]
args
; forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Bool
True
, SpecEnv
env''
, [Id]
leftover_bndrs
, CoreExpr -> [Id]
exprFreeIdsList (forall b. Id -> Expr b
varToCoreExpr Id
bndr') forall a. [a] -> [a] -> [a]
++ [Id]
rule_bs
, forall b. Id -> Expr b
varToCoreExpr Id
bndr' forall a. a -> [a] -> [a]
: [CoreExpr]
rule_es
, [Id]
bs'
, forall a. Maybe a -> [a]
maybeToList Maybe DictBind
dx_bind forall a. [a] -> [a] -> [a]
++ [DictBind]
dx
, CoreExpr
spec_dict forall a. a -> [a] -> [a]
: [CoreExpr]
spec_args
)
}
specHeader SpecEnv
env (Id
bndr : [Id]
bndrs) (SpecArg
UnspecArg : [SpecArg]
args)
= do {
let (SpecEnv
env', Id
bndr') = SpecEnv -> Id -> (SpecEnv, Id)
substBndr SpecEnv
env (Id -> Id
zapIdOccInfo Id
bndr)
; (Bool
useful, SpecEnv
env'', [Id]
leftover_bndrs, [Id]
rule_bs, [CoreExpr]
rule_es, [Id]
bs', [DictBind]
dx, [CoreExpr]
spec_args)
<- SpecEnv
-> [Id]
-> [SpecArg]
-> SpecM
(Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
specHeader SpecEnv
env' [Id]
bndrs [SpecArg]
args
; forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Bool
useful
, SpecEnv
env''
, [Id]
leftover_bndrs
, Id
bndr' forall a. a -> [a] -> [a]
: [Id]
rule_bs
, forall b. Id -> Expr b
varToCoreExpr Id
bndr' forall a. a -> [a] -> [a]
: [CoreExpr]
rule_es
, if Id -> Bool
isDeadBinder Id
bndr
then [Id]
bs'
else Id
bndr' forall a. a -> [a] -> [a]
: [Id]
bs'
, [DictBind]
dx
, forall b. Id -> Expr b
varToCoreExpr Id
bndr' forall a. a -> [a] -> [a]
: [CoreExpr]
spec_args
)
}
specHeader SpecEnv
env [] [SpecArg]
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, SpecEnv
env, [], [], [], [], [], [])
specHeader SpecEnv
env [Id]
bndrs []
= forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, SpecEnv
env', [Id]
bndrs', [], [], [], [], [])
where
(SpecEnv
env', [Id]
bndrs') = SpecEnv -> [Id] -> (SpecEnv, [Id])
substBndrs SpecEnv
env [Id]
bndrs
bindAuxiliaryDict
:: SpecEnv
-> InId -> OutId -> OutExpr
-> ( SpecEnv
, Maybe DictBind
, OutExpr)
bindAuxiliaryDict :: SpecEnv
-> Id -> Id -> CoreExpr -> (SpecEnv, Maybe DictBind, CoreExpr)
bindAuxiliaryDict env :: SpecEnv
env@(SE { se_subst :: SpecEnv -> Subst
se_subst = Subst
subst, se_interesting :: SpecEnv -> VarSet
se_interesting = VarSet
interesting })
Id
orig_dict_id Id
fresh_dict_id CoreExpr
dict_expr
| Just Id
dict_id <- CoreExpr -> Maybe Id
getIdFromTrivialExpr_maybe CoreExpr
dict_expr
= let env' :: SpecEnv
env' = SpecEnv
env { se_subst :: Subst
se_subst = Subst -> Id -> CoreExpr -> Subst
Core.extendSubst Subst
subst Id
orig_dict_id CoreExpr
dict_expr
Subst -> Id -> Subst
`Core.extendInScope` Id
dict_id
, se_interesting :: VarSet
se_interesting = VarSet
interesting VarSet -> Id -> VarSet
`extendVarSet` Id
dict_id }
in (SpecEnv
env', forall a. Maybe a
Nothing, CoreExpr
dict_expr)
| Bool
otherwise
= let dict_bind :: DictBind
dict_bind = CoreBind -> DictBind
mkDB (forall b. b -> Expr b -> Bind b
NonRec Id
fresh_dict_id CoreExpr
dict_expr)
env' :: SpecEnv
env' = SpecEnv
env { se_subst :: Subst
se_subst = Subst -> Id -> CoreExpr -> Subst
Core.extendSubst Subst
subst Id
orig_dict_id (forall b. Id -> Expr b
Var Id
fresh_dict_id)
Subst -> Id -> Subst
`Core.extendInScope` Id
fresh_dict_id
, se_interesting :: VarSet
se_interesting = VarSet
interesting VarSet -> Id -> VarSet
`extendVarSet` Id
fresh_dict_id }
in (SpecEnv
env', forall a. a -> Maybe a
Just DictBind
dict_bind, forall b. Id -> Expr b
Var Id
fresh_dict_id)
data UsageDetails
= MkUD {
UsageDetails -> Bag DictBind
ud_binds :: !(Bag DictBind),
UsageDetails -> CallDetails
ud_calls :: !CallDetails
}
data DictBind = DB { DictBind -> CoreBind
db_bind :: CoreBind, DictBind -> VarSet
db_fvs :: VarSet }
instance Outputable DictBind where
ppr :: DictBind -> SDoc
ppr (DB { db_bind :: DictBind -> CoreBind
db_bind = CoreBind
bind, db_fvs :: DictBind -> VarSet
db_fvs = VarSet
fvs })
= String -> SDoc
text String
"DB" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
sep [ String -> SDoc
text String
"bind:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr CoreBind
bind
, String -> SDoc
text String
"fvs: " SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr VarSet
fvs ])
instance Outputable UsageDetails where
ppr :: UsageDetails -> SDoc
ppr (MkUD { ud_binds :: UsageDetails -> Bag DictBind
ud_binds = Bag DictBind
dbs, ud_calls :: UsageDetails -> CallDetails
ud_calls = CallDetails
calls })
= String -> SDoc
text String
"MkUD" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces ([SDoc] -> SDoc
sep (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
[String -> SDoc
text String
"binds" SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Bag DictBind
dbs,
String -> SDoc
text String
"calls" SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr CallDetails
calls]))
emptyUDs :: UsageDetails
emptyUDs :: UsageDetails
emptyUDs = MkUD { ud_binds :: Bag DictBind
ud_binds = forall a. Bag a
emptyBag, ud_calls :: CallDetails
ud_calls = forall a. DVarEnv a
emptyDVarEnv }
type CallDetails = DIdEnv CallInfoSet
data CallInfoSet = CIS Id (Bag CallInfo)
data CallInfo
= CI { CallInfo -> [SpecArg]
ci_key :: [SpecArg]
, CallInfo -> VarSet
ci_fvs :: VarSet
}
type DictExpr = CoreExpr
ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet
ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet
ciSetFilter CallInfo -> Bool
p (CIS Id
id Bag CallInfo
a) = Id -> Bag CallInfo -> CallInfoSet
CIS Id
id (forall a. (a -> Bool) -> Bag a -> Bag a
filterBag CallInfo -> Bool
p Bag CallInfo
a)
instance Outputable CallInfoSet where
ppr :: CallInfoSet -> SDoc
ppr (CIS Id
fn Bag CallInfo
map) = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"CIS" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Id
fn)
Int
2 (forall a. Outputable a => a -> SDoc
ppr Bag CallInfo
map)
pprCallInfo :: Id -> CallInfo -> SDoc
pprCallInfo :: Id -> CallInfo -> SDoc
pprCallInfo Id
fn (CI { ci_key :: CallInfo -> [SpecArg]
ci_key = [SpecArg]
key })
= forall a. Outputable a => a -> SDoc
ppr Id
fn SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [SpecArg]
key
ppr_call_key_ty :: SpecArg -> Maybe SDoc
ppr_call_key_ty :: SpecArg -> Maybe SDoc
ppr_call_key_ty (SpecType Kind
ty) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Char -> SDoc
char Char
'@' SDoc -> SDoc -> SDoc
<> Kind -> SDoc
pprParendType Kind
ty
ppr_call_key_ty SpecArg
UnspecType = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Char -> SDoc
char Char
'_'
ppr_call_key_ty (SpecDict CoreExpr
_) = forall a. Maybe a
Nothing
ppr_call_key_ty SpecArg
UnspecArg = forall a. Maybe a
Nothing
instance Outputable CallInfo where
ppr :: CallInfo -> SDoc
ppr (CI { ci_key :: CallInfo -> [SpecArg]
ci_key = [SpecArg]
key, ci_fvs :: CallInfo -> VarSet
ci_fvs = VarSet
_fvs })
= String -> SDoc
text String
"CI" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces ([SDoc] -> SDoc
sep (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr [SpecArg]
key))
unionCalls :: CallDetails -> CallDetails -> CallDetails
unionCalls :: CallDetails -> CallDetails -> CallDetails
unionCalls CallDetails
c1 CallDetails
c2 = forall a. (a -> a -> a) -> DVarEnv a -> DVarEnv a -> DVarEnv a
plusDVarEnv_C CallInfoSet -> CallInfoSet -> CallInfoSet
unionCallInfoSet CallDetails
c1 CallDetails
c2
unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet
unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet
unionCallInfoSet (CIS Id
f Bag CallInfo
calls1) (CIS Id
_ Bag CallInfo
calls2) =
Id -> Bag CallInfo -> CallInfoSet
CIS Id
f (Bag CallInfo
calls1 forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag CallInfo
calls2)
callDetailsFVs :: CallDetails -> VarSet
callDetailsFVs :: CallDetails -> VarSet
callDetailsFVs CallDetails
calls =
forall elt a key. (elt -> a -> a) -> a -> UniqDFM key elt -> a
nonDetStrictFoldUDFM (VarSet -> VarSet -> VarSet
unionVarSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallInfoSet -> VarSet
callInfoFVs) VarSet
emptyVarSet CallDetails
calls
callInfoFVs :: CallInfoSet -> VarSet
callInfoFVs :: CallInfoSet -> VarSet
callInfoFVs (CIS Id
_ Bag CallInfo
call_info) =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(CI { ci_fvs :: CallInfo -> VarSet
ci_fvs = VarSet
fv }) VarSet
vs -> VarSet -> VarSet -> VarSet
unionVarSet VarSet
fv VarSet
vs) VarSet
emptyVarSet Bag CallInfo
call_info
getTheta :: [TyCoBinder] -> [PredType]
getTheta :: [TyCoBinder] -> [Kind]
getTheta = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyCoBinder -> Kind
tyBinderType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter TyCoBinder -> Bool
isInvisibleBinder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCoBinder -> Bool
isNamedBinder)
singleCall :: Id -> [SpecArg] -> UsageDetails
singleCall :: Id -> [SpecArg] -> UsageDetails
singleCall Id
id [SpecArg]
args
= MkUD {ud_binds :: Bag DictBind
ud_binds = forall a. Bag a
emptyBag,
ud_calls :: CallDetails
ud_calls = forall a. Id -> a -> DVarEnv a
unitDVarEnv Id
id forall a b. (a -> b) -> a -> b
$ Id -> Bag CallInfo -> CallInfoSet
CIS Id
id forall a b. (a -> b) -> a -> b
$
forall a. a -> Bag a
unitBag (CI { ci_key :: [SpecArg]
ci_key = [SpecArg]
args
, ci_fvs :: VarSet
ci_fvs = VarSet
call_fvs }) }
where
call_fvs :: VarSet
call_fvs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (VarSet -> VarSet -> VarSet
unionVarSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecArg -> VarSet
specArgFreeVars) VarSet
emptyVarSet [SpecArg]
args
mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails
mkCallUDs :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails
mkCallUDs SpecEnv
env Id
f [CoreExpr]
args
=
UsageDetails
res
where
res :: UsageDetails
res = SpecEnv -> Id -> [CoreExpr] -> UsageDetails
mkCallUDs' SpecEnv
env Id
f [CoreExpr]
args
mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails
mkCallUDs' SpecEnv
env Id
f [CoreExpr]
args
| SpecEnv -> Id -> Bool
wantCallsFor SpecEnv
env Id
f
, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SpecArg]
ci_key)
=
Id -> [SpecArg] -> UsageDetails
singleCall Id
f [SpecArg]
ci_key
| Bool
otherwise
=
UsageDetails
emptyUDs
where
_trace_doc :: SDoc
_trace_doc = [SDoc] -> SDoc
vcat [forall a. Outputable a => a -> SDoc
ppr Id
f, forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args, forall a. Outputable a => a -> SDoc
ppr [SpecArg]
ci_key]
pis :: [TyCoBinder]
pis = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Kind -> ([TyCoBinder], Kind)
splitPiTys forall a b. (a -> b) -> a -> b
$ Id -> Kind
idType Id
f
constrained_tyvars :: VarSet
constrained_tyvars = [Kind] -> VarSet
tyCoVarsOfTypes forall a b. (a -> b) -> a -> b
$ [TyCoBinder] -> [Kind]
getTheta [TyCoBinder]
pis
ci_key :: [SpecArg]
ci_key :: [SpecArg]
ci_key = forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecArg -> Bool
isSpecDict) forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith CoreExpr -> TyCoBinder -> SpecArg
mk_spec_arg [CoreExpr]
args [TyCoBinder]
pis
mk_spec_arg :: CoreExpr -> TyCoBinder -> SpecArg
mk_spec_arg :: CoreExpr -> TyCoBinder -> SpecArg
mk_spec_arg CoreExpr
arg (Named TyCoVarBinder
bndr)
| forall tv argf. VarBndr tv argf -> tv
binderVar TyCoVarBinder
bndr Id -> VarSet -> Bool
`elemVarSet` VarSet
constrained_tyvars
= case CoreExpr
arg of
Type Kind
ty -> Kind -> SpecArg
SpecType Kind
ty
CoreExpr
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"ci_key" forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr CoreExpr
arg
| Bool
otherwise = SpecArg
UnspecType
mk_spec_arg CoreExpr
arg (Anon AnonArgFlag
InvisArg Scaled Kind
pred)
| Bool -> Bool
not (Kind -> Bool
isIPLikePred (forall a. Scaled a -> a
scaledThing Scaled Kind
pred))
, SpecEnv -> CoreExpr -> Bool
interestingDict SpecEnv
env CoreExpr
arg
= CoreExpr -> SpecArg
SpecDict CoreExpr
arg
| Bool
otherwise = SpecArg
UnspecArg
mk_spec_arg CoreExpr
_ (Anon AnonArgFlag
VisArg Scaled Kind
_)
= SpecArg
UnspecArg
wantCallsFor :: SpecEnv -> Id -> Bool
wantCallsFor :: SpecEnv -> Id -> Bool
wantCallsFor SpecEnv
_env Id
_f = Bool
True
interestingDict :: SpecEnv -> CoreExpr -> Bool
interestingDict :: SpecEnv -> CoreExpr -> Bool
interestingDict SpecEnv
env (Var Id
v) = Unfolding -> Bool
hasSomeUnfolding (Id -> Unfolding
idUnfolding Id
v)
Bool -> Bool -> Bool
|| Id -> Bool
isDataConWorkId Id
v
Bool -> Bool -> Bool
|| Id
v Id -> VarSet -> Bool
`elemVarSet` SpecEnv -> VarSet
se_interesting SpecEnv
env
interestingDict SpecEnv
_ (Type Kind
_) = Bool
False
interestingDict SpecEnv
_ (Coercion Coercion
_) = Bool
False
interestingDict SpecEnv
env (App CoreExpr
fn (Type Kind
_)) = SpecEnv -> CoreExpr -> Bool
interestingDict SpecEnv
env CoreExpr
fn
interestingDict SpecEnv
env (App CoreExpr
fn (Coercion Coercion
_)) = SpecEnv -> CoreExpr -> Bool
interestingDict SpecEnv
env CoreExpr
fn
interestingDict SpecEnv
env (Tick CoreTickish
_ CoreExpr
a) = SpecEnv -> CoreExpr -> Bool
interestingDict SpecEnv
env CoreExpr
a
interestingDict SpecEnv
env (Cast CoreExpr
e Coercion
_) = SpecEnv -> CoreExpr -> Bool
interestingDict SpecEnv
env CoreExpr
e
interestingDict SpecEnv
_ CoreExpr
_ = Bool
True
plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
plusUDs (MkUD {ud_binds :: UsageDetails -> Bag DictBind
ud_binds = Bag DictBind
db1, ud_calls :: UsageDetails -> CallDetails
ud_calls = CallDetails
calls1})
(MkUD {ud_binds :: UsageDetails -> Bag DictBind
ud_binds = Bag DictBind
db2, ud_calls :: UsageDetails -> CallDetails
ud_calls = CallDetails
calls2})
= MkUD { ud_binds :: Bag DictBind
ud_binds = Bag DictBind
db1 forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag DictBind
db2
, ud_calls :: CallDetails
ud_calls = CallDetails
calls1 CallDetails -> CallDetails -> CallDetails
`unionCalls` CallDetails
calls2 }
_dictBindBndrs :: Bag DictBind -> [Id]
_dictBindBndrs :: Bag DictBind -> [Id]
_dictBindBndrs Bag DictBind
dbs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. [a] -> [a] -> [a]
(++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Bind b -> [b]
bindersOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. DictBind -> CoreBind
db_bind) [] Bag DictBind
dbs
mkDB :: CoreBind -> DictBind
mkDB :: CoreBind -> DictBind
mkDB CoreBind
bind = DB { db_bind :: CoreBind
db_bind = CoreBind
bind, db_fvs :: VarSet
db_fvs = CoreBind -> VarSet
bind_fvs CoreBind
bind }
bind_fvs :: CoreBind -> VarSet
bind_fvs :: CoreBind -> VarSet
bind_fvs (NonRec Id
bndr CoreExpr
rhs) = (Id, CoreExpr) -> VarSet
pair_fvs (Id
bndr,CoreExpr
rhs)
bind_fvs (Rec [(Id, CoreExpr)]
prs) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' VarSet -> Id -> VarSet
delVarSet VarSet
rhs_fvs [Id]
bndrs
where
bndrs :: [Id]
bndrs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
prs
rhs_fvs :: VarSet
rhs_fvs = [VarSet] -> VarSet
unionVarSets (forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> VarSet
pair_fvs [(Id, CoreExpr)]
prs)
pair_fvs :: (Id, CoreExpr) -> VarSet
pair_fvs :: (Id, CoreExpr) -> VarSet
pair_fvs (Id
bndr, CoreExpr
rhs) = (Id -> Bool) -> CoreExpr -> VarSet
exprSomeFreeVars Id -> Bool
interesting CoreExpr
rhs
VarSet -> VarSet -> VarSet
`unionVarSet` Id -> VarSet
idFreeVars Id
bndr
where
interesting :: InterestingVarFun
interesting :: Id -> Bool
interesting Id
v = Id -> Bool
isLocalVar Id
v Bool -> Bool -> Bool
|| (Id -> Bool
isId Id
v Bool -> Bool -> Bool
&& Id -> Bool
isDFunId Id
v)
recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind -> DictBind
recWithDumpedDicts :: [(Id, CoreExpr)] -> Bag DictBind -> DictBind
recWithDumpedDicts [(Id, CoreExpr)]
pairs Bag DictBind
dbs
= DB { db_bind :: CoreBind
db_bind = forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CoreExpr)]
bindings, db_fvs :: VarSet
db_fvs = VarSet
fvs }
where
([(Id, CoreExpr)]
bindings, VarSet
fvs) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DictBind
-> ([(Id, CoreExpr)], VarSet) -> ([(Id, CoreExpr)], VarSet)
add ([], VarSet
emptyVarSet)
(Bag DictBind
dbs forall a. Bag a -> a -> Bag a
`snocBag` CoreBind -> DictBind
mkDB (forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CoreExpr)]
pairs))
add :: DictBind
-> ([(Id, CoreExpr)], VarSet) -> ([(Id, CoreExpr)], VarSet)
add (DB { db_bind :: DictBind -> CoreBind
db_bind = CoreBind
bind, db_fvs :: DictBind -> VarSet
db_fvs = VarSet
fvs }) ([(Id, CoreExpr)]
prs_acc, VarSet
fvs_acc)
= case CoreBind
bind of
NonRec Id
b CoreExpr
r -> ((Id
b,CoreExpr
r) forall a. a -> [a] -> [a]
: [(Id, CoreExpr)]
prs_acc, VarSet
fvs')
Rec [(Id, CoreExpr)]
prs1 -> ([(Id, CoreExpr)]
prs1 forall a. [a] -> [a] -> [a]
++ [(Id, CoreExpr)]
prs_acc, VarSet
fvs')
where
fvs' :: VarSet
fvs' = VarSet
fvs_acc VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
fvs
snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails
snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails
snocDictBinds UsageDetails
uds [DictBind]
dbs
= UsageDetails
uds { ud_binds :: Bag DictBind
ud_binds = UsageDetails -> Bag DictBind
ud_binds UsageDetails
uds forall a. Bag a -> Bag a -> Bag a
`unionBags` forall a. [a] -> Bag a
listToBag [DictBind]
dbs }
consDictBind :: DictBind -> UsageDetails -> UsageDetails
consDictBind :: DictBind -> UsageDetails -> UsageDetails
consDictBind DictBind
bind UsageDetails
uds = UsageDetails
uds { ud_binds :: Bag DictBind
ud_binds = DictBind
bind forall a. a -> Bag a -> Bag a
`consBag` UsageDetails -> Bag DictBind
ud_binds UsageDetails
uds }
addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails
addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails
addDictBinds [DictBind]
binds UsageDetails
uds = UsageDetails
uds { ud_binds :: Bag DictBind
ud_binds = forall a. [a] -> Bag a
listToBag [DictBind]
binds forall a. Bag a -> Bag a -> Bag a
`unionBags` UsageDetails -> Bag DictBind
ud_binds UsageDetails
uds }
snocDictBind :: UsageDetails -> DictBind -> UsageDetails
snocDictBind :: UsageDetails -> DictBind -> UsageDetails
snocDictBind UsageDetails
uds DictBind
bind = UsageDetails
uds { ud_binds :: Bag DictBind
ud_binds = UsageDetails -> Bag DictBind
ud_binds UsageDetails
uds forall a. Bag a -> a -> Bag a
`snocBag` DictBind
bind }
wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]
wrapDictBinds :: Bag DictBind -> CoreProgram -> CoreProgram
wrapDictBinds Bag DictBind
dbs CoreProgram
binds
= forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DictBind -> CoreProgram -> CoreProgram
add CoreProgram
binds Bag DictBind
dbs
where
add :: DictBind -> CoreProgram -> CoreProgram
add (DB { db_bind :: DictBind -> CoreBind
db_bind = CoreBind
bind }) CoreProgram
binds = CoreBind
bind forall a. a -> [a] -> [a]
: CoreProgram
binds
wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr
wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr
wrapDictBindsE Bag DictBind
dbs CoreExpr
expr
= forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DictBind -> CoreExpr -> CoreExpr
add CoreExpr
expr Bag DictBind
dbs
where
add :: DictBind -> CoreExpr -> CoreExpr
add (DB { db_bind :: DictBind -> CoreBind
db_bind = CoreBind
bind }) CoreExpr
expr = forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind CoreExpr
expr
dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind)
dumpUDs :: [Id] -> UsageDetails -> (UsageDetails, Bag DictBind)
dumpUDs [Id]
bndrs uds :: UsageDetails
uds@(MkUD { ud_binds :: UsageDetails -> Bag DictBind
ud_binds = Bag DictBind
orig_dbs, ud_calls :: UsageDetails -> CallDetails
ud_calls = CallDetails
orig_calls })
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bndrs = (UsageDetails
uds, forall a. Bag a
emptyBag)
| Bool
otherwise =
(UsageDetails
free_uds, Bag DictBind
dump_dbs)
where
free_uds :: UsageDetails
free_uds = MkUD { ud_binds :: Bag DictBind
ud_binds = Bag DictBind
free_dbs, ud_calls :: CallDetails
ud_calls = CallDetails
free_calls }
bndr_set :: VarSet
bndr_set = [Id] -> VarSet
mkVarSet [Id]
bndrs
(Bag DictBind
free_dbs, Bag DictBind
dump_dbs, VarSet
dump_set) = Bag DictBind -> VarSet -> (Bag DictBind, Bag DictBind, VarSet)
splitDictBinds Bag DictBind
orig_dbs VarSet
bndr_set
free_calls :: CallDetails
free_calls = VarSet -> CallDetails -> CallDetails
deleteCallsMentioning VarSet
dump_set forall a b. (a -> b) -> a -> b
$
[Id] -> CallDetails -> CallDetails
deleteCallsFor [Id]
bndrs CallDetails
orig_calls
dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)
dumpBindUDs :: [Id] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)
dumpBindUDs [Id]
bndrs (MkUD { ud_binds :: UsageDetails -> Bag DictBind
ud_binds = Bag DictBind
orig_dbs, ud_calls :: UsageDetails -> CallDetails
ud_calls = CallDetails
orig_calls })
=
(UsageDetails
free_uds, Bag DictBind
dump_dbs, Bool
float_all)
where
free_uds :: UsageDetails
free_uds = MkUD { ud_binds :: Bag DictBind
ud_binds = Bag DictBind
free_dbs, ud_calls :: CallDetails
ud_calls = CallDetails
free_calls }
bndr_set :: VarSet
bndr_set = [Id] -> VarSet
mkVarSet [Id]
bndrs
(Bag DictBind
free_dbs, Bag DictBind
dump_dbs, VarSet
dump_set) = Bag DictBind -> VarSet -> (Bag DictBind, Bag DictBind, VarSet)
splitDictBinds Bag DictBind
orig_dbs VarSet
bndr_set
free_calls :: CallDetails
free_calls = [Id] -> CallDetails -> CallDetails
deleteCallsFor [Id]
bndrs CallDetails
orig_calls
float_all :: Bool
float_all = VarSet
dump_set VarSet -> VarSet -> Bool
`intersectsVarSet` CallDetails -> VarSet
callDetailsFVs CallDetails
free_calls
callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])
callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])
callsForMe Id
fn (MkUD { ud_binds :: UsageDetails -> Bag DictBind
ud_binds = Bag DictBind
orig_dbs, ud_calls :: UsageDetails -> CallDetails
ud_calls = CallDetails
orig_calls })
=
(UsageDetails
uds_without_me, [CallInfo]
calls_for_me)
where
uds_without_me :: UsageDetails
uds_without_me = MkUD { ud_binds :: Bag DictBind
ud_binds = Bag DictBind
orig_dbs
, ud_calls :: CallDetails
ud_calls = forall a. DVarEnv a -> Id -> DVarEnv a
delDVarEnv CallDetails
orig_calls Id
fn }
calls_for_me :: [CallInfo]
calls_for_me = case forall a. DVarEnv a -> Id -> Maybe a
lookupDVarEnv CallDetails
orig_calls Id
fn of
Maybe CallInfoSet
Nothing -> []
Just CallInfoSet
cis -> CallInfoSet -> Bag DictBind -> [CallInfo]
filterCalls CallInfoSet
cis Bag DictBind
orig_dbs
filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]
filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]
filterCalls (CIS Id
fn Bag CallInfo
call_bag) Bag DictBind
dbs
= forall a. (a -> Bool) -> [a] -> [a]
filter CallInfo -> Bool
ok_call (forall a. Bag a -> [a]
bagToList Bag CallInfo
call_bag)
where
dump_set :: VarSet
dump_set = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' VarSet -> DictBind -> VarSet
go (Id -> VarSet
unitVarSet Id
fn) Bag DictBind
dbs
go :: VarSet -> DictBind -> VarSet
go VarSet
so_far (DB { db_bind :: DictBind -> CoreBind
db_bind = CoreBind
bind, db_fvs :: DictBind -> VarSet
db_fvs = VarSet
fvs })
| VarSet
fvs VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
so_far
= VarSet -> [Id] -> VarSet
extendVarSetList VarSet
so_far (forall b. Bind b -> [b]
bindersOf CoreBind
bind)
| Bool
otherwise = VarSet
so_far
ok_call :: CallInfo -> Bool
ok_call (CI { ci_fvs :: CallInfo -> VarSet
ci_fvs = VarSet
fvs }) = VarSet
fvs VarSet -> VarSet -> Bool
`disjointVarSet` VarSet
dump_set
splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)
splitDictBinds :: Bag DictBind -> VarSet -> (Bag DictBind, Bag DictBind, VarSet)
splitDictBinds Bag DictBind
dbs VarSet
bndr_set
= forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Bag DictBind, Bag DictBind, VarSet)
-> DictBind -> (Bag DictBind, Bag DictBind, VarSet)
split_db (forall a. Bag a
emptyBag, forall a. Bag a
emptyBag, VarSet
bndr_set) Bag DictBind
dbs
where
split_db :: (Bag DictBind, Bag DictBind, VarSet)
-> DictBind -> (Bag DictBind, Bag DictBind, VarSet)
split_db (Bag DictBind
free_dbs, Bag DictBind
dump_dbs, VarSet
dump_idset) DictBind
db
| DB { db_bind :: DictBind -> CoreBind
db_bind = CoreBind
bind, db_fvs :: DictBind -> VarSet
db_fvs = VarSet
fvs } <- DictBind
db
, VarSet
dump_idset VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
fvs
= (Bag DictBind
free_dbs, Bag DictBind
dump_dbs forall a. Bag a -> a -> Bag a
`snocBag` DictBind
db,
VarSet -> [Id] -> VarSet
extendVarSetList VarSet
dump_idset (forall b. Bind b -> [b]
bindersOf CoreBind
bind))
| Bool
otherwise
= (Bag DictBind
free_dbs forall a. Bag a -> a -> Bag a
`snocBag` DictBind
db, Bag DictBind
dump_dbs, VarSet
dump_idset)
deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails
deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails
deleteCallsMentioning VarSet
bs CallDetails
calls
= forall a b. (a -> b) -> DVarEnv a -> DVarEnv b
mapDVarEnv ((CallInfo -> Bool) -> CallInfoSet -> CallInfoSet
ciSetFilter CallInfo -> Bool
keep_call) CallDetails
calls
where
keep_call :: CallInfo -> Bool
keep_call (CI { ci_fvs :: CallInfo -> VarSet
ci_fvs = VarSet
fvs }) = VarSet
fvs VarSet -> VarSet -> Bool
`disjointVarSet` VarSet
bs
deleteCallsFor :: [Id] -> CallDetails -> CallDetails
deleteCallsFor :: [Id] -> CallDetails -> CallDetails
deleteCallsFor [Id]
bs CallDetails
calls = forall a. DVarEnv a -> [Id] -> DVarEnv a
delDVarEnvList CallDetails
calls [Id]
bs
type SpecM a = UniqSM a
runSpecM :: SpecM a -> CoreM a
runSpecM :: forall a. SpecM a -> CoreM a
runSpecM SpecM a
thing_inside
= do { UniqSupply
us <- forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us SpecM a
thing_inside) }
mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM :: forall a b.
(a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM a -> SpecM (b, UsageDetails)
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ([], UsageDetails
emptyUDs)
mapAndCombineSM a -> SpecM (b, UsageDetails)
f (a
x:[a]
xs) = do (b
y, UsageDetails
uds1) <- a -> SpecM (b, UsageDetails)
f a
x
([b]
ys, UsageDetails
uds2) <- forall a b.
(a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM a -> SpecM (b, UsageDetails)
f [a]
xs
forall (m :: * -> *) a. Monad m => a -> m a
return (b
yforall a. a -> [a] -> [a]
:[b]
ys, UsageDetails
uds1 UsageDetails -> UsageDetails -> UsageDetails
`plusUDs` UsageDetails
uds2)
extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv
extendTvSubstList :: SpecEnv -> [(Id, Kind)] -> SpecEnv
extendTvSubstList SpecEnv
env [(Id, Kind)]
tv_binds
= SpecEnv
env { se_subst :: Subst
se_subst = Subst -> [(Id, Kind)] -> Subst
Core.extendTvSubstList (SpecEnv -> Subst
se_subst SpecEnv
env) [(Id, Kind)]
tv_binds }
substTy :: SpecEnv -> Type -> Type
substTy :: SpecEnv -> Kind -> Kind
substTy SpecEnv
env Kind
ty = Subst -> Kind -> Kind
Core.substTy (SpecEnv -> Subst
se_subst SpecEnv
env) Kind
ty
substCo :: SpecEnv -> Coercion -> Coercion
substCo :: SpecEnv -> Coercion -> Coercion
substCo SpecEnv
env Coercion
co = HasCallStack => Subst -> Coercion -> Coercion
Core.substCo (SpecEnv -> Subst
se_subst SpecEnv
env) Coercion
co
substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr)
substBndr :: SpecEnv -> Id -> (SpecEnv, Id)
substBndr SpecEnv
env Id
bs = case Subst -> Id -> (Subst, Id)
Core.substBndr (SpecEnv -> Subst
se_subst SpecEnv
env) Id
bs of
(Subst
subst', Id
bs') -> (SpecEnv
env { se_subst :: Subst
se_subst = Subst
subst' }, Id
bs')
substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr])
substBndrs :: SpecEnv -> [Id] -> (SpecEnv, [Id])
substBndrs SpecEnv
env [Id]
bs = case Subst -> [Id] -> (Subst, [Id])
Core.substBndrs (SpecEnv -> Subst
se_subst SpecEnv
env) [Id]
bs of
(Subst
subst', [Id]
bs') -> (SpecEnv
env { se_subst :: Subst
se_subst = Subst
subst' }, [Id]
bs')
cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind)
cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind)
cloneBindSM env :: SpecEnv
env@(SE { se_subst :: SpecEnv -> Subst
se_subst = Subst
subst, se_interesting :: SpecEnv -> VarSet
se_interesting = VarSet
interesting }) (NonRec Id
bndr CoreExpr
rhs)
= do { UniqSupply
us <- forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
; let (Subst
subst', Id
bndr') = Subst -> UniqSupply -> Id -> (Subst, Id)
Core.cloneIdBndr Subst
subst UniqSupply
us Id
bndr
interesting' :: VarSet
interesting' | SpecEnv -> CoreExpr -> Bool
interestingDict SpecEnv
env CoreExpr
rhs
= VarSet
interesting VarSet -> Id -> VarSet
`extendVarSet` Id
bndr'
| Bool
otherwise = VarSet
interesting
; forall (m :: * -> *) a. Monad m => a -> m a
return (SpecEnv
env, SpecEnv
env { se_subst :: Subst
se_subst = Subst
subst', se_interesting :: VarSet
se_interesting = VarSet
interesting' }
, forall b. b -> Expr b -> Bind b
NonRec Id
bndr' CoreExpr
rhs) }
cloneBindSM env :: SpecEnv
env@(SE { se_subst :: SpecEnv -> Subst
se_subst = Subst
subst, se_interesting :: SpecEnv -> VarSet
se_interesting = VarSet
interesting }) (Rec [(Id, CoreExpr)]
pairs)
= do { UniqSupply
us <- forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
; let (Subst
subst', [Id]
bndrs') = Subst -> UniqSupply -> [Id] -> (Subst, [Id])
Core.cloneRecIdBndrs Subst
subst UniqSupply
us (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
pairs)
env' :: SpecEnv
env' = SpecEnv
env { se_subst :: Subst
se_subst = Subst
subst'
, se_interesting :: VarSet
se_interesting = VarSet
interesting VarSet -> [Id] -> VarSet
`extendVarSetList`
[ Id
v | (Id
v,CoreExpr
r) <- [(Id, CoreExpr)]
pairs, SpecEnv -> CoreExpr -> Bool
interestingDict SpecEnv
env CoreExpr
r ] }
; forall (m :: * -> *) a. Monad m => a -> m a
return (SpecEnv
env', SpecEnv
env', forall b. [(b, Expr b)] -> Bind b
Rec ([Id]
bndrs' forall a b. [a] -> [b] -> [(a, b)]
`zip` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Id, CoreExpr)]
pairs)) }
newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr
newDictBndr :: SpecEnv -> Id -> SpecM Id
newDictBndr SpecEnv
env Id
b = do { Unique
uniq <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let n :: Name
n = Id -> Name
idName Id
b
ty' :: Kind
ty' = SpecEnv -> Kind -> Kind
substTy SpecEnv
env (Id -> Kind
idType Id
b)
; forall (m :: * -> *) a. Monad m => a -> m a
return (OccName -> Unique -> Kind -> Kind -> SrcSpan -> Id
mkUserLocal (Name -> OccName
nameOccName Name
n) Unique
uniq Kind
Many Kind
ty' (forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
n)) }
newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id
newSpecIdSM :: Id -> Kind -> Maybe Int -> SpecM Id
newSpecIdSM Id
old_id Kind
new_ty Maybe Int
join_arity_maybe
= do { Unique
uniq <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let name :: Name
name = Id -> Name
idName Id
old_id
new_occ :: OccName
new_occ = OccName -> OccName
mkSpecOcc (Name -> OccName
nameOccName Name
name)
new_id :: Id
new_id = OccName -> Unique -> Kind -> Kind -> SrcSpan -> Id
mkUserLocal OccName
new_occ Unique
uniq Kind
Many Kind
new_ty (forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
name)
Id -> Maybe Int -> Id
`asJoinId_maybe` Maybe Int
join_arity_maybe
; forall (m :: * -> *) a. Monad m => a -> m a
return Id
new_id }