1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
|
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-|
Module : GHC.Cmm.Reducibility
Description : Tell if a `CmmGraph` is reducible, or make it so
Test a Cmm control-flow graph for reducibility. And provide a
function that, when given an arbitrary control-flow graph, returns an
equivalent, reducible control-flow graph. The equivalent graph is
obtained by "splitting" (copying) nodes of the original graph.
The resulting equivalent graph has the same dynamic behavior as the
original, but it is larger.
Documentation uses the language of control-flow analysis, in which a
basic block is called a "node." These "nodes" are `CmmBlock`s or
equivalent; they have nothing to do with a `CmmNode`.
For more on reducibility and related analyses and algorithms, see
Note [Reducibility resources]
-}
module GHC.Cmm.Reducibility
( Reducibility(..)
, reducibility
, asReducible
)
where
import GHC.Prelude hiding (splitAt, succ)
import Control.Monad
import Data.List (nub)
import Data.Maybe
import Data.Semigroup
import qualified Data.Sequence as Seq
import GHC.Cmm
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dominators
import GHC.Cmm.Dataflow.Graph hiding (addBlock)
import GHC.Cmm.Dataflow.Label
import GHC.Data.Graph.Collapse
import GHC.Data.Graph.Inductive.Graph
import GHC.Data.Graph.Inductive.PatriciaTree
import GHC.Types.Unique.Supply
import GHC.Utils.Panic
-- | Represents the result of a reducibility analysis.
data Reducibility = Reducible | Irreducible
deriving (Eq, Show)
-- | Given a graph, say whether the graph is reducible. The graph must
-- be bundled with a dominator analysis and a reverse postorder
-- numbering, as these results are needed to perform the test.
reducibility :: NonLocal node
=> GraphWithDominators node
-> Reducibility
reducibility gwd =
if all goodBlock blockmap then Reducible else Irreducible
where goodBlock b = all (goodEdge (entryLabel b)) (successors b)
goodEdge from to = rpnum to > rpnum from || to `dominates` from
rpnum = gwdRPNumber gwd
blockmap = graphMap $ gwd_graph gwd
dominators = gwdDominatorsOf gwd
dominates lbl blockname =
lbl == blockname || dominatorsMember lbl (dominators blockname)
-- | Given a graph, return an equivalent reducible graph, by
-- "splitting" (copying) nodes if necessary. The input
-- graph must be bundled with a dominator analysis and a reverse
-- postorder numbering. The computation is monadic because when a
-- node is split, the new copy needs a fresh label.
--
-- Use this function whenever a downstream algorithm needs a reducible
-- control-flow graph.
asReducible :: GraphWithDominators CmmNode
-> UniqSM (GraphWithDominators CmmNode)
asReducible gwd = case reducibility gwd of
Reducible -> return gwd
Irreducible -> assertReducible <$> nodeSplit gwd
assertReducible :: GraphWithDominators CmmNode -> GraphWithDominators CmmNode
assertReducible gwd = case reducibility gwd of
Reducible -> gwd
Irreducible -> panic "result not reducible"
----------------------------------------------------------------
-- | Split one or more nodes of the given graph, which must be
-- irreducible.
nodeSplit :: GraphWithDominators CmmNode
-> UniqSM (GraphWithDominators CmmNode)
nodeSplit gwd =
graphWithDominators <$> inflate (g_entry g) <$> runNullCollapse collapsed
where g = gwd_graph gwd
collapsed :: NullCollapseViz (Gr CmmSuper ())
collapsed = collapseInductiveGraph (cgraphOfCmm g)
type CGraph = Gr CmmSuper ()
-- | Turn a collapsed supernode back into a control-flow graph
inflate :: Label -> CGraph -> CmmGraph
inflate entry cg = CmmGraph entry graph
where graph = GMany NothingO body NothingO
body :: LabelMap CmmBlock
body = foldl (\map block -> mapInsert (entryLabel block) block map) mapEmpty $
blocks super
super = case labNodes cg of
[(_, s)] -> s
_ -> panic "graph given to `inflate` is not singleton"
-- | Convert a `CmmGraph` into an inductive graph.
-- (The function coalesces duplicate edges into a single edge.)
cgraphOfCmm :: CmmGraph -> CGraph
cgraphOfCmm g = foldl' addSuccEdges (mkGraph cnodes []) blocks
where blocks = zip [0..] $ revPostorderFrom (graphMap g) (g_entry g)
cnodes = [(k, super block) | (k, block) <- blocks]
where super block = Nodes (entryLabel block) (Seq.singleton block)
labelNumber = \lbl -> fromJust $ mapLookup lbl numbers
where numbers :: LabelMap Int
numbers = mapFromList $ map swap blocks
swap (k, block) = (entryLabel block, k)
addSuccEdges :: CGraph -> (Node, CmmBlock) -> CGraph
addSuccEdges graph (k, block) =
insEdges [(k, labelNumber lbl, ()) | lbl <- nub $ successors block] graph
{-
Note [Reducibility resources]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*Flow Analysis of Computer Programs.* Matthew S. Hecht North Holland, 1977.
Available to borrow from archive.org.
Matthew S. Hecht and Jeffrey D. Ullman (1972).
Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202.
https://doi.org/10.1137/0201014
Johan Janssen and Henk Corporaal. 1997. Making graphs reducible with
controlled node splitting. ACM TOPLAS 19, 6 (Nov. 1997),
1031–1052. DOI:https://doi.org/10.1145/267959.269971
Sebastian Unger and Frank Mueller. 2002. Handling irreducible loops:
optimized node splitting versus DJ-graphs. ACM TOPLAS 24, 4 (July
2002), 299–333. https://doi.org/10.1145/567097.567098. (This one
contains the most detailed account of how the Hecht/Ullman algorithm
is used to modify an actual control-flow graph. But still not much detail.)
https://rgrig.blogspot.com/2009/10/dtfloatleftclearleft-summary-of-some.html
(Nice summary of useful facts)
-}
type Seq = Seq.Seq
-- | A "supernode" contains a single-entry, multiple-exit, reducible subgraph.
-- The entry point is the given label, and the block with that label
-- dominates all the other blocks in the supernode. When an entire
-- graph is collapsed into a single supernode, the graph is reducible.
-- More detail can be found in "GHC.Data.Graph.Collapse".
data CmmSuper
= Nodes { label :: Label
, blocks :: Seq CmmBlock
}
instance Semigroup CmmSuper where
s <> s' = Nodes (label s) (blocks s <> blocks s')
instance PureSupernode CmmSuper where
superLabel = label
mapLabels = changeLabels
instance Supernode CmmSuper NullCollapseViz where
freshen s = liftUniqSM $ relabel s
-- | Return all labels defined within a supernode.
definedLabels :: CmmSuper -> Seq Label
definedLabels = fmap entryLabel . blocks
-- | Map the given function over every use and definition of a label
-- in the given supernode.
changeLabels :: (Label -> Label) -> (CmmSuper -> CmmSuper)
changeLabels f (Nodes l blocks) = Nodes (f l) (fmap (changeBlockLabels f) blocks)
-- | Map the given function over every use and definition of a label
-- in the given block.
changeBlockLabels :: (Label -> Label) -> CmmBlock -> CmmBlock
changeBlockLabels f block = blockJoin entry' middle exit'
where (entry, middle, exit) = blockSplit block
entry' = let CmmEntry l scope = entry
in CmmEntry (f l) scope
exit' = case exit of
-- unclear why mapSuccessors doesn't touch these
CmmCall { cml_cont = Just l } -> exit { cml_cont = Just (f l) }
CmmForeignCall { succ = l } -> exit { succ = f l }
_ -> mapSuccessors f exit
-- | Within the given supernode, replace every defined label (and all
-- of its uses) with a fresh label.
relabel :: CmmSuper -> UniqSM CmmSuper
relabel node = do
finite_map <- foldM addPair mapEmpty $ definedLabels node
return $ changeLabels (labelChanger finite_map) node
where addPair :: LabelMap Label -> Label -> UniqSM (LabelMap Label)
addPair map old = do new <- newBlockId
return $ mapInsert old new map
labelChanger :: LabelMap Label -> (Label -> Label)
labelChanger mapping = \lbl -> mapFindWithDefault lbl lbl mapping
|
