Commit af7428e8 authored by Joachim Breitner's avatar Joachim Breitner
Browse files

Call Arity refactoring: fakeBoringCalls

parent ba4616b6
...@@ -396,21 +396,16 @@ interestingBinds bind = ...@@ -396,21 +396,16 @@ interestingBinds bind =
where where
go (v,e) = exprArity e < length (typeArity (idType v)) go (v,e) = exprArity e < length (typeArity (idType v))
boringBinds :: CoreBind -> [Var]
boringBinds bind =
map fst $ filter go $ case bind of (NonRec v e) -> [(v,e)]
(Rec ves) -> ves
where
go (v,e) = exprArity e >= length (typeArity (idType v))
addInterestingBinds :: VarSet -> CoreBind -> VarSet addInterestingBinds :: VarSet -> CoreBind -> VarSet
addInterestingBinds int bind addInterestingBinds int bind
= int `delVarSetList` bindersOf bind -- Possible shadowing = int `delVarSetList` bindersOf bind -- Possible shadowing
`extendVarSetList` interestingBinds bind `extendVarSetList` interestingBinds bind
addBoringCalls :: CallArityEnv -> CoreBind -> CallArityEnv -- This function pretens a (Many 0) call for every variable bound in the binder
addBoringCalls ae bind -- that is not interesting, as calls to these are not reported by the analysis.
= ae `lubEnv` (mkVarEnv $ zip (boringBinds bind) (repeat topCallCount)) fakeBoringCalls :: VarSet -> CoreBind -> CallArityEnv
fakeBoringCalls int bind
= mkVarEnv [ (v, topCallCount) | v <- bindersOf bind, not (v `elemVarSet` int) ]
-- Used for both local and top-level binds -- Used for both local and top-level binds
-- First argument is the demand from the body -- First argument is the demand from the body
...@@ -433,7 +428,7 @@ callArityBind ae_body int b@(Rec binds) ...@@ -433,7 +428,7 @@ callArityBind ae_body int b@(Rec binds)
where where
int_body = int `addInterestingBinds` b int_body = int `addInterestingBinds` b
-- We are ignoring calls to boring binds, so we need to pretend them here! -- We are ignoring calls to boring binds, so we need to pretend them here!
ae_body' = ae_body `addBoringCalls` b ae_body' = ae_body `lubEnv` (fakeBoringCalls int_body b)
(ae_rhs, binds') = callArityFix ae_body' int_body [(i,Nothing,e) | (i,e) <- binds] (ae_rhs, binds') = callArityFix ae_body' int_body [(i,Nothing,e) | (i,e) <- binds]
final_ae = ae_rhs `delVarEnvList` interestingBinds b final_ae = ae_rhs `delVarEnvList` interestingBinds b
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment