{-# 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 <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let top_env :: SpecEnv
top_env = SE { se_subst :: Subst
se_subst = InScopeSet -> Subst
Core.mkEmptySubst (InScopeSet -> Subst) -> InScopeSet -> Subst
forall a b. (a -> b) -> a -> b
$ VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ [Id] -> VarSet
mkVarSet ([Id] -> VarSet) -> [Id] -> VarSet
forall a b. (a -> b) -> a -> b
$
CoreProgram -> [Id]
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 [] = (CoreProgram, UsageDetails) -> UniqSM (CoreProgram, UsageDetails)
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
(CoreProgram, UsageDetails) -> UniqSM (CoreProgram, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreProgram
bind' CoreProgram -> CoreProgram -> CoreProgram
forall a. [a] -> [a] -> [a]
++ CoreProgram
binds', UsageDetails
uds')
; (CoreProgram
binds', UsageDetails
uds) <- UniqSM (CoreProgram, UsageDetails)
-> CoreM (CoreProgram, UsageDetails)
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
; ModGuts -> CoreM ModGuts
forall (m :: * -> *) a. Monad m => a -> m a
return (ModGuts
guts { mg_binds :: CoreProgram
mg_binds = CoreProgram
spec_binds CoreProgram -> CoreProgram -> CoreProgram
forall a. [a] -> [a] -> [a]
++ CoreProgram
binds'
, mg_rules :: [CoreRule]
mg_rules = [CoreRule]
spec_rules [CoreRule] -> [CoreRule] -> [CoreRule]
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CrossModuleSpecialise (SpecEnv -> DynFlags
se_dflags SpecEnv
top_env)
= ([CoreRule], CoreProgram) -> CoreM ([CoreRule], CoreProgram)
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
| CoreProgram -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null CoreProgram
spec_binds = Bag DictBind -> CoreProgram -> CoreProgram
wrapDictBinds Bag DictBind
dict_binds []
| Bool
otherwise = [[(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(Id, CoreExpr)] -> CoreBind) -> [(Id, CoreExpr)] -> CoreBind
forall a b. (a -> b) -> a -> b
$ CoreProgram -> [(Id, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds (CoreProgram -> [(Id, CoreExpr)])
-> CoreProgram -> [(Id, CoreExpr)]
forall a b. (a -> b) -> a -> b
$
Bag DictBind -> CoreProgram -> CoreProgram
wrapDictBinds Bag DictBind
dict_binds CoreProgram
spec_binds]
; ([CoreRule], CoreProgram) -> CoreM ([CoreRule], CoreProgram)
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 = CallDetails -> [CallInfoSet]
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
; ([CoreRule], CoreProgram) -> CoreM ([CoreRule], CoreProgram)
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
_ [] = ([CoreRule], CoreProgram) -> CoreM ([CoreRule], CoreProgram)
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
; ([CoreRule], CoreProgram) -> CoreM ([CoreRule], CoreProgram)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreRule]
rules1 [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
++ [CoreRule]
rules2, CoreProgram
spec_binds1 CoreProgram -> CoreProgram -> CoreProgram
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
_)
| String -> Id -> [Id] -> Bool
forall a. Eq a => String -> a -> [a] -> Bool
isIn String
"specImport" Id
fn [Id]
callers
= ([CoreRule], CoreProgram) -> CoreM ([CoreRule], CoreProgram)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
| [CallInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CallInfo]
good_calls
= ([CoreRule], CoreProgram) -> CoreM ([CoreRule], CoreProgram)
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 <- IO ExternalPackageState -> CoreM ExternalPackageState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ExternalPackageState -> CoreM ExternalPackageState)
-> IO ExternalPackageState -> CoreM ExternalPackageState
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 })
<-
(SpecM ([CoreRule], [(Id, CoreExpr)], UsageDetails)
-> CoreM ([CoreRule], [(Id, CoreExpr)], UsageDetails)
forall a. SpecM a -> CoreM a
runSpecM (SpecM ([CoreRule], [(Id, CoreExpr)], UsageDetails)
-> CoreM ([CoreRule], [(Id, CoreExpr)], UsageDetails))
-> SpecM ([CoreRule], [(Id, CoreExpr)], UsageDetails)
-> CoreM ([CoreRule], [(Id, CoreExpr)], UsageDetails)
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 = [Id -> CoreExpr -> CoreBind
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
fnId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
callers)
(RuleBase -> [CoreRule] -> RuleBase
extendRuleBaseList RuleBase
rb [CoreRule]
rules1)
(Bag DictBind
dict_binds Bag DictBind -> Bag DictBind -> Bag DictBind
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 (CoreProgram -> CoreProgram) -> CoreProgram -> CoreProgram
forall a b. (a -> b) -> a -> b
$
CoreProgram
spec_binds2 CoreProgram -> CoreProgram -> CoreProgram
forall a. [a] -> [a] -> [a]
++ CoreProgram
spec_binds1
; ([CoreRule], CoreProgram) -> CoreM ([CoreRule], CoreProgram)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreRule]
rules2 [CoreRule] -> [CoreRule] -> [CoreRule]
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
; ([CoreRule], CoreProgram) -> CoreM ([CoreRule], CoreProgram)
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
= CoreExpr -> Maybe CoreExpr
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 = Maybe CoreExpr
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
| WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnMissedSpecs DynFlags
dflags
Bool -> Bool -> Bool
&& Bool -> Bool
not ([Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
callers)
Bool -> Bool -> Bool
&& Bool
allCallersInlined = WarnReason -> CoreM ()
doWarn (WarnReason -> CoreM ()) -> WarnReason -> CoreM ()
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 (WarnReason -> CoreM ()) -> WarnReason -> CoreM ()
forall a b. (a -> b) -> a -> b
$ WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnAllMissedSpecs
| Bool
otherwise = () -> CoreM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
allCallersInlined :: Bool
allCallersInlined = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (InlinePragma -> Bool
isAnyInlinePragma (InlinePragma -> Bool) -> (Id -> InlinePragma) -> Id -> Bool
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 (Id -> SDoc
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 (Id -> SDoc
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 ((CallInfo -> SDoc) -> [CallInfo] -> [SDoc]
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 (Id -> SDoc
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 ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
[ String -> SDoc
text String
"subst =" SDoc -> SDoc -> SDoc
<+> Subst -> SDoc
forall a. Outputable a => a -> SDoc
ppr Subst
subst
, String -> SDoc
text String
"interesting =" SDoc -> SDoc -> SDoc
<+> VarSet -> 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
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) = (CoreExpr, UsageDetails) -> SpecM (CoreExpr, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> CoreExpr
forall b. Kind -> Expr b
Type (SpecEnv -> Kind -> Kind
substTy SpecEnv
env Kind
ty), UsageDetails
emptyUDs)
specExpr SpecEnv
env (Coercion Coercion
co) = (CoreExpr, UsageDetails) -> SpecM (CoreExpr, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> CoreExpr
forall b. Coercion -> Expr b
Coercion (SpecEnv -> Coercion -> Coercion
substCo SpecEnv
env Coercion
co), UsageDetails
emptyUDs)
specExpr SpecEnv
env (Var Id
v) = (CoreExpr, UsageDetails) -> SpecM (CoreExpr, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (SpecEnv -> Id -> CoreExpr
specVar SpecEnv
env Id
v, UsageDetails
emptyUDs)
specExpr SpecEnv
_ (Lit Literal
lit) = (CoreExpr, UsageDetails) -> SpecM (CoreExpr, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> CoreExpr
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
; (CoreExpr, UsageDetails) -> SpecM (CoreExpr, UsageDetails)
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
; (CoreExpr, UsageDetails) -> SpecM (CoreExpr, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreTickish -> CoreExpr -> CoreExpr
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'CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
:[CoreExpr]
args)
(CoreExpr, UsageDetails) -> SpecM (CoreExpr, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> CoreExpr -> CoreExpr
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' -> (CoreExpr, UsageDetails) -> SpecM (CoreExpr, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
f', SpecEnv -> Id -> [CoreExpr] -> UsageDetails
mkCallUDs SpecEnv
env Id
f' [CoreExpr]
args)
CoreExpr
e' -> (CoreExpr, UsageDetails) -> SpecM (CoreExpr, UsageDetails)
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) = CoreExpr -> ([Id], CoreExpr)
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
; (CoreExpr, UsageDetails) -> SpecM (CoreExpr, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr -> Id -> Kind -> [Alt Id] -> CoreExpr
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
; (CoreExpr, UsageDetails) -> SpecM (CoreExpr, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ((CoreBind -> CoreExpr -> CoreExpr)
-> CoreExpr -> CoreProgram -> CoreExpr
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreBind -> CoreExpr -> CoreExpr
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
| [Id] -> Bool
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
; (CoreExpr, UsageDetails) -> SpecM (CoreExpr, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id] -> CoreExpr -> CoreExpr
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)
= XBreakpoint 'TickishPassCore
-> Int -> [XTickishId 'TickishPassCore] -> CoreTickish
forall (pass :: TickishPass).
XBreakpoint pass -> Int -> [XTickishId pass] -> GenTickish pass
Breakpoint XBreakpoint 'TickishPassCore
ext Int
ix [ Id
XTickishId 'TickishPassCore
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
&& [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
sc_args')
= do { (Id
case_bndr_flt : [Id]
sc_args_flt) <- (Id -> UniqSM Id) -> [Id] -> UniqSM [Id]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Id -> UniqSM Id
forall {m :: * -> *}. MonadUnique m => Id -> m Id
clone_me (Id
case_bndr' Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
sc_args')
; let sc_rhss :: [CoreExpr]
sc_rhss = [ CoreExpr -> Id -> Kind -> [Alt Id] -> CoreExpr
forall b. Expr b -> b -> Kind -> [Alt b] -> Expr b
Case (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
case_bndr_flt) Id
case_bndr' (Id -> Kind
idType Id
sc_arg')
[AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
args' (Id -> CoreExpr
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 = (Id -> Maybe Id) -> [Id] -> [Maybe Id]
forall a b. (a -> b) -> [a] -> [b]
map (VarEnv Id -> Id -> Maybe Id
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv Id
clone_env) [Id]
args'
clone_env :: VarEnv Id
clone_env = [Id] -> [Id] -> VarEnv Id
forall a. [Id] -> [a] -> VarEnv a
zipVarEnv [Id]
sc_args' [Id]
sc_args_flt
subst_prs :: [(Id, CoreExpr)]
subst_prs = (Id
case_bndr, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
case_bndr_flt)
(Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. a -> [a] -> [a]
: [ (Id
arg, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
sc_flt)
| (Id
arg, Just Id
sc_flt) <- [Id]
args [Id] -> [Maybe Id] -> [(Id, Maybe Id)]
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 Id -> [Id] -> [Id]
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 (Id -> CoreExpr -> CoreBind
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 = Id -> CoreExpr -> CoreBind
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 [Id] -> [CoreExpr] -> [(Id, CoreExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [CoreExpr]
sc_rhss ]
flt_binds :: [DictBind]
flt_binds = DictBind
scrut_bind DictBind -> [DictBind] -> [DictBind]
forall a. a -> [a] -> [a]
: [DictBind]
sc_binds
(UsageDetails
free_uds, Bag DictBind
dumped_dbs) = [Id] -> UsageDetails -> (UsageDetails, Bag DictBind)
dumpUDs (Id
case_bndr'Id -> [Id] -> [Id]
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' = AltCon -> [Id] -> CoreExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
args' (Bag DictBind -> CoreExpr -> CoreExpr
wrapDictBindsE Bag DictBind
dumped_dbs CoreExpr
rhs')
; (CoreExpr, Id, [Alt Id], UsageDetails)
-> SpecM (CoreExpr, Id, [Alt Id], UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> CoreExpr
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_bndrId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
args)
sc_args' :: [Id]
sc_args' = (Id -> Bool) -> [Id] -> [Id]
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 <- m Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; Id -> m Id
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 = Name -> SrcSpan
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) <- (Alt Id -> SpecM (Alt Id, UsageDetails))
-> [Alt Id] -> SpecM ([Alt Id], UsageDetails)
forall a b.
(a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM Alt Id -> SpecM (Alt Id, UsageDetails)
spec_alt [Alt Id]
alts
; (CoreExpr, Id, [Alt Id], UsageDetails)
-> SpecM (CoreExpr, Id, [Alt Id], UsageDetails)
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 -> SpecM (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' Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
args') UsageDetails
uds
(Alt Id, UsageDetails) -> SpecM (Alt Id, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon -> [Id] -> CoreExpr -> Alt Id
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 [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
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 (Bag DictBind -> Bool
forall a. Bag a -> Bool
isEmptyBag Bag DictBind
dump_dbs)
, Bool -> Bool
not ([(Id, CoreExpr)] -> Bool
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 (CoreBind -> DictBind) -> CoreBind -> DictBind
forall a b. (a -> b) -> a -> b
$ Id -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Id
b CoreExpr
r | (Id
b,CoreExpr
r) <- [(Id, CoreExpr)]
pairs]
[DictBind] -> [DictBind] -> [DictBind]
forall a. [a] -> [a] -> [a]
++ Bag DictBind -> [DictBind]
forall a. Bag a -> [a]
bagToList Bag DictBind
dump_dbs
; if Bool
float_all then
(CoreProgram, UsageDetails) -> UniqSM (CoreProgram, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], UsageDetails
free_uds UsageDetails -> [DictBind] -> UsageDetails
`snocDictBinds` [DictBind]
final_binds)
else
(CoreProgram, UsageDetails) -> UniqSM (CoreProgram, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ((DictBind -> CoreBind) -> [DictBind] -> CoreProgram
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) = [(Id, CoreExpr)] -> ([Id], [CoreExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, CoreExpr)]
pairs
; ([CoreExpr]
rhss', UsageDetails
rhs_uds) <- (CoreExpr -> SpecM (CoreExpr, UsageDetails))
-> [CoreExpr] -> SpecM ([CoreExpr], UsageDetails)
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 [(Id, CoreExpr)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Id, CoreExpr)]
spec_defns1
then ([Id], [(Id, CoreExpr)], UsageDetails)
-> SpecM ([Id], [(Id, CoreExpr)], UsageDetails)
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 [Id] -> [CoreExpr] -> [(Id, CoreExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [CoreExpr]
rhss)
; ([Id], [(Id, CoreExpr)], UsageDetails)
-> SpecM ([Id], [(Id, CoreExpr)], UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
bndrs2, [(Id, CoreExpr)]
spec_defns2 [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
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 [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. [a] -> [a] -> [a]
++ [Id] -> [CoreExpr] -> [(Id, CoreExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs3 [CoreExpr]
rhss')
Bag DictBind
dumped_dbs
; if Bool
float_all then
(CoreProgram, UsageDetails) -> UniqSM (CoreProgram, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], UsageDetails
final_uds UsageDetails -> DictBind -> UsageDetails
`snocDictBind` DictBind
final_bind)
else
(CoreProgram, UsageDetails) -> UniqSM (CoreProgram, UsageDetails)
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 []
= ([Id], [(Id, CoreExpr)], UsageDetails)
-> SpecM ([Id], [(Id, CoreExpr)], UsageDetails)
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
; ([Id], [(Id, CoreExpr)], UsageDetails)
-> SpecM ([Id], [(Id, CoreExpr)], UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
bndr1 Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
bndrs1, [(Id, CoreExpr)]
spec_defns1 [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
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
; (Id, [(Id, CoreExpr)], UsageDetails)
-> SpecM (Id, [(Id, CoreExpr)], UsageDetails)
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
| [CallInfo] -> Bool
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))
=
(([CoreRule], [(Id, CoreExpr)], UsageDetails)
-> CallInfo -> SpecM ([CoreRule], [(Id, CoreExpr)], UsageDetails))
-> ([CoreRule], [(Id, CoreExpr)], UsageDetails)
-> [CallInfo]
-> SpecM ([CoreRule], [(Id, CoreExpr)], UsageDetails)
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 )
([CoreRule], [(Id, CoreExpr)], UsageDetails)
-> SpecM ([CoreRule], [(Id, CoreExpr)], UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], UsageDetails
emptyUDs)
where
_trace_doc :: SDoc
_trace_doc = [SDoc] -> SDoc
sep [ [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
rhs_bndrs, Activation -> SDoc
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
= Maybe (CoreRule, CoreExpr) -> Bool
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)
(Bool -> Activation -> Bool
forall a b. a -> b -> a
const Bool
True) Id
fn [CoreExpr]
args
([CoreRule]
new_rules [CoreRule] -> [CoreRule] -> [CoreRule]
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 [SpecArg] -> [SpecArg] -> [SpecArg]
forall a. [a] -> [a] -> [a]
++ SpecArg -> [SpecArg]
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 ([CoreRule], [(Id, CoreExpr)], UsageDetails)
-> SpecM ([CoreRule], [(Id, CoreExpr)], UsageDetails)
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 [Id] -> [Id] -> [Id]
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
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 Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
spec_bndrs1
, Id -> CoreExpr -> CoreExpr
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 = [CoreExpr] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CoreExpr]
rule_lhs_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Id] -> Int
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
= Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
orig_join_arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
join_arity_decr)
| Bool
otherwise
= Maybe Int
forall a. Maybe a
Nothing
; Id
spec_fn <- Id -> Kind -> Maybe Int -> UniqSM 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
<> Module -> 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 (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$
SDoc
herald SDoc -> SDoc -> SDoc
<+> FastString -> SDoc
ftext (OccName -> FastString
occNameFS (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
fn))
SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
hsep ((SpecArg -> Maybe SDoc) -> [SpecArg] -> [SDoc]
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
(CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> CoreExpr
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 = (DictBind -> UsageDetails -> UsageDetails)
-> UsageDetails -> [DictBind] -> UsageDetails
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 (CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
`mkApps` [CoreExpr]
spec_args)
[CoreExpr]
rule_lhs_args Unfolding
fn_unf)
arity_decr :: Int
arity_decr = (CoreExpr -> Bool) -> [CoreExpr] -> Int
forall a. (a -> Bool) -> [a] -> Int
count CoreExpr -> Bool
forall b. Expr b -> Bool
isValArg [CoreExpr]
rule_lhs_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Id -> Bool) -> [Id] -> Int
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` Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
fn_arity Int -> Int -> Int
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 [ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
fn_type
, Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
spec_fn SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
spec_fn_ty
, [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
rhs_bndrs, [SpecArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SpecArg]
call_args
, CoreRule -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreRule
spec_rule
]
;
([CoreRule], [(Id, CoreExpr)], UsageDetails)
-> SpecM ([CoreRule], [(Id, CoreExpr)], UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ( CoreRule
spec_rule CoreRule -> [CoreRule] -> [CoreRule]
forall a. a -> [a] -> [a]
: [CoreRule]
rules_acc
, (Id
spec_f_w_arity, CoreExpr
spec_rhs) (Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
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
<+> Kind -> 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
<+> CoreExpr -> 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
; (Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
-> SpecM
(Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Bool
useful
, SpecEnv
env''
, [Id]
leftover_bndrs
, [Id]
rule_bs
, Kind -> CoreExpr
forall b. Kind -> Expr b
Type Kind
t CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
rule_es
, [Id]
bs'
, [DictBind]
dx
, Kind -> CoreExpr
forall b. Kind -> Expr b
Type Kind
t CoreExpr -> [CoreExpr] -> [CoreExpr]
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
; (Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
-> SpecM
(Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Bool
useful
, SpecEnv
env''
, [Id]
leftover_bndrs
, Id
bndr' Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
rule_bs
, Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
bndr' CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
rule_es
, Id
bndr' Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
bs'
, [DictBind]
dx
, Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
bndr' CoreExpr -> [CoreExpr] -> [CoreExpr]
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 -> UniqSM 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
; (Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
-> SpecM
(Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Bool
True
, SpecEnv
env''
, [Id]
leftover_bndrs
, CoreExpr -> [Id]
exprFreeIdsList (Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
bndr') [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
rule_bs
, Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
bndr' CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
rule_es
, [Id]
bs'
, Maybe DictBind -> [DictBind]
forall a. Maybe a -> [a]
maybeToList Maybe DictBind
dx_bind [DictBind] -> [DictBind] -> [DictBind]
forall a. [a] -> [a] -> [a]
++ [DictBind]
dx
, CoreExpr
spec_dict CoreExpr -> [CoreExpr] -> [CoreExpr]
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
; (Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
-> SpecM
(Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Bool
useful
, SpecEnv
env''
, [Id]
leftover_bndrs
, Id
bndr' Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
rule_bs
, Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
bndr' CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
rule_es
, if Id -> Bool
isDeadBinder Id
bndr
then [Id]
bs'
else Id
bndr' Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
bs'
, [DictBind]
dx
, Id -> CoreExpr
forall b. Id -> Expr b
varToCoreExpr Id
bndr' CoreExpr -> [CoreExpr] -> [CoreExpr]
forall a. a -> [a] -> [a]
: [CoreExpr]
spec_args
)
}
specHeader SpecEnv
env [] [SpecArg]
_ = (Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
-> SpecM
(Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, SpecEnv
env, [], [], [], [], [], [])
specHeader SpecEnv
env [Id]
bndrs []
= (Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
-> SpecM
(Bool, SpecEnv, [Id], [Id], [CoreExpr], [Id], [DictBind],
[CoreExpr])
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', Maybe DictBind
forall a. Maybe a
Nothing, CoreExpr
dict_expr)
| Bool
otherwise
= let dict_bind :: DictBind
dict_bind = CoreBind -> DictBind
mkDB (Id -> CoreExpr -> CoreBind
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 (Id -> CoreExpr
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', DictBind -> Maybe DictBind
forall a. a -> Maybe a
Just DictBind
dict_bind, Id -> CoreExpr
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
<+> CoreBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBind
bind
, String -> SDoc
text String
"fvs: " SDoc -> SDoc -> SDoc
<+> VarSet -> 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
<+> Bag DictBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag DictBind
dbs,
String -> SDoc
text String
"calls" SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> CallDetails -> SDoc
forall a. Outputable a => a -> SDoc
ppr CallDetails
calls]))
emptyUDs :: UsageDetails
emptyUDs :: UsageDetails
emptyUDs = MkUD { ud_binds :: Bag DictBind
ud_binds = Bag DictBind
forall a. Bag a
emptyBag, ud_calls :: CallDetails
ud_calls = CallDetails
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 ((CallInfo -> Bool) -> Bag CallInfo -> Bag CallInfo
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
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn)
Int
2 (Bag CallInfo -> SDoc
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 })
= Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn SDoc -> SDoc -> SDoc
<+> [SpecArg] -> 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) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
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 = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ Char -> SDoc
char Char
'_'
ppr_call_key_ty (SpecDict CoreExpr
_) = Maybe SDoc
forall a. Maybe a
Nothing
ppr_call_key_ty SpecArg
UnspecArg = Maybe SDoc
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 ((SpecArg -> SDoc) -> [SpecArg] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map SpecArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SpecArg]
key))
unionCalls :: CallDetails -> CallDetails -> CallDetails
unionCalls :: CallDetails -> CallDetails -> CallDetails
unionCalls CallDetails
c1 CallDetails
c2 = (CallInfoSet -> CallInfoSet -> CallInfoSet)
-> CallDetails -> CallDetails -> CallDetails
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 Bag CallInfo -> Bag CallInfo -> Bag CallInfo
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag CallInfo
calls2)
callDetailsFVs :: CallDetails -> VarSet
callDetailsFVs :: CallDetails -> VarSet
callDetailsFVs CallDetails
calls =
(CallInfoSet -> VarSet -> VarSet)
-> VarSet -> CallDetails -> VarSet
forall elt a key. (elt -> a -> a) -> a -> UniqDFM key elt -> a
nonDetStrictFoldUDFM (VarSet -> VarSet -> VarSet
unionVarSet (VarSet -> VarSet -> VarSet)
-> (CallInfoSet -> VarSet) -> CallInfoSet -> VarSet -> VarSet
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) =
(CallInfo -> VarSet -> VarSet) -> VarSet -> Bag CallInfo -> VarSet
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 = (TyCoBinder -> Kind) -> [TyCoBinder] -> [Kind]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyCoBinder -> Kind
tyBinderType ([TyCoBinder] -> [Kind])
-> ([TyCoBinder] -> [TyCoBinder]) -> [TyCoBinder] -> [Kind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyCoBinder -> Bool) -> [TyCoBinder] -> [TyCoBinder]
forall a. (a -> Bool) -> [a] -> [a]
filter TyCoBinder -> Bool
isInvisibleBinder ([TyCoBinder] -> [TyCoBinder])
-> ([TyCoBinder] -> [TyCoBinder]) -> [TyCoBinder] -> [TyCoBinder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TyCoBinder -> Bool) -> [TyCoBinder] -> [TyCoBinder]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (TyCoBinder -> Bool) -> TyCoBinder -> Bool
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 = Bag DictBind
forall a. Bag a
emptyBag,
ud_calls :: CallDetails
ud_calls = Id -> CallInfoSet -> CallDetails
forall a. Id -> a -> DVarEnv a
unitDVarEnv Id
id (CallInfoSet -> CallDetails) -> CallInfoSet -> CallDetails
forall a b. (a -> b) -> a -> b
$ Id -> Bag CallInfo -> CallInfoSet
CIS Id
id (Bag CallInfo -> CallInfoSet) -> Bag CallInfo -> CallInfoSet
forall a b. (a -> b) -> a -> b
$
CallInfo -> Bag CallInfo
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 = (SpecArg -> VarSet -> VarSet) -> VarSet -> [SpecArg] -> VarSet
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (VarSet -> VarSet -> VarSet
unionVarSet (VarSet -> VarSet -> VarSet)
-> (SpecArg -> VarSet) -> SpecArg -> VarSet -> VarSet
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 ([SpecArg] -> Bool
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 [Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
f, [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
args, [SpecArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SpecArg]
ci_key]
pis :: [TyCoBinder]
pis = ([TyCoBinder], Kind) -> [TyCoBinder]
forall a b. (a, b) -> a
fst (([TyCoBinder], Kind) -> [TyCoBinder])
-> ([TyCoBinder], Kind) -> [TyCoBinder]
forall a b. (a -> b) -> a -> b
$ Kind -> ([TyCoBinder], Kind)
splitPiTys (Kind -> ([TyCoBinder], Kind)) -> Kind -> ([TyCoBinder], Kind)
forall a b. (a -> b) -> a -> b
$ Id -> Kind
idType Id
f
constrained_tyvars :: VarSet
constrained_tyvars = [Kind] -> VarSet
tyCoVarsOfTypes ([Kind] -> VarSet) -> [Kind] -> VarSet
forall a b. (a -> b) -> a -> b
$ [TyCoBinder] -> [Kind]
getTheta [TyCoBinder]
pis
ci_key :: [SpecArg]
ci_key :: [SpecArg]
ci_key = (SpecArg -> Bool) -> [SpecArg] -> [SpecArg]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE (Bool -> Bool
not (Bool -> Bool) -> (SpecArg -> Bool) -> SpecArg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecArg -> Bool
isSpecDict) ([SpecArg] -> [SpecArg]) -> [SpecArg] -> [SpecArg]
forall a b. (a -> b) -> a -> b
$
(CoreExpr -> TyCoBinder -> SpecArg)
-> [CoreExpr] -> [TyCoBinder] -> [SpecArg]
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)
| TyCoVarBinder -> Id
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
_ -> String -> SDoc -> SpecArg
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"ci_key" (SDoc -> SpecArg) -> SDoc -> SpecArg
forall a b. (a -> b) -> a -> b
$ CoreExpr -> SDoc
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 (Scaled Kind -> Kind
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 Bag DictBind -> Bag DictBind -> Bag DictBind
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 = (DictBind -> [Id] -> [Id]) -> [Id] -> Bag DictBind -> [Id]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
(++) ([Id] -> [Id] -> [Id])
-> (DictBind -> [Id]) -> DictBind -> [Id] -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBind -> [Id]
forall b. Bind b -> [b]
bindersOf (CoreBind -> [Id]) -> (DictBind -> CoreBind) -> DictBind -> [Id]
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) = (VarSet -> Id -> VarSet) -> VarSet -> [Id] -> VarSet
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 = ((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, CoreExpr)]
prs
rhs_fvs :: VarSet
rhs_fvs = [VarSet] -> VarSet
unionVarSets (((Id, CoreExpr) -> VarSet) -> [(Id, CoreExpr)] -> [VarSet]
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 = [(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CoreExpr)]
bindings, db_fvs :: VarSet
db_fvs = VarSet
fvs }
where
([(Id, CoreExpr)]
bindings, VarSet
fvs) = (DictBind
-> ([(Id, CoreExpr)], VarSet) -> ([(Id, CoreExpr)], VarSet))
-> ([(Id, CoreExpr)], VarSet)
-> Bag DictBind
-> ([(Id, CoreExpr)], VarSet)
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 Bag DictBind -> DictBind -> Bag DictBind
forall a. Bag a -> a -> Bag a
`snocBag` CoreBind -> DictBind
mkDB ([(Id, CoreExpr)] -> CoreBind
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) (Id, CoreExpr) -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
forall a. a -> [a] -> [a]
: [(Id, CoreExpr)]
prs_acc, VarSet
fvs')
Rec [(Id, CoreExpr)]
prs1 -> ([(Id, CoreExpr)]
prs1 [(Id, CoreExpr)] -> [(Id, CoreExpr)] -> [(Id, CoreExpr)]
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 Bag DictBind -> Bag DictBind -> Bag DictBind
forall a. Bag a -> Bag a -> Bag a
`unionBags` [DictBind] -> Bag DictBind
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 DictBind -> Bag DictBind -> Bag DictBind
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 = [DictBind] -> Bag DictBind
forall a. [a] -> Bag a
listToBag [DictBind]
binds Bag DictBind -> Bag DictBind -> Bag DictBind
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 Bag DictBind -> DictBind -> Bag DictBind
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
= (DictBind -> CoreProgram -> CoreProgram)
-> CoreProgram -> Bag DictBind -> CoreProgram
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 CoreBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
: CoreProgram
binds
wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr
wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr
wrapDictBindsE Bag DictBind
dbs CoreExpr
expr
= (DictBind -> CoreExpr -> CoreExpr)
-> CoreExpr -> Bag DictBind -> CoreExpr
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 = CoreBind -> CoreExpr -> CoreExpr
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 })
| [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bndrs = (UsageDetails
uds, Bag DictBind
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 (CallDetails -> CallDetails) -> CallDetails -> CallDetails
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 = CallDetails -> Id -> CallDetails
forall a. DVarEnv a -> Id -> DVarEnv a
delDVarEnv CallDetails
orig_calls Id
fn }
calls_for_me :: [CallInfo]
calls_for_me = case CallDetails -> Id -> Maybe CallInfoSet
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
= (CallInfo -> Bool) -> [CallInfo] -> [CallInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter CallInfo -> Bool
ok_call (Bag CallInfo -> [CallInfo]
forall a. Bag a -> [a]
bagToList Bag CallInfo
call_bag)
where
dump_set :: VarSet
dump_set = (VarSet -> DictBind -> VarSet) -> VarSet -> Bag DictBind -> VarSet
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 (CoreBind -> [Id]
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
= ((Bag DictBind, Bag DictBind, VarSet)
-> DictBind -> (Bag DictBind, Bag DictBind, VarSet))
-> (Bag DictBind, Bag DictBind, VarSet)
-> Bag DictBind
-> (Bag DictBind, Bag DictBind, VarSet)
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 (Bag DictBind
forall a. Bag a
emptyBag, Bag DictBind
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 Bag DictBind -> DictBind -> Bag DictBind
forall a. Bag a -> a -> Bag a
`snocBag` DictBind
db,
VarSet -> [Id] -> VarSet
extendVarSetList VarSet
dump_idset (CoreBind -> [Id]
forall b. Bind b -> [b]
bindersOf CoreBind
bind))
| Bool
otherwise
= (Bag DictBind
free_dbs Bag DictBind -> DictBind -> Bag DictBind
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
= (CallInfoSet -> CallInfoSet) -> CallDetails -> CallDetails
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 = CallDetails -> [Id] -> CallDetails
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 <- CoreM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
; a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqSupply -> SpecM a -> a
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)
_ [] = ([b], UsageDetails) -> UniqSM ([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) <- (a -> SpecM (b, UsageDetails)) -> [a] -> UniqSM ([b], UsageDetails)
forall a b.
(a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM a -> SpecM (b, UsageDetails)
f [a]
xs
([b], UsageDetails) -> UniqSM ([b], UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
yb -> [b] -> [b]
forall 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
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 <- UniqSM UniqSupply
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
; (SpecEnv, SpecEnv, CoreBind) -> SpecM (SpecEnv, SpecEnv, CoreBind)
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' }
, Id -> CoreExpr -> CoreBind
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 <- UniqSM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
; let (Subst
subst', [Id]
bndrs') = Subst -> UniqSupply -> [Id] -> (Subst, [Id])
Core.cloneRecIdBndrs Subst
subst UniqSupply
us (((Id, CoreExpr) -> Id) -> [(Id, CoreExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> Id
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 ] }
; (SpecEnv, SpecEnv, CoreBind) -> SpecM (SpecEnv, SpecEnv, CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (SpecEnv
env', SpecEnv
env', [(Id, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([Id]
bndrs' [Id] -> [CoreExpr] -> [(Id, CoreExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` ((Id, CoreExpr) -> CoreExpr) -> [(Id, CoreExpr)] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Id, CoreExpr) -> CoreExpr
forall a b. (a, b) -> b
snd [(Id, CoreExpr)]
pairs)) }
newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr
newDictBndr :: SpecEnv -> Id -> UniqSM Id
newDictBndr SpecEnv
env Id
b = do { Unique
uniq <- UniqSM Unique
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)
; Id -> UniqSM Id
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' (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
n)) }
newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id
newSpecIdSM :: Id -> Kind -> Maybe Int -> UniqSM Id
newSpecIdSM Id
old_id Kind
new_ty Maybe Int
join_arity_maybe
= do { Unique
uniq <- UniqSM Unique
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 (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
name)
Id -> Maybe Int -> Id
`asJoinId_maybe` Maybe Int
join_arity_maybe
; Id -> UniqSM Id
forall (m :: * -> *) a. Monad m => a -> m a
return Id
new_id }