{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where
#include "GhclibHsVersions.h"
import GHC.Prelude
import GHC.Types.Id
import GHC.Tc.Utils.TcType hiding( substTy )
import GHC.Core.Type hiding( substTy, extendTvSubstList )
import GHC.Core.Multiplicity
import GHC.Core.Predicate
import GHC.Unit.Module( Module, HasModule(..) )
import GHC.Core.Coercion( Coercion )
import GHC.Core.Opt.Monad
import qualified GHC.Core.Subst as Core
import GHC.Core.Unfold
import GHC.Types.Var ( isLocalVar )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Core
import GHC.Core.Rules
import GHC.Core.SimpleOpt ( collectBindersPushingCo )
import GHC.Core.Utils ( exprIsTrivial, getIdFromTrivialExpr_maybe
, mkCast, exprType )
import GHC.Core.FVs
import GHC.Core.Opt.Arity ( etaExpandToJoinPointRule )
import GHC.Types.Unique.Supply
import GHC.Types.Name
import GHC.Types.Id.Make ( voidArgId, voidPrimId )
import GHC.Builtin.Types.Prim ( voidPrimTy )
import GHC.Data.Maybe ( mapMaybe, maybeToList, isJust )
import GHC.Utils.Monad ( foldlM )
import GHC.Types.Basic
import GHC.Driver.Types
import GHC.Data.Bag
import GHC.Driver.Session
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Utils.Monad.State
import GHC.Types.Unique.DFM
import GHC.Core.TyCo.Rep (TyCoBinder (..))
import Control.Monad
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
; (CoreProgram
binds', UsageDetails
uds) <- DynFlags
-> Module
-> SpecM (CoreProgram, UsageDetails)
-> CoreM (CoreProgram, UsageDetails)
forall a. DynFlags -> Module -> SpecM a -> CoreM a
runSpecM DynFlags
dflags Module
this_mod (CoreProgram -> SpecM (CoreProgram, UsageDetails)
go CoreProgram
binds)
; ([CoreRule]
spec_rules, CoreProgram
spec_binds) <- DynFlags
-> Module
-> SpecEnv
-> [CoreRule]
-> UsageDetails
-> CoreM ([CoreRule], CoreProgram)
specImports DynFlags
dflags Module
this_mod 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 }) }
where
top_env :: SpecEnv
top_env = SE :: Subst -> VarSet -> SpecEnv
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
$ [Var] -> VarSet
mkVarSet ([Var] -> VarSet) -> [Var] -> VarSet
forall a b. (a -> b) -> a -> b
$
CoreProgram -> [Var]
forall b. [Bind b] -> [b]
bindersOfBinds CoreProgram
binds
, se_interesting :: VarSet
se_interesting = VarSet
emptyVarSet }
go :: CoreProgram -> SpecM (CoreProgram, UsageDetails)
go [] = (CoreProgram, UsageDetails) -> SpecM (CoreProgram, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], UsageDetails
emptyUDs)
go (CoreBind
bind:CoreProgram
binds) = do (CoreProgram
binds', UsageDetails
uds) <- CoreProgram -> SpecM (CoreProgram, UsageDetails)
go CoreProgram
binds
(CoreProgram
bind', UsageDetails
uds') <- SpecEnv
-> CoreBind -> UsageDetails -> SpecM (CoreProgram, UsageDetails)
specBind SpecEnv
top_env CoreBind
bind UsageDetails
uds
(CoreProgram, UsageDetails) -> SpecM (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')
specImports :: DynFlags -> Module -> SpecEnv
-> [CoreRule]
-> UsageDetails
-> CoreM ([CoreRule], [CoreBind])
specImports :: DynFlags
-> Module
-> SpecEnv
-> [CoreRule]
-> UsageDetails
-> CoreM ([CoreRule], CoreProgram)
specImports DynFlags
dflags Module
this_mod 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 DynFlags
dflags
= ([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) <- DynFlags
-> Module
-> SpecEnv
-> [Var]
-> RuleBase
-> Bag DictBind
-> CallDetails
-> CoreM ([CoreRule], CoreProgram)
spec_imports DynFlags
dflags Module
this_mod 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 = [[(Var, Expr Var)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(Var, Expr Var)] -> CoreBind) -> [(Var, Expr Var)] -> CoreBind
forall a b. (a -> b) -> a -> b
$ CoreProgram -> [(Var, Expr Var)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds (CoreProgram -> [(Var, Expr Var)])
-> CoreProgram -> [(Var, Expr Var)]
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 :: DynFlags
-> Module
-> SpecEnv
-> [Id]
-> RuleBase
-> Bag DictBind
-> CallDetails
-> CoreM ( [CoreRule]
, [CoreBind] )
spec_imports :: DynFlags
-> Module
-> SpecEnv
-> [Var]
-> RuleBase
-> Bag DictBind
-> CallDetails
-> CoreM ([CoreRule], CoreProgram)
spec_imports DynFlags
dflags Module
this_mod SpecEnv
top_env
[Var]
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) <- DynFlags
-> Module
-> SpecEnv
-> [Var]
-> RuleBase
-> Bag DictBind
-> CallInfoSet
-> CoreM ([CoreRule], CoreProgram)
spec_import DynFlags
dflags Module
this_mod SpecEnv
top_env
[Var]
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 :: DynFlags
-> Module
-> SpecEnv
-> [Id]
-> RuleBase
-> Bag DictBind
-> CallInfoSet
-> CoreM ( [CoreRule]
, [CoreBind] )
spec_import :: DynFlags
-> Module
-> SpecEnv
-> [Var]
-> RuleBase
-> Bag DictBind
-> CallInfoSet
-> CoreM ([CoreRule], CoreProgram)
spec_import DynFlags
dflags Module
this_mod SpecEnv
top_env [Var]
callers
RuleBase
rb Bag DictBind
dict_binds cis :: CallInfoSet
cis@(CIS Var
fn Bag CallInfo
_)
| String -> Var -> [Var] -> Bool
forall a. Eq a => String -> a -> [a] -> Bool
isIn String
"specImport" Var
fn [Var]
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
= do {
; ([CoreRule], CoreProgram) -> CoreM ([CoreRule], CoreProgram)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], []) }
| DynFlags -> Unfolding -> Bool
wantSpecImport DynFlags
dflags Unfolding
unfolding
, Just Expr Var
rhs <- Unfolding -> Maybe (Expr Var)
maybeUnfoldingTemplate Unfolding
unfolding
= 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 -> Var -> [CoreRule]
getRules (RuleBase -> ModuleSet -> RuleEnv
RuleEnv RuleBase
full_rb ModuleSet
vis_orphs) Var
fn
; ([CoreRule]
rules1, [(Var, Expr Var)]
spec_pairs, MkUD { ud_binds :: UsageDetails -> Bag DictBind
ud_binds = Bag DictBind
dict_binds1, ud_calls :: UsageDetails -> CallDetails
ud_calls = CallDetails
new_calls })
<- do {
; DynFlags
-> Module
-> SpecM ([CoreRule], [(Var, Expr Var)], UsageDetails)
-> CoreM ([CoreRule], [(Var, Expr Var)], UsageDetails)
forall a. DynFlags -> Module -> SpecM a -> CoreM a
runSpecM DynFlags
dflags Module
this_mod (SpecM ([CoreRule], [(Var, Expr Var)], UsageDetails)
-> CoreM ([CoreRule], [(Var, Expr Var)], UsageDetails))
-> SpecM ([CoreRule], [(Var, Expr Var)], UsageDetails)
-> CoreM ([CoreRule], [(Var, Expr Var)], UsageDetails)
forall a b. (a -> b) -> a -> b
$
Maybe Module
-> SpecEnv
-> [CoreRule]
-> [CallInfo]
-> Var
-> Expr Var
-> SpecM ([CoreRule], [(Var, Expr Var)], UsageDetails)
specCalls (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
this_mod) SpecEnv
top_env [CoreRule]
rules_for_fn [CallInfo]
good_calls Var
fn Expr Var
rhs }
; let spec_binds1 :: CoreProgram
spec_binds1 = [Var -> Expr Var -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Var
b Expr Var
r | (Var
b,Expr Var
r) <- [(Var, Expr Var)]
spec_pairs]
; ([CoreRule]
rules2, CoreProgram
spec_binds2) <- DynFlags
-> Module
-> SpecEnv
-> [Var]
-> RuleBase
-> Bag DictBind
-> CallDetails
-> CoreM ([CoreRule], CoreProgram)
spec_imports DynFlags
dflags Module
this_mod SpecEnv
top_env
(Var
fnVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
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 -> [Var] -> Var -> [CallInfo] -> CoreM ()
tryWarnMissingSpecs DynFlags
dflags [Var]
callers Var
fn [CallInfo]
good_calls
; ([CoreRule], CoreProgram) -> CoreM ([CoreRule], CoreProgram)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])}
where
unfolding :: Unfolding
unfolding = Var -> Unfolding
realIdUnfolding Var
fn
good_calls :: [CallInfo]
good_calls = CallInfoSet -> Bag DictBind -> [CallInfo]
filterCalls CallInfoSet
cis Bag DictBind
dict_binds
tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM ()
tryWarnMissingSpecs :: DynFlags -> [Var] -> Var -> [CallInfo] -> CoreM ()
tryWarnMissingSpecs DynFlags
dflags [Var]
callers Var
fn [CallInfo]
calls_for_fn
| WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnMissedSpecs DynFlags
dflags
Bool -> Bool -> Bool
&& Bool -> Bool
not ([Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
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 = (Var -> Bool) -> [Var] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (InlinePragma -> Bool
isAnyInlinePragma (InlinePragma -> Bool) -> (Var -> InlinePragma) -> Var -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> InlinePragma
idInlinePragma) [Var]
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 (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
fn))
Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"when specialising" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
caller)
| Var
caller <- [Var]
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 (Var -> CallInfo -> SDoc
pprCallInfo Var
fn) [CallInfo]
calls_for_fn))
, String -> SDoc
text String
"Probable fix: add INLINABLE pragma on" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
fn) ])
wantSpecImport :: DynFlags -> Unfolding -> Bool
wantSpecImport :: DynFlags -> Unfolding -> Bool
wantSpecImport DynFlags
dflags Unfolding
unf
= case Unfolding
unf of
Unfolding
NoUnfolding -> Bool
False
Unfolding
BootUnfolding -> Bool
False
OtherCon {} -> Bool
False
DFunUnfolding {} -> Bool
True
CoreUnfolding { uf_src :: Unfolding -> UnfoldingSource
uf_src = UnfoldingSource
src, uf_guidance :: Unfolding -> UnfoldingGuidance
uf_guidance = UnfoldingGuidance
_guidance }
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SpecialiseAggressively DynFlags
dflags -> Bool
True
| UnfoldingSource -> Bool
isStableSource UnfoldingSource
src -> Bool
True
| Bool
otherwise -> Bool
False
data SpecEnv
= SE { SpecEnv -> Subst
se_subst :: Core.Subst
, SpecEnv -> VarSet
se_interesting :: VarSet
}
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 -> Var -> Expr Var
specVar SpecEnv
env Var
v = HasDebugCallStack => Subst -> Var -> Expr Var
Subst -> Var -> Expr Var
Core.lookupIdSubst (SpecEnv -> Subst
se_subst SpecEnv
env) Var
v
specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr :: SpecEnv -> Expr Var -> SpecM (Expr Var, UsageDetails)
specExpr SpecEnv
env (Type Type
ty) = (Expr Var, UsageDetails) -> SpecM (Expr Var, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Expr Var
forall b. Type -> Expr b
Type (SpecEnv -> Type -> Type
substTy SpecEnv
env Type
ty), UsageDetails
emptyUDs)
specExpr SpecEnv
env (Coercion Coercion
co) = (Expr Var, UsageDetails) -> SpecM (Expr Var, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> Expr Var
forall b. Coercion -> Expr b
Coercion (SpecEnv -> Coercion -> Coercion
substCo SpecEnv
env Coercion
co), UsageDetails
emptyUDs)
specExpr SpecEnv
env (Var Var
v) = (Expr Var, UsageDetails) -> SpecM (Expr Var, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (SpecEnv -> Var -> Expr Var
specVar SpecEnv
env Var
v, UsageDetails
emptyUDs)
specExpr SpecEnv
_ (Lit Literal
lit) = (Expr Var, UsageDetails) -> SpecM (Expr Var, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> Expr Var
forall b. Literal -> Expr b
Lit Literal
lit, UsageDetails
emptyUDs)
specExpr SpecEnv
env (Cast Expr Var
e Coercion
co)
= do { (Expr Var
e', UsageDetails
uds) <- SpecEnv -> Expr Var -> SpecM (Expr Var, UsageDetails)
specExpr SpecEnv
env Expr Var
e
; (Expr Var, UsageDetails) -> SpecM (Expr Var, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Expr Var -> Coercion -> Expr Var
mkCast Expr Var
e' (SpecEnv -> Coercion -> Coercion
substCo SpecEnv
env Coercion
co)), UsageDetails
uds) }
specExpr SpecEnv
env (Tick Tickish Var
tickish Expr Var
body)
= do { (Expr Var
body', UsageDetails
uds) <- SpecEnv -> Expr Var -> SpecM (Expr Var, UsageDetails)
specExpr SpecEnv
env Expr Var
body
; (Expr Var, UsageDetails) -> SpecM (Expr Var, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Tickish Var -> Expr Var -> Expr Var
forall b. Tickish Var -> Expr b -> Expr b
Tick (SpecEnv -> Tickish Var -> Tickish Var
specTickish SpecEnv
env Tickish Var
tickish) Expr Var
body', UsageDetails
uds) }
specExpr SpecEnv
env expr :: Expr Var
expr@(App {})
= Expr Var -> [Expr Var] -> SpecM (Expr Var, UsageDetails)
go Expr Var
expr []
where
go :: Expr Var -> [Expr Var] -> SpecM (Expr Var, UsageDetails)
go (App Expr Var
fun Expr Var
arg) [Expr Var]
args = do (Expr Var
arg', UsageDetails
uds_arg) <- SpecEnv -> Expr Var -> SpecM (Expr Var, UsageDetails)
specExpr SpecEnv
env Expr Var
arg
(Expr Var
fun', UsageDetails
uds_app) <- Expr Var -> [Expr Var] -> SpecM (Expr Var, UsageDetails)
go Expr Var
fun (Expr Var
arg'Expr Var -> [Expr Var] -> [Expr Var]
forall a. a -> [a] -> [a]
:[Expr Var]
args)
(Expr Var, UsageDetails) -> SpecM (Expr Var, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Var -> Expr Var -> Expr Var
forall b. Expr b -> Expr b -> Expr b
App Expr Var
fun' Expr Var
arg', UsageDetails
uds_arg UsageDetails -> UsageDetails -> UsageDetails
`plusUDs` UsageDetails
uds_app)
go (Var Var
f) [Expr Var]
args = case SpecEnv -> Var -> Expr Var
specVar SpecEnv
env Var
f of
Var Var
f' -> (Expr Var, UsageDetails) -> SpecM (Expr Var, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Expr Var
forall b. Var -> Expr b
Var Var
f', SpecEnv -> Var -> [Expr Var] -> UsageDetails
mkCallUDs SpecEnv
env Var
f' [Expr Var]
args)
Expr Var
e' -> (Expr Var, UsageDetails) -> SpecM (Expr Var, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Var
e', UsageDetails
emptyUDs)
go Expr Var
other [Expr Var]
_ = SpecEnv -> Expr Var -> SpecM (Expr Var, UsageDetails)
specExpr SpecEnv
env Expr Var
other
specExpr SpecEnv
env e :: Expr Var
e@(Lam {})
= SpecEnv -> [Var] -> Expr Var -> SpecM (Expr Var, UsageDetails)
specLam SpecEnv
env' [Var]
bndrs' Expr Var
body
where
([Var]
bndrs, Expr Var
body) = Expr Var -> ([Var], Expr Var)
forall b. Expr b -> ([b], Expr b)
collectBinders Expr Var
e
(SpecEnv
env', [Var]
bndrs') = SpecEnv -> [Var] -> (SpecEnv, [Var])
substBndrs SpecEnv
env [Var]
bndrs
specExpr SpecEnv
env (Case Expr Var
scrut Var
case_bndr Type
ty [Alt Var]
alts)
= do { (Expr Var
scrut', UsageDetails
scrut_uds) <- SpecEnv -> Expr Var -> SpecM (Expr Var, UsageDetails)
specExpr SpecEnv
env Expr Var
scrut
; (Expr Var
scrut'', Var
case_bndr', [Alt Var]
alts', UsageDetails
alts_uds)
<- SpecEnv
-> Expr Var
-> Var
-> [Alt Var]
-> SpecM (Expr Var, Var, [Alt Var], UsageDetails)
specCase SpecEnv
env Expr Var
scrut' Var
case_bndr [Alt Var]
alts
; (Expr Var, UsageDetails) -> SpecM (Expr Var, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Var -> Var -> Type -> [Alt Var] -> Expr Var
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case Expr Var
scrut'' Var
case_bndr' (SpecEnv -> Type -> Type
substTy SpecEnv
env Type
ty) [Alt Var]
alts'
, UsageDetails
scrut_uds UsageDetails -> UsageDetails -> UsageDetails
`plusUDs` UsageDetails
alts_uds) }
specExpr SpecEnv
env (Let CoreBind
bind Expr Var
body)
= do {
(SpecEnv
rhs_env, SpecEnv
body_env, CoreBind
bind') <- SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind)
cloneBindSM SpecEnv
env CoreBind
bind
; (Expr Var
body', UsageDetails
body_uds) <- SpecEnv -> Expr Var -> SpecM (Expr Var, UsageDetails)
specExpr SpecEnv
body_env Expr Var
body
; (CoreProgram
binds', UsageDetails
uds) <- SpecEnv
-> CoreBind -> UsageDetails -> SpecM (CoreProgram, UsageDetails)
specBind SpecEnv
rhs_env CoreBind
bind' UsageDetails
body_uds
; (Expr Var, UsageDetails) -> SpecM (Expr Var, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ((CoreBind -> Expr Var -> Expr Var)
-> Expr Var -> CoreProgram -> Expr Var
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CoreBind -> Expr Var -> Expr Var
forall b. Bind b -> Expr b -> Expr b
Let Expr Var
body' CoreProgram
binds', UsageDetails
uds) }
specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails)
specLam :: SpecEnv -> [Var] -> Expr Var -> SpecM (Expr Var, UsageDetails)
specLam SpecEnv
env [Var]
bndrs Expr Var
body
| [Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
bndrs
= SpecEnv -> Expr Var -> SpecM (Expr Var, UsageDetails)
specExpr SpecEnv
env Expr Var
body
| Bool
otherwise
= do { (Expr Var
body', UsageDetails
uds) <- SpecEnv -> Expr Var -> SpecM (Expr Var, UsageDetails)
specExpr SpecEnv
env Expr Var
body
; let (UsageDetails
free_uds, Bag DictBind
dumped_dbs) = [Var] -> UsageDetails -> (UsageDetails, Bag DictBind)
dumpUDs [Var]
bndrs UsageDetails
uds
; (Expr Var, UsageDetails) -> SpecM (Expr Var, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Var] -> Expr Var -> Expr Var
forall b. [b] -> Expr b -> Expr b
mkLams [Var]
bndrs (Bag DictBind -> Expr Var -> Expr Var
wrapDictBindsE Bag DictBind
dumped_dbs Expr Var
body'), UsageDetails
free_uds) }
specTickish :: SpecEnv -> Tickish Id -> Tickish Id
specTickish :: SpecEnv -> Tickish Var -> Tickish Var
specTickish SpecEnv
env (Breakpoint Int
ix [Var]
ids)
= Int -> [Var] -> Tickish Var
forall id. Int -> [id] -> Tickish id
Breakpoint Int
ix [ Var
id' | Var
id <- [Var]
ids, Var Var
id' <- [SpecEnv -> Var -> Expr Var
specVar SpecEnv
env Var
id]]
specTickish SpecEnv
_ Tickish Var
other_tickish = Tickish Var
other_tickish
specCase :: SpecEnv
-> CoreExpr
-> Id -> [CoreAlt]
-> SpecM ( CoreExpr
, Id
, [CoreAlt]
, UsageDetails)
specCase :: SpecEnv
-> Expr Var
-> Var
-> [Alt Var]
-> SpecM (Expr Var, Var, [Alt Var], UsageDetails)
specCase SpecEnv
env Expr Var
scrut' Var
case_bndr [(AltCon
con, [Var]
args, Expr Var
rhs)]
| Var -> Bool
isDictId Var
case_bndr
, SpecEnv -> Expr Var -> Bool
interestingDict SpecEnv
env Expr Var
scrut'
, Bool -> Bool
not (Var -> Bool
isDeadBinder Var
case_bndr Bool -> Bool -> Bool
&& [Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
sc_args')
= do { (Var
case_bndr_flt : [Var]
sc_args_flt) <- (Var -> SpecM Var) -> [Var] -> SpecM [Var]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Var -> SpecM Var
forall (m :: * -> *). MonadUnique m => Var -> m Var
clone_me (Var
case_bndr' Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Var]
sc_args')
; let sc_rhss :: [Expr Var]
sc_rhss = [ Expr Var -> Var -> Type -> [Alt Var] -> Expr Var
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (Var -> Expr Var
forall b. Var -> Expr b
Var Var
case_bndr_flt) Var
case_bndr' (Var -> Type
idType Var
sc_arg')
[(AltCon
con, [Var]
args', Var -> Expr Var
forall b. Var -> Expr b
Var Var
sc_arg')]
| Var
sc_arg' <- [Var]
sc_args' ]
mb_sc_flts :: [Maybe DictId]
mb_sc_flts :: [Maybe Var]
mb_sc_flts = (Var -> Maybe Var) -> [Var] -> [Maybe Var]
forall a b. (a -> b) -> [a] -> [b]
map (VarEnv Var -> Var -> Maybe Var
forall a. VarEnv a -> Var -> Maybe a
lookupVarEnv VarEnv Var
clone_env) [Var]
args'
clone_env :: VarEnv Var
clone_env = [Var] -> [Var] -> VarEnv Var
forall a. [Var] -> [a] -> VarEnv a
zipVarEnv [Var]
sc_args' [Var]
sc_args_flt
subst_prs :: [(Var, Expr b)]
subst_prs = (Var
case_bndr, Var -> Expr b
forall b. Var -> Expr b
Var Var
case_bndr_flt)
(Var, Expr b) -> [(Var, Expr b)] -> [(Var, Expr b)]
forall a. a -> [a] -> [a]
: [ (Var
arg, Var -> Expr b
forall b. Var -> Expr b
Var Var
sc_flt)
| (Var
arg, Just Var
sc_flt) <- [Var]
args [Var] -> [Maybe Var] -> [(Var, Maybe Var)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Maybe Var]
mb_sc_flts ]
env_rhs' :: SpecEnv
env_rhs' = SpecEnv
env_rhs { se_subst :: Subst
se_subst = Subst -> [(Var, Expr Var)] -> Subst
Core.extendIdSubstList (SpecEnv -> Subst
se_subst SpecEnv
env_rhs) [(Var, Expr Var)]
forall b. [(Var, Expr b)]
subst_prs
, se_interesting :: VarSet
se_interesting = SpecEnv -> VarSet
se_interesting SpecEnv
env_rhs VarSet -> [Var] -> VarSet
`extendVarSetList`
(Var
case_bndr_flt Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Var]
sc_args_flt) }
; (Expr Var
rhs', UsageDetails
rhs_uds) <- SpecEnv -> Expr Var -> SpecM (Expr Var, UsageDetails)
specExpr SpecEnv
env_rhs' Expr Var
rhs
; let scrut_bind :: DictBind
scrut_bind = CoreBind -> DictBind
mkDB (Var -> Expr Var -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Var
case_bndr_flt Expr Var
scrut')
case_bndr_set :: VarSet
case_bndr_set = Var -> VarSet
unitVarSet Var
case_bndr_flt
sc_binds :: [DictBind]
sc_binds = [ DB :: CoreBind -> VarSet -> DictBind
DB { db_bind :: CoreBind
db_bind = Var -> Expr Var -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Var
sc_arg_flt Expr Var
sc_rhs
, db_fvs :: VarSet
db_fvs = VarSet
case_bndr_set }
| (Var
sc_arg_flt, Expr Var
sc_rhs) <- [Var]
sc_args_flt [Var] -> [Expr Var] -> [(Var, Expr Var)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Expr Var]
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) = [Var] -> UsageDetails -> (UsageDetails, Bag DictBind)
dumpUDs (Var
case_bndr'Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
args') UsageDetails
rhs_uds
all_uds :: UsageDetails
all_uds = [DictBind]
flt_binds [DictBind] -> UsageDetails -> UsageDetails
`addDictBinds` UsageDetails
free_uds
alt' :: Alt Var
alt' = (AltCon
con, [Var]
args', Bag DictBind -> Expr Var -> Expr Var
wrapDictBindsE Bag DictBind
dumped_dbs Expr Var
rhs')
; (Expr Var, Var, [Alt Var], UsageDetails)
-> SpecM (Expr Var, Var, [Alt Var], UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Expr Var
forall b. Var -> Expr b
Var Var
case_bndr_flt, Var
case_bndr', [Alt Var
alt'], UsageDetails
all_uds) }
where
(SpecEnv
env_rhs, (Var
case_bndr':[Var]
args')) = SpecEnv -> [Var] -> (SpecEnv, [Var])
substBndrs SpecEnv
env (Var
case_bndrVar -> [Var] -> [Var]
forall a. a -> [a] -> [a]
:[Var]
args)
sc_args' :: [Var]
sc_args' = (Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter Var -> Bool
is_flt_sc_arg [Var]
args'
clone_me :: Var -> m Var
clone_me Var
bndr = do { Unique
uniq <- m Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; Var -> m Var
forall (m :: * -> *) a. Monad m => a -> m a
return (OccName -> Unique -> Type -> Type -> SrcSpan -> Var
mkUserLocalOrCoVar OccName
occ Unique
uniq Type
wght Type
ty SrcSpan
loc) }
where
name :: Name
name = Var -> Name
idName Var
bndr
wght :: Type
wght = Var -> Type
idMult Var
bndr
ty :: Type
ty = Var -> Type
idType Var
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 = [Var] -> VarSet
mkVarSet [Var]
args'
is_flt_sc_arg :: Var -> Bool
is_flt_sc_arg Var
var = Var -> Bool
isId Var
var
Bool -> Bool -> Bool
&& Bool -> Bool
not (Var -> Bool
isDeadBinder Var
var)
Bool -> Bool -> Bool
&& Type -> Bool
isDictTy Type
var_ty
Bool -> Bool -> Bool
&& Type -> VarSet
tyCoVarsOfType Type
var_ty VarSet -> VarSet -> Bool
`disjointVarSet` VarSet
arg_set
where
var_ty :: Type
var_ty = Var -> Type
idType Var
var
specCase SpecEnv
env Expr Var
scrut Var
case_bndr [Alt Var]
alts
= do { ([Alt Var]
alts', UsageDetails
uds_alts) <- (Alt Var -> SpecM (Alt Var, UsageDetails))
-> [Alt Var] -> SpecM ([Alt Var], UsageDetails)
forall a b.
(a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM Alt Var -> SpecM (Alt Var, UsageDetails)
forall a.
(a, [Var], Expr Var) -> SpecM ((a, [Var], Expr Var), UsageDetails)
spec_alt [Alt Var]
alts
; (Expr Var, Var, [Alt Var], UsageDetails)
-> SpecM (Expr Var, Var, [Alt Var], UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr Var
scrut, Var
case_bndr', [Alt Var]
alts', UsageDetails
uds_alts) }
where
(SpecEnv
env_alt, Var
case_bndr') = SpecEnv -> Var -> (SpecEnv, Var)
substBndr SpecEnv
env Var
case_bndr
spec_alt :: (a, [Var], Expr Var) -> SpecM ((a, [Var], Expr Var), UsageDetails)
spec_alt (a
con, [Var]
args, Expr Var
rhs) = do
(Expr Var
rhs', UsageDetails
uds) <- SpecEnv -> Expr Var -> SpecM (Expr Var, UsageDetails)
specExpr SpecEnv
env_rhs Expr Var
rhs
let (UsageDetails
free_uds, Bag DictBind
dumped_dbs) = [Var] -> UsageDetails -> (UsageDetails, Bag DictBind)
dumpUDs (Var
case_bndr' Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Var]
args') UsageDetails
uds
((a, [Var], Expr Var), UsageDetails)
-> SpecM ((a, [Var], Expr Var), UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
con, [Var]
args', Bag DictBind -> Expr Var -> Expr Var
wrapDictBindsE Bag DictBind
dumped_dbs Expr Var
rhs'), UsageDetails
free_uds)
where
(SpecEnv
env_rhs, [Var]
args') = SpecEnv -> [Var] -> (SpecEnv, [Var])
substBndrs SpecEnv
env_alt [Var]
args
specBind :: SpecEnv
-> CoreBind
-> UsageDetails
-> SpecM ([CoreBind],
UsageDetails)
specBind :: SpecEnv
-> CoreBind -> UsageDetails -> SpecM (CoreProgram, UsageDetails)
specBind SpecEnv
rhs_env (NonRec Var
fn Expr Var
rhs) UsageDetails
body_uds
= do { (Expr Var
rhs', UsageDetails
rhs_uds) <- SpecEnv -> Expr Var -> SpecM (Expr Var, UsageDetails)
specExpr SpecEnv
rhs_env Expr Var
rhs
; let zapped_fn :: Var
zapped_fn = Var -> Var
zapIdDemandInfo Var
fn
; (Var
fn', [(Var, Expr Var)]
spec_defns, UsageDetails
body_uds1) <- SpecEnv
-> UsageDetails
-> Var
-> Expr Var
-> SpecM (Var, [(Var, Expr Var)], UsageDetails)
specDefn SpecEnv
rhs_env UsageDetails
body_uds Var
zapped_fn Expr Var
rhs
; let pairs :: [(Var, Expr Var)]
pairs = [(Var, Expr Var)]
spec_defns [(Var, Expr Var)] -> [(Var, Expr Var)] -> [(Var, Expr Var)]
forall a. [a] -> [a] -> [a]
++ [(Var
fn', Expr Var
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) = [Var] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)
dumpBindUDs [Var
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 ([(Var, Expr Var)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var, Expr Var)]
spec_defns)
= [[(Var, Expr Var)] -> Bag DictBind -> DictBind
recWithDumpedDicts [(Var, Expr Var)]
pairs Bag DictBind
dump_dbs]
| Bool
otherwise
= [CoreBind -> DictBind
mkDB (CoreBind -> DictBind) -> CoreBind -> DictBind
forall a b. (a -> b) -> a -> b
$ Var -> Expr Var -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Var
b Expr Var
r | (Var
b,Expr Var
r) <- [(Var, Expr Var)]
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) -> SpecM (CoreProgram, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], UsageDetails
free_uds UsageDetails -> [DictBind] -> UsageDetails
`snocDictBinds` [DictBind]
final_binds)
else
(CoreProgram, UsageDetails) -> SpecM (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 [(Var, Expr Var)]
pairs) UsageDetails
body_uds
= do { let ([Var]
bndrs,[Expr Var]
rhss) = [(Var, Expr Var)] -> ([Var], [Expr Var])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Var, Expr Var)]
pairs
; ([Expr Var]
rhss', UsageDetails
rhs_uds) <- (Expr Var -> SpecM (Expr Var, UsageDetails))
-> [Expr Var] -> SpecM ([Expr Var], UsageDetails)
forall a b.
(a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM (SpecEnv -> Expr Var -> SpecM (Expr Var, UsageDetails)
specExpr SpecEnv
rhs_env) [Expr Var]
rhss
; let scope_uds :: UsageDetails
scope_uds = UsageDetails
body_uds UsageDetails -> UsageDetails -> UsageDetails
`plusUDs` UsageDetails
rhs_uds
; ([Var]
bndrs1, [(Var, Expr Var)]
spec_defns1, UsageDetails
uds1) <- SpecEnv
-> UsageDetails
-> [(Var, Expr Var)]
-> SpecM ([Var], [(Var, Expr Var)], UsageDetails)
specDefns SpecEnv
rhs_env UsageDetails
scope_uds [(Var, Expr Var)]
pairs
; ([Var]
bndrs3, [(Var, Expr Var)]
spec_defns3, UsageDetails
uds3)
<- if [(Var, Expr Var)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Var, Expr Var)]
spec_defns1
then ([Var], [(Var, Expr Var)], UsageDetails)
-> SpecM ([Var], [(Var, Expr Var)], UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Var]
bndrs1, [], UsageDetails
uds1)
else do {
([Var]
bndrs2, [(Var, Expr Var)]
spec_defns2, UsageDetails
uds2)
<- SpecEnv
-> UsageDetails
-> [(Var, Expr Var)]
-> SpecM ([Var], [(Var, Expr Var)], UsageDetails)
specDefns SpecEnv
rhs_env UsageDetails
uds1 ([Var]
bndrs1 [Var] -> [Expr Var] -> [(Var, Expr Var)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Expr Var]
rhss)
; ([Var], [(Var, Expr Var)], UsageDetails)
-> SpecM ([Var], [(Var, Expr Var)], UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Var]
bndrs2, [(Var, Expr Var)]
spec_defns2 [(Var, Expr Var)] -> [(Var, Expr Var)] -> [(Var, Expr Var)]
forall a. [a] -> [a] -> [a]
++ [(Var, Expr Var)]
spec_defns1, UsageDetails
uds2) }
; let (UsageDetails
final_uds, Bag DictBind
dumped_dbs, Bool
float_all) = [Var] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)
dumpBindUDs [Var]
bndrs UsageDetails
uds3
final_bind :: DictBind
final_bind = [(Var, Expr Var)] -> Bag DictBind -> DictBind
recWithDumpedDicts ([(Var, Expr Var)]
spec_defns3 [(Var, Expr Var)] -> [(Var, Expr Var)] -> [(Var, Expr Var)]
forall a. [a] -> [a] -> [a]
++ [Var] -> [Expr Var] -> [(Var, Expr Var)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
bndrs3 [Expr Var]
rhss')
Bag DictBind
dumped_dbs
; if Bool
float_all then
(CoreProgram, UsageDetails) -> SpecM (CoreProgram, UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], UsageDetails
final_uds UsageDetails -> DictBind -> UsageDetails
`snocDictBind` DictBind
final_bind)
else
(CoreProgram, UsageDetails) -> SpecM (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
-> [(Var, Expr Var)]
-> SpecM ([Var], [(Var, Expr Var)], UsageDetails)
specDefns SpecEnv
_env UsageDetails
uds []
= ([Var], [(Var, Expr Var)], UsageDetails)
-> SpecM ([Var], [(Var, Expr Var)], UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], UsageDetails
uds)
specDefns SpecEnv
env UsageDetails
uds ((Var
bndr,Expr Var
rhs):[(Var, Expr Var)]
pairs)
= do { ([Var]
bndrs1, [(Var, Expr Var)]
spec_defns1, UsageDetails
uds1) <- SpecEnv
-> UsageDetails
-> [(Var, Expr Var)]
-> SpecM ([Var], [(Var, Expr Var)], UsageDetails)
specDefns SpecEnv
env UsageDetails
uds [(Var, Expr Var)]
pairs
; (Var
bndr1, [(Var, Expr Var)]
spec_defns2, UsageDetails
uds2) <- SpecEnv
-> UsageDetails
-> Var
-> Expr Var
-> SpecM (Var, [(Var, Expr Var)], UsageDetails)
specDefn SpecEnv
env UsageDetails
uds1 Var
bndr Expr Var
rhs
; ([Var], [(Var, Expr Var)], UsageDetails)
-> SpecM ([Var], [(Var, Expr Var)], UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return (Var
bndr1 Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Var]
bndrs1, [(Var, Expr Var)]
spec_defns1 [(Var, Expr Var)] -> [(Var, Expr Var)] -> [(Var, Expr Var)]
forall a. [a] -> [a] -> [a]
++ [(Var, Expr Var)]
spec_defns2, UsageDetails
uds2) }
specDefn :: SpecEnv
-> UsageDetails
-> OutId -> InExpr
-> SpecM (Id,
[(Id,CoreExpr)],
UsageDetails)
specDefn :: SpecEnv
-> UsageDetails
-> Var
-> Expr Var
-> SpecM (Var, [(Var, Expr Var)], UsageDetails)
specDefn SpecEnv
env UsageDetails
body_uds Var
fn Expr Var
rhs
= do { let (UsageDetails
body_uds_without_me, [CallInfo]
calls_for_me) = Var -> UsageDetails -> (UsageDetails, [CallInfo])
callsForMe Var
fn UsageDetails
body_uds
rules_for_me :: [CoreRule]
rules_for_me = Var -> [CoreRule]
idCoreRules Var
fn
; ([CoreRule]
rules, [(Var, Expr Var)]
spec_defns, UsageDetails
spec_uds) <- Maybe Module
-> SpecEnv
-> [CoreRule]
-> [CallInfo]
-> Var
-> Expr Var
-> SpecM ([CoreRule], [(Var, Expr Var)], UsageDetails)
specCalls Maybe Module
forall a. Maybe a
Nothing SpecEnv
env [CoreRule]
rules_for_me
[CallInfo]
calls_for_me Var
fn Expr Var
rhs
; (Var, [(Var, Expr Var)], UsageDetails)
-> SpecM (Var, [(Var, Expr Var)], UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ( Var
fn Var -> [CoreRule] -> Var
`addIdSpecialisations` [CoreRule]
rules
, [(Var, Expr Var)]
spec_defns
, UsageDetails
body_uds_without_me UsageDetails -> UsageDetails -> UsageDetails
`plusUDs` UsageDetails
spec_uds) }
specCalls :: Maybe Module
-> SpecEnv
-> [CoreRule]
-> [CallInfo]
-> OutId -> InExpr
-> SpecM SpecInfo
type SpecInfo = ( [CoreRule]
, [(Id,CoreExpr)]
, UsageDetails )
specCalls :: Maybe Module
-> SpecEnv
-> [CoreRule]
-> [CallInfo]
-> Var
-> Expr Var
-> SpecM ([CoreRule], [(Var, Expr Var)], UsageDetails)
specCalls Maybe Module
mb_mod SpecEnv
env [CoreRule]
existing_rules [CallInfo]
calls_for_me Var
fn Expr Var
rhs
| [CallInfo] -> Bool
forall a. [a] -> Bool
notNull [CallInfo]
calls_for_me
Bool -> Bool -> Bool
&& Bool -> Bool
not (Activation -> Bool
isNeverActive (Var -> Activation
idInlineActivation Var
fn))
=
(([CoreRule], [(Var, Expr Var)], UsageDetails)
-> CallInfo -> SpecM ([CoreRule], [(Var, Expr Var)], UsageDetails))
-> ([CoreRule], [(Var, Expr Var)], UsageDetails)
-> [CallInfo]
-> SpecM ([CoreRule], [(Var, Expr Var)], UsageDetails)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ([CoreRule], [(Var, Expr Var)], UsageDetails)
-> CallInfo -> SpecM ([CoreRule], [(Var, Expr Var)], 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], [(Var, Expr Var)], UsageDetails)
-> SpecM ([CoreRule], [(Var, Expr Var)], UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], UsageDetails
emptyUDs)
where
_trace_doc :: SDoc
_trace_doc = [SDoc] -> SDoc
sep [ [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
rhs_bndrs, Activation -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Var -> Activation
idInlineActivation Var
fn) ]
fn_type :: Type
fn_type = Var -> Type
idType Var
fn
fn_arity :: Int
fn_arity = Var -> Int
idArity Var
fn
fn_unf :: Unfolding
fn_unf = Var -> Unfolding
realIdUnfolding Var
fn
inl_prag :: InlinePragma
inl_prag = Var -> InlinePragma
idInlinePragma Var
fn
inl_act :: Activation
inl_act = InlinePragma -> Activation
inlinePragmaActivation InlinePragma
inl_prag
is_local :: Bool
is_local = Var -> Bool
isLocalId Var
fn
is_dfun :: Bool
is_dfun = Var -> Bool
isDFunId Var
fn
([Var]
rhs_bndrs, Expr Var
rhs_body) = Expr Var -> ([Var], Expr Var)
collectBindersPushingCo Expr Var
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] -> [Expr Var] -> Bool
already_covered RuleOpts
ropts [CoreRule]
new_rules [Expr Var]
args
= Maybe (CoreRule, Expr Var) -> Bool
forall a. Maybe a -> Bool
isJust (RuleOpts
-> InScopeEnv
-> (Activation -> Bool)
-> Var
-> [Expr Var]
-> [CoreRule]
-> Maybe (CoreRule, Expr Var)
lookupRule RuleOpts
ropts (InScopeSet
in_scope, Var -> Unfolding
realIdUnfolding)
(Bool -> Activation -> Bool
forall a b. a -> b -> a
const Bool
True) Var
fn [Expr Var]
args
([CoreRule]
new_rules [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
++ [CoreRule]
existing_rules))
spec_call :: SpecInfo
-> CallInfo
-> SpecM SpecInfo
spec_call :: ([CoreRule], [(Var, Expr Var)], UsageDetails)
-> CallInfo -> SpecM ([CoreRule], [(Var, Expr Var)], UsageDetails)
spec_call spec_acc :: ([CoreRule], [(Var, Expr Var)], UsageDetails)
spec_acc@([CoreRule]
rules_acc, [(Var, Expr Var)]
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, [Var]
leftover_bndrs
, [Var]
rule_bndrs, [Expr Var]
rule_lhs_args
, [Var]
spec_bndrs1, [DictBind]
dx_binds, [Expr Var]
spec_args) <- SpecEnv
-> [Var]
-> [SpecArg]
-> SpecM
(Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
specHeader SpecEnv
env [Var]
rhs_bndrs [SpecArg]
all_call_args
; DynFlags
dflags <- SpecM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let ropts :: RuleOpts
ropts = DynFlags -> RuleOpts
initRuleOpts DynFlags
dflags
; if Bool -> Bool
not Bool
useful
Bool -> Bool -> Bool
|| RuleOpts -> [CoreRule] -> [Expr Var] -> Bool
already_covered RuleOpts
ropts [CoreRule]
rules_acc [Expr Var]
rule_lhs_args
then ([CoreRule], [(Var, Expr Var)], UsageDetails)
-> SpecM ([CoreRule], [(Var, Expr Var)], UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreRule], [(Var, Expr Var)], UsageDetails)
spec_acc
else
do {
; (Expr Var
spec_rhs1, UsageDetails
rhs_uds) <- SpecEnv -> [Var] -> Expr Var -> SpecM (Expr Var, UsageDetails)
specLam SpecEnv
rhs_env2 ([Var]
spec_bndrs1 [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
leftover_bndrs) Expr Var
rhs_body
; let spec_fn_ty1 :: Type
spec_fn_ty1 = Expr Var -> Type
exprType Expr Var
spec_rhs1
add_void_arg :: Bool
add_void_arg = HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
spec_fn_ty1 Bool -> Bool -> Bool
&& Bool -> Bool
not (Var -> Bool
isJoinId Var
fn)
([Var]
spec_bndrs, Expr Var
spec_rhs, Type
spec_fn_ty)
| Bool
add_void_arg = ( Var
voidPrimId Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Var]
spec_bndrs1
, Var -> Expr Var -> Expr Var
forall b. b -> Expr b -> Expr b
Lam Var
voidArgId Expr Var
spec_rhs1
, Type -> Type -> Type
mkVisFunTyMany Type
voidPrimTy Type
spec_fn_ty1)
| Bool
otherwise = ([Var]
spec_bndrs1, Expr Var
spec_rhs1, Type
spec_fn_ty1)
join_arity_decr :: Int
join_arity_decr = [Expr Var] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr Var]
rule_lhs_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Var] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Var]
spec_bndrs
spec_join_arity :: Maybe Int
spec_join_arity | Just Int
orig_join_arity <- Var -> Maybe Int
isJoinId_maybe Var
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
; Var
spec_fn <- Var -> Type -> Maybe Int -> SpecM Var
newSpecIdSM Var
fn Type
spec_fn_ty Maybe Int
spec_join_arity
; Module
this_mod <- SpecM Module
forall (m :: * -> *). HasModule m => m Module
getModule
; let
herald :: SDoc
herald = case Maybe Module
mb_mod of
Maybe Module
Nothing
-> String -> SDoc
text String
"SPEC"
Just Module
this_mod
-> String -> SDoc
text String
"SPEC/" SDoc -> SDoc -> SDoc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod
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 (Var -> OccName
forall a. NamedThing a => a -> OccName
getOccName Var
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
-> [Var]
-> [Expr Var]
-> Expr Var
-> CoreRule
mkRule
Module
this_mod
Bool
True
Bool
is_local
FastString
rule_name
Activation
inl_act
(Var -> Name
idName Var
fn)
[Var]
rule_bndrs
[Expr Var]
rule_lhs_args
(Expr Var -> [Var] -> Expr Var
forall b. Expr b -> [Var] -> Expr b
mkVarApps (Var -> Expr Var
forall b. Var -> Expr b
Var Var
spec_fn) [Var]
spec_bndrs)
spec_rule :: CoreRule
spec_rule
= case Var -> Maybe Int
isJoinId_maybe Var
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
(InlinePragma
spec_inl_prag, Unfolding
spec_unf)
| Bool -> Bool
not Bool
is_local Bool -> Bool -> Bool
&& OccInfo -> Bool
isStrongLoopBreaker (Var -> OccInfo
idOccInfo Var
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
NoUserInline }, Unfolding
noUnfolding)
| Bool
otherwise
= (InlinePragma
inl_prag, DynFlags
-> [Var]
-> (Expr Var -> Expr Var)
-> [Expr Var]
-> Unfolding
-> Unfolding
specUnfolding DynFlags
dflags [Var]
spec_bndrs (Expr Var -> [Expr Var] -> Expr Var
forall b. Expr b -> [Expr b] -> Expr b
`mkApps` [Expr Var]
spec_args)
[Expr Var]
rule_lhs_args Unfolding
fn_unf)
arity_decr :: Int
arity_decr = (Expr Var -> Bool) -> [Expr Var] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Expr Var -> Bool
forall b. Expr b -> Bool
isValArg [Expr Var]
rule_lhs_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Var -> Bool) -> [Var] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Var -> Bool
isId [Var]
spec_bndrs
spec_f_w_arity :: Var
spec_f_w_arity = Var
spec_fn Var -> Int -> Var
`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)
Var -> InlinePragma -> Var
`setInlinePragma` InlinePragma
spec_inl_prag
Var -> Unfolding -> Var
`setIdUnfolding` Unfolding
spec_unf
Var -> Maybe Int -> Var
`asJoinId_maybe` Maybe Int
spec_join_arity
_rule_trace_doc :: SDoc
_rule_trace_doc = [SDoc] -> SDoc
vcat [ Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
fn SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
fn_type
, Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
spec_fn SDoc -> SDoc -> SDoc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
spec_fn_ty
, [Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Var]
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], [(Var, Expr Var)], UsageDetails)
-> SpecM ([CoreRule], [(Var, Expr Var)], UsageDetails)
forall (m :: * -> *) a. Monad m => a -> m a
return ( CoreRule
spec_rule CoreRule -> [CoreRule] -> [CoreRule]
forall a. a -> [a] -> [a]
: [CoreRule]
rules_acc
, (Var
spec_f_w_arity, Expr Var
spec_rhs) (Var, Expr Var) -> [(Var, Expr Var)] -> [(Var, Expr Var)]
forall a. a -> [a] -> [a]
: [(Var, Expr Var)]
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 Type
t) = String -> SDoc
text String
"SpecType" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
t
ppr SpecArg
UnspecType = String -> SDoc
text String
"UnspecType"
ppr (SpecDict Expr Var
d) = String -> SDoc
text String
"SpecDict" SDoc -> SDoc -> SDoc
<+> Expr Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr Var
d
ppr SpecArg
UnspecArg = String -> SDoc
text String
"UnspecArg"
specArgFreeVars :: SpecArg -> VarSet
specArgFreeVars :: SpecArg -> VarSet
specArgFreeVars (SpecType Type
ty) = Type -> VarSet
tyCoVarsOfType Type
ty
specArgFreeVars (SpecDict Expr Var
dx) = Expr Var -> VarSet
exprFreeVars Expr Var
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 (Var
bndr : [Var]
bndrs) (SpecType Type
t : [SpecArg]
args)
= do { let env' :: SpecEnv
env' = SpecEnv -> [(Var, Type)] -> SpecEnv
extendTvSubstList SpecEnv
env [(Var
bndr, Type
t)]
; (Bool
useful, SpecEnv
env'', [Var]
leftover_bndrs, [Var]
rule_bs, [Expr Var]
rule_es, [Var]
bs', [DictBind]
dx, [Expr Var]
spec_args)
<- SpecEnv
-> [Var]
-> [SpecArg]
-> SpecM
(Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
specHeader SpecEnv
env' [Var]
bndrs [SpecArg]
args
; (Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
-> SpecM
(Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Bool
useful
, SpecEnv
env''
, [Var]
leftover_bndrs
, [Var]
rule_bs
, Type -> Expr Var
forall b. Type -> Expr b
Type Type
t Expr Var -> [Expr Var] -> [Expr Var]
forall a. a -> [a] -> [a]
: [Expr Var]
rule_es
, [Var]
bs'
, [DictBind]
dx
, Type -> Expr Var
forall b. Type -> Expr b
Type Type
t Expr Var -> [Expr Var] -> [Expr Var]
forall a. a -> [a] -> [a]
: [Expr Var]
spec_args
)
}
specHeader SpecEnv
env (Var
bndr : [Var]
bndrs) (SpecArg
UnspecType : [SpecArg]
args)
= do { let (SpecEnv
env', Var
bndr') = SpecEnv -> Var -> (SpecEnv, Var)
substBndr SpecEnv
env Var
bndr
; (Bool
useful, SpecEnv
env'', [Var]
leftover_bndrs, [Var]
rule_bs, [Expr Var]
rule_es, [Var]
bs', [DictBind]
dx, [Expr Var]
spec_args)
<- SpecEnv
-> [Var]
-> [SpecArg]
-> SpecM
(Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
specHeader SpecEnv
env' [Var]
bndrs [SpecArg]
args
; (Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
-> SpecM
(Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Bool
useful
, SpecEnv
env''
, [Var]
leftover_bndrs
, Var
bndr' Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Var]
rule_bs
, Var -> Expr Var
forall b. Var -> Expr b
varToCoreExpr Var
bndr' Expr Var -> [Expr Var] -> [Expr Var]
forall a. a -> [a] -> [a]
: [Expr Var]
rule_es
, Var
bndr' Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Var]
bs'
, [DictBind]
dx
, Var -> Expr Var
forall b. Var -> Expr b
varToCoreExpr Var
bndr' Expr Var -> [Expr Var] -> [Expr Var]
forall a. a -> [a] -> [a]
: [Expr Var]
spec_args
)
}
specHeader SpecEnv
env (Var
bndr : [Var]
bndrs) (SpecDict Expr Var
d : [SpecArg]
args)
= do { Var
bndr' <- SpecEnv -> Var -> SpecM Var
newDictBndr SpecEnv
env Var
bndr
; let (SpecEnv
env', Maybe DictBind
dx_bind, Expr Var
spec_dict) = SpecEnv
-> Var -> Var -> Expr Var -> (SpecEnv, Maybe DictBind, Expr Var)
bindAuxiliaryDict SpecEnv
env Var
bndr Var
bndr' Expr Var
d
; (Bool
_, SpecEnv
env'', [Var]
leftover_bndrs, [Var]
rule_bs, [Expr Var]
rule_es, [Var]
bs', [DictBind]
dx, [Expr Var]
spec_args)
<- SpecEnv
-> [Var]
-> [SpecArg]
-> SpecM
(Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
specHeader SpecEnv
env' [Var]
bndrs [SpecArg]
args
; (Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
-> SpecM
(Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Bool
True
, SpecEnv
env''
, [Var]
leftover_bndrs
, Expr Var -> [Var]
exprFreeIdsList (Var -> Expr Var
forall b. Var -> Expr b
varToCoreExpr Var
bndr') [Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
++ [Var]
rule_bs
, Var -> Expr Var
forall b. Var -> Expr b
varToCoreExpr Var
bndr' Expr Var -> [Expr Var] -> [Expr Var]
forall a. a -> [a] -> [a]
: [Expr Var]
rule_es
, [Var]
bs'
, Maybe DictBind -> [DictBind]
forall a. Maybe a -> [a]
maybeToList Maybe DictBind
dx_bind [DictBind] -> [DictBind] -> [DictBind]
forall a. [a] -> [a] -> [a]
++ [DictBind]
dx
, Expr Var
spec_dict Expr Var -> [Expr Var] -> [Expr Var]
forall a. a -> [a] -> [a]
: [Expr Var]
spec_args
)
}
specHeader SpecEnv
env (Var
bndr : [Var]
bndrs) (SpecArg
UnspecArg : [SpecArg]
args)
= do {
let (SpecEnv
env', Var
bndr') = SpecEnv -> Var -> (SpecEnv, Var)
substBndr SpecEnv
env (Var -> Var
zapIdOccInfo Var
bndr)
; (Bool
useful, SpecEnv
env'', [Var]
leftover_bndrs, [Var]
rule_bs, [Expr Var]
rule_es, [Var]
bs', [DictBind]
dx, [Expr Var]
spec_args)
<- SpecEnv
-> [Var]
-> [SpecArg]
-> SpecM
(Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
specHeader SpecEnv
env' [Var]
bndrs [SpecArg]
args
; (Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
-> SpecM
(Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Bool
useful
, SpecEnv
env''
, [Var]
leftover_bndrs
, Var
bndr' Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Var]
rule_bs
, Var -> Expr Var
forall b. Var -> Expr b
varToCoreExpr Var
bndr' Expr Var -> [Expr Var] -> [Expr Var]
forall a. a -> [a] -> [a]
: [Expr Var]
rule_es
, if Var -> Bool
isDeadBinder Var
bndr
then [Var]
bs'
else Var
bndr' Var -> [Var] -> [Var]
forall a. a -> [a] -> [a]
: [Var]
bs'
, [DictBind]
dx
, Var -> Expr Var
forall b. Var -> Expr b
varToCoreExpr Var
bndr' Expr Var -> [Expr Var] -> [Expr Var]
forall a. a -> [a] -> [a]
: [Expr Var]
spec_args
)
}
specHeader SpecEnv
env [] [SpecArg]
_ = (Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
-> SpecM
(Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, SpecEnv
env, [], [], [], [], [], [])
specHeader SpecEnv
env [Var]
bndrs []
= (Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
-> SpecM
(Bool, SpecEnv, [Var], [Var], [Expr Var], [Var], [DictBind],
[Expr Var])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, SpecEnv
env', [Var]
bndrs', [], [], [], [], [])
where
(SpecEnv
env', [Var]
bndrs') = SpecEnv -> [Var] -> (SpecEnv, [Var])
substBndrs SpecEnv
env [Var]
bndrs
bindAuxiliaryDict
:: SpecEnv
-> InId -> OutId -> OutExpr
-> ( SpecEnv
, Maybe DictBind
, OutExpr)
bindAuxiliaryDict :: SpecEnv
-> Var -> Var -> Expr Var -> (SpecEnv, Maybe DictBind, Expr Var)
bindAuxiliaryDict env :: SpecEnv
env@(SE { se_subst :: SpecEnv -> Subst
se_subst = Subst
subst, se_interesting :: SpecEnv -> VarSet
se_interesting = VarSet
interesting })
Var
orig_dict_id Var
fresh_dict_id Expr Var
dict_expr
| Just Var
dict_id <- Expr Var -> Maybe Var
getIdFromTrivialExpr_maybe Expr Var
dict_expr
= let env' :: SpecEnv
env' = SpecEnv
env { se_subst :: Subst
se_subst = Subst -> Var -> Expr Var -> Subst
Core.extendSubst Subst
subst Var
orig_dict_id Expr Var
dict_expr
Subst -> Var -> Subst
`Core.extendInScope` Var
dict_id
, se_interesting :: VarSet
se_interesting = VarSet
interesting VarSet -> Var -> VarSet
`extendVarSet` Var
dict_id }
in (SpecEnv
env', Maybe DictBind
forall a. Maybe a
Nothing, Expr Var
dict_expr)
| Bool
otherwise
= let dict_bind :: DictBind
dict_bind = CoreBind -> DictBind
mkDB (Var -> Expr Var -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Var
fresh_dict_id Expr Var
dict_expr)
env' :: SpecEnv
env' = SpecEnv
env { se_subst :: Subst
se_subst = Subst -> Var -> Expr Var -> Subst
Core.extendSubst Subst
subst Var
orig_dict_id (Var -> Expr Var
forall b. Var -> Expr b
Var Var
fresh_dict_id)
Subst -> Var -> Subst
`Core.extendInScope` Var
fresh_dict_id
, se_interesting :: VarSet
se_interesting = VarSet
interesting VarSet -> Var -> VarSet
`extendVarSet` Var
fresh_dict_id }
in (SpecEnv
env', DictBind -> Maybe DictBind
forall a. a -> Maybe a
Just DictBind
dict_bind, Var -> Expr Var
forall b. Var -> Expr b
Var Var
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 :: Bag DictBind -> CallDetails -> UsageDetails
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 Var
id Bag CallInfo
a) = Var -> Bag CallInfo -> CallInfoSet
CIS Var
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 Var
fn Bag CallInfo
map) = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"CIS" SDoc -> SDoc -> SDoc
<+> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
fn)
Int
2 (Bag CallInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag CallInfo
map)
pprCallInfo :: Id -> CallInfo -> SDoc
pprCallInfo :: Var -> CallInfo -> SDoc
pprCallInfo Var
fn (CI { ci_key :: CallInfo -> [SpecArg]
ci_key = [SpecArg]
key })
= Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
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 Type
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
<> Type -> SDoc
pprParendType Type
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 Expr Var
_) = 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 Var
f Bag CallInfo
calls1) (CIS Var
_ Bag CallInfo
calls2) =
Var -> Bag CallInfo -> CallInfoSet
CIS Var
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 Var
_ 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] -> [Type]
getTheta = (TyCoBinder -> Type) -> [TyCoBinder] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TyCoBinder -> Type
tyBinderType ([TyCoBinder] -> [Type])
-> ([TyCoBinder] -> [TyCoBinder]) -> [TyCoBinder] -> [Type]
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 :: Var -> [SpecArg] -> UsageDetails
singleCall Var
id [SpecArg]
args
= MkUD :: Bag DictBind -> CallDetails -> UsageDetails
MkUD {ud_binds :: Bag DictBind
ud_binds = Bag DictBind
forall a. Bag a
emptyBag,
ud_calls :: CallDetails
ud_calls = Var -> CallInfoSet -> CallDetails
forall a. Var -> a -> DVarEnv a
unitDVarEnv Var
id (CallInfoSet -> CallDetails) -> CallInfoSet -> CallDetails
forall a b. (a -> b) -> a -> b
$ Var -> Bag CallInfo -> CallInfoSet
CIS Var
id (Bag CallInfo -> CallInfoSet) -> Bag CallInfo -> CallInfoSet
forall a b. (a -> b) -> a -> b
$
CallInfo -> Bag CallInfo
forall a. a -> Bag a
unitBag (CI :: [SpecArg] -> VarSet -> CallInfo
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 -> Var -> [Expr Var] -> UsageDetails
mkCallUDs SpecEnv
env Var
f [Expr Var]
args
=
UsageDetails
res
where
res :: UsageDetails
res = SpecEnv -> Var -> [Expr Var] -> UsageDetails
mkCallUDs' SpecEnv
env Var
f [Expr Var]
args
mkCallUDs' :: SpecEnv -> Var -> [Expr Var] -> UsageDetails
mkCallUDs' SpecEnv
env Var
f [Expr Var]
args
| Bool -> Bool
not (Var -> Bool
want_calls_for Var
f)
Bool -> Bool -> Bool
|| [SpecArg] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SpecArg]
ci_key
=
UsageDetails
emptyUDs
| Bool
otherwise
=
Var -> [SpecArg] -> UsageDetails
singleCall Var
f [SpecArg]
ci_key
where
_trace_doc :: SDoc
_trace_doc = [SDoc] -> SDoc
vcat [Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
f, [Expr Var] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Expr Var]
args, [SpecArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SpecArg]
ci_key]
pis :: [TyCoBinder]
pis = ([TyCoBinder], Type) -> [TyCoBinder]
forall a b. (a, b) -> a
fst (([TyCoBinder], Type) -> [TyCoBinder])
-> ([TyCoBinder], Type) -> [TyCoBinder]
forall a b. (a -> b) -> a -> b
$ Type -> ([TyCoBinder], Type)
splitPiTys (Type -> ([TyCoBinder], Type)) -> Type -> ([TyCoBinder], Type)
forall a b. (a -> b) -> a -> b
$ Var -> Type
idType Var
f
constrained_tyvars :: VarSet
constrained_tyvars = [Type] -> VarSet
tyCoVarsOfTypes ([Type] -> VarSet) -> [Type] -> VarSet
forall a b. (a -> b) -> a -> b
$ [TyCoBinder] -> [Type]
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
$
(Expr Var -> TyCoBinder -> SpecArg)
-> [Expr Var] -> [TyCoBinder] -> [SpecArg]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Expr Var -> TyCoBinder -> SpecArg
mk_spec_arg [Expr Var]
args [TyCoBinder]
pis
mk_spec_arg :: CoreExpr -> TyCoBinder -> SpecArg
mk_spec_arg :: Expr Var -> TyCoBinder -> SpecArg
mk_spec_arg Expr Var
arg (Named TyCoVarBinder
bndr)
| TyCoVarBinder -> Var
forall tv argf. VarBndr tv argf -> tv
binderVar TyCoVarBinder
bndr Var -> VarSet -> Bool
`elemVarSet` VarSet
constrained_tyvars
= case Expr Var
arg of
Type Type
ty -> Type -> SpecArg
SpecType Type
ty
Expr Var
_ -> String -> SDoc -> SpecArg
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"ci_key" (SDoc -> SpecArg) -> SDoc -> SpecArg
forall a b. (a -> b) -> a -> b
$ Expr Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Expr Var
arg
| Bool
otherwise = SpecArg
UnspecType
mk_spec_arg Expr Var
arg (Anon AnonArgFlag
InvisArg Scaled Type
pred)
| Bool -> Bool
not (Type -> Bool
isIPLikePred (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
pred))
, SpecEnv -> Expr Var -> Bool
interestingDict SpecEnv
env Expr Var
arg
= Expr Var -> SpecArg
SpecDict Expr Var
arg
| Bool
otherwise = SpecArg
UnspecArg
mk_spec_arg Expr Var
_ (Anon AnonArgFlag
VisArg Scaled Type
_)
= SpecArg
UnspecArg
want_calls_for :: Var -> Bool
want_calls_for Var
f = Var -> Bool
isLocalId Var
f Bool -> Bool -> Bool
|| Maybe (Expr Var) -> Bool
forall a. Maybe a -> Bool
isJust (Unfolding -> Maybe (Expr Var)
maybeUnfoldingTemplate (Var -> Unfolding
realIdUnfolding Var
f))
interestingDict :: SpecEnv -> CoreExpr -> Bool
interestingDict :: SpecEnv -> Expr Var -> Bool
interestingDict SpecEnv
env (Var Var
v) = Unfolding -> Bool
hasSomeUnfolding (Var -> Unfolding
idUnfolding Var
v)
Bool -> Bool -> Bool
|| Var -> Bool
isDataConWorkId Var
v
Bool -> Bool -> Bool
|| Var
v Var -> VarSet -> Bool
`elemVarSet` SpecEnv -> VarSet
se_interesting SpecEnv
env
interestingDict SpecEnv
_ (Type Type
_) = Bool
False
interestingDict SpecEnv
_ (Coercion Coercion
_) = Bool
False
interestingDict SpecEnv
env (App Expr Var
fn (Type Type
_)) = SpecEnv -> Expr Var -> Bool
interestingDict SpecEnv
env Expr Var
fn
interestingDict SpecEnv
env (App Expr Var
fn (Coercion Coercion
_)) = SpecEnv -> Expr Var -> Bool
interestingDict SpecEnv
env Expr Var
fn
interestingDict SpecEnv
env (Tick Tickish Var
_ Expr Var
a) = SpecEnv -> Expr Var -> Bool
interestingDict SpecEnv
env Expr Var
a
interestingDict SpecEnv
env (Cast Expr Var
e Coercion
_) = SpecEnv -> Expr Var -> Bool
interestingDict SpecEnv
env Expr Var
e
interestingDict SpecEnv
_ Expr Var
_ = 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 :: Bag DictBind -> CallDetails -> UsageDetails
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 -> [Var]
_dictBindBndrs Bag DictBind
dbs = (DictBind -> [Var] -> [Var]) -> [Var] -> Bag DictBind -> [Var]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Var] -> [Var] -> [Var]
forall a. [a] -> [a] -> [a]
(++) ([Var] -> [Var] -> [Var])
-> (DictBind -> [Var]) -> DictBind -> [Var] -> [Var]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBind -> [Var]
forall b. Bind b -> [b]
bindersOf (CoreBind -> [Var]) -> (DictBind -> CoreBind) -> DictBind -> [Var]
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 :: CoreBind -> VarSet -> DictBind
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 Var
bndr Expr Var
rhs) = (Var, Expr Var) -> VarSet
pair_fvs (Var
bndr,Expr Var
rhs)
bind_fvs (Rec [(Var, Expr Var)]
prs) = (VarSet -> Var -> VarSet) -> VarSet -> [Var] -> VarSet
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' VarSet -> Var -> VarSet
delVarSet VarSet
rhs_fvs [Var]
bndrs
where
bndrs :: [Var]
bndrs = ((Var, Expr Var) -> Var) -> [(Var, Expr Var)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Expr Var) -> Var
forall a b. (a, b) -> a
fst [(Var, Expr Var)]
prs
rhs_fvs :: VarSet
rhs_fvs = [VarSet] -> VarSet
unionVarSets (((Var, Expr Var) -> VarSet) -> [(Var, Expr Var)] -> [VarSet]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Expr Var) -> VarSet
pair_fvs [(Var, Expr Var)]
prs)
pair_fvs :: (Id, CoreExpr) -> VarSet
pair_fvs :: (Var, Expr Var) -> VarSet
pair_fvs (Var
bndr, Expr Var
rhs) = (Var -> Bool) -> Expr Var -> VarSet
exprSomeFreeVars Var -> Bool
interesting Expr Var
rhs
VarSet -> VarSet -> VarSet
`unionVarSet` Var -> VarSet
idFreeVars Var
bndr
where
interesting :: InterestingVarFun
interesting :: Var -> Bool
interesting Var
v = Var -> Bool
isLocalVar Var
v Bool -> Bool -> Bool
|| (Var -> Bool
isId Var
v Bool -> Bool -> Bool
&& Var -> Bool
isDFunId Var
v)
recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind -> DictBind
recWithDumpedDicts :: [(Var, Expr Var)] -> Bag DictBind -> DictBind
recWithDumpedDicts [(Var, Expr Var)]
pairs Bag DictBind
dbs
= DB :: CoreBind -> VarSet -> DictBind
DB { db_bind :: CoreBind
db_bind = [(Var, Expr Var)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Var, Expr Var)]
bindings, db_fvs :: VarSet
db_fvs = VarSet
fvs }
where
([(Var, Expr Var)]
bindings, VarSet
fvs) = (DictBind
-> ([(Var, Expr Var)], VarSet) -> ([(Var, Expr Var)], VarSet))
-> ([(Var, Expr Var)], VarSet)
-> Bag DictBind
-> ([(Var, Expr Var)], VarSet)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DictBind
-> ([(Var, Expr Var)], VarSet) -> ([(Var, Expr Var)], VarSet)
add ([], VarSet
emptyVarSet)
(Bag DictBind
dbs Bag DictBind -> DictBind -> Bag DictBind
forall a. Bag a -> a -> Bag a
`snocBag` CoreBind -> DictBind
mkDB ([(Var, Expr Var)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Var, Expr Var)]
pairs))
add :: DictBind
-> ([(Var, Expr Var)], VarSet) -> ([(Var, Expr Var)], VarSet)
add (DB { db_bind :: DictBind -> CoreBind
db_bind = CoreBind
bind, db_fvs :: DictBind -> VarSet
db_fvs = VarSet
fvs }) ([(Var, Expr Var)]
prs_acc, VarSet
fvs_acc)
= case CoreBind
bind of
NonRec Var
b Expr Var
r -> ((Var
b,Expr Var
r) (Var, Expr Var) -> [(Var, Expr Var)] -> [(Var, Expr Var)]
forall a. a -> [a] -> [a]
: [(Var, Expr Var)]
prs_acc, VarSet
fvs')
Rec [(Var, Expr Var)]
prs1 -> ([(Var, Expr Var)]
prs1 [(Var, Expr Var)] -> [(Var, Expr Var)] -> [(Var, Expr Var)]
forall a. [a] -> [a] -> [a]
++ [(Var, Expr Var)]
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 -> Expr Var -> Expr Var
wrapDictBindsE Bag DictBind
dbs Expr Var
expr
= (DictBind -> Expr Var -> Expr Var)
-> Expr Var -> Bag DictBind -> Expr Var
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DictBind -> Expr Var -> Expr Var
add Expr Var
expr Bag DictBind
dbs
where
add :: DictBind -> Expr Var -> Expr Var
add (DB { db_bind :: DictBind -> CoreBind
db_bind = CoreBind
bind }) Expr Var
expr = CoreBind -> Expr Var -> Expr Var
forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind Expr Var
expr
dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind)
dumpUDs :: [Var] -> UsageDetails -> (UsageDetails, Bag DictBind)
dumpUDs [Var]
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 })
| [Var] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Var]
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 :: Bag DictBind -> CallDetails -> UsageDetails
MkUD { ud_binds :: Bag DictBind
ud_binds = Bag DictBind
free_dbs, ud_calls :: CallDetails
ud_calls = CallDetails
free_calls }
bndr_set :: VarSet
bndr_set = [Var] -> VarSet
mkVarSet [Var]
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
$
[Var] -> CallDetails -> CallDetails
deleteCallsFor [Var]
bndrs CallDetails
orig_calls
dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)
dumpBindUDs :: [Var] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)
dumpBindUDs [Var]
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 :: Bag DictBind -> CallDetails -> UsageDetails
MkUD { ud_binds :: Bag DictBind
ud_binds = Bag DictBind
free_dbs, ud_calls :: CallDetails
ud_calls = CallDetails
free_calls }
bndr_set :: VarSet
bndr_set = [Var] -> VarSet
mkVarSet [Var]
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 = [Var] -> CallDetails -> CallDetails
deleteCallsFor [Var]
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 :: Var -> UsageDetails -> (UsageDetails, [CallInfo])
callsForMe Var
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 :: Bag DictBind -> CallDetails -> UsageDetails
MkUD { ud_binds :: Bag DictBind
ud_binds = Bag DictBind
orig_dbs
, ud_calls :: CallDetails
ud_calls = CallDetails -> Var -> CallDetails
forall a. DVarEnv a -> Var -> DVarEnv a
delDVarEnv CallDetails
orig_calls Var
fn }
calls_for_me :: [CallInfo]
calls_for_me = case CallDetails -> Var -> Maybe CallInfoSet
forall a. DVarEnv a -> Var -> Maybe a
lookupDVarEnv CallDetails
orig_calls Var
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 Var
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 (Var -> VarSet
unitVarSet Var
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 -> [Var] -> VarSet
extendVarSetList VarSet
so_far (CoreBind -> [Var]
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 -> [Var] -> VarSet
extendVarSetList VarSet
dump_idset (CoreBind -> [Var]
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 :: [Var] -> CallDetails -> CallDetails
deleteCallsFor [Var]
bs CallDetails
calls = CallDetails -> [Var] -> CallDetails
forall a. DVarEnv a -> [Var] -> DVarEnv a
delDVarEnvList CallDetails
calls [Var]
bs
newtype SpecM a = SpecM (State SpecState a) deriving (a -> SpecM b -> SpecM a
(a -> b) -> SpecM a -> SpecM b
(forall a b. (a -> b) -> SpecM a -> SpecM b)
-> (forall a b. a -> SpecM b -> SpecM a) -> Functor SpecM
forall a b. a -> SpecM b -> SpecM a
forall a b. (a -> b) -> SpecM a -> SpecM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SpecM b -> SpecM a
$c<$ :: forall a b. a -> SpecM b -> SpecM a
fmap :: (a -> b) -> SpecM a -> SpecM b
$cfmap :: forall a b. (a -> b) -> SpecM a -> SpecM b
Functor)
data SpecState = SpecState {
SpecState -> UniqSupply
spec_uniq_supply :: UniqSupply,
SpecState -> Module
spec_module :: Module,
SpecState -> DynFlags
spec_dflags :: DynFlags
}
instance Applicative SpecM where
pure :: a -> SpecM a
pure a
x = State SpecState a -> SpecM a
forall a. State SpecState a -> SpecM a
SpecM (State SpecState a -> SpecM a) -> State SpecState a -> SpecM a
forall a b. (a -> b) -> a -> b
$ a -> State SpecState a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
<*> :: SpecM (a -> b) -> SpecM a -> SpecM b
(<*>) = SpecM (a -> b) -> SpecM a -> SpecM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad SpecM where
SpecM State SpecState a
x >>= :: SpecM a -> (a -> SpecM b) -> SpecM b
>>= a -> SpecM b
f = State SpecState b -> SpecM b
forall a. State SpecState a -> SpecM a
SpecM (State SpecState b -> SpecM b) -> State SpecState b -> SpecM b
forall a b. (a -> b) -> a -> b
$ do a
y <- State SpecState a
x
case a -> SpecM b
f a
y of
SpecM State SpecState b
z ->
State SpecState b
z
instance MonadFail SpecM where
fail :: String -> SpecM a
fail String
str = State SpecState a -> SpecM a
forall a. State SpecState a -> SpecM a
SpecM (State SpecState a -> SpecM a) -> State SpecState a -> SpecM a
forall a b. (a -> b) -> a -> b
$ String -> State SpecState a
forall a. HasCallStack => String -> a
error String
str
instance MonadUnique SpecM where
getUniqueSupplyM :: SpecM UniqSupply
getUniqueSupplyM
= State SpecState UniqSupply -> SpecM UniqSupply
forall a. State SpecState a -> SpecM a
SpecM (State SpecState UniqSupply -> SpecM UniqSupply)
-> State SpecState UniqSupply -> SpecM UniqSupply
forall a b. (a -> b) -> a -> b
$ do SpecState
st <- State SpecState SpecState
forall s. State s s
get
let (UniqSupply
us1, UniqSupply
us2) = UniqSupply -> (UniqSupply, UniqSupply)
splitUniqSupply (UniqSupply -> (UniqSupply, UniqSupply))
-> UniqSupply -> (UniqSupply, UniqSupply)
forall a b. (a -> b) -> a -> b
$ SpecState -> UniqSupply
spec_uniq_supply SpecState
st
SpecState -> State SpecState ()
forall s. s -> State s ()
put (SpecState -> State SpecState ())
-> SpecState -> State SpecState ()
forall a b. (a -> b) -> a -> b
$ SpecState
st { spec_uniq_supply :: UniqSupply
spec_uniq_supply = UniqSupply
us2 }
UniqSupply -> State SpecState UniqSupply
forall (m :: * -> *) a. Monad m => a -> m a
return UniqSupply
us1
getUniqueM :: SpecM Unique
getUniqueM
= State SpecState Unique -> SpecM Unique
forall a. State SpecState a -> SpecM a
SpecM (State SpecState Unique -> SpecM Unique)
-> State SpecState Unique -> SpecM Unique
forall a b. (a -> b) -> a -> b
$ do SpecState
st <- State SpecState SpecState
forall s. State s s
get
let (Unique
u,UniqSupply
us') = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (UniqSupply -> (Unique, UniqSupply))
-> UniqSupply -> (Unique, UniqSupply)
forall a b. (a -> b) -> a -> b
$ SpecState -> UniqSupply
spec_uniq_supply SpecState
st
SpecState -> State SpecState ()
forall s. s -> State s ()
put (SpecState -> State SpecState ())
-> SpecState -> State SpecState ()
forall a b. (a -> b) -> a -> b
$ SpecState
st { spec_uniq_supply :: UniqSupply
spec_uniq_supply = UniqSupply
us' }
Unique -> State SpecState Unique
forall (m :: * -> *) a. Monad m => a -> m a
return Unique
u
instance HasDynFlags SpecM where
getDynFlags :: SpecM DynFlags
getDynFlags = State SpecState DynFlags -> SpecM DynFlags
forall a. State SpecState a -> SpecM a
SpecM (State SpecState DynFlags -> SpecM DynFlags)
-> State SpecState DynFlags -> SpecM DynFlags
forall a b. (a -> b) -> a -> b
$ (SpecState -> DynFlags)
-> State SpecState SpecState -> State SpecState DynFlags
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM SpecState -> DynFlags
spec_dflags State SpecState SpecState
forall s. State s s
get
instance HasModule SpecM where
getModule :: SpecM Module
getModule = State SpecState Module -> SpecM Module
forall a. State SpecState a -> SpecM a
SpecM (State SpecState Module -> SpecM Module)
-> State SpecState Module -> SpecM Module
forall a b. (a -> b) -> a -> b
$ (SpecState -> Module)
-> State SpecState SpecState -> State SpecState Module
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM SpecState -> Module
spec_module State SpecState SpecState
forall s. State s s
get
runSpecM :: DynFlags -> Module -> SpecM a -> CoreM a
runSpecM :: DynFlags -> Module -> SpecM a -> CoreM a
runSpecM DynFlags
dflags Module
this_mod (SpecM State SpecState a
spec)
= do UniqSupply
us <- CoreM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
let initialState :: SpecState
initialState = SpecState :: UniqSupply -> Module -> DynFlags -> SpecState
SpecState {
spec_uniq_supply :: UniqSupply
spec_uniq_supply = UniqSupply
us,
spec_module :: Module
spec_module = Module
this_mod,
spec_dflags :: DynFlags
spec_dflags = DynFlags
dflags
}
a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> CoreM a) -> a -> CoreM a
forall a b. (a -> b) -> a -> b
$ State SpecState a -> SpecState -> a
forall s a. State s a -> s -> a
evalState State SpecState a
spec SpecState
initialState
mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM a -> SpecM (b, UsageDetails)
_ [] = ([b], UsageDetails) -> 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) <- (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
forall a b.
(a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM a -> SpecM (b, UsageDetails)
f [a]
xs
([b], UsageDetails) -> SpecM ([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 -> [(Var, Type)] -> SpecEnv
extendTvSubstList SpecEnv
env [(Var, Type)]
tv_binds
= SpecEnv
env { se_subst :: Subst
se_subst = Subst -> [(Var, Type)] -> Subst
Core.extendTvSubstList (SpecEnv -> Subst
se_subst SpecEnv
env) [(Var, Type)]
tv_binds }
substTy :: SpecEnv -> Type -> Type
substTy :: SpecEnv -> Type -> Type
substTy SpecEnv
env Type
ty = Subst -> Type -> Type
Core.substTy (SpecEnv -> Subst
se_subst SpecEnv
env) Type
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 -> Var -> (SpecEnv, Var)
substBndr SpecEnv
env Var
bs = case Subst -> Var -> (Subst, Var)
Core.substBndr (SpecEnv -> Subst
se_subst SpecEnv
env) Var
bs of
(Subst
subst', Var
bs') -> (SpecEnv
env { se_subst :: Subst
se_subst = Subst
subst' }, Var
bs')
substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr])
substBndrs :: SpecEnv -> [Var] -> (SpecEnv, [Var])
substBndrs SpecEnv
env [Var]
bs = case Subst -> [Var] -> (Subst, [Var])
Core.substBndrs (SpecEnv -> Subst
se_subst SpecEnv
env) [Var]
bs of
(Subst
subst', [Var]
bs') -> (SpecEnv
env { se_subst :: Subst
se_subst = Subst
subst' }, [Var]
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 Var
bndr Expr Var
rhs)
= do { UniqSupply
us <- SpecM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
; let (Subst
subst', Var
bndr') = Subst -> UniqSupply -> Var -> (Subst, Var)
Core.cloneIdBndr Subst
subst UniqSupply
us Var
bndr
interesting' :: VarSet
interesting' | SpecEnv -> Expr Var -> Bool
interestingDict SpecEnv
env Expr Var
rhs
= VarSet
interesting VarSet -> Var -> VarSet
`extendVarSet` Var
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' }
, Var -> Expr Var -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Var
bndr' Expr Var
rhs) }
cloneBindSM env :: SpecEnv
env@(SE { se_subst :: SpecEnv -> Subst
se_subst = Subst
subst, se_interesting :: SpecEnv -> VarSet
se_interesting = VarSet
interesting }) (Rec [(Var, Expr Var)]
pairs)
= do { UniqSupply
us <- SpecM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
; let (Subst
subst', [Var]
bndrs') = Subst -> UniqSupply -> [Var] -> (Subst, [Var])
Core.cloneRecIdBndrs Subst
subst UniqSupply
us (((Var, Expr Var) -> Var) -> [(Var, Expr Var)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Expr Var) -> Var
forall a b. (a, b) -> a
fst [(Var, Expr Var)]
pairs)
env' :: SpecEnv
env' = SpecEnv
env { se_subst :: Subst
se_subst = Subst
subst'
, se_interesting :: VarSet
se_interesting = VarSet
interesting VarSet -> [Var] -> VarSet
`extendVarSetList`
[ Var
v | (Var
v,Expr Var
r) <- [(Var, Expr Var)]
pairs, SpecEnv -> Expr Var -> Bool
interestingDict SpecEnv
env Expr Var
r ] }
; (SpecEnv, SpecEnv, CoreBind) -> SpecM (SpecEnv, SpecEnv, CoreBind)
forall (m :: * -> *) a. Monad m => a -> m a
return (SpecEnv
env', SpecEnv
env', [(Var, Expr Var)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([Var]
bndrs' [Var] -> [Expr Var] -> [(Var, Expr Var)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` ((Var, Expr Var) -> Expr Var) -> [(Var, Expr Var)] -> [Expr Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Expr Var) -> Expr Var
forall a b. (a, b) -> b
snd [(Var, Expr Var)]
pairs)) }
newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr
newDictBndr :: SpecEnv -> Var -> SpecM Var
newDictBndr SpecEnv
env Var
b = do { Unique
uniq <- SpecM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let n :: Name
n = Var -> Name
idName Var
b
ty' :: Type
ty' = SpecEnv -> Type -> Type
substTy SpecEnv
env (Var -> Type
idType Var
b)
; Var -> SpecM Var
forall (m :: * -> *) a. Monad m => a -> m a
return (OccName -> Unique -> Type -> Type -> SrcSpan -> Var
mkUserLocal (Name -> OccName
nameOccName Name
n) Unique
uniq Type
Many Type
ty' (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
n)) }
newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id
newSpecIdSM :: Var -> Type -> Maybe Int -> SpecM Var
newSpecIdSM Var
old_id Type
new_ty Maybe Int
join_arity_maybe
= do { Unique
uniq <- SpecM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let name :: Name
name = Var -> Name
idName Var
old_id
new_occ :: OccName
new_occ = OccName -> OccName
mkSpecOcc (Name -> OccName
nameOccName Name
name)
new_id :: Var
new_id = OccName -> Unique -> Type -> Type -> SrcSpan -> Var
mkUserLocal OccName
new_occ Unique
uniq Type
Many Type
new_ty (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
name)
Var -> Maybe Int -> Var
`asJoinId_maybe` Maybe Int
join_arity_maybe
; Var -> SpecM Var
forall (m :: * -> *) a. Monad m => a -> m a
return Var
new_id }