Commit cb8a63cb authored by Joachim Breitner's avatar Joachim Breitner

Major Call Arity rework

This patch improves the call arity analysis in various ways.

Most importantly, it enriches the analysis result information so that
when looking at a call, we do not have to make a random choice about
what side we want to take the information from. Instead we can combine
the results in a way that does not lose valuable information.

To do so, besides the incoming arities, we store remember "what can be
called with what", i.e. an undirected graph between the (interesting)
free variables of an expression. Of course it makes combining the
results a bit more tricky (especially mutual recursion), but still
doable.

The actually implemation of the graph structure is abstractly put away
in a module of its own (UnVarGraph.hs)

The implementation is geared towards efficiently representing the graphs
that we need (which can contain large complete and large complete
bipartite graphs, which would be huge in other representations). If
someone feels like designing data structures: There is surely some
speed-up to be obtained by improving that data structure.

Additionally, the analysis now takes into account that if a RHS stays a
thunk, then its calls happen only once, even if the variables the RHS is
bound to is evaluated multiple times, or is part of a recursive group.
parent 01f9ac3e
......@@ -165,6 +165,7 @@ Library
Var
VarEnv
VarSet
UnVarGraph
BlockId
CLabel
Cmm
......
This diff is collapsed.
{-
Copyright (c) 2014 Joachim Breitner
A data structure for undirected graphs of variables
(or in plain terms: Sets of unordered pairs of numbers)
This is very specifically tailored for the use in CallArity. In particular it
stores the graph as a union of complete and complete bipartite graph, which
would be very expensive to store as sets of edges or as adjanceny lists.
It does not normalize the graphs. This means that g `unionUnVarGraph` g is
equal to g, but twice as expensive and large.
-}
module UnVarGraph
( UnVarSet
, emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets
, delUnVarSet
, elemUnVarSet, isEmptyUnVarSet
, UnVarGraph
, emptyUnVarGraph
, unionUnVarGraph, unionUnVarGraphs
, completeGraph, completeBipartiteGraph
, neighbors
, delNode
) where
import Id
import VarEnv
import UniqFM
import Outputable
import Data.List
import Bag
import Unique
import qualified Data.IntSet as S
-- We need a type for sets of variables (UnVarSet).
-- We do not use VarSet, because for that we need to have the actual variable
-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet.
-- Therefore, use a IntSet directly (which is likely also a bit more efficient).
-- Set of uniques, i.e. for adjancet nodes
newtype UnVarSet = UnVarSet (S.IntSet)
deriving Eq
k :: Var -> Int
k v = getKey (getUnique v)
emptyUnVarSet :: UnVarSet
emptyUnVarSet = UnVarSet S.empty
elemUnVarSet :: Var -> UnVarSet -> Bool
elemUnVarSet v (UnVarSet s) = k v `S.member` s
isEmptyUnVarSet :: UnVarSet -> Bool
isEmptyUnVarSet (UnVarSet s) = S.null s
delUnVarSet :: UnVarSet -> Var -> UnVarSet
delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s
mkUnVarSet :: [Var] -> UnVarSet
mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs
varEnvDom :: VarEnv a -> UnVarSet
varEnvDom ae = UnVarSet $ ufmToSet_Directly ae
unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)
unionUnVarSets :: [UnVarSet] -> UnVarSet
unionUnVarSets = foldr unionUnVarSet emptyUnVarSet
instance Outputable UnVarSet where
ppr (UnVarSet s) = braces $
hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]
-- The graph type. A list of complete bipartite graphs
data Gen = CBPG UnVarSet UnVarSet -- complete bipartite
| CG UnVarSet -- complete
newtype UnVarGraph = UnVarGraph (Bag Gen)
emptyUnVarGraph :: UnVarGraph
emptyUnVarGraph = UnVarGraph emptyBag
unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph
{-
Premature optimisation, it seems.
unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
| s1 == s3 && s2 == s4
= pprTrace "unionUnVarGraph fired" empty $
completeGraph (s1 `unionUnVarSet` s2)
unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
| s2 == s3 && s1 == s4
= pprTrace "unionUnVarGraph fired2" empty $
completeGraph (s1 `unionUnVarSet` s2)
-}
unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2)
= -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $
UnVarGraph (g1 `unionBags` g2)
unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph
unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph
-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B }
completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph
completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2
completeGraph :: UnVarSet -> UnVarGraph
completeGraph s = prune $ UnVarGraph $ unitBag $ CG s
neighbors :: UnVarGraph -> Var -> UnVarSet
neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g
where go (CG s) = (if v `elemUnVarSet` s then [s] else [])
go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++
(if v `elemUnVarSet` s2 then [s1] else [])
delNode :: UnVarGraph -> Var -> UnVarGraph
delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g
where go (CG s) = CG (s `delUnVarSet` v)
go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v)
prune :: UnVarGraph -> UnVarGraph
prune (UnVarGraph g) = UnVarGraph $ filterBag go g
where go (CG s) = not (isEmptyUnVarSet s)
go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2)
instance Outputable Gen where
ppr (CG s) = ppr s <> char '²'
ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2
instance Outputable UnVarGraph where
ppr (UnVarGraph g) = ppr g
......@@ -58,6 +58,7 @@ module UniqFM (
lookupUFM, lookupUFM_Directly,
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
eltsUFM, keysUFM, splitUFM,
ufmToSet_Directly,
ufmToList,
joinUFM
) where
......@@ -69,6 +70,7 @@ import Compiler.Hoopl hiding (Unique)
import Data.Function (on)
import qualified Data.IntMap as M
import qualified Data.IntSet as S
import qualified Data.Foldable as Foldable
import qualified Data.Traversable as Traversable
import Data.Typeable
......@@ -180,6 +182,7 @@ lookupWithDefaultUFM_Directly
:: UniqFM elt -> elt -> Unique -> elt
keysUFM :: UniqFM elt -> [Unique] -- Get the keys
eltsUFM :: UniqFM elt -> [elt]
ufmToSet_Directly :: UniqFM elt -> S.IntSet
ufmToList :: UniqFM elt -> [(Unique, elt)]
\end{code}
......@@ -293,6 +296,7 @@ lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m
lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m
keysUFM (UFM m) = map getUnique $ M.keys m
eltsUFM (UFM m) = M.elems m
ufmToSet_Directly (UFM m) = M.keysSet m
ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
-- Hoopl
......
......@@ -57,11 +57,12 @@ exprs =
mkLams [z] $ Var d `mkVarApps` [x] )$
Var go2 `mkApps` [mkLit 1] ) $
go `mkLApps` [0, 0]
, ("d0",) $
, ("d0 (go 2 would be bad)",) $
mkRFun go [x]
(mkLet d (mkACase (Var go `mkVarApps` [x])
(mkLams [y] $ Var y)
) $ mkLams [z] $ Var f `mkApps` [ Var d `mkVarApps` [x], Var d `mkVarApps` [x] ]) $
) $
mkLams [z] $ Var f `mkApps` [ Var d `mkVarApps` [x], Var d `mkVarApps` [x] ]) $
go `mkLApps` [0, 0]
, ("go2 (in case crut)",) $
mkRFun go [x]
......@@ -90,7 +91,11 @@ exprs =
(mkLams [y] $ Var y)
) $ mkLams [z] $ Var d `mkVarApps` [x]) $
Var f `mkApps` [Var z, go `mkLApps` [0, 0]]
, ("two recursions (both arity 1 would be good!)",) $
, ("two calls, one from let and from body (d 1 would be bad)",) $
mkLet d (mkACase (mkLams [y] $ mkLit 0) (mkLams [y] $ mkLit 0)) $
mkFun go [x,y] (mkVarApps (Var d) [x]) $
mkApps (Var d) [mkLApps go [1,2]]
, ("two recursions",) $
mkRLet n (mkACase (mkLams [y] $ mkLit 0) (Var n)) $
mkRLet d (mkACase (mkLams [y] $ mkLit 0) (Var d)) $
Var n `mkApps` [d `mkLApps` [0]]
......@@ -135,6 +140,29 @@ exprs =
Let (Rec [ (go, mkLams [x, y] (Var d `mkApps` [go2 `mkLApps` [1,2]]))
, (go2, mkLams [x] (mkACase (mkLams [y] $ mkLit 0) (Var go `mkVarApps` [x])))]) $
Var d `mkApps` [go2 `mkLApps` [0,1]]
, ("a thunk (non-function-type), called twice, still calls once",) $
mkLet d (f `mkLApps` [0]) $
mkLet x (d `mkLApps` [1]) $
Var f `mkVarApps` [x, x]
, ("a thunk (function type), called multiple times, still calls once",) $
mkLet d (f `mkLApps` [0]) $
mkLet n (Var f `mkApps` [d `mkLApps` [1]]) $
mkLams [x] $ Var n `mkVarApps` [x]
, ("a thunk (non-function-type), in mutual recursion, still calls once (d 1 would be good)",) $
mkLet d (f `mkLApps` [0]) $
Let (Rec [ (x, Var d `mkApps` [go `mkLApps` [1,2]])
, (go, mkLams [x] $ mkACase (mkLams [z] $ Var x) (Var go `mkVarApps` [x]) ) ]) $
Var go `mkApps` [mkLit 0, go `mkLApps` [0,1]]
, ("a thunk (function type), in mutual recursion, still calls once (d 1 would be good)",) $
mkLet d (f `mkLApps` [0]) $
Let (Rec [ (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 (function type), in mutual recursion, still calls once, d part of mutual recursion (d 1 would be good)",) $
Let (Rec [ (d, Var f `mkApps` [n `mkLApps` [1]])
, (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]]
]
main = do
......
......@@ -6,7 +6,7 @@ nested_go2:
go2 2
d 1
n 1
d0:
d0 (go 2 would be bad):
go 1
d 0
go2 (in case crut):
......@@ -23,8 +23,11 @@ go2 (using surrounding boring let):
go 2
d 1
z 0
two recursions (both arity 1 would be good!):
two calls, one from let and from body (d 1 would be bad):
go 2
d 0
two recursions:
d 1
n 1
two recursions (semantically like the previous case):
d 1
......@@ -54,6 +57,24 @@ mutual recursion (functions), but no thunks:
go 2
go2 2
mutual recursion (functions), one boring (d 1 would be bad):
go 0
go 2
go2 2
d 0
a thunk (non-function-type), called twice, still calls once:
x 0
d 1
a thunk (function type), called multiple times, still calls once:
d 1
n 0
a thunk (non-function-type), in mutual recursion, still calls once (d 1 would be good):
go 2
x 0
d 1
a thunk (function type), in mutual recursion, still calls once (d 1 would be good):
go 1
d 1
n 0
a thunk (function type), in mutual recursion, still calls once, d part of mutual recursion (d 1 would be good):
go 1
d 1
n 0
......@@ -392,10 +392,11 @@ test('T6048',
[(wordsize(32), 48887164, 10),
# prev: 38000000 (x86/Linux)
# 2012-10-08: 48887164 (x86/Linux)
(wordsize(64), 95960720, 10)])
(wordsize(64), 110646312, 10)])
# 18/09/2012 97247032 amd64/Linux
# 16/01/2014 108578664 amd64/Linux (unknown, likely foldl-via-foldr)
# 18/01/2014 95960720 amd64/Linux Call Arity improvements
# 28/02/2014 105556793 amd64/Linux (unknown, tweak in base/4d9e7c9e3 resulted in change)
# 05/03/2014 110646312 amd64/Linux Call Arity became more elaborate
],
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