{-# LANGUAGE BangPatterns #-}
module GHC.Core.Opt.CallArity
( callArityAnalProgram
, callArityRHS
) where
import GHC.Prelude
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Driver.Session ( DynFlags )
import GHC.Types.Basic
import GHC.Core
import GHC.Types.Id
import GHC.Core.Opt.Arity ( typeArity )
import GHC.Core.Utils ( exprIsCheap, exprIsTrivial )
import GHC.Data.Graph.UnVar
import GHC.Types.Demand
import GHC.Utils.Misc
import Control.Arrow ( first, second )
callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram
callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram
callArityAnalProgram DynFlags
_dflags CoreProgram
binds = CoreProgram
binds'
where
(CallArityRes
_, CoreProgram
binds') = [Id] -> VarSet -> CoreProgram -> (CallArityRes, CoreProgram)
callArityTopLvl [] VarSet
emptyVarSet CoreProgram
binds
callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind])
callArityTopLvl :: [Id] -> VarSet -> CoreProgram -> (CallArityRes, CoreProgram)
callArityTopLvl [Id]
exported VarSet
_ []
= ( CallArityRes -> CallArityRes
calledMultipleTimes forall a b. (a -> b) -> a -> b
$ (UnVarGraph
emptyUnVarGraph, forall a. [(Id, a)] -> VarEnv a
mkVarEnv forall a b. (a -> b) -> a -> b
$ [(Id
v, Arity
0) | Id
v <- [Id]
exported])
, [] )
callArityTopLvl [Id]
exported VarSet
int1 (CoreBind
b:CoreProgram
bs)
= (CallArityRes
ae2, CoreBind
b'forall a. a -> [a] -> [a]
:CoreProgram
bs')
where
int2 :: [Id]
int2 = forall b. Bind b -> [b]
bindersOf CoreBind
b
exported' :: [Id]
exported' = forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
isExportedId [Id]
int2 forall a. [a] -> [a] -> [a]
++ [Id]
exported
int' :: VarSet
int' = VarSet
int1 VarSet -> CoreBind -> VarSet
`addInterestingBinds` CoreBind
b
(CallArityRes
ae1, CoreProgram
bs') = [Id] -> VarSet -> CoreProgram -> (CallArityRes, CoreProgram)
callArityTopLvl [Id]
exported' VarSet
int' CoreProgram
bs
(CallArityRes
ae2, CoreBind
b') = VarSet
-> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)
callArityBind (CoreBind -> VarSet
boringBinds CoreBind
b) CallArityRes
ae1 VarSet
int1 CoreBind
b
callArityRHS :: CoreExpr -> CoreExpr
callArityRHS :: CoreExpr -> CoreExpr
callArityRHS = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arity -> VarSet -> CoreExpr -> (CallArityRes, CoreExpr)
callArityAnal Arity
0 VarSet
emptyVarSet
callArityAnal ::
Arity ->
VarSet ->
CoreExpr ->
(CallArityRes, CoreExpr)
callArityAnal :: Arity -> VarSet -> CoreExpr -> (CallArityRes, CoreExpr)
callArityAnal Arity
_ VarSet
_ e :: CoreExpr
e@(Lit Literal
_)
= (CallArityRes
emptyArityRes, CoreExpr
e)
callArityAnal Arity
_ VarSet
_ e :: CoreExpr
e@(Type Type
_)
= (CallArityRes
emptyArityRes, CoreExpr
e)
callArityAnal Arity
_ VarSet
_ e :: CoreExpr
e@(Coercion Coercion
_)
= (CallArityRes
emptyArityRes, CoreExpr
e)
callArityAnal Arity
arity VarSet
int (Tick CoreTickish
t CoreExpr
e)
= forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t) forall a b. (a -> b) -> a -> b
$ Arity -> VarSet -> CoreExpr -> (CallArityRes, CoreExpr)
callArityAnal Arity
arity VarSet
int CoreExpr
e
callArityAnal Arity
arity VarSet
int (Cast CoreExpr
e Coercion
co)
= forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (\CoreExpr
e -> forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
e Coercion
co) forall a b. (a -> b) -> a -> b
$ Arity -> VarSet -> CoreExpr -> (CallArityRes, CoreExpr)
callArityAnal Arity
arity VarSet
int CoreExpr
e
callArityAnal Arity
arity VarSet
int e :: CoreExpr
e@(Var Id
v)
| Id
v Id -> VarSet -> Bool
`elemVarSet` VarSet
int
= (Id -> Arity -> CallArityRes
unitArityRes Id
v Arity
arity, CoreExpr
e)
| Bool
otherwise
= (CallArityRes
emptyArityRes, CoreExpr
e)
callArityAnal Arity
arity VarSet
int (Lam Id
v CoreExpr
e) | Bool -> Bool
not (Id -> Bool
isId Id
v)
= forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (forall b. b -> Expr b -> Expr b
Lam Id
v) forall a b. (a -> b) -> a -> b
$ Arity -> VarSet -> CoreExpr -> (CallArityRes, CoreExpr)
callArityAnal Arity
arity (VarSet
int VarSet -> Id -> VarSet
`delVarSet` Id
v) CoreExpr
e
callArityAnal Arity
0 VarSet
int (Lam Id
v CoreExpr
e)
= (CallArityRes
ae', forall b. b -> Expr b -> Expr b
Lam Id
v CoreExpr
e')
where
(CallArityRes
ae, CoreExpr
e') = Arity -> VarSet -> CoreExpr -> (CallArityRes, CoreExpr)
callArityAnal Arity
0 (VarSet
int VarSet -> Id -> VarSet
`delVarSet` Id
v) CoreExpr
e
ae' :: CallArityRes
ae' = CallArityRes -> CallArityRes
calledMultipleTimes CallArityRes
ae
callArityAnal Arity
arity VarSet
int (Lam Id
v CoreExpr
e)
= (CallArityRes
ae, forall b. b -> Expr b -> Expr b
Lam Id
v CoreExpr
e')
where
(CallArityRes
ae, CoreExpr
e') = Arity -> VarSet -> CoreExpr -> (CallArityRes, CoreExpr)
callArityAnal (Arity
arity forall a. Num a => a -> a -> a
- Arity
1) (VarSet
int VarSet -> Id -> VarSet
`delVarSet` Id
v) CoreExpr
e
callArityAnal Arity
arity VarSet
int (App CoreExpr
e (Type Type
t))
= forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (\CoreExpr
e -> forall b. Expr b -> Expr b -> Expr b
App CoreExpr
e (forall b. Type -> Expr b
Type Type
t)) forall a b. (a -> b) -> a -> b
$ Arity -> VarSet -> CoreExpr -> (CallArityRes, CoreExpr)
callArityAnal Arity
arity VarSet
int CoreExpr
e
callArityAnal Arity
arity VarSet
int (App CoreExpr
e1 CoreExpr
e2)
= (CallArityRes
final_ae, forall b. Expr b -> Expr b -> Expr b
App CoreExpr
e1' CoreExpr
e2')
where
(CallArityRes
ae1, CoreExpr
e1') = Arity -> VarSet -> CoreExpr -> (CallArityRes, CoreExpr)
callArityAnal (Arity
arity forall a. Num a => a -> a -> a
+ Arity
1) VarSet
int CoreExpr
e1
(CallArityRes
ae2, CoreExpr
e2') = Arity -> VarSet -> CoreExpr -> (CallArityRes, CoreExpr)
callArityAnal Arity
0 VarSet
int CoreExpr
e2
ae2' :: CallArityRes
ae2' | CoreExpr -> Bool
exprIsTrivial CoreExpr
e2 = CallArityRes -> CallArityRes
calledMultipleTimes CallArityRes
ae2
| Bool
otherwise = CallArityRes
ae2
final_ae :: CallArityRes
final_ae = CallArityRes
ae1 CallArityRes -> CallArityRes -> CallArityRes
`both` CallArityRes
ae2'
callArityAnal Arity
arity VarSet
int (Case CoreExpr
scrut Id
bndr Type
ty [Alt Id]
alts)
=
(CallArityRes
final_ae, forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
scrut' Id
bndr Type
ty [Alt Id]
alts')
where
([CallArityRes]
alt_aes, [Alt Id]
alts') = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Alt Id -> (CallArityRes, Alt Id)
go [Alt Id]
alts
go :: Alt Id -> (CallArityRes, Alt Id)
go (Alt AltCon
dc [Id]
bndrs CoreExpr
e) = let (CallArityRes
ae, CoreExpr
e') = Arity -> VarSet -> CoreExpr -> (CallArityRes, CoreExpr)
callArityAnal Arity
arity VarSet
int CoreExpr
e
in (CallArityRes
ae, forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
dc [Id]
bndrs CoreExpr
e')
alt_ae :: CallArityRes
alt_ae = [CallArityRes] -> CallArityRes
lubRess [CallArityRes]
alt_aes
(CallArityRes
scrut_ae, CoreExpr
scrut') = Arity -> VarSet -> CoreExpr -> (CallArityRes, CoreExpr)
callArityAnal Arity
0 VarSet
int CoreExpr
scrut
final_ae :: CallArityRes
final_ae = CallArityRes
scrut_ae CallArityRes -> CallArityRes -> CallArityRes
`both` CallArityRes
alt_ae
callArityAnal Arity
arity VarSet
int (Let CoreBind
bind CoreExpr
e)
=
(CallArityRes
final_ae, forall b. Bind b -> Expr b -> Expr b
Let CoreBind
bind' CoreExpr
e')
where
int_body :: VarSet
int_body = VarSet
int VarSet -> CoreBind -> VarSet
`addInterestingBinds` CoreBind
bind
(CallArityRes
ae_body, CoreExpr
e') = Arity -> VarSet -> CoreExpr -> (CallArityRes, CoreExpr)
callArityAnal Arity
arity VarSet
int_body CoreExpr
e
(CallArityRes
final_ae, CoreBind
bind') = VarSet
-> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)
callArityBind (CoreBind -> VarSet
boringBinds CoreBind
bind) CallArityRes
ae_body VarSet
int CoreBind
bind
isInteresting :: Var -> Bool
isInteresting :: Id -> Bool
isInteresting Id
v = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Type -> [OneShotInfo]
typeArity (Id -> Type
idType Id
v))
interestingBinds :: CoreBind -> [Var]
interestingBinds :: CoreBind -> [Id]
interestingBinds = forall a. (a -> Bool) -> [a] -> [a]
filter Id -> Bool
isInteresting forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Bind b -> [b]
bindersOf
boringBinds :: CoreBind -> VarSet
boringBinds :: CoreBind -> VarSet
boringBinds = [Id] -> VarSet
mkVarSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Bool
isInteresting) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Bind b -> [b]
bindersOf
addInterestingBinds :: VarSet -> CoreBind -> VarSet
addInterestingBinds :: VarSet -> CoreBind -> VarSet
addInterestingBinds VarSet
int CoreBind
bind
= VarSet
int VarSet -> [Id] -> VarSet
`delVarSetList` forall b. Bind b -> [b]
bindersOf CoreBind
bind
VarSet -> [Id] -> VarSet
`extendVarSetList` CoreBind -> [Id]
interestingBinds CoreBind
bind
callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)
callArityBind :: VarSet
-> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)
callArityBind VarSet
boring_vars CallArityRes
ae_body VarSet
int (NonRec Id
v CoreExpr
rhs)
| Bool
otherwise
=
(CallArityRes
final_ae, forall b. b -> Expr b -> Bind b
NonRec Id
v' CoreExpr
rhs')
where
is_thunk :: Bool
is_thunk = Bool -> Bool
not (CoreExpr -> Bool
exprIsCheap CoreExpr
rhs)
boring :: Bool
boring = Id
v Id -> VarSet -> Bool
`elemVarSet` VarSet
boring_vars
(Arity
arity, Bool
called_once)
| Bool
boring = (Arity
0, Bool
False)
| Bool
otherwise = CallArityRes -> Id -> (Arity, Bool)
lookupCallArityRes CallArityRes
ae_body Id
v
safe_arity :: Arity
safe_arity | Bool
called_once = Arity
arity
| Bool
is_thunk = Arity
0
| Bool
otherwise = Arity
arity
trimmed_arity :: Arity
trimmed_arity = Id -> Arity -> Arity
trimArity Id
v Arity
safe_arity
(CallArityRes
ae_rhs, CoreExpr
rhs') = Arity -> VarSet -> CoreExpr -> (CallArityRes, CoreExpr)
callArityAnal Arity
trimmed_arity VarSet
int CoreExpr
rhs
ae_rhs' :: CallArityRes
ae_rhs'| Bool
called_once = CallArityRes
ae_rhs
| Arity
safe_arity forall a. Eq a => a -> a -> Bool
== Arity
0 = CallArityRes
ae_rhs
| Bool
otherwise = CallArityRes -> CallArityRes
calledMultipleTimes CallArityRes
ae_rhs
called_by_v :: UnVarSet
called_by_v = CallArityRes -> UnVarSet
domRes CallArityRes
ae_rhs'
called_with_v :: UnVarSet
called_with_v
| Bool
boring = CallArityRes -> UnVarSet
domRes CallArityRes
ae_body
| Bool
otherwise = CallArityRes -> Id -> UnVarSet
calledWith CallArityRes
ae_body Id
v UnVarSet -> Id -> UnVarSet
`delUnVarSet` Id
v
final_ae :: CallArityRes
final_ae = UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes
addCrossCoCalls UnVarSet
called_by_v UnVarSet
called_with_v forall a b. (a -> b) -> a -> b
$ CallArityRes
ae_rhs' CallArityRes -> CallArityRes -> CallArityRes
`lubRes` Id -> CallArityRes -> CallArityRes
resDel Id
v CallArityRes
ae_body
v' :: Id
v' = Id
v Id -> Arity -> Id
`setIdCallArity` Arity
trimmed_arity
callArityBind VarSet
boring_vars CallArityRes
ae_body VarSet
int b :: CoreBind
b@(Rec [(Id, CoreExpr)]
binds)
=
(CallArityRes
final_ae, forall b. [(b, Expr b)] -> Bind b
Rec [(Id, CoreExpr)]
binds')
where
any_boring :: Bool
any_boring = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Id -> VarSet -> Bool
`elemVarSet` VarSet
boring_vars) [ Id
i | (Id
i, CoreExpr
_) <- [(Id, CoreExpr)]
binds]
int_body :: VarSet
int_body = VarSet
int VarSet -> CoreBind -> VarSet
`addInterestingBinds` CoreBind
b
(CallArityRes
ae_rhs, [(Id, CoreExpr)]
binds') = [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)]
-> (CallArityRes, [(Id, CoreExpr)])
fix [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)]
initial_binds
final_ae :: CallArityRes
final_ae = forall b. Bind b -> [b]
bindersOf CoreBind
b [Id] -> CallArityRes -> CallArityRes
`resDelList` CallArityRes
ae_rhs
initial_binds :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)]
initial_binds = [(Id
i,forall a. Maybe a
Nothing,CoreExpr
e) | (Id
i,CoreExpr
e) <- [(Id, CoreExpr)]
binds]
fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)])
fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)]
-> (CallArityRes, [(Id, CoreExpr)])
fix [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)]
ann_binds
|
Bool
any_change
= [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)]
-> (CallArityRes, [(Id, CoreExpr)])
fix [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)]
ann_binds'
| Bool
otherwise
= (CallArityRes
ae, forall a b. (a -> b) -> [a] -> [b]
map (\(Id
i, Maybe (Bool, Arity, CallArityRes)
_, CoreExpr
e) -> (Id
i, CoreExpr
e)) [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)]
ann_binds')
where
aes_old :: [(Id, CallArityRes)]
aes_old = [ (Id
i,CallArityRes
ae) | (Id
i, Just (Bool
_,Arity
_,CallArityRes
ae), CoreExpr
_) <- [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)]
ann_binds ]
ae :: CallArityRes
ae = Bool -> [(Id, CallArityRes)] -> CallArityRes -> CallArityRes
callArityRecEnv Bool
any_boring [(Id, CallArityRes)]
aes_old CallArityRes
ae_body
rerun :: (Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)
-> (Bool, (Id, Maybe (Bool, Arity, CallArityRes), CoreExpr))
rerun (Id
i, Maybe (Bool, Arity, CallArityRes)
mbLastRun, CoreExpr
rhs)
| Id
i Id -> VarSet -> Bool
`elemVarSet` VarSet
int_body Bool -> Bool -> Bool
&& Bool -> Bool
not (Id
i Id -> UnVarSet -> Bool
`elemUnVarSet` CallArityRes -> UnVarSet
domRes CallArityRes
ae)
= (Bool
False, (Id
i, forall a. Maybe a
Nothing, CoreExpr
rhs))
| Just (Bool
old_called_once, Arity
old_arity, CallArityRes
_) <- Maybe (Bool, Arity, CallArityRes)
mbLastRun
, Bool
called_once forall a. Eq a => a -> a -> Bool
== Bool
old_called_once
, Arity
new_arity forall a. Eq a => a -> a -> Bool
== Arity
old_arity
= (Bool
False, (Id
i, Maybe (Bool, Arity, CallArityRes)
mbLastRun, CoreExpr
rhs))
| Bool
otherwise
= let is_thunk :: Bool
is_thunk = Bool -> Bool
not (CoreExpr -> Bool
exprIsCheap CoreExpr
rhs)
safe_arity :: Arity
safe_arity | Bool
is_thunk = Arity
0
| Bool
otherwise = Arity
new_arity
trimmed_arity :: Arity
trimmed_arity = Id -> Arity -> Arity
trimArity Id
i Arity
safe_arity
(CallArityRes
ae_rhs, CoreExpr
rhs') = Arity -> VarSet -> CoreExpr -> (CallArityRes, CoreExpr)
callArityAnal Arity
trimmed_arity VarSet
int_body CoreExpr
rhs
ae_rhs' :: CallArityRes
ae_rhs' | Bool
called_once = CallArityRes
ae_rhs
| Arity
safe_arity forall a. Eq a => a -> a -> Bool
== Arity
0 = CallArityRes
ae_rhs
| Bool
otherwise = CallArityRes -> CallArityRes
calledMultipleTimes CallArityRes
ae_rhs
i' :: Id
i' = Id
i Id -> Arity -> Id
`setIdCallArity` Arity
trimmed_arity
in (Bool
True, (Id
i', forall a. a -> Maybe a
Just (Bool
called_once, Arity
new_arity, CallArityRes
ae_rhs'), CoreExpr
rhs'))
where
(Arity
new_arity, Bool
called_once) | Id
i Id -> VarSet -> Bool
`elemVarSet` VarSet
boring_vars = (Arity
0, Bool
False)
| Bool
otherwise = CallArityRes -> Id -> (Arity, Bool)
lookupCallArityRes CallArityRes
ae Id
i
([Bool]
changes, [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)]
ann_binds') = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)
-> (Bool, (Id, Maybe (Bool, Arity, CallArityRes), CoreExpr))
rerun [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)]
ann_binds
any_change :: Bool
any_change = forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
changes
callArityRecEnv :: Bool -> [(Var, CallArityRes)] -> CallArityRes -> CallArityRes
callArityRecEnv :: Bool -> [(Id, CallArityRes)] -> CallArityRes -> CallArityRes
callArityRecEnv Bool
any_boring [(Id, CallArityRes)]
ae_rhss CallArityRes
ae_body
=
CallArityRes
ae_new
where
vars :: [Id]
vars = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Id, CallArityRes)]
ae_rhss
ae_combined :: CallArityRes
ae_combined = [CallArityRes] -> CallArityRes
lubRess (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Id, CallArityRes)]
ae_rhss) CallArityRes -> CallArityRes -> CallArityRes
`lubRes` CallArityRes
ae_body
cross_calls :: UnVarGraph
cross_calls
| Bool
any_boring = UnVarSet -> UnVarGraph
completeGraph (CallArityRes -> UnVarSet
domRes CallArityRes
ae_combined)
| forall a. [a] -> Arity -> Bool
lengthExceeds [(Id, CallArityRes)]
ae_rhss Arity
25 = UnVarSet -> UnVarGraph
completeGraph (CallArityRes -> UnVarSet
domRes CallArityRes
ae_combined)
| Bool
otherwise = [UnVarGraph] -> UnVarGraph
unionUnVarGraphs forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Id, CallArityRes) -> UnVarGraph
cross_call [(Id, CallArityRes)]
ae_rhss
cross_call :: (Id, CallArityRes) -> UnVarGraph
cross_call (Id
v, CallArityRes
ae_rhs) = UnVarSet -> UnVarSet -> UnVarGraph
completeBipartiteGraph UnVarSet
called_by_v UnVarSet
called_with_v
where
is_thunk :: Bool
is_thunk = Id -> Arity
idCallArity Id
v forall a. Eq a => a -> a -> Bool
== Arity
0
ae_before_v :: CallArityRes
ae_before_v | Bool
is_thunk = [CallArityRes] -> CallArityRes
lubRess (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/= Id
v) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Id, CallArityRes)]
ae_rhss) CallArityRes -> CallArityRes -> CallArityRes
`lubRes` CallArityRes
ae_body
| Bool
otherwise = CallArityRes
ae_combined
called_with_v :: UnVarSet
called_with_v
= [UnVarSet] -> UnVarSet
unionUnVarSets forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (CallArityRes -> Id -> UnVarSet
calledWith CallArityRes
ae_before_v) [Id]
vars
called_by_v :: UnVarSet
called_by_v = CallArityRes -> UnVarSet
domRes CallArityRes
ae_rhs
ae_new :: CallArityRes
ae_new = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (UnVarGraph
cross_calls UnVarGraph -> UnVarGraph -> UnVarGraph
`unionUnVarGraph`) CallArityRes
ae_combined
trimArity :: Id -> Arity -> Arity
trimArity :: Id -> Arity -> Arity
trimArity Id
v Arity
a = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Arity
a, Arity
max_arity_by_type, Arity
max_arity_by_strsig]
where
max_arity_by_type :: Arity
max_arity_by_type = forall (t :: * -> *) a. Foldable t => t a -> Arity
length (Type -> [OneShotInfo]
typeArity (Id -> Type
idType Id
v))
max_arity_by_strsig :: Arity
max_arity_by_strsig
| Divergence -> Bool
isDeadEndDiv Divergence
result_info = forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Demand]
demands
| Bool
otherwise = Arity
a
([Demand]
demands, Divergence
result_info) = StrictSig -> ([Demand], Divergence)
splitStrictSig (Id -> StrictSig
idStrictness Id
v)
type CallArityRes = (UnVarGraph, VarEnv Arity)
emptyArityRes :: CallArityRes
emptyArityRes :: CallArityRes
emptyArityRes = (UnVarGraph
emptyUnVarGraph, forall a. VarEnv a
emptyVarEnv)
unitArityRes :: Var -> Arity -> CallArityRes
unitArityRes :: Id -> Arity -> CallArityRes
unitArityRes Id
v Arity
arity = (UnVarGraph
emptyUnVarGraph, forall a. Id -> a -> VarEnv a
unitVarEnv Id
v Arity
arity)
resDelList :: [Var] -> CallArityRes -> CallArityRes
resDelList :: [Id] -> CallArityRes -> CallArityRes
resDelList [Id]
vs CallArityRes
ae = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip Id -> CallArityRes -> CallArityRes
resDel) CallArityRes
ae [Id]
vs
resDel :: Var -> CallArityRes -> CallArityRes
resDel :: Id -> CallArityRes -> CallArityRes
resDel Id
v (!UnVarGraph
g, !VarEnv Arity
ae) = (UnVarGraph
g UnVarGraph -> Id -> UnVarGraph
`delNode` Id
v, VarEnv Arity
ae forall a. VarEnv a -> Id -> VarEnv a
`delVarEnv` Id
v)
domRes :: CallArityRes -> UnVarSet
domRes :: CallArityRes -> UnVarSet
domRes (UnVarGraph
_, VarEnv Arity
ae) = forall a. VarEnv a -> UnVarSet
varEnvDom VarEnv Arity
ae
lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool)
lookupCallArityRes :: CallArityRes -> Id -> (Arity, Bool)
lookupCallArityRes (UnVarGraph
g, VarEnv Arity
ae) Id
v
= case forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarEnv Arity
ae Id
v of
Just Arity
a -> (Arity
a, Bool -> Bool
not (UnVarGraph
g UnVarGraph -> Id -> Bool
`hasLoopAt` Id
v))
Maybe Arity
Nothing -> (Arity
0, Bool
False)
calledWith :: CallArityRes -> Var -> UnVarSet
calledWith :: CallArityRes -> Id -> UnVarSet
calledWith (UnVarGraph
g, VarEnv Arity
_) Id
v = UnVarGraph -> Id -> UnVarSet
neighbors UnVarGraph
g Id
v
addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes
addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes
addCrossCoCalls UnVarSet
set1 UnVarSet
set2 = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (UnVarSet -> UnVarSet -> UnVarGraph
completeBipartiteGraph UnVarSet
set1 UnVarSet
set2 UnVarGraph -> UnVarGraph -> UnVarGraph
`unionUnVarGraph`)
calledMultipleTimes :: CallArityRes -> CallArityRes
calledMultipleTimes :: CallArityRes -> CallArityRes
calledMultipleTimes CallArityRes
res = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (forall a b. a -> b -> a
const (UnVarSet -> UnVarGraph
completeGraph (CallArityRes -> UnVarSet
domRes CallArityRes
res))) CallArityRes
res
both :: CallArityRes -> CallArityRes -> CallArityRes
both :: CallArityRes -> CallArityRes -> CallArityRes
both CallArityRes
r1 CallArityRes
r2 = UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes
addCrossCoCalls (CallArityRes -> UnVarSet
domRes CallArityRes
r1) (CallArityRes -> UnVarSet
domRes CallArityRes
r2) forall a b. (a -> b) -> a -> b
$ CallArityRes
r1 CallArityRes -> CallArityRes -> CallArityRes
`lubRes` CallArityRes
r2
lubRes :: CallArityRes -> CallArityRes -> CallArityRes
lubRes :: CallArityRes -> CallArityRes -> CallArityRes
lubRes (UnVarGraph
g1, VarEnv Arity
ae1) (UnVarGraph
g2, VarEnv Arity
ae2) = (UnVarGraph
g1 UnVarGraph -> UnVarGraph -> UnVarGraph
`unionUnVarGraph` UnVarGraph
g2, VarEnv Arity
ae1 VarEnv Arity -> VarEnv Arity -> VarEnv Arity
`lubArityEnv` VarEnv Arity
ae2)
lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity
lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity
lubArityEnv = forall a. (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a
plusVarEnv_C forall a. Ord a => a -> a -> a
min
lubRess :: [CallArityRes] -> CallArityRes
lubRess :: [CallArityRes] -> CallArityRes
lubRess = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' CallArityRes -> CallArityRes -> CallArityRes
lubRes CallArityRes
emptyArityRes