Commit 7f919dec authored by Joachim Breitner's avatar Joachim Breitner
Browse files

Call Arity: Resurrect fakeBoringCalls

(Otherwise the analysis was wrong, as covered by the new test case.)
parent d793a148
......@@ -348,7 +348,8 @@ callArityTopLvl exported int1 (b:bs)
exported' = filter isExportedId int2 ++ exported
int' = int1 `addInterestingBinds` b
(ae1, bs') = callArityTopLvl exported' int' bs
(ae2, b') = callArityBind ae1 int1 b
ae1' = fakeBoringCalls int' b ae1
(ae2, b') = callArityBind ae1' int1 b
callArityRHS :: CoreExpr -> CoreExpr
......@@ -434,7 +435,8 @@ callArityAnal arity int (Let bind e)
where
int_body = int `addInterestingBinds` bind
(ae_body, e') = callArityAnal arity int_body e
(final_ae, bind') = callArityBind ae_body int bind
ae_body' = fakeBoringCalls int_body bind ae_body
(final_ae, bind') = callArityBind ae_body' int bind
-- This is a variant of callArityAnal that is additionally told whether
-- the expression is called once or multiple times, and treats thunks appropriately.
......@@ -468,6 +470,16 @@ addInterestingBinds int bind
= int `delVarSetList` bindersOf bind -- Possible shadowing
`extendVarSetList` interestingBinds bind
-- For every boring variable in the binder, this amends the CallArityRes to
-- report safe information about them (co-called with everything else, arity 0).
fakeBoringCalls :: VarSet -> CoreBind -> CallArityRes -> CallArityRes
fakeBoringCalls int bind res
= addCrossCoCalls (domRes boring) (domRes res) $ (boring `lubRes` res)
where
boring = ( emptyUnVarGraph
, mkVarEnv [ (v, 0) | v <- bindersOf bind, not (v `elemVarSet` int)])
-- Used for both local and top-level binds
-- First argument is the demand from the body
callArityBind :: CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)
......
......@@ -163,6 +163,10 @@ exprs =
, (n, Var go `mkApps` [d `mkLApps` [1]])
, (go, mkLams [x] $ mkACase (Var n) (Var go `mkApps` [Var n `mkVarApps` [x]]) ) ]) $
Var go `mkApps` [mkLit 0, go `mkLApps` [0,1]]
, ("a thunk (non-function-type) co-calls with the body (d 1 would be bad)",) $
mkLet d (f `mkLApps` [0]) $
mkLet x (d `mkLApps` [1]) $
Var d `mkVarApps` [x]
]
main = do
......
......@@ -78,3 +78,6 @@ a thunk (function type), in mutual recursion, still calls once, d part of mutual
go 1
d 1
n 0
a thunk (non-function-type) co-calls with the body (d 1 would be bad):
x 0
d 0
......@@ -133,7 +133,7 @@ test('T3294',
# 2012-10-08: 1373514844 (x86/Linux)
# 2013-11-13: 1478325844 (x86/Windows, 64bit machine)
# 2014-01-12: 1565185140 (x86/Linux)
(wordsize(64), 2897630040, 5)]),
(wordsize(64), 2705289664, 5)]),
# old: 1357587088 (amd64/Linux)
# 29/08/2012: 2961778696 (amd64/Linux)
# (^ increase due to new codegen, see #7198)
......@@ -141,6 +141,7 @@ test('T3294',
# 08/06/2013: 2901451552 (amd64/Linux) (reason unknown)
# 12/12/2013: 3083825616 (amd64/Linux) (reason unknown)
# 18/02/2014: 2897630040 (amd64/Linux) (call arity improvements)
# 12/03/2014: 2705289664 (amd64/Linux) (more call arity improvements)
conf_3294
],
compile,
......
Markdown is supported
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