{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where
import GHC.Prelude
import GHC.Driver.DynFlags
import GHC.Driver.Config
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Core.Rules ( initRuleOpts )
import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst )
import GHC.Core.Multiplicity
import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith )
import GHC.Core.Predicate
import GHC.Core.Coercion( Coercion )
import GHC.Core.Opt.Monad
import qualified GHC.Core.Subst as Core
import GHC.Core.Unfold.Make
import GHC.Core
import GHC.Core.Make ( mkLitRubbish )
import GHC.Core.Unify ( tcMatchTy )
import GHC.Core.Rules
import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable
, mkCast, exprType
, stripTicksTop, mkInScopeSetBndrs )
import GHC.Core.FVs
import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )
import GHC.Core.Opt.Arity( collectBindersPushingCo )
import GHC.Builtin.Types ( unboxedUnitTy )
import GHC.Data.Maybe ( maybeToList, isJust )
import GHC.Data.Bag
import GHC.Data.OrdList
import GHC.Data.List.SetOps
import GHC.Types.Basic
import GHC.Types.Unique.Supply
import GHC.Types.Unique.DFM
import GHC.Types.Name
import GHC.Types.Tickish
import GHC.Types.Id.Make ( voidArgId, voidPrimId )
import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg, mkLocalVar )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Error
import GHC.Utils.Error ( mkMCDiagnostic )
import GHC.Utils.Monad ( foldlM )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Unit.Module( Module )
import GHC.Unit.Module.ModGuts
import GHC.Core.Unfold
import Data.List( partition )
import Data.List.NonEmpty ( NonEmpty (..) )
import GHC.Core.Subst (substTickish)
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 { dflags <- CoreM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; rule_env <- initRuleEnv guts
; let top_env = SE { se_subst :: Subst
se_subst = InScopeSet -> Subst
Core.mkEmptySubst (InScopeSet -> Subst) -> InScopeSet -> Subst
forall a b. (a -> b) -> a -> b
$
CoreProgram -> InScopeSet
mkInScopeSetBndrs CoreProgram
binds
, se_module :: Module
se_module = Module
this_mod
, se_rules :: RuleEnv
se_rules = RuleEnv
rule_env
, se_dflags :: DynFlags
se_dflags = DynFlags
dflags }
go [] = (CoreProgram, UsageDetails) -> SpecM (CoreProgram, UsageDetails)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], UsageDetails
emptyUDs)
go (InBind
bind:CoreProgram
binds) = do (bind', binds', uds') <- TopLevelFlag
-> SpecEnv
-> InBind
-> (SpecEnv -> SpecM (CoreProgram, UsageDetails))
-> SpecM (CoreProgram, CoreProgram, UsageDetails)
forall body.
TopLevelFlag
-> SpecEnv
-> InBind
-> (SpecEnv -> SpecM (body, UsageDetails))
-> SpecM (CoreProgram, body, UsageDetails)
specBind TopLevelFlag
TopLevel SpecEnv
top_env InBind
bind ((SpecEnv -> SpecM (CoreProgram, UsageDetails))
-> SpecM (CoreProgram, CoreProgram, UsageDetails))
-> (SpecEnv -> SpecM (CoreProgram, UsageDetails))
-> SpecM (CoreProgram, CoreProgram, UsageDetails)
forall a b. (a -> b) -> a -> b
$ \SpecEnv
_ ->
CoreProgram -> SpecM (CoreProgram, UsageDetails)
go CoreProgram
binds
return (bind' ++ binds', uds')
; (binds', uds) <- runSpecM (go binds)
; (spec_rules, spec_binds) <- specImports top_env uds
; return (guts { mg_binds = spec_binds ++ binds'
, mg_rules = spec_rules ++ local_rules }) }
specImports :: SpecEnv
-> UsageDetails
-> CoreM ([CoreRule], [CoreBind])
specImports :: SpecEnv -> UsageDetails -> CoreM ([CoreRule], CoreProgram)
specImports SpecEnv
top_env (MkUD { ud_binds :: UsageDetails -> FloatedDictBinds
ud_binds = FloatedDictBinds
dict_binds, ud_calls :: UsageDetails -> CallDetails
ud_calls = CallDetails
calls })
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CrossModuleSpecialise (SpecEnv -> DynFlags
se_dflags SpecEnv
top_env)
= ([CoreRule], CoreProgram) -> CoreM ([CoreRule], CoreProgram)
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], FloatedDictBinds -> CoreProgram -> CoreProgram
wrapDictBinds FloatedDictBinds
dict_binds [])
| Bool
otherwise
= do { let env_w_dict_bndrs :: SpecEnv
env_w_dict_bndrs = SpecEnv
top_env SpecEnv -> FloatedDictBinds -> SpecEnv
`bringFloatedDictsIntoScope` FloatedDictBinds
dict_binds
; (_env, spec_rules, spec_binds) <- SpecEnv
-> [Id]
-> FloatedDictBinds
-> CallDetails
-> CoreM (SpecEnv, [CoreRule], CoreProgram)
spec_imports SpecEnv
env_w_dict_bndrs [] FloatedDictBinds
dict_binds CallDetails
calls
; let (rules_for_locals, rules_for_imps) = partition isLocalRule spec_rules
local_rule_base = RuleBase -> [CoreRule] -> RuleBase
extendRuleBaseList RuleBase
emptyRuleBase [CoreRule]
rules_for_locals
final_binds
| CoreProgram -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null CoreProgram
spec_binds = FloatedDictBinds -> CoreProgram -> CoreProgram
wrapDictBinds FloatedDictBinds
dict_binds []
| Bool
otherwise = [[(Id, OutExpr)] -> InBind
forall b. [(b, Expr b)] -> Bind b
Rec ([(Id, OutExpr)] -> InBind) -> [(Id, OutExpr)] -> InBind
forall a b. (a -> b) -> a -> b
$ (Id -> Id) -> [(Id, OutExpr)] -> [(Id, OutExpr)]
forall (f :: * -> *) a c b.
Functor f =>
(a -> c) -> f (a, b) -> f (c, b)
mapFst (RuleBase -> Id -> Id
addRulesToId RuleBase
local_rule_base) ([(Id, OutExpr)] -> [(Id, OutExpr)])
-> [(Id, OutExpr)] -> [(Id, OutExpr)]
forall a b. (a -> b) -> a -> b
$
CoreProgram -> [(Id, OutExpr)]
forall b. [Bind b] -> [(b, Expr b)]
flattenBinds (CoreProgram -> [(Id, OutExpr)]) -> CoreProgram -> [(Id, OutExpr)]
forall a b. (a -> b) -> a -> b
$
FloatedDictBinds -> CoreProgram -> CoreProgram
wrapDictBinds FloatedDictBinds
dict_binds (CoreProgram -> CoreProgram) -> CoreProgram -> CoreProgram
forall a b. (a -> b) -> a -> b
$
CoreProgram
spec_binds]
; return (rules_for_imps, final_binds)
}
spec_imports :: SpecEnv
-> [Id]
-> FloatedDictBinds
-> CallDetails
-> CoreM ( SpecEnv
, [CoreRule]
, [CoreBind] )
spec_imports :: SpecEnv
-> [Id]
-> FloatedDictBinds
-> CallDetails
-> CoreM (SpecEnv, [CoreRule], CoreProgram)
spec_imports SpecEnv
env [Id]
callers FloatedDictBinds
dict_binds CallDetails
calls
= do { let import_calls :: [CallInfoSet]
import_calls = CallDetails -> [CallInfoSet]
forall a. DVarEnv a -> [a]
dVarEnvElts CallDetails
calls
; (env, rules, spec_binds) <- SpecEnv
-> [CallInfoSet] -> CoreM (SpecEnv, [CoreRule], CoreProgram)
go SpecEnv
env [CallInfoSet]
import_calls
; return (env, rules, spec_binds) }
where
go :: SpecEnv -> [CallInfoSet] -> CoreM (SpecEnv, [CoreRule], [CoreBind])
go :: SpecEnv
-> [CallInfoSet] -> CoreM (SpecEnv, [CoreRule], CoreProgram)
go SpecEnv
env [] = (SpecEnv, [CoreRule], CoreProgram)
-> CoreM (SpecEnv, [CoreRule], CoreProgram)
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (SpecEnv
env, [], [])
go SpecEnv
env (CallInfoSet
cis : [CallInfoSet]
other_calls)
= do {
; (env, rules1, spec_binds1) <- SpecEnv
-> [Id]
-> FloatedDictBinds
-> CallInfoSet
-> CoreM (SpecEnv, [CoreRule], CoreProgram)
spec_import SpecEnv
env [Id]
callers FloatedDictBinds
dict_binds CallInfoSet
cis
;
; (env, rules2, spec_binds2) <- go env other_calls
; return (env, rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
spec_import :: SpecEnv
-> [Id]
-> FloatedDictBinds
-> CallInfoSet
-> CoreM ( SpecEnv
, [CoreRule]
, [CoreBind] )
spec_import :: SpecEnv
-> [Id]
-> FloatedDictBinds
-> CallInfoSet
-> CoreM (SpecEnv, [CoreRule], CoreProgram)
spec_import SpecEnv
env [Id]
callers FloatedDictBinds
dict_binds cis :: CallInfoSet
cis@(CIS Id
fn Bag CallInfo
_)
| String -> Id -> [Id] -> Bool
forall a. Eq a => String -> a -> [a] -> Bool
isIn String
"specImport" Id
fn [Id]
callers
= (SpecEnv, [CoreRule], CoreProgram)
-> CoreM (SpecEnv, [CoreRule], CoreProgram)
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (SpecEnv
env, [], [])
| [CallInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [CallInfo]
good_calls
= (SpecEnv, [CoreRule], CoreProgram)
-> CoreM (SpecEnv, [CoreRule], CoreProgram)
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (SpecEnv
env, [], [])
| Just OutExpr
rhs <- DynFlags -> Id -> Maybe OutExpr
canSpecImport DynFlags
dflags Id
fn
= do {
; eps_rules <- CoreM RuleBase
getExternalRuleBase
; let rule_env = SpecEnv -> RuleEnv
se_rules SpecEnv
env RuleEnv -> RuleBase -> RuleEnv
`updExternalPackageRules` RuleBase
eps_rules
; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })
<- runSpecM $ specCalls True env (getRules rule_env fn) good_calls fn rhs
; let spec_binds1 = [Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
b OutExpr
r | (Id
b,OutExpr
r) <- [(Id, OutExpr)]
spec_pairs]
new_subst = SpecEnv -> Subst
se_subst SpecEnv
env Subst -> [Id] -> Subst
`Core.extendSubstInScopeList` ((Id, OutExpr) -> Id) -> [(Id, OutExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, OutExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, OutExpr)]
spec_pairs
new_env = SpecEnv
env { se_rules = rule_env `addLocalRules` rules1
, se_subst = new_subst }
SpecEnv -> FloatedDictBinds -> SpecEnv
`bringFloatedDictsIntoScope` FloatedDictBinds
dict_binds1
; (env, rules2, spec_binds2)
<- spec_imports new_env (fn:callers)
(dict_binds `thenFDBs` dict_binds1)
new_calls
; let final_binds = FloatedDictBinds -> CoreProgram -> CoreProgram
wrapDictBinds FloatedDictBinds
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
; return (env, rules2 ++ rules1, final_binds) }
| Bool
otherwise
= do { DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM ()
tryWarnMissingSpecs DynFlags
dflags [Id]
callers Id
fn [CallInfo]
good_calls
; (SpecEnv, [CoreRule], CoreProgram)
-> CoreM (SpecEnv, [CoreRule], CoreProgram)
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (SpecEnv
env, [], [])}
where
dflags :: DynFlags
dflags = SpecEnv -> DynFlags
se_dflags SpecEnv
env
good_calls :: [CallInfo]
good_calls = CallInfoSet -> FloatedDictBinds -> [CallInfo]
filterCalls CallInfoSet
cis FloatedDictBinds
dict_binds
canSpecImport :: DynFlags -> Id -> Maybe CoreExpr
canSpecImport :: DynFlags -> Id -> Maybe OutExpr
canSpecImport DynFlags
dflags Id
fn
| Id -> Bool
isDataConWrapId Id
fn
= Maybe OutExpr
forall a. Maybe a
Nothing
| CoreUnfolding { uf_tmpl :: Unfolding -> OutExpr
uf_tmpl = OutExpr
rhs } <- Unfolding
unf
, InlinePragma -> Bool
isAnyInlinePragma (Id -> InlinePragma
idInlinePragma Id
fn)
= OutExpr -> Maybe OutExpr
forall a. a -> Maybe a
Just OutExpr
rhs
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SpecialiseAggressively DynFlags
dflags
= Unfolding -> Maybe OutExpr
maybeUnfoldingTemplate Unfolding
unf
| Bool
otherwise = Maybe OutExpr
forall a. Maybe a
Nothing
where
unf :: Unfolding
unf = Id -> Unfolding
realIdUnfolding Id
fn
tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM ()
tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM ()
tryWarnMissingSpecs DynFlags
dflags [Id]
callers Id
fn [CallInfo]
calls_for_fn
| Id -> Bool
isClassOpId Id
fn = () -> CoreM ()
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnMissedSpecs DynFlags
dflags
Bool -> Bool -> Bool
&& Bool -> Bool
not ([Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
callers)
Bool -> Bool -> Bool
&& Bool
allCallersInlined = DiagnosticReason -> CoreM ()
doWarn (DiagnosticReason -> CoreM ()) -> DiagnosticReason -> CoreM ()
forall a b. (a -> b) -> a -> b
$ WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnMissedSpecs
| WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnAllMissedSpecs DynFlags
dflags = DiagnosticReason -> CoreM ()
doWarn (DiagnosticReason -> CoreM ()) -> DiagnosticReason -> CoreM ()
forall a b. (a -> b) -> a -> b
$ WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnAllMissedSpecs
| Bool
otherwise = () -> CoreM ()
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
allCallersInlined :: Bool
allCallersInlined = (Id -> Bool) -> [Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (InlinePragma -> Bool
isAnyInlinePragma (InlinePragma -> Bool) -> (Id -> InlinePragma) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> InlinePragma
idInlinePragma) [Id]
callers
diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
doWarn :: DiagnosticReason -> CoreM ()
doWarn DiagnosticReason
reason =
MessageClass -> SDoc -> CoreM ()
msg (DiagOpts
-> DiagnosticReason -> Maybe DiagnosticCode -> MessageClass
mkMCDiagnostic DiagOpts
diag_opts DiagnosticReason
reason Maybe DiagnosticCode
forall a. Maybe a
Nothing)
([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"Could not specialise imported function") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn))
Int
2 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"when specialising" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
caller)
| Id
caller <- [Id]
callers])
, SDoc -> SDoc
forall doc. IsOutput doc => doc -> doc
whenPprDebug (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"calls:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((CallInfo -> SDoc) -> [CallInfo] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> CallInfo -> SDoc
pprCallInfo Id
fn) [CallInfo]
calls_for_fn))
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Probable fix: add INLINABLE pragma on" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn) ])
data SpecEnv
= SE { SpecEnv -> Subst
se_subst :: Core.Subst
, SpecEnv -> Module
se_module :: Module
, SpecEnv -> RuleEnv
se_rules :: RuleEnv
, SpecEnv -> DynFlags
se_dflags :: DynFlags
}
instance Outputable SpecEnv where
ppr :: SpecEnv -> SDoc
ppr (SE { se_subst :: SpecEnv -> Subst
se_subst = Subst
subst })
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SE" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"subst =" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Subst -> SDoc
forall a. Outputable a => a -> SDoc
ppr Subst
subst)
specVar :: SpecEnv -> InId -> SpecM (OutExpr, UsageDetails)
specVar :: SpecEnv -> Id -> SpecM (OutExpr, UsageDetails)
specVar env :: SpecEnv
env@(SE { se_subst :: SpecEnv -> Subst
se_subst = Core.Subst InScopeSet
in_scope IdSubstEnv
ids TvSubstEnv
_ CvSubstEnv
_ }) Id
v
| Bool -> Bool
not (Id -> Bool
isLocalId Id
v) = (OutExpr, UsageDetails) -> SpecM (OutExpr, UsageDetails)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> OutExpr
forall b. Id -> Expr b
Var Id
v, UsageDetails
emptyUDs)
| Just OutExpr
e <- IdSubstEnv -> Id -> Maybe OutExpr
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv IdSubstEnv
ids Id
v = SpecEnv -> OutExpr -> SpecM (OutExpr, UsageDetails)
specExpr (SpecEnv -> SpecEnv
zapSubst SpecEnv
env) OutExpr
e
| Just Id
v' <- InScopeSet -> Id -> Maybe Id
lookupInScope InScopeSet
in_scope Id
v = (OutExpr, UsageDetails) -> SpecM (OutExpr, UsageDetails)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> OutExpr
forall b. Id -> Expr b
Var Id
v', UsageDetails
emptyUDs)
| Bool
otherwise = String -> SDoc -> SpecM (OutExpr, UsageDetails)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"specVar" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
v SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ InScopeSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr InScopeSet
in_scope)
specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
specExpr :: SpecEnv -> OutExpr -> SpecM (OutExpr, UsageDetails)
specExpr SpecEnv
env (Var Id
v) = SpecEnv -> Id -> SpecM (OutExpr, UsageDetails)
specVar SpecEnv
env Id
v
specExpr SpecEnv
env (Type Kind
ty) = (OutExpr, UsageDetails) -> SpecM (OutExpr, UsageDetails)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> OutExpr
forall b. Kind -> Expr b
Type (SpecEnv -> Kind -> Kind
substTy SpecEnv
env Kind
ty), UsageDetails
emptyUDs)
specExpr SpecEnv
env (Coercion Coercion
co) = (OutExpr, UsageDetails) -> SpecM (OutExpr, UsageDetails)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> OutExpr
forall b. Coercion -> Expr b
Coercion (SpecEnv -> Coercion -> Coercion
substCo SpecEnv
env Coercion
co), UsageDetails
emptyUDs)
specExpr SpecEnv
_ (Lit Literal
lit) = (OutExpr, UsageDetails) -> SpecM (OutExpr, UsageDetails)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> OutExpr
forall b. Literal -> Expr b
Lit Literal
lit, UsageDetails
emptyUDs)
specExpr SpecEnv
env (Cast OutExpr
e Coercion
co)
= do { (e', uds) <- SpecEnv -> OutExpr -> SpecM (OutExpr, UsageDetails)
specExpr SpecEnv
env OutExpr
e
; return ((mkCast e' (substCo env co)), uds) }
specExpr SpecEnv
env (Tick CoreTickish
tickish OutExpr
body)
= do { (body', uds) <- SpecEnv -> OutExpr -> SpecM (OutExpr, UsageDetails)
specExpr SpecEnv
env OutExpr
body
; return (Tick (specTickish env tickish) body', uds) }
specExpr SpecEnv
env expr :: OutExpr
expr@(App {})
= do { let (OutExpr
fun_in, [OutExpr]
args_in) = OutExpr -> (OutExpr, [OutExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs OutExpr
expr
; (args_out, uds_args) <- (OutExpr -> SpecM (OutExpr, UsageDetails))
-> [OutExpr] -> SpecM ([OutExpr], UsageDetails)
forall a b.
(a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM (SpecEnv -> OutExpr -> SpecM (OutExpr, UsageDetails)
specExpr SpecEnv
env) [OutExpr]
args_in
; let env_args = SpecEnv
env SpecEnv -> FloatedDictBinds -> SpecEnv
`bringFloatedDictsIntoScope` UsageDetails -> FloatedDictBinds
ud_binds UsageDetails
uds_args
(fun_in', args_out') = fireRewriteRules env_args fun_in args_out
; (fun_out', uds_fun) <- specExpr env fun_in'
; let uds_call = SpecEnv -> OutExpr -> [OutExpr] -> UsageDetails
mkCallUDs SpecEnv
env OutExpr
fun_out' [OutExpr]
args_out'
; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) }
specExpr SpecEnv
env e :: OutExpr
e@(Lam {})
= SpecEnv -> [Id] -> OutExpr -> SpecM (OutExpr, UsageDetails)
specLam SpecEnv
env' [Id]
bndrs' OutExpr
body
where
([Id]
bndrs, OutExpr
body) = OutExpr -> ([Id], OutExpr)
forall b. Expr b -> ([b], Expr b)
collectBinders OutExpr
e
(SpecEnv
env', [Id]
bndrs') = SpecEnv -> [Id] -> (SpecEnv, [Id])
substBndrs SpecEnv
env [Id]
bndrs
specExpr SpecEnv
env (Case OutExpr
scrut Id
case_bndr Kind
ty [Alt Id]
alts)
= do { (scrut', scrut_uds) <- SpecEnv -> OutExpr -> SpecM (OutExpr, UsageDetails)
specExpr SpecEnv
env OutExpr
scrut
; (scrut'', case_bndr', alts', alts_uds)
<- specCase env scrut' case_bndr alts
; return (Case scrut'' case_bndr' (substTy env ty) alts'
, scrut_uds `thenUDs` alts_uds) }
specExpr SpecEnv
env (Let InBind
bind OutExpr
body)
= do { (binds', body', uds) <- TopLevelFlag
-> SpecEnv
-> InBind
-> (SpecEnv -> SpecM (OutExpr, UsageDetails))
-> SpecM (CoreProgram, OutExpr, UsageDetails)
forall body.
TopLevelFlag
-> SpecEnv
-> InBind
-> (SpecEnv -> SpecM (body, UsageDetails))
-> SpecM (CoreProgram, body, UsageDetails)
specBind TopLevelFlag
NotTopLevel SpecEnv
env InBind
bind ((SpecEnv -> SpecM (OutExpr, UsageDetails))
-> SpecM (CoreProgram, OutExpr, UsageDetails))
-> (SpecEnv -> SpecM (OutExpr, UsageDetails))
-> SpecM (CoreProgram, OutExpr, UsageDetails)
forall a b. (a -> b) -> a -> b
$ \SpecEnv
body_env ->
SpecEnv -> OutExpr -> SpecM (OutExpr, UsageDetails)
specExpr SpecEnv
body_env OutExpr
body
; return (foldr Let body' binds', uds) }
fireRewriteRules :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr])
fireRewriteRules :: SpecEnv -> OutExpr -> [OutExpr] -> (OutExpr, [OutExpr])
fireRewriteRules SpecEnv
env (Var Id
f) [OutExpr]
args
| Just (CoreRule
rule, OutExpr
expr) <- SpecEnv
-> Id
-> [OutExpr]
-> CompilerPhase
-> [CoreRule]
-> Maybe (CoreRule, OutExpr)
specLookupRule SpecEnv
env Id
f [OutExpr]
args CompilerPhase
InitialPhase (RuleEnv -> Id -> [CoreRule]
getRules (SpecEnv -> RuleEnv
se_rules SpecEnv
env) Id
f)
, let rest_args :: [OutExpr]
rest_args = Int -> [OutExpr] -> [OutExpr]
forall a. Int -> [a] -> [a]
drop (CoreRule -> Int
ruleArity CoreRule
rule) [OutExpr]
args
zapped_subst :: Subst
zapped_subst = Subst -> Subst
Core.zapSubst (SpecEnv -> Subst
se_subst SpecEnv
env)
expr' :: OutExpr
expr' = HasDebugCallStack => SimpleOpts -> Subst -> OutExpr -> OutExpr
SimpleOpts -> Subst -> OutExpr -> OutExpr
simpleOptExprWith SimpleOpts
defaultSimpleOpts Subst
zapped_subst OutExpr
expr
, (OutExpr
fun, [OutExpr]
args) <- OutExpr -> (OutExpr, [OutExpr])
forall b. Expr b -> (Expr b, [Expr b])
collectArgs OutExpr
expr'
= SpecEnv -> OutExpr -> [OutExpr] -> (OutExpr, [OutExpr])
fireRewriteRules SpecEnv
env OutExpr
fun ([OutExpr]
args[OutExpr] -> [OutExpr] -> [OutExpr]
forall a. [a] -> [a] -> [a]
++[OutExpr]
rest_args)
fireRewriteRules SpecEnv
_ OutExpr
fun [OutExpr]
args = (OutExpr
fun, [OutExpr]
args)
specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails)
specLam :: SpecEnv -> [Id] -> OutExpr -> SpecM (OutExpr, UsageDetails)
specLam SpecEnv
env [Id]
bndrs OutExpr
body
| [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bndrs
= SpecEnv -> OutExpr -> SpecM (OutExpr, UsageDetails)
specExpr SpecEnv
env OutExpr
body
| Bool
otherwise
= do { (body', uds) <- SpecEnv -> OutExpr -> SpecM (OutExpr, UsageDetails)
specExpr SpecEnv
env OutExpr
body
; let (free_uds, dumped_dbs) = dumpUDs bndrs uds
; return (mkLams bndrs (wrapDictBindsE dumped_dbs body'), free_uds) }
specTickish :: SpecEnv -> CoreTickish -> CoreTickish
specTickish :: SpecEnv -> CoreTickish -> CoreTickish
specTickish (SE { se_subst :: SpecEnv -> Subst
se_subst = Subst
subst }) CoreTickish
bp = Subst -> CoreTickish -> CoreTickish
substTickish Subst
subst CoreTickish
bp
specCase :: SpecEnv
-> OutExpr
-> InId -> [InAlt]
-> SpecM ( OutExpr
, OutId
, [OutAlt]
, UsageDetails)
specCase :: SpecEnv
-> OutExpr
-> Id
-> [Alt Id]
-> SpecM (OutExpr, Id, [Alt Id], UsageDetails)
specCase SpecEnv
env OutExpr
scrut' Id
case_bndr [Alt AltCon
con [Id]
args OutExpr
rhs]
|
OutExpr -> Kind -> Bool
interestingDict OutExpr
scrut' (Id -> Kind
idType Id
case_bndr)
, Bool -> Bool
not (Id -> Bool
isDeadBinder Id
case_bndr Bool -> Bool -> Bool
&& [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
sc_args')
= do { case_bndr_flt :| sc_args_flt <- (Id -> UniqSM Id) -> NonEmpty Id -> UniqSM (NonEmpty Id)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM Id -> UniqSM Id
forall {m :: * -> *}. MonadUnique m => Id -> m Id
clone_me (Id
case_bndr' Id -> [Id] -> NonEmpty Id
forall a. a -> [a] -> NonEmpty a
:| [Id]
sc_args')
; let case_bndr_flt' = Id
case_bndr_flt Id -> OutExpr -> Id
`addDictUnfolding` OutExpr
scrut'
scrut_bind = InBind -> DictBind
mkDB (Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
case_bndr_flt OutExpr
scrut')
sc_args_flt' = (Id -> OutExpr -> Id) -> [Id] -> [OutExpr] -> [Id]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Id -> OutExpr -> Id
addDictUnfolding [Id]
sc_args_flt [OutExpr]
sc_rhss
sc_rhss = [ OutExpr -> Id -> Kind -> [Alt Id] -> OutExpr
forall b. Expr b -> b -> Kind -> [Alt b] -> Expr b
Case (Id -> OutExpr
forall b. Id -> Expr b
Var Id
case_bndr_flt') Id
case_bndr' (Id -> Kind
idType Id
sc_arg')
[AltCon -> [Id] -> OutExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
args' (Id -> OutExpr
forall b. Id -> Expr b
Var Id
sc_arg')]
| Id
sc_arg' <- [Id]
sc_args' ]
cb_set = Id -> VarSet
unitVarSet Id
case_bndr_flt'
sc_binds = [ DB { db_bind :: InBind
db_bind = Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
sc_arg_flt OutExpr
sc_rhs, db_fvs :: VarSet
db_fvs = VarSet
cb_set }
| (Id
sc_arg_flt, OutExpr
sc_rhs) <- [Id]
sc_args_flt' [Id] -> [OutExpr] -> [(Id, OutExpr)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [OutExpr]
sc_rhss ]
flt_binds = DictBind
scrut_bind DictBind -> [DictBind] -> [DictBind]
forall a. a -> [a] -> [a]
: [DictBind]
sc_binds
mb_sc_flts :: [Maybe DictId]
mb_sc_flts = (Id -> Maybe Id) -> [Id] -> [Maybe Id]
forall a b. (a -> b) -> [a] -> [b]
map (VarEnv Id -> Id -> Maybe Id
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv Id
clone_env) [Id]
args'
clone_env = [Id] -> [Id] -> VarEnv Id
forall a. [Id] -> [a] -> VarEnv a
zipVarEnv [Id]
sc_args' [Id]
sc_args_flt'
subst_prs = (Id
case_bndr, Id -> OutExpr
forall b. Id -> Expr b
Var Id
case_bndr_flt)
(Id, OutExpr) -> [(Id, OutExpr)] -> [(Id, OutExpr)]
forall a. a -> [a] -> [a]
: [ (Id
arg, Id -> OutExpr
forall b. Id -> Expr b
Var Id
sc_flt)
| (Id
arg, Just Id
sc_flt) <- [Id]
args [Id] -> [Maybe Id] -> [(Id, Maybe Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Maybe Id]
mb_sc_flts ]
subst' = SpecEnv -> Subst
se_subst SpecEnv
env_rhs
Subst -> [Id] -> Subst
`Core.extendSubstInScopeList` (Id
case_bndr_flt' Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
sc_args_flt')
Subst -> [(Id, OutExpr)] -> Subst
`Core.extendIdSubstList` [(Id, OutExpr)]
subst_prs
env_rhs' = SpecEnv
env_rhs { se_subst = subst' }
; (rhs', rhs_uds) <- specExpr env_rhs' rhs
; let (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds
all_uds = [DictBind]
flt_binds [DictBind] -> UsageDetails -> UsageDetails
`consDictBinds` UsageDetails
free_uds
alt' = AltCon -> [Id] -> OutExpr -> Alt Id
forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
args' (OrdList DictBind -> OutExpr -> OutExpr
wrapDictBindsE OrdList DictBind
dumped_dbs OutExpr
rhs')
; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }
where
(SpecEnv
env_rhs, (Id
case_bndr':[Id]
args')) = SpecEnv -> [Id] -> (SpecEnv, [Id])
substBndrs SpecEnv
env (Id
case_bndrId -> [Id] -> [Id]
forall a. a -> [a] -> [a]
:[Id]
args)
sc_args' :: [Id]
sc_args' = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
is_flt_sc_arg [Id]
args'
clone_me :: Id -> m Id
clone_me Id
bndr = do { uniq <- m Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; return (mkUserLocalOrCoVar occ uniq wght ty loc) }
where
name :: Name
name = Id -> Name
idName Id
bndr
wght :: Kind
wght = HasDebugCallStack => Id -> Kind
Id -> Kind
idMult Id
bndr
ty :: Kind
ty = Id -> Kind
idType Id
bndr
occ :: OccName
occ = Name -> OccName
nameOccName Name
name
loc :: SrcSpan
loc = Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
name
arg_set :: VarSet
arg_set = [Id] -> VarSet
mkVarSet [Id]
args'
is_flt_sc_arg :: Id -> Bool
is_flt_sc_arg Id
var = Id -> Bool
isId Id
var
Bool -> Bool -> Bool
&& Bool -> Bool
not (Id -> Bool
isDeadBinder Id
var)
Bool -> Bool -> Bool
&& Kind -> Bool
isDictTy Kind
var_ty
Bool -> Bool -> Bool
&& Kind -> VarSet
tyCoVarsOfType Kind
var_ty VarSet -> VarSet -> Bool
`disjointVarSet` VarSet
arg_set
where
var_ty :: Kind
var_ty = Id -> Kind
idType Id
var
specCase SpecEnv
env OutExpr
scrut Id
case_bndr [Alt Id]
alts
= do { (alts', uds_alts) <- (Alt Id -> SpecM (Alt Id, UsageDetails))
-> [Alt Id] -> SpecM ([Alt Id], UsageDetails)
forall a b.
(a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM Alt Id -> SpecM (Alt Id, UsageDetails)
spec_alt [Alt Id]
alts
; return (scrut, case_bndr', alts', uds_alts) }
where
(SpecEnv
env_alt, Id
case_bndr') = SpecEnv -> Id -> (SpecEnv, Id)
substBndr SpecEnv
env Id
case_bndr
spec_alt :: Alt Id -> SpecM (Alt Id, UsageDetails)
spec_alt (Alt AltCon
con [Id]
args OutExpr
rhs)
= do { (rhs', uds) <- SpecEnv -> OutExpr -> SpecM (OutExpr, UsageDetails)
specExpr SpecEnv
env_rhs OutExpr
rhs
; let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds
; return (Alt con args' (wrapDictBindsE dumped_dbs rhs'), free_uds) }
where
(SpecEnv
env_rhs, [Id]
args') = SpecEnv -> [Id] -> (SpecEnv, [Id])
substBndrs SpecEnv
env_alt [Id]
args
bringFloatedDictsIntoScope :: SpecEnv -> FloatedDictBinds -> SpecEnv
bringFloatedDictsIntoScope :: SpecEnv -> FloatedDictBinds -> SpecEnv
bringFloatedDictsIntoScope SpecEnv
env (FDB { fdb_bndrs :: FloatedDictBinds -> VarSet
fdb_bndrs = VarSet
dx_bndrs })
=
SpecEnv
env {se_subst=subst'}
where
subst' :: Subst
subst' = SpecEnv -> Subst
se_subst SpecEnv
env Subst -> VarSet -> Subst
`Core.extendSubstInScopeSet` VarSet
dx_bndrs
specBind :: TopLevelFlag
-> SpecEnv
-> InBind
-> (SpecEnv -> SpecM (body, UsageDetails))
-> SpecM ( [OutBind]
, body
, UsageDetails)
specBind :: forall body.
TopLevelFlag
-> SpecEnv
-> InBind
-> (SpecEnv -> SpecM (body, UsageDetails))
-> SpecM (CoreProgram, body, UsageDetails)
specBind TopLevelFlag
top_lvl SpecEnv
env (NonRec Id
fn OutExpr
rhs) SpecEnv -> SpecM (body, UsageDetails)
do_body
= do { (rhs', rhs_uds) <- SpecEnv -> OutExpr -> SpecM (OutExpr, UsageDetails)
specExpr SpecEnv
env OutExpr
rhs
; (body_env1, fn1) <- case top_lvl of
TopLevelFlag
TopLevel -> (SpecEnv, Id) -> UniqSM (SpecEnv, Id)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (SpecEnv
env, Id
fn)
TopLevelFlag
NotTopLevel -> SpecEnv -> Id -> UniqSM (SpecEnv, Id)
cloneBndrSM SpecEnv
env Id
fn
; let fn2 | Unfolding -> Bool
isStableUnfolding (Id -> Unfolding
idUnfolding Id
fn1) = Id
fn1
| Bool
otherwise = Id
fn1 Id -> Unfolding -> Id
`setIdUnfolding` UnfoldingOpts -> OutExpr -> Unfolding
mkSimpleUnfolding UnfoldingOpts
defaultUnfoldingOpts OutExpr
rhs'
fn3 = Id -> Id
floatifyIdDemandInfo Id
fn2
body_env2 = SpecEnv
body_env1 SpecEnv -> FloatedDictBinds -> SpecEnv
`bringFloatedDictsIntoScope` UsageDetails -> FloatedDictBinds
ud_binds UsageDetails
rhs_uds
SpecEnv -> Id -> SpecEnv
`extendInScope` Id
fn3
; (body', body_uds) <- do_body body_env2
; (fn4, spec_defns, body_uds1) <- specDefn env body_uds fn3 rhs
; let (free_uds, dump_dbs, float_all) = dumpBindUDs [fn4] body_uds1
all_free_uds = UsageDetails
free_uds UsageDetails -> UsageDetails -> UsageDetails
`thenUDs` UsageDetails
rhs_uds
pairs = [(Id, OutExpr)]
spec_defns [(Id, OutExpr)] -> [(Id, OutExpr)] -> [(Id, OutExpr)]
forall a. [a] -> [a] -> [a]
++ [(Id
fn4, OutExpr
rhs')]
final_binds :: [DictBind]
final_binds | Bool -> Bool
not (OrdList DictBind -> Bool
forall a. OrdList a -> Bool
isNilOL OrdList DictBind
dump_dbs)
, Bool -> Bool
not ([(Id, OutExpr)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Id, OutExpr)]
spec_defns)
= [[(Id, OutExpr)] -> OrdList DictBind -> DictBind
recWithDumpedDicts [(Id, OutExpr)]
pairs OrdList DictBind
dump_dbs]
| Bool
otherwise
= [InBind -> DictBind
mkDB (InBind -> DictBind) -> InBind -> DictBind
forall a b. (a -> b) -> a -> b
$ Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
b OutExpr
r | (Id
b,OutExpr
r) <- [(Id, OutExpr)]
pairs]
[DictBind] -> [DictBind] -> [DictBind]
forall a. [a] -> [a] -> [a]
++ OrdList DictBind -> [DictBind]
forall a. OrdList a -> [a]
fromOL OrdList DictBind
dump_dbs
can_float_this_one = OutExpr -> Kind -> Bool
exprIsTopLevelBindable OutExpr
rhs (Id -> Kind
idType Id
fn)
; if float_all && can_float_this_one then
return ([], body', all_free_uds `snocDictBinds` final_binds)
else
return (map db_bind final_binds, body', all_free_uds) }
specBind TopLevelFlag
top_lvl SpecEnv
env (Rec [(Id, OutExpr)]
pairs) SpecEnv -> SpecM (body, UsageDetails)
do_body
= do { let ([Id]
bndrs,[OutExpr]
rhss) = [(Id, OutExpr)] -> ([Id], [OutExpr])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Id, OutExpr)]
pairs
; (rec_env, bndrs1) <- case TopLevelFlag
top_lvl of
TopLevelFlag
TopLevel -> (SpecEnv, [Id]) -> UniqSM (SpecEnv, [Id])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (SpecEnv
env, [Id]
bndrs)
TopLevelFlag
NotTopLevel -> SpecEnv -> [Id] -> UniqSM (SpecEnv, [Id])
cloneRecBndrsSM SpecEnv
env [Id]
bndrs
; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rec_env) rhss
; (body', body_uds) <- do_body rec_env
; let scope_uds = UsageDetails
body_uds UsageDetails -> UsageDetails -> UsageDetails
`thenUDs` UsageDetails
rhs_uds
; (bndrs2, spec_defns2, uds2) <- specDefns rec_env scope_uds (bndrs1 `zip` rhss)
; (bndrs3, spec_defns3, uds3)
<- if null spec_defns2
then return (bndrs2, [], uds2)
else do {
(bndrs3, spec_defns3, uds3)
<- specDefns rec_env uds2 (bndrs2 `zip` rhss)
; return (bndrs3, spec_defns3 ++ spec_defns2, uds3) }
; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs1 uds3
final_bind = [(Id, OutExpr)] -> OrdList DictBind -> DictBind
recWithDumpedDicts ([(Id, OutExpr)]
spec_defns3 [(Id, OutExpr)] -> [(Id, OutExpr)] -> [(Id, OutExpr)]
forall a. [a] -> [a] -> [a]
++ [Id] -> [OutExpr] -> [(Id, OutExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
bndrs3 [OutExpr]
rhss')
OrdList DictBind
dumped_dbs
; if float_all then
return ([], body', final_uds `snocDictBind` final_bind)
else
return ([db_bind final_bind], body', final_uds) }
specDefns :: SpecEnv
-> UsageDetails
-> [(OutId,InExpr)]
-> SpecM ([OutId],
[(OutId,OutExpr)],
UsageDetails)
specDefns :: SpecEnv
-> UsageDetails
-> [(Id, OutExpr)]
-> SpecM ([Id], [(Id, OutExpr)], UsageDetails)
specDefns SpecEnv
_env UsageDetails
uds []
= ([Id], [(Id, OutExpr)], UsageDetails)
-> SpecM ([Id], [(Id, OutExpr)], UsageDetails)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], UsageDetails
uds)
specDefns SpecEnv
env UsageDetails
uds ((Id
bndr,OutExpr
rhs):[(Id, OutExpr)]
pairs)
= do { (bndrs1, spec_defns1, uds1) <- SpecEnv
-> UsageDetails
-> [(Id, OutExpr)]
-> SpecM ([Id], [(Id, OutExpr)], UsageDetails)
specDefns SpecEnv
env UsageDetails
uds [(Id, OutExpr)]
pairs
; (bndr1, spec_defns2, uds2) <- specDefn env uds1 bndr rhs
; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }
specDefn :: SpecEnv
-> UsageDetails
-> OutId -> InExpr
-> SpecM (Id,
[(Id,CoreExpr)],
UsageDetails)
specDefn :: SpecEnv
-> UsageDetails
-> Id
-> OutExpr
-> SpecM (Id, [(Id, OutExpr)], UsageDetails)
specDefn SpecEnv
env UsageDetails
body_uds Id
fn OutExpr
rhs
= do { let (UsageDetails
body_uds_without_me, [CallInfo]
calls_for_me) = Id -> UsageDetails -> (UsageDetails, [CallInfo])
callsForMe Id
fn UsageDetails
body_uds
rules_for_me :: [CoreRule]
rules_for_me = Id -> [CoreRule]
idCoreRules Id
fn
env_w_dict_bndrs :: SpecEnv
env_w_dict_bndrs = SpecEnv -> FloatedDictBinds -> SpecEnv
bringFloatedDictsIntoScope SpecEnv
env (UsageDetails -> FloatedDictBinds
ud_binds UsageDetails
body_uds)
; (rules, spec_defns, spec_uds) <- Bool
-> SpecEnv
-> [CoreRule]
-> [CallInfo]
-> Id
-> OutExpr
-> SpecM ([CoreRule], [(Id, OutExpr)], UsageDetails)
specCalls Bool
False SpecEnv
env_w_dict_bndrs
[CoreRule]
rules_for_me [CallInfo]
calls_for_me Id
fn OutExpr
rhs
; return ( fn `addIdSpecialisations` rules
, spec_defns
, body_uds_without_me `thenUDs` spec_uds) }
specCalls :: Bool
-> SpecEnv
-> [CoreRule]
-> [CallInfo]
-> OutId -> InExpr
-> SpecM SpecInfo
type SpecInfo = ( [CoreRule]
, [(Id,CoreExpr)]
, UsageDetails )
specCalls :: Bool
-> SpecEnv
-> [CoreRule]
-> [CallInfo]
-> Id
-> OutExpr
-> SpecM ([CoreRule], [(Id, OutExpr)], UsageDetails)
specCalls Bool
spec_imp SpecEnv
env [CoreRule]
existing_rules [CallInfo]
calls_for_me Id
fn OutExpr
rhs
| [CallInfo] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [CallInfo]
calls_for_me
Bool -> Bool -> Bool
&& Bool -> Bool
not (Activation -> Bool
isNeverActive (Id -> Activation
idInlineActivation Id
fn))
=
(([CoreRule], [(Id, OutExpr)], UsageDetails)
-> CallInfo -> SpecM ([CoreRule], [(Id, OutExpr)], UsageDetails))
-> ([CoreRule], [(Id, OutExpr)], UsageDetails)
-> [CallInfo]
-> SpecM ([CoreRule], [(Id, OutExpr)], UsageDetails)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ([CoreRule], [(Id, OutExpr)], UsageDetails)
-> CallInfo -> SpecM ([CoreRule], [(Id, OutExpr)], UsageDetails)
spec_call ([], [], UsageDetails
emptyUDs) [CallInfo]
calls_for_me
| Bool
otherwise
= Bool
-> String
-> SDoc
-> SpecM ([CoreRule], [(Id, OutExpr)], UsageDetails)
-> SpecM ([CoreRule], [(Id, OutExpr)], UsageDetails)
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace (Bool -> Bool
not (OutExpr -> Bool
exprIsTrivial OutExpr
rhs) Bool -> Bool -> Bool
&& [CallInfo] -> Bool
forall (f :: * -> *) a. Foldable f => f a -> Bool
notNull [CallInfo]
calls_for_me Bool -> Bool -> Bool
&& Bool -> Bool
not (Id -> Bool
isClassOpId Id
fn))
String
"Missed specialisation opportunity for" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
trace_doc) (SpecM ([CoreRule], [(Id, OutExpr)], UsageDetails)
-> SpecM ([CoreRule], [(Id, OutExpr)], UsageDetails))
-> SpecM ([CoreRule], [(Id, OutExpr)], UsageDetails)
-> SpecM ([CoreRule], [(Id, OutExpr)], UsageDetails)
forall a b. (a -> b) -> a -> b
$
([CoreRule], [(Id, OutExpr)], UsageDetails)
-> SpecM ([CoreRule], [(Id, OutExpr)], UsageDetails)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], UsageDetails
emptyUDs)
where
trace_doc :: SDoc
trace_doc = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
rhs_bndrs, Activation -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Activation
idInlineActivation Id
fn) ]
fn_type :: Kind
fn_type = Id -> Kind
idType Id
fn
fn_arity :: Int
fn_arity = Id -> Int
idArity Id
fn
fn_unf :: Unfolding
fn_unf = Id -> Unfolding
realIdUnfolding Id
fn
inl_prag :: InlinePragma
inl_prag = Id -> InlinePragma
idInlinePragma Id
fn
inl_act :: Activation
inl_act = InlinePragma -> Activation
inlinePragmaActivation InlinePragma
inl_prag
is_local :: Bool
is_local = Id -> Bool
isLocalId Id
fn
is_dfun :: Bool
is_dfun = Id -> Bool
isDFunId Id
fn
dflags :: DynFlags
dflags = SpecEnv -> DynFlags
se_dflags SpecEnv
env
this_mod :: Module
this_mod = SpecEnv -> Module
se_module SpecEnv
env
([Id]
rhs_bndrs, OutExpr
rhs_body) = OutExpr -> ([Id], OutExpr)
collectBindersPushingCo OutExpr
rhs
already_covered :: SpecEnv -> [CoreRule] -> [CoreExpr] -> Bool
already_covered :: SpecEnv -> [CoreRule] -> [OutExpr] -> Bool
already_covered SpecEnv
env [CoreRule]
new_rules [OutExpr]
args
= Maybe (CoreRule, OutExpr) -> Bool
forall a. Maybe a -> Bool
isJust (SpecEnv
-> Id
-> [OutExpr]
-> CompilerPhase
-> [CoreRule]
-> Maybe (CoreRule, OutExpr)
specLookupRule SpecEnv
env Id
fn [OutExpr]
args (Activation -> CompilerPhase
beginPhase Activation
inl_act)
([CoreRule]
new_rules [CoreRule] -> [CoreRule] -> [CoreRule]
forall a. [a] -> [a] -> [a]
++ [CoreRule]
existing_rules))
spec_call :: SpecInfo
-> CallInfo
-> SpecM SpecInfo
spec_call :: ([CoreRule], [(Id, OutExpr)], UsageDetails)
-> CallInfo -> SpecM ([CoreRule], [(Id, OutExpr)], UsageDetails)
spec_call spec_acc :: ([CoreRule], [(Id, OutExpr)], UsageDetails)
spec_acc@([CoreRule]
rules_acc, [(Id, OutExpr)]
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]
saturating_call_args
| Bool
otherwise = [SpecArg]
call_args
saturating_call_args :: [SpecArg]
saturating_call_args = [SpecArg]
call_args [SpecArg] -> [SpecArg] -> [SpecArg]
forall a. [a] -> [a] -> [a]
++ (Id -> SpecArg) -> [Id] -> [SpecArg]
forall a b. (a -> b) -> [a] -> [b]
map Id -> SpecArg
mk_extra_dfun_arg ([SpecArg] -> [Id] -> [Id]
forall b a. [b] -> [a] -> [a]
dropList [SpecArg]
call_args [Id]
rhs_bndrs)
mk_extra_dfun_arg :: Id -> SpecArg
mk_extra_dfun_arg Id
bndr | Id -> Bool
isTyVar Id
bndr = SpecArg
UnspecType
| Bool
otherwise = SpecArg
UnspecArg
; ( useful, rhs_env2, leftover_bndrs
, rule_bndrs, rule_lhs_args
, spec_bndrs1, dx_binds, spec_args) <- SpecEnv
-> [Id]
-> [SpecArg]
-> SpecM
(Bool, SpecEnv, [Id], [Id], [OutExpr], [Id], [DictBind], [OutExpr])
specHeader SpecEnv
env [Id]
rhs_bndrs [SpecArg]
all_call_args
; if not useful
|| already_covered rhs_env2 rules_acc rule_lhs_args
then return spec_acc
else
do {
; (rhs_body', rhs_uds) <- specExpr rhs_env2 rhs_body
; let rhs_uds_w_dx = [DictBind]
dx_binds [DictBind] -> UsageDetails -> UsageDetails
`consDictBinds` UsageDetails
rhs_uds
spec_rhs_bndrs = [Id]
spec_bndrs1 [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
leftover_bndrs
(spec_uds, dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds_w_dx
spec_rhs1 = [Id] -> OutExpr -> OutExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
spec_rhs_bndrs (OutExpr -> OutExpr) -> OutExpr -> OutExpr
forall a b. (a -> b) -> a -> b
$
OrdList DictBind -> OutExpr -> OutExpr
wrapDictBindsE OrdList DictBind
dumped_dbs OutExpr
rhs_body'
spec_fn_ty1 = HasDebugCallStack => OutExpr -> Kind
OutExpr -> Kind
exprType OutExpr
spec_rhs1
add_void_arg = HasDebugCallStack => Kind -> Bool
Kind -> Bool
isUnliftedType Kind
spec_fn_ty1 Bool -> Bool -> Bool
&& Bool -> Bool
not (Id -> Bool
isJoinId Id
fn)
(spec_bndrs, spec_rhs, spec_fn_ty)
| add_void_arg = ( voidPrimId : spec_bndrs1
, Lam voidArgId spec_rhs1
, mkVisFunTyMany unboxedUnitTy spec_fn_ty1)
| otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1)
join_arity_decr = [OutExpr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [OutExpr]
rule_lhs_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
spec_bndrs
simpl_opts = DynFlags -> SimpleOpts
initSimpleOpts DynFlags
dflags
wrap_unf_body OutExpr
body = (DictBind -> OutExpr -> OutExpr)
-> OutExpr -> [DictBind] -> OutExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (InBind -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let (InBind -> OutExpr -> OutExpr)
-> (DictBind -> InBind) -> DictBind -> OutExpr -> OutExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DictBind -> InBind
db_bind) (OutExpr
body OutExpr -> [OutExpr] -> OutExpr
forall b. Expr b -> [Expr b] -> Expr b
`mkApps` [OutExpr]
spec_args) [DictBind]
dx_binds
spec_unf = SimpleOpts
-> [Id]
-> (OutExpr -> OutExpr)
-> [OutExpr]
-> Unfolding
-> Unfolding
specUnfolding SimpleOpts
simpl_opts [Id]
spec_bndrs OutExpr -> OutExpr
wrap_unf_body
[OutExpr]
rule_lhs_args Unfolding
fn_unf
arity_decr = (OutExpr -> Bool) -> [OutExpr] -> Int
forall a. (a -> Bool) -> [a] -> Int
count OutExpr -> Bool
forall b. Expr b -> Bool
isValArg [OutExpr]
rule_lhs_args Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Id -> Bool) -> [Id] -> Int
forall a. (a -> Bool) -> [a] -> Int
count Id -> Bool
isId [Id]
spec_bndrs
spec_inl_prag
| Bool -> Bool
not Bool
is_local
, OccInfo -> Bool
isStrongLoopBreaker (Id -> OccInfo
idOccInfo Id
fn)
= InlinePragma
neverInlinePragma
| Bool
otherwise
= InlinePragma
inl_prag
spec_fn_info
= IdInfo
vanillaIdInfo IdInfo -> Int -> IdInfo
`setArityInfo` 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)
IdInfo -> InlinePragma -> IdInfo
`setInlinePragInfo` InlinePragma
spec_inl_prag
IdInfo -> Unfolding -> IdInfo
`setUnfoldingInfo` Unfolding
spec_unf
spec_fn_details
= case Id -> IdDetails
idDetails Id
fn of
JoinId Int
join_arity Maybe [CbvMark]
_ -> Int -> Maybe [CbvMark] -> IdDetails
JoinId (Int
join_arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
join_arity_decr) Maybe [CbvMark]
forall a. Maybe a
Nothing
DFunId Bool
is_nt -> Bool -> IdDetails
DFunId Bool
is_nt
IdDetails
_ -> IdDetails
VanillaId
; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info
; let
herald | Bool
spec_imp =
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SPEC/" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
this_mod
| Bool
otherwise =
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SPEC"
spec_rule = DynFlags
-> Module
-> Bool
-> Activation
-> SDoc
-> Id
-> [Id]
-> [OutExpr]
-> OutExpr
-> CoreRule
mkSpecRule DynFlags
dflags Module
this_mod Bool
True Activation
inl_act
SDoc
herald Id
fn [Id]
rule_bndrs [OutExpr]
rule_lhs_args
(OutExpr -> [Id] -> OutExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> OutExpr
forall b. Id -> Expr b
Var Id
spec_fn) [Id]
spec_bndrs)
spec_f_w_arity = Id
spec_fn
_rule_trace_doc = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
fn_type
, Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
spec_fn SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
spec_fn_ty
, [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
rhs_bndrs, [SpecArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SpecArg]
call_args
, CoreRule -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreRule
spec_rule
]
;
return ( spec_rule : rules_acc
, (spec_f_w_arity, spec_rhs) : pairs_acc
, spec_uds `thenUDs` uds_acc
) } }
specLookupRule :: SpecEnv -> Id -> [CoreExpr]
-> CompilerPhase
-> [CoreRule] -> Maybe (CoreRule, CoreExpr)
specLookupRule :: SpecEnv
-> Id
-> [OutExpr]
-> CompilerPhase
-> [CoreRule]
-> Maybe (CoreRule, OutExpr)
specLookupRule SpecEnv
env Id
fn [OutExpr]
args CompilerPhase
phase [CoreRule]
rules
= RuleOpts
-> InScopeEnv
-> (Activation -> Bool)
-> Id
-> [OutExpr]
-> [CoreRule]
-> Maybe (CoreRule, OutExpr)
lookupRule RuleOpts
ropts InScopeEnv
in_scope_env Activation -> Bool
is_active Id
fn [OutExpr]
args [CoreRule]
rules
where
dflags :: DynFlags
dflags = SpecEnv -> DynFlags
se_dflags SpecEnv
env
in_scope :: InScopeSet
in_scope = Subst -> InScopeSet
getSubstInScope (SpecEnv -> Subst
se_subst SpecEnv
env)
in_scope_env :: InScopeEnv
in_scope_env = InScopeSet -> (Id -> Unfolding) -> InScopeEnv
ISE InScopeSet
in_scope ((Activation -> Bool) -> Id -> Unfolding
whenActiveUnfoldingFun Activation -> Bool
is_active)
ropts :: RuleOpts
ropts = DynFlags -> RuleOpts
initRuleOpts DynFlags
dflags
is_active :: Activation -> Bool
is_active = CompilerPhase -> Activation -> Bool
isActive CompilerPhase
phase
data SpecArg
=
SpecType Type
| UnspecType
| SpecDict DictExpr
| UnspecArg
instance Outputable SpecArg where
ppr :: SpecArg -> SDoc
ppr (SpecType Kind
t) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SpecType" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Kind -> SDoc
forall a. Outputable a => a -> SDoc
ppr Kind
t
ppr SpecArg
UnspecType = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"UnspecType"
ppr (SpecDict OutExpr
d) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SpecDict" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> OutExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutExpr
d
ppr SpecArg
UnspecArg = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"UnspecArg"
specArgFreeIds :: SpecArg -> IdSet
specArgFreeIds :: SpecArg -> VarSet
specArgFreeIds (SpecType {}) = VarSet
emptyVarSet
specArgFreeIds (SpecDict OutExpr
dx) = OutExpr -> VarSet
exprFreeIds OutExpr
dx
specArgFreeIds SpecArg
UnspecType = VarSet
emptyVarSet
specArgFreeIds SpecArg
UnspecArg = VarSet
emptyVarSet
specArgFreeVars :: SpecArg -> VarSet
specArgFreeVars :: SpecArg -> VarSet
specArgFreeVars (SpecType Kind
ty) = Kind -> VarSet
tyCoVarsOfType Kind
ty
specArgFreeVars (SpecDict OutExpr
dx) = OutExpr -> VarSet
exprFreeVars OutExpr
dx
specArgFreeVars SpecArg
UnspecType = VarSet
emptyVarSet
specArgFreeVars SpecArg
UnspecArg = VarSet
emptyVarSet
isSpecDict :: SpecArg -> Bool
isSpecDict :: SpecArg -> Bool
isSpecDict (SpecDict {}) = Bool
True
isSpecDict SpecArg
_ = Bool
False
specHeader
:: SpecEnv
-> [InBndr]
-> [SpecArg]
-> SpecM ( Bool
, SpecEnv
, [OutBndr]
, [OutBndr]
, [OutExpr]
, [OutBndr]
, [DictBind]
, [OutExpr]
)
SpecEnv
env (Id
bndr : [Id]
bndrs) (SpecType Kind
ty : [SpecArg]
args)
= do {
let in_scope :: InScopeSet
in_scope = Subst -> InScopeSet
Core.getSubstInScope (SpecEnv -> Subst
se_subst SpecEnv
env)
qvars :: [Id]
qvars = [Id] -> [Id]
scopedSort ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$
(Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Id -> InScopeSet -> Bool
`elemInScopeSet` InScopeSet
in_scope) ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$
Kind -> [Id]
tyCoVarsOfTypeList Kind
ty
(SpecEnv
env1, [Id]
qvars') = SpecEnv -> [Id] -> (SpecEnv, [Id])
substBndrs SpecEnv
env [Id]
qvars
ty' :: Kind
ty' = SpecEnv -> Kind -> Kind
substTy SpecEnv
env1 Kind
ty
env2 :: SpecEnv
env2 = SpecEnv -> Id -> Kind -> SpecEnv
extendTvSubst SpecEnv
env1 Id
bndr Kind
ty'
; (useful, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
<- SpecEnv
-> [Id]
-> [SpecArg]
-> SpecM
(Bool, SpecEnv, [Id], [Id], [OutExpr], [Id], [DictBind], [OutExpr])
specHeader SpecEnv
env2 [Id]
bndrs [SpecArg]
args
; pure ( useful
, env3
, leftover_bndrs
, qvars' ++ rule_bs
, Type ty' : rule_es
, qvars' ++ bs'
, dx
, Type ty' : spec_args
)
}
specHeader SpecEnv
env (Id
bndr : [Id]
bndrs) (SpecArg
UnspecType : [SpecArg]
args)
= do { let (SpecEnv
env', Id
bndr') = SpecEnv -> Id -> (SpecEnv, Id)
substBndr SpecEnv
env Id
bndr
; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
<- SpecEnv
-> [Id]
-> [SpecArg]
-> SpecM
(Bool, SpecEnv, [Id], [Id], [OutExpr], [Id], [DictBind], [OutExpr])
specHeader SpecEnv
env' [Id]
bndrs [SpecArg]
args
; pure ( useful
, env''
, leftover_bndrs
, bndr' : rule_bs
, varToCoreExpr bndr' : rule_es
, bndr' : bs'
, dx
, varToCoreExpr bndr' : spec_args
)
}
specHeader SpecEnv
env (Id
bndr : [Id]
bndrs) (SpecDict OutExpr
d : [SpecArg]
args)
| Bool -> Bool
not (Id -> Bool
isDeadBinder Id
bndr)
, (Id -> Bool) -> VarSet -> Bool
allVarSet (Id -> InScopeSet -> Bool
`elemInScopeSet` InScopeSet
in_scope) (OutExpr -> VarSet
exprFreeVars OutExpr
d)
= do { (env1, bndr') <- SpecEnv -> Id -> UniqSM (SpecEnv, Id)
newDictBndr SpecEnv
env Id
bndr
; let (env2, dx_bind, spec_dict) = bindAuxiliaryDict env1 bndr bndr' d
; (_, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
<- specHeader env2 bndrs args
; pure ( True
, env3
, leftover_bndrs
, exprFreeIdsList (varToCoreExpr bndr') ++ rule_bs
, varToCoreExpr bndr' : rule_es
, bs'
, maybeToList dx_bind ++ dx
, spec_dict : spec_args
)
}
where
in_scope :: InScopeSet
in_scope = Subst -> InScopeSet
Core.getSubstInScope (SpecEnv -> Subst
se_subst SpecEnv
env)
specHeader SpecEnv
env (Id
bndr : [Id]
bndrs) (SpecArg
_ : [SpecArg]
args)
= do {
let (SpecEnv
env', Id
bndr') = SpecEnv -> Id -> (SpecEnv, Id)
substBndr SpecEnv
env (Id -> Id
zapIdOccInfo Id
bndr)
; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
<- SpecEnv
-> [Id]
-> [SpecArg]
-> SpecM
(Bool, SpecEnv, [Id], [Id], [OutExpr], [Id], [DictBind], [OutExpr])
specHeader SpecEnv
env' [Id]
bndrs [SpecArg]
args
; let bndr_ty = Id -> Kind
idType Id
bndr'
(mb_spec_bndr, spec_arg)
| isDeadBinder bndr
, Just lit_expr <- mkLitRubbish bndr_ty
= (Nothing, lit_expr)
| otherwise
= (Just bndr', varToCoreExpr bndr')
; pure ( useful
, env''
, leftover_bndrs
, bndr' : rule_bs
, varToCoreExpr bndr' : rule_es
, case mb_spec_bndr of
Just Id
b' -> Id
b' Id -> [Id] -> [Id]
forall a. a -> [a] -> [a]
: [Id]
bs'
Maybe Id
Nothing -> [Id]
bs'
, dx
, spec_arg : spec_args
)
}
specHeader SpecEnv
env [] [SpecArg]
_ = (Bool, SpecEnv, [Id], [Id], [OutExpr], [Id], [DictBind], [OutExpr])
-> SpecM
(Bool, SpecEnv, [Id], [Id], [OutExpr], [Id], [DictBind], [OutExpr])
forall a. a -> UniqSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, SpecEnv
env, [], [], [], [], [], [])
specHeader SpecEnv
env [Id]
bndrs []
= (Bool, SpecEnv, [Id], [Id], [OutExpr], [Id], [DictBind], [OutExpr])
-> SpecM
(Bool, SpecEnv, [Id], [Id], [OutExpr], [Id], [DictBind], [OutExpr])
forall a. a -> UniqSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, SpecEnv
env', [Id]
bndrs', [], [], [], [], [])
where
(SpecEnv
env', [Id]
bndrs') = SpecEnv -> [Id] -> (SpecEnv, [Id])
substBndrs SpecEnv
env [Id]
bndrs
bindAuxiliaryDict
:: SpecEnv
-> InId -> OutId -> OutExpr
-> ( SpecEnv
, Maybe DictBind
, OutExpr)
bindAuxiliaryDict :: SpecEnv
-> Id -> Id -> OutExpr -> (SpecEnv, Maybe DictBind, OutExpr)
bindAuxiliaryDict env :: SpecEnv
env@(SE { se_subst :: SpecEnv -> Subst
se_subst = Subst
subst })
Id
orig_dict_id Id
fresh_dict_id OutExpr
dict_expr
| OutExpr -> Bool
exprIsTrivial OutExpr
dict_expr
= let env' :: SpecEnv
env' = SpecEnv
env { se_subst = Core.extendSubst subst orig_dict_id dict_expr }
in
(SpecEnv
env', Maybe DictBind
forall a. Maybe a
Nothing, OutExpr
dict_expr)
| Bool
otherwise
= let fresh_dict_id' :: Id
fresh_dict_id' = Id
fresh_dict_id Id -> OutExpr -> Id
`addDictUnfolding` OutExpr
dict_expr
dict_bind :: DictBind
dict_bind = InBind -> DictBind
mkDB (Id -> OutExpr -> InBind
forall b. b -> Expr b -> Bind b
NonRec Id
fresh_dict_id' OutExpr
dict_expr)
env' :: SpecEnv
env' = SpecEnv
env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id')
`Core.extendSubstInScope` fresh_dict_id' }
in
(SpecEnv
env', DictBind -> Maybe DictBind
forall a. a -> Maybe a
Just DictBind
dict_bind, Id -> OutExpr
forall b. Id -> Expr b
Var Id
fresh_dict_id')
addDictUnfolding :: Id -> CoreExpr -> Id
addDictUnfolding :: Id -> OutExpr -> Id
addDictUnfolding Id
id OutExpr
rhs
= Id
id Id -> Unfolding -> Id
`setIdUnfolding` UnfoldingOpts -> OutExpr -> Unfolding
mkSimpleUnfolding UnfoldingOpts
defaultUnfoldingOpts OutExpr
rhs
data UsageDetails
= MkUD { UsageDetails -> FloatedDictBinds
ud_binds :: !FloatedDictBinds
, UsageDetails -> CallDetails
ud_calls :: !CallDetails }
data FloatedDictBinds
= FDB { FloatedDictBinds -> OrdList DictBind
fdb_binds :: !(OrdList DictBind)
, FloatedDictBinds -> VarSet
fdb_bndrs :: !IdSet
}
data DictBind = DB { DictBind -> InBind
db_bind :: CoreBind, DictBind -> VarSet
db_fvs :: VarSet }
bindersOfDictBind :: DictBind -> [Id]
bindersOfDictBind :: DictBind -> [Id]
bindersOfDictBind = InBind -> [Id]
forall b. Bind b -> [b]
bindersOf (InBind -> [Id]) -> (DictBind -> InBind) -> DictBind -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DictBind -> InBind
db_bind
bindersOfDictBinds :: Foldable f => f DictBind -> [Id]
bindersOfDictBinds :: forall (f :: * -> *). Foldable f => f DictBind -> [Id]
bindersOfDictBinds = CoreProgram -> [Id]
forall b. [Bind b] -> [b]
bindersOfBinds (CoreProgram -> [Id])
-> (f DictBind -> CoreProgram) -> f DictBind -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DictBind -> CoreProgram -> CoreProgram)
-> CoreProgram -> f DictBind -> CoreProgram
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((:) (InBind -> CoreProgram -> CoreProgram)
-> (DictBind -> InBind) -> DictBind -> CoreProgram -> CoreProgram
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DictBind -> InBind
db_bind) []
instance Outputable DictBind where
ppr :: DictBind -> SDoc
ppr (DB { db_bind :: DictBind -> InBind
db_bind = InBind
bind, db_fvs :: DictBind -> VarSet
db_fvs = VarSet
fvs })
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DB" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fvs: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> VarSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarSet
fvs
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"bind:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> InBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr InBind
bind ])
instance Outputable UsageDetails where
ppr :: UsageDetails -> SDoc
ppr (MkUD { ud_binds :: UsageDetails -> FloatedDictBinds
ud_binds = FloatedDictBinds
dbs, ud_calls :: UsageDetails -> CallDetails
ud_calls = CallDetails
calls })
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"MkUD" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma
[String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"binds" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
forall doc. IsLine doc => doc
equals SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FloatedDictBinds -> SDoc
forall a. Outputable a => a -> SDoc
ppr FloatedDictBinds
dbs,
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"calls" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
forall doc. IsLine doc => doc
equals SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CallDetails -> SDoc
forall a. Outputable a => a -> SDoc
ppr CallDetails
calls]))
instance Outputable FloatedDictBinds where
ppr :: FloatedDictBinds -> SDoc
ppr (FDB { fdb_binds :: FloatedDictBinds -> OrdList DictBind
fdb_binds = OrdList DictBind
binds }) = OrdList DictBind -> SDoc
forall a. Outputable a => a -> SDoc
ppr OrdList DictBind
binds
emptyUDs :: UsageDetails
emptyUDs :: UsageDetails
emptyUDs = MkUD { ud_binds :: FloatedDictBinds
ud_binds = FloatedDictBinds
emptyFDBs, ud_calls :: CallDetails
ud_calls = CallDetails
forall a. DVarEnv a
emptyDVarEnv }
emptyFDBs :: FloatedDictBinds
emptyFDBs :: FloatedDictBinds
emptyFDBs = FDB { fdb_binds :: OrdList DictBind
fdb_binds = OrdList DictBind
forall a. OrdList a
nilOL, fdb_bndrs :: VarSet
fdb_bndrs = VarSet
emptyVarSet }
type CallDetails = DIdEnv CallInfoSet
data CallInfoSet = CIS Id (Bag CallInfo)
data CallInfo
= CI { CallInfo -> [SpecArg]
ci_key :: [SpecArg]
, CallInfo -> VarSet
ci_fvs :: IdSet
}
type DictExpr = CoreExpr
ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet
ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet
ciSetFilter CallInfo -> Bool
p (CIS Id
id Bag CallInfo
a) = Id -> Bag CallInfo -> CallInfoSet
CIS Id
id ((CallInfo -> Bool) -> Bag CallInfo -> Bag CallInfo
forall a. (a -> Bool) -> Bag a -> Bag a
filterBag CallInfo -> Bool
p Bag CallInfo
a)
instance Outputable CallInfoSet where
ppr :: CallInfoSet -> SDoc
ppr (CIS Id
fn Bag CallInfo
map) = SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CIS" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn)
Int
2 (Bag CallInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bag CallInfo
map)
pprCallInfo :: Id -> CallInfo -> SDoc
pprCallInfo :: Id -> CallInfo -> SDoc
pprCallInfo Id
fn (CI { ci_key :: CallInfo -> [SpecArg]
ci_key = [SpecArg]
key })
= Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fn SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SpecArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SpecArg]
key
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
forall doc. IsLine doc => String -> doc
text String
"CI" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep ((SpecArg -> SDoc) -> [SpecArg] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map SpecArg -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SpecArg]
key))
unionCalls :: CallDetails -> CallDetails -> CallDetails
unionCalls :: CallDetails -> CallDetails -> CallDetails
unionCalls CallDetails
c1 CallDetails
c2 = (CallInfoSet -> CallInfoSet -> CallInfoSet)
-> CallDetails -> CallDetails -> CallDetails
forall a. (a -> a -> a) -> DVarEnv a -> DVarEnv a -> DVarEnv a
plusDVarEnv_C CallInfoSet -> CallInfoSet -> CallInfoSet
unionCallInfoSet CallDetails
c1 CallDetails
c2
unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet
unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet
unionCallInfoSet (CIS Id
f Bag CallInfo
calls1) (CIS Id
_ Bag CallInfo
calls2) =
Id -> Bag CallInfo -> CallInfoSet
CIS Id
f (Bag CallInfo
calls1 Bag CallInfo -> Bag CallInfo -> Bag CallInfo
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag CallInfo
calls2)
callDetailsFVs :: CallDetails -> VarSet
callDetailsFVs :: CallDetails -> VarSet
callDetailsFVs CallDetails
calls =
(CallInfoSet -> VarSet -> VarSet)
-> VarSet -> CallDetails -> VarSet
forall {k} elt a (key :: k).
(elt -> a -> a) -> a -> UniqDFM key elt -> a
nonDetStrictFoldUDFM (VarSet -> VarSet -> VarSet
unionVarSet (VarSet -> VarSet -> VarSet)
-> (CallInfoSet -> VarSet) -> CallInfoSet -> VarSet -> VarSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallInfoSet -> VarSet
callInfoFVs) VarSet
emptyVarSet CallDetails
calls
callInfoFVs :: CallInfoSet -> VarSet
callInfoFVs :: CallInfoSet -> VarSet
callInfoFVs (CIS Id
_ Bag CallInfo
call_info) =
(CallInfo -> VarSet -> VarSet) -> VarSet -> Bag CallInfo -> VarSet
forall a b. (a -> b -> b) -> b -> Bag a -> b
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 :: [PiTyBinder] -> [PredType]
getTheta :: [PiTyBinder] -> [Kind]
getTheta = (PiTyBinder -> Kind) -> [PiTyBinder] -> [Kind]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PiTyBinder -> Kind
piTyBinderType ([PiTyBinder] -> [Kind])
-> ([PiTyBinder] -> [PiTyBinder]) -> [PiTyBinder] -> [Kind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PiTyBinder -> Bool) -> [PiTyBinder] -> [PiTyBinder]
forall a. (a -> Bool) -> [a] -> [a]
filter PiTyBinder -> Bool
isInvisiblePiTyBinder ([PiTyBinder] -> [PiTyBinder])
-> ([PiTyBinder] -> [PiTyBinder]) -> [PiTyBinder] -> [PiTyBinder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PiTyBinder -> Bool) -> [PiTyBinder] -> [PiTyBinder]
forall a. (a -> Bool) -> [a] -> [a]
filter PiTyBinder -> Bool
isAnonPiTyBinder
singleCall :: SpecEnv -> Id -> [SpecArg] -> UsageDetails
singleCall :: SpecEnv -> Id -> [SpecArg] -> UsageDetails
singleCall SpecEnv
spec_env Id
id [SpecArg]
args
= MkUD {ud_binds :: FloatedDictBinds
ud_binds = FloatedDictBinds
emptyFDBs,
ud_calls :: CallDetails
ud_calls = Id -> CallInfoSet -> CallDetails
forall a. Id -> a -> DVarEnv a
unitDVarEnv Id
id (CallInfoSet -> CallDetails) -> CallInfoSet -> CallDetails
forall a b. (a -> b) -> a -> b
$ Id -> Bag CallInfo -> CallInfoSet
CIS Id
id (Bag CallInfo -> CallInfoSet) -> Bag CallInfo -> CallInfoSet
forall a b. (a -> b) -> a -> b
$
CallInfo -> Bag CallInfo
forall a. a -> Bag a
unitBag (CI { ci_key :: [SpecArg]
ci_key = [SpecArg]
args
, ci_fvs :: VarSet
ci_fvs = VarSet
call_fvs }) }
where
call_fvs :: VarSet
call_fvs =
(SpecArg -> VarSet -> VarSet) -> VarSet -> [SpecArg] -> VarSet
forall a b. (a -> b -> b) -> b -> [a] -> b
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
free_var_fn) VarSet
emptyVarSet [SpecArg]
args
free_var_fn :: SpecArg -> VarSet
free_var_fn =
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_PolymorphicSpecialisation (SpecEnv -> DynFlags
se_dflags SpecEnv
spec_env)
then SpecArg -> VarSet
specArgFreeIds
else SpecArg -> VarSet
specArgFreeVars
mkCallUDs :: SpecEnv -> OutExpr -> [OutExpr] -> UsageDetails
mkCallUDs :: SpecEnv -> OutExpr -> [OutExpr] -> UsageDetails
mkCallUDs SpecEnv
env OutExpr
fun [OutExpr]
args
| ([CoreTickish]
_, Var Id
f) <- (CoreTickish -> Bool) -> OutExpr -> ([CoreTickish], OutExpr)
forall b.
(CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)
stripTicksTop CoreTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishFloatable OutExpr
fun
=
SpecEnv -> Id -> [OutExpr] -> UsageDetails
mkCallUDs' SpecEnv
env Id
f [OutExpr]
args
| Bool
otherwise
= UsageDetails
emptyUDs
mkCallUDs' :: SpecEnv -> Id -> [OutExpr] -> UsageDetails
mkCallUDs' :: SpecEnv -> Id -> [OutExpr] -> UsageDetails
mkCallUDs' SpecEnv
env Id
f [OutExpr]
args
| SpecEnv -> Id -> Bool
wantCallsFor SpecEnv
env Id
f
, Bool -> Bool
not ([SpecArg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SpecArg]
ci_key)
=
SpecEnv -> Id -> [SpecArg] -> UsageDetails
singleCall SpecEnv
env Id
f [SpecArg]
ci_key
| Bool
otherwise
=
UsageDetails
emptyUDs
where
_trace_doc :: SDoc
_trace_doc = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
f, [OutExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [OutExpr]
args, [SpecArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SpecArg]
ci_key]
pis :: [PiTyBinder]
pis = ([PiTyBinder], Kind) -> [PiTyBinder]
forall a b. (a, b) -> a
fst (([PiTyBinder], Kind) -> [PiTyBinder])
-> ([PiTyBinder], Kind) -> [PiTyBinder]
forall a b. (a -> b) -> a -> b
$ Kind -> ([PiTyBinder], Kind)
splitPiTys (Kind -> ([PiTyBinder], Kind)) -> Kind -> ([PiTyBinder], Kind)
forall a b. (a -> b) -> a -> b
$ Id -> Kind
idType Id
f
constrained_tyvars :: VarSet
constrained_tyvars = [Kind] -> VarSet
tyCoVarsOfTypes ([Kind] -> VarSet) -> [Kind] -> VarSet
forall a b. (a -> b) -> a -> b
$ [PiTyBinder] -> [Kind]
getTheta [PiTyBinder]
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
$
(OutExpr -> PiTyBinder -> SpecArg)
-> [OutExpr] -> [PiTyBinder] -> [SpecArg]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith OutExpr -> PiTyBinder -> SpecArg
mk_spec_arg [OutExpr]
args [PiTyBinder]
pis
mk_spec_arg :: OutExpr -> PiTyBinder -> SpecArg
mk_spec_arg :: OutExpr -> PiTyBinder -> SpecArg
mk_spec_arg OutExpr
arg (Named ForAllTyBinder
bndr)
| ForAllTyBinder -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar ForAllTyBinder
bndr Id -> VarSet -> Bool
`elemVarSet` VarSet
constrained_tyvars
= case OutExpr
arg of
Type Kind
ty -> Kind -> SpecArg
SpecType Kind
ty
OutExpr
_ -> String -> SDoc -> SpecArg
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"ci_key" (SDoc -> SpecArg) -> SDoc -> SpecArg
forall a b. (a -> b) -> a -> b
$ OutExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr OutExpr
arg
| Bool
otherwise = SpecArg
UnspecType
mk_spec_arg OutExpr
arg (Anon Scaled Kind
pred FunTyFlag
af)
| FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af
, OutExpr -> Kind -> Bool
interestingDict OutExpr
arg (Scaled Kind -> Kind
forall a. Scaled a -> a
scaledThing Scaled Kind
pred)
= OutExpr -> SpecArg
SpecDict OutExpr
arg
| Bool
otherwise = SpecArg
UnspecArg
wantCallsFor :: SpecEnv -> Id -> Bool
wantCallsFor :: SpecEnv -> Id -> Bool
wantCallsFor SpecEnv
_env Id
_f = Bool
True
interestingDict :: CoreExpr -> Type -> Bool
interestingDict :: OutExpr -> Kind -> Bool
interestingDict OutExpr
arg Kind
arg_ty
| Bool -> Bool
not (Kind -> Bool
typeDeterminesValue Kind
arg_ty) = Bool
False
| Bool
otherwise = OutExpr -> Bool
forall b. Expr b -> Bool
go OutExpr
arg
where
go :: Expr b -> Bool
go (Var Id
v) = Unfolding -> Bool
hasSomeUnfolding (Id -> Unfolding
idUnfolding Id
v)
Bool -> Bool -> Bool
|| Id -> Bool
isDataConWorkId Id
v
go (Type Kind
_) = Bool
False
go (Coercion Coercion
_) = Bool
False
go (App Expr b
fn (Type Kind
_)) = Expr b -> Bool
go Expr b
fn
go (App Expr b
fn (Coercion Coercion
_)) = Expr b -> Bool
go Expr b
fn
go (Tick CoreTickish
_ Expr b
a) = Expr b -> Bool
go Expr b
a
go (Cast Expr b
e Coercion
_) = Expr b -> Bool
go Expr b
e
go Expr b
_ = Bool
True
thenUDs :: UsageDetails -> UsageDetails -> UsageDetails
thenUDs :: UsageDetails -> UsageDetails -> UsageDetails
thenUDs (MkUD {ud_binds :: UsageDetails -> FloatedDictBinds
ud_binds = FloatedDictBinds
db1, ud_calls :: UsageDetails -> CallDetails
ud_calls = CallDetails
calls1})
(MkUD {ud_binds :: UsageDetails -> FloatedDictBinds
ud_binds = FloatedDictBinds
db2, ud_calls :: UsageDetails -> CallDetails
ud_calls = CallDetails
calls2})
= MkUD { ud_binds :: FloatedDictBinds
ud_binds = FloatedDictBinds
db1 FloatedDictBinds -> FloatedDictBinds -> FloatedDictBinds
`thenFDBs` FloatedDictBinds
db2
, ud_calls :: CallDetails
ud_calls = CallDetails
calls1 CallDetails -> CallDetails -> CallDetails
`unionCalls` CallDetails
calls2 }
thenFDBs :: FloatedDictBinds -> FloatedDictBinds -> FloatedDictBinds
thenFDBs :: FloatedDictBinds -> FloatedDictBinds -> FloatedDictBinds
thenFDBs (FDB { fdb_binds :: FloatedDictBinds -> OrdList DictBind
fdb_binds = OrdList DictBind
dbs1, fdb_bndrs :: FloatedDictBinds -> VarSet
fdb_bndrs = VarSet
bs1 })
(FDB { fdb_binds :: FloatedDictBinds -> OrdList DictBind
fdb_binds = OrdList DictBind
dbs2, fdb_bndrs :: FloatedDictBinds -> VarSet
fdb_bndrs = VarSet
bs2 })
= FDB { fdb_binds :: OrdList DictBind
fdb_binds = OrdList DictBind
dbs1 OrdList DictBind -> OrdList DictBind -> OrdList DictBind
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList DictBind
dbs2
, fdb_bndrs :: VarSet
fdb_bndrs = VarSet
bs1 VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
bs2 }
_dictBindBndrs :: OrdList DictBind -> [Id]
_dictBindBndrs :: OrdList DictBind -> [Id]
_dictBindBndrs OrdList DictBind
dbs = (DictBind -> [Id] -> [Id]) -> [Id] -> OrdList DictBind -> [Id]
forall a b. (a -> b -> b) -> b -> OrdList a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ([Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
(++) ([Id] -> [Id] -> [Id])
-> (DictBind -> [Id]) -> DictBind -> [Id] -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InBind -> [Id]
forall b. Bind b -> [b]
bindersOf (InBind -> [Id]) -> (DictBind -> InBind) -> DictBind -> [Id]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DictBind -> InBind
db_bind) [] OrdList DictBind
dbs
mkDB :: CoreBind -> DictBind
mkDB :: InBind -> DictBind
mkDB InBind
bind = DB { db_bind :: InBind
db_bind = InBind
bind, db_fvs :: VarSet
db_fvs = InBind -> VarSet
bind_fvs InBind
bind }
bind_fvs :: CoreBind -> VarSet
bind_fvs :: InBind -> VarSet
bind_fvs (NonRec Id
bndr OutExpr
rhs) = (Id, OutExpr) -> VarSet
pair_fvs (Id
bndr,OutExpr
rhs)
bind_fvs (Rec [(Id, OutExpr)]
prs) = VarSet
rhs_fvs VarSet -> [Id] -> VarSet
`delVarSetList` (((Id, OutExpr) -> Id) -> [(Id, OutExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, OutExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, OutExpr)]
prs)
where
rhs_fvs :: VarSet
rhs_fvs = [VarSet] -> VarSet
unionVarSets (((Id, OutExpr) -> VarSet) -> [(Id, OutExpr)] -> [VarSet]
forall a b. (a -> b) -> [a] -> [b]
map (Id, OutExpr) -> VarSet
pair_fvs [(Id, OutExpr)]
prs)
pair_fvs :: (Id, CoreExpr) -> VarSet
pair_fvs :: (Id, OutExpr) -> VarSet
pair_fvs (Id
bndr, OutExpr
rhs) = (Id -> Bool) -> OutExpr -> VarSet
exprSomeFreeVars Id -> Bool
interesting OutExpr
rhs
VarSet -> VarSet -> VarSet
`unionVarSet` Id -> VarSet
idFreeVars Id
bndr
where
interesting :: InterestingVarFun
interesting :: Id -> Bool
interesting Id
v = Id -> Bool
isLocalVar Id
v Bool -> Bool -> Bool
|| (Id -> Bool
isId Id
v Bool -> Bool -> Bool
&& Id -> Bool
isDFunId Id
v)
recWithDumpedDicts :: [(Id,CoreExpr)] -> OrdList DictBind -> DictBind
recWithDumpedDicts :: [(Id, OutExpr)] -> OrdList DictBind -> DictBind
recWithDumpedDicts [(Id, OutExpr)]
pairs OrdList DictBind
dbs
= DB { db_bind :: InBind
db_bind = [(Id, OutExpr)] -> InBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, OutExpr)]
bindings
, db_fvs :: VarSet
db_fvs = VarSet
fvs VarSet -> [Id] -> VarSet
`delVarSetList` ((Id, OutExpr) -> Id) -> [(Id, OutExpr)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Id, OutExpr) -> Id
forall a b. (a, b) -> a
fst [(Id, OutExpr)]
bindings }
where
([(Id, OutExpr)]
bindings, VarSet
fvs) = (DictBind
-> ([(Id, OutExpr)], VarSet) -> ([(Id, OutExpr)], VarSet))
-> ([(Id, OutExpr)], VarSet)
-> OrdList DictBind
-> ([(Id, OutExpr)], VarSet)
forall a b. (a -> b -> b) -> b -> OrdList a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DictBind -> ([(Id, OutExpr)], VarSet) -> ([(Id, OutExpr)], VarSet)
add ([], VarSet
emptyVarSet)
(OrdList DictBind
dbs OrdList DictBind -> DictBind -> OrdList DictBind
forall a. OrdList a -> a -> OrdList a
`snocOL` InBind -> DictBind
mkDB ([(Id, OutExpr)] -> InBind
forall b. [(b, Expr b)] -> Bind b
Rec [(Id, OutExpr)]
pairs))
add :: DictBind -> ([(Id, OutExpr)], VarSet) -> ([(Id, OutExpr)], VarSet)
add (DB { db_bind :: DictBind -> InBind
db_bind = InBind
bind, db_fvs :: DictBind -> VarSet
db_fvs = VarSet
fvs }) ([(Id, OutExpr)]
prs_acc, VarSet
fvs_acc)
= case InBind
bind of
NonRec Id
b OutExpr
r -> ((Id
b,OutExpr
r) (Id, OutExpr) -> [(Id, OutExpr)] -> [(Id, OutExpr)]
forall a. a -> [a] -> [a]
: [(Id, OutExpr)]
prs_acc, VarSet
fvs')
Rec [(Id, OutExpr)]
prs1 -> ([(Id, OutExpr)]
prs1 [(Id, OutExpr)] -> [(Id, OutExpr)] -> [(Id, OutExpr)]
forall a. [a] -> [a] -> [a]
++ [(Id, OutExpr)]
prs_acc, VarSet
fvs')
where
fvs' :: VarSet
fvs' = VarSet
fvs_acc VarSet -> VarSet -> VarSet
`unionVarSet` VarSet
fvs
snocDictBind :: UsageDetails -> DictBind -> UsageDetails
snocDictBind :: UsageDetails -> DictBind -> UsageDetails
snocDictBind uds :: UsageDetails
uds@MkUD{ud_binds :: UsageDetails -> FloatedDictBinds
ud_binds= FDB { fdb_binds :: FloatedDictBinds -> OrdList DictBind
fdb_binds = OrdList DictBind
dbs, fdb_bndrs :: FloatedDictBinds -> VarSet
fdb_bndrs = VarSet
bs }} DictBind
db
= UsageDetails
uds { ud_binds = FDB { fdb_binds = dbs `snocOL` db
, fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }
snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails
snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails
snocDictBinds uds :: UsageDetails
uds@MkUD{ud_binds :: UsageDetails -> FloatedDictBinds
ud_binds=FDB{ fdb_binds :: FloatedDictBinds -> OrdList DictBind
fdb_binds = OrdList DictBind
binds, fdb_bndrs :: FloatedDictBinds -> VarSet
fdb_bndrs = VarSet
bs }} [DictBind]
dbs
= UsageDetails
uds { ud_binds = FDB { fdb_binds = binds `appOL` (toOL dbs)
, fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } }
consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails
consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails
consDictBinds [DictBind]
dbs uds :: UsageDetails
uds@MkUD{ud_binds :: UsageDetails -> FloatedDictBinds
ud_binds=FDB{fdb_binds :: FloatedDictBinds -> OrdList DictBind
fdb_binds = OrdList DictBind
binds, fdb_bndrs :: FloatedDictBinds -> VarSet
fdb_bndrs = VarSet
bs}}
= UsageDetails
uds { ud_binds = FDB{ fdb_binds = toOL dbs `appOL` binds
, fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } }
wrapDictBinds :: FloatedDictBinds -> [CoreBind] -> [CoreBind]
wrapDictBinds :: FloatedDictBinds -> CoreProgram -> CoreProgram
wrapDictBinds (FDB { fdb_binds :: FloatedDictBinds -> OrdList DictBind
fdb_binds = OrdList DictBind
dbs }) CoreProgram
binds
= (DictBind -> CoreProgram -> CoreProgram)
-> CoreProgram -> OrdList DictBind -> CoreProgram
forall a b. (a -> b -> b) -> b -> OrdList a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DictBind -> CoreProgram -> CoreProgram
add CoreProgram
binds OrdList DictBind
dbs
where
add :: DictBind -> CoreProgram -> CoreProgram
add (DB { db_bind :: DictBind -> InBind
db_bind = InBind
bind }) CoreProgram
binds = InBind
bind InBind -> CoreProgram -> CoreProgram
forall a. a -> [a] -> [a]
: CoreProgram
binds
wrapDictBindsE :: OrdList DictBind -> CoreExpr -> CoreExpr
wrapDictBindsE :: OrdList DictBind -> OutExpr -> OutExpr
wrapDictBindsE OrdList DictBind
dbs OutExpr
expr
= (DictBind -> OutExpr -> OutExpr)
-> OutExpr -> OrdList DictBind -> OutExpr
forall a b. (a -> b -> b) -> b -> OrdList a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DictBind -> OutExpr -> OutExpr
add OutExpr
expr OrdList DictBind
dbs
where
add :: DictBind -> OutExpr -> OutExpr
add (DB { db_bind :: DictBind -> InBind
db_bind = InBind
bind }) OutExpr
expr = InBind -> OutExpr -> OutExpr
forall b. Bind b -> Expr b -> Expr b
Let InBind
bind OutExpr
expr
dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList DictBind)
dumpUDs :: [Id] -> UsageDetails -> (UsageDetails, OrdList DictBind)
dumpUDs [Id]
bndrs uds :: UsageDetails
uds@(MkUD { ud_binds :: UsageDetails -> FloatedDictBinds
ud_binds = FloatedDictBinds
orig_dbs, ud_calls :: UsageDetails -> CallDetails
ud_calls = CallDetails
orig_calls })
| [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
bndrs = (UsageDetails
uds, OrdList DictBind
forall a. OrdList a
nilOL)
| Bool
otherwise =
(UsageDetails
free_uds, OrdList DictBind
dump_dbs)
where
free_uds :: UsageDetails
free_uds = UsageDetails
uds { ud_binds = free_dbs, ud_calls = free_calls }
bndr_set :: VarSet
bndr_set = [Id] -> VarSet
mkVarSet [Id]
bndrs
(FloatedDictBinds
free_dbs, OrdList DictBind
dump_dbs, VarSet
dump_set) = FloatedDictBinds
-> VarSet -> (FloatedDictBinds, OrdList DictBind, VarSet)
splitDictBinds FloatedDictBinds
orig_dbs VarSet
bndr_set
free_calls :: CallDetails
free_calls = VarSet -> CallDetails -> CallDetails
deleteCallsMentioning VarSet
dump_set (CallDetails -> CallDetails) -> CallDetails -> CallDetails
forall a b. (a -> b) -> a -> b
$
[Id] -> CallDetails -> CallDetails
deleteCallsFor [Id]
bndrs CallDetails
orig_calls
dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList DictBind, Bool)
dumpBindUDs :: [Id] -> UsageDetails -> (UsageDetails, OrdList DictBind, Bool)
dumpBindUDs [Id]
bndrs (MkUD { ud_binds :: UsageDetails -> FloatedDictBinds
ud_binds = FloatedDictBinds
orig_dbs, ud_calls :: UsageDetails -> CallDetails
ud_calls = CallDetails
orig_calls })
=
(UsageDetails
free_uds, OrdList DictBind
dump_dbs, Bool
float_all)
where
free_uds :: UsageDetails
free_uds = MkUD { ud_binds :: FloatedDictBinds
ud_binds = FloatedDictBinds
free_dbs, ud_calls :: CallDetails
ud_calls = CallDetails
free_calls }
bndr_set :: VarSet
bndr_set = [Id] -> VarSet
mkVarSet [Id]
bndrs
(FloatedDictBinds
free_dbs, OrdList DictBind
dump_dbs, VarSet
dump_set) = FloatedDictBinds
-> VarSet -> (FloatedDictBinds, OrdList DictBind, VarSet)
splitDictBinds FloatedDictBinds
orig_dbs VarSet
bndr_set
free_calls :: CallDetails
free_calls = [Id] -> CallDetails -> CallDetails
deleteCallsFor [Id]
bndrs CallDetails
orig_calls
float_all :: Bool
float_all = VarSet
dump_set VarSet -> VarSet -> Bool
`intersectsVarSet` CallDetails -> VarSet
callDetailsFVs CallDetails
free_calls
callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])
callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])
callsForMe Id
fn uds :: UsageDetails
uds@MkUD { ud_binds :: UsageDetails -> FloatedDictBinds
ud_binds = FloatedDictBinds
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 = UsageDetails
uds { ud_calls = delDVarEnv orig_calls fn }
calls_for_me :: [CallInfo]
calls_for_me = case CallDetails -> Id -> Maybe CallInfoSet
forall a. DVarEnv a -> Id -> Maybe a
lookupDVarEnv CallDetails
orig_calls Id
fn of
Maybe CallInfoSet
Nothing -> []
Just CallInfoSet
cis -> CallInfoSet -> FloatedDictBinds -> [CallInfo]
filterCalls CallInfoSet
cis FloatedDictBinds
orig_dbs
filterCalls :: CallInfoSet -> FloatedDictBinds -> [CallInfo]
filterCalls :: CallInfoSet -> FloatedDictBinds -> [CallInfo]
filterCalls (CIS Id
fn Bag CallInfo
call_bag) (FDB { fdb_binds :: FloatedDictBinds -> OrdList DictBind
fdb_binds = OrdList DictBind
dbs })
| Id -> Bool
isDFunId Id
fn
= (CallInfo -> Bool) -> [CallInfo] -> [CallInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter CallInfo -> Bool
ok_call [CallInfo]
de_dupd_calls
| Bool
otherwise
= [CallInfo]
de_dupd_calls
where
de_dupd_calls :: [CallInfo]
de_dupd_calls = Bag CallInfo -> [CallInfo]
remove_dups Bag CallInfo
call_bag
dump_set :: VarSet
dump_set = (VarSet -> DictBind -> VarSet)
-> VarSet -> OrdList DictBind -> VarSet
forall b a. (b -> a -> b) -> b -> OrdList a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' VarSet -> DictBind -> VarSet
go (Id -> VarSet
unitVarSet Id
fn) OrdList DictBind
dbs
go :: VarSet -> DictBind -> VarSet
go VarSet
so_far (DB { db_bind :: DictBind -> InBind
db_bind = InBind
bind, db_fvs :: DictBind -> VarSet
db_fvs = VarSet
fvs })
| VarSet
fvs VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
so_far
= VarSet -> [Id] -> VarSet
extendVarSetList VarSet
so_far (InBind -> [Id]
forall b. Bind b -> [b]
bindersOf InBind
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
remove_dups :: Bag CallInfo -> [CallInfo]
remove_dups :: Bag CallInfo -> [CallInfo]
remove_dups Bag CallInfo
calls = (CallInfo -> [CallInfo] -> [CallInfo])
-> [CallInfo] -> Bag CallInfo -> [CallInfo]
forall a b. (a -> b -> b) -> b -> Bag a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr CallInfo -> [CallInfo] -> [CallInfo]
add [] Bag CallInfo
calls
where
add :: CallInfo -> [CallInfo] -> [CallInfo]
add :: CallInfo -> [CallInfo] -> [CallInfo]
add CallInfo
ci [] = [CallInfo
ci]
add CallInfo
ci1 (CallInfo
ci2:[CallInfo]
cis) | CallInfo
ci2 CallInfo -> CallInfo -> Bool
`beats_or_same` CallInfo
ci1 = CallInfo
ci2CallInfo -> [CallInfo] -> [CallInfo]
forall a. a -> [a] -> [a]
:[CallInfo]
cis
| CallInfo
ci1 CallInfo -> CallInfo -> Bool
`beats_or_same` CallInfo
ci2 = CallInfo
ci1CallInfo -> [CallInfo] -> [CallInfo]
forall a. a -> [a] -> [a]
:[CallInfo]
cis
| Bool
otherwise = CallInfo
ci2 CallInfo -> [CallInfo] -> [CallInfo]
forall a. a -> [a] -> [a]
: CallInfo -> [CallInfo] -> [CallInfo]
add CallInfo
ci1 [CallInfo]
cis
beats_or_same :: CallInfo -> CallInfo -> Bool
beats_or_same :: CallInfo -> CallInfo -> Bool
beats_or_same (CI { ci_key :: CallInfo -> [SpecArg]
ci_key = [SpecArg]
args1 }) (CI { ci_key :: CallInfo -> [SpecArg]
ci_key = [SpecArg]
args2 })
= [SpecArg] -> [SpecArg] -> Bool
go [SpecArg]
args1 [SpecArg]
args2
where
go :: [SpecArg] -> [SpecArg] -> Bool
go [] [SpecArg]
_ = Bool
True
go (SpecArg
arg1:[SpecArg]
args1) (SpecArg
arg2:[SpecArg]
args2) = SpecArg -> SpecArg -> Bool
go_arg SpecArg
arg1 SpecArg
arg2 Bool -> Bool -> Bool
&& [SpecArg] -> [SpecArg] -> Bool
go [SpecArg]
args1 [SpecArg]
args2
go (SpecArg
_:[SpecArg]
_) [] = Bool
False
go_arg :: SpecArg -> SpecArg -> Bool
go_arg (SpecType Kind
ty1) (SpecType Kind
ty2) = Maybe Subst -> Bool
forall a. Maybe a -> Bool
isJust (Kind -> Kind -> Maybe Subst
tcMatchTy Kind
ty1 Kind
ty2)
go_arg SpecArg
UnspecType SpecArg
UnspecType = Bool
True
go_arg (SpecDict {}) (SpecDict {}) = Bool
True
go_arg SpecArg
UnspecArg SpecArg
UnspecArg = Bool
True
go_arg SpecArg
_ SpecArg
_ = Bool
False
splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, OrdList DictBind, IdSet)
splitDictBinds :: FloatedDictBinds
-> VarSet -> (FloatedDictBinds, OrdList DictBind, VarSet)
splitDictBinds (FDB { fdb_binds :: FloatedDictBinds -> OrdList DictBind
fdb_binds = OrdList DictBind
dbs, fdb_bndrs :: FloatedDictBinds -> VarSet
fdb_bndrs = VarSet
bs }) VarSet
bndr_set
= (FDB { fdb_binds :: OrdList DictBind
fdb_binds = OrdList DictBind
free_dbs
, fdb_bndrs :: VarSet
fdb_bndrs = VarSet
bs VarSet -> VarSet -> VarSet
`minusVarSet` VarSet
dump_set }
, OrdList DictBind
dump_dbs, VarSet
dump_set)
where
(OrdList DictBind
free_dbs, OrdList DictBind
dump_dbs, VarSet
dump_set)
= ((OrdList DictBind, OrdList DictBind, VarSet)
-> DictBind -> (OrdList DictBind, OrdList DictBind, VarSet))
-> (OrdList DictBind, OrdList DictBind, VarSet)
-> OrdList DictBind
-> (OrdList DictBind, OrdList DictBind, VarSet)
forall b a. (b -> a -> b) -> b -> OrdList a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (OrdList DictBind, OrdList DictBind, VarSet)
-> DictBind -> (OrdList DictBind, OrdList DictBind, VarSet)
split_db (OrdList DictBind
forall a. OrdList a
nilOL, OrdList DictBind
forall a. OrdList a
nilOL, VarSet
bndr_set) OrdList DictBind
dbs
split_db :: (OrdList DictBind, OrdList DictBind, VarSet)
-> DictBind -> (OrdList DictBind, OrdList DictBind, VarSet)
split_db (OrdList DictBind
free_dbs, OrdList DictBind
dump_dbs, VarSet
dump_idset) DictBind
db
| DB { db_bind :: DictBind -> InBind
db_bind = InBind
bind, db_fvs :: DictBind -> VarSet
db_fvs = VarSet
fvs } <- DictBind
db
, VarSet
dump_idset VarSet -> VarSet -> Bool
`intersectsVarSet` VarSet
fvs
= (OrdList DictBind
free_dbs, OrdList DictBind
dump_dbs OrdList DictBind -> DictBind -> OrdList DictBind
forall a. OrdList a -> a -> OrdList a
`snocOL` DictBind
db,
VarSet -> [Id] -> VarSet
extendVarSetList VarSet
dump_idset (InBind -> [Id]
forall b. Bind b -> [b]
bindersOf InBind
bind))
| Bool
otherwise
= (OrdList DictBind
free_dbs OrdList DictBind -> DictBind -> OrdList DictBind
forall a. OrdList a -> a -> OrdList a
`snocOL` DictBind
db, OrdList DictBind
dump_dbs, VarSet
dump_idset)
deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails
deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails
deleteCallsMentioning VarSet
bndrs 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
bndrs
deleteCallsFor :: [Id] -> CallDetails -> CallDetails
deleteCallsFor :: [Id] -> CallDetails -> CallDetails
deleteCallsFor [Id]
bndrs CallDetails
calls = CallDetails -> [Id] -> CallDetails
forall a. DVarEnv a -> [Id] -> DVarEnv a
delDVarEnvList CallDetails
calls [Id]
bndrs
type SpecM a = UniqSM a
runSpecM :: SpecM a -> CoreM a
runSpecM :: forall a. SpecM a -> CoreM a
runSpecM SpecM a
thing_inside
= do { us <- CoreM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
; return (initUs_ us thing_inside) }
mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM :: forall a b.
(a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)
mapAndCombineSM a -> SpecM (b, UsageDetails)
_ [] = ([b], UsageDetails) -> UniqSM ([b], UsageDetails)
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], UsageDetails
emptyUDs)
mapAndCombineSM a -> SpecM (b, UsageDetails)
f (a
x:[a]
xs) = do (y, uds1) <- a -> SpecM (b, UsageDetails)
f a
x
(ys, uds2) <- mapAndCombineSM f xs
return (y:ys, uds1 `thenUDs` uds2)
extendTvSubst :: SpecEnv -> TyVar -> Type -> SpecEnv
extendTvSubst :: SpecEnv -> Id -> Kind -> SpecEnv
extendTvSubst SpecEnv
env Id
tv Kind
ty
= SpecEnv
env { se_subst = Core.extendTvSubst (se_subst env) tv ty }
extendInScope :: SpecEnv -> OutId -> SpecEnv
extendInScope :: SpecEnv -> Id -> SpecEnv
extendInScope env :: SpecEnv
env@(SE { se_subst :: SpecEnv -> Subst
se_subst = Subst
subst }) Id
bndr
= SpecEnv
env { se_subst = subst `Core.extendSubstInScope` bndr }
zapSubst :: SpecEnv -> SpecEnv
zapSubst :: SpecEnv -> SpecEnv
zapSubst env :: SpecEnv
env@(SE { se_subst :: SpecEnv -> Subst
se_subst = Subst
subst })
= SpecEnv
env { se_subst = Core.zapSubst subst }
substTy :: SpecEnv -> Type -> Type
substTy :: SpecEnv -> Kind -> Kind
substTy SpecEnv
env Kind
ty = Subst -> Kind -> Kind
substTyUnchecked (SpecEnv -> Subst
se_subst SpecEnv
env) Kind
ty
substCo :: SpecEnv -> Coercion -> Coercion
substCo :: SpecEnv -> Coercion -> Coercion
substCo SpecEnv
env Coercion
co = HasDebugCallStack => Subst -> Coercion -> Coercion
Subst -> Coercion -> Coercion
Core.substCo (SpecEnv -> Subst
se_subst SpecEnv
env) Coercion
co
substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr)
substBndr :: SpecEnv -> Id -> (SpecEnv, Id)
substBndr SpecEnv
env Id
bs = case Subst -> Id -> (Subst, Id)
Core.substBndr (SpecEnv -> Subst
se_subst SpecEnv
env) Id
bs of
(Subst
subst', Id
bs') -> (SpecEnv
env { se_subst = subst' }, Id
bs')
substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr])
substBndrs :: SpecEnv -> [Id] -> (SpecEnv, [Id])
substBndrs SpecEnv
env [Id]
bs = case Subst -> [Id] -> (Subst, [Id])
forall (f :: * -> *).
Traversable f =>
Subst -> f Id -> (Subst, f Id)
Core.substBndrs (SpecEnv -> Subst
se_subst SpecEnv
env) [Id]
bs of
(Subst
subst', [Id]
bs') -> (SpecEnv
env { se_subst = subst' }, [Id]
bs')
cloneBndrSM :: SpecEnv -> Id -> SpecM (SpecEnv, Id)
cloneBndrSM :: SpecEnv -> Id -> UniqSM (SpecEnv, Id)
cloneBndrSM env :: SpecEnv
env@(SE { se_subst :: SpecEnv -> Subst
se_subst = Subst
subst }) Id
bndr
= do { us <- UniqSM UniqSupply
forall (m :: * -> *). MonadUnique m => m UniqSupply
getUniqueSupplyM
; let (subst', bndr') = Core.cloneIdBndr subst us bndr
; return (env { se_subst = subst' }, bndr') }
cloneRecBndrsSM :: SpecEnv -> [Id] -> SpecM (SpecEnv, [Id])
env :: SpecEnv
env@(SE { se_subst :: SpecEnv -> Subst
se_subst = Subst
subst }) [Id]
bndrs
= do { (subst', bndrs') <- Subst -> [Id] -> UniqSM (Subst, [Id])
forall (m :: * -> *).
MonadUnique m =>
Subst -> [Id] -> m (Subst, [Id])
Core.cloneRecIdBndrs Subst
subst [Id]
bndrs
; let env' = SpecEnv
env { se_subst = subst' }
; return (env', bndrs') }
newDictBndr :: SpecEnv -> CoreBndr -> SpecM (SpecEnv, CoreBndr)
newDictBndr :: SpecEnv -> Id -> UniqSM (SpecEnv, Id)
newDictBndr env :: SpecEnv
env@(SE { se_subst :: SpecEnv -> Subst
se_subst = Subst
subst }) Id
b
= do { uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let n = Id -> Name
idName Id
b
ty' = Subst -> Kind -> Kind
substTyUnchecked Subst
subst (Id -> Kind
idType Id
b)
b' = OccName -> Unique -> Kind -> Kind -> SrcSpan -> Id
mkUserLocal (Name -> OccName
nameOccName Name
n) Unique
uniq Kind
ManyTy Kind
ty' (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
n)
env' = SpecEnv
env { se_subst = subst `Core.extendSubstInScope` b' }
; pure (env', b') }
newSpecIdSM :: Name -> Type -> IdDetails -> IdInfo -> SpecM Id
newSpecIdSM :: Name -> Kind -> IdDetails -> IdInfo -> UniqSM Id
newSpecIdSM Name
old_name Kind
new_ty IdDetails
details IdInfo
info
= do { uniq <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; let new_occ = OccName -> OccName
mkSpecOcc (Name -> OccName
nameOccName Name
old_name)
new_name = Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
new_occ (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
old_name)
; return (assert (not (isCoVarType new_ty)) $
mkLocalVar details new_name ManyTy new_ty info) }