Commit cb8a63cb by 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!