never executed always true always false
1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE DataKinds #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE GADTs #-}
5 {-# LANGUAGE RankNTypes #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE TypeFamilies #-}
8 module GHC.Cmm.Dataflow.Graph
9 ( Body
10 , Graph
11 , Graph'(..)
12 , NonLocal(..)
13 , addBlock
14 , bodyList
15 , emptyBody
16 , labelsDefined
17 , mapGraph
18 , mapGraphBlocks
19 , revPostorderFrom
20 ) where
21
22
23 import GHC.Prelude
24 import GHC.Utils.Misc
25
26 import GHC.Cmm.Dataflow.Label
27 import GHC.Cmm.Dataflow.Block
28 import GHC.Cmm.Dataflow.Collections
29
30 import Data.Kind
31
32 -- | A (possibly empty) collection of closed/closed blocks
33 type Body n = LabelMap (Block n C C)
34
35 -- | @Body@ abstracted over @block@
36 type Body' block (n :: Extensibility -> Extensibility -> Type) = LabelMap (block n C C)
37
38 -------------------------------
39 -- | Gives access to the anchor points for
40 -- nonlocal edges as well as the edges themselves
41 class NonLocal thing where
42 entryLabel :: thing C x -> Label -- ^ The label of a first node or block
43 successors :: thing e C -> [Label] -- ^ Gives control-flow successors
44
45 instance NonLocal n => NonLocal (Block n) where
46 entryLabel (BlockCO f _) = entryLabel f
47 entryLabel (BlockCC f _ _) = entryLabel f
48
49 successors (BlockOC _ n) = successors n
50 successors (BlockCC _ _ n) = successors n
51
52
53 emptyBody :: Body' block n
54 emptyBody = mapEmpty
55
56 bodyList :: Body' block n -> [(Label,block n C C)]
57 bodyList body = mapToList body
58
59 addBlock
60 :: (NonLocal block, HasDebugCallStack)
61 => block C C -> LabelMap (block C C) -> LabelMap (block C C)
62 addBlock block body = mapAlter add lbl body
63 where
64 lbl = entryLabel block
65 add Nothing = Just block
66 add _ = error $ "duplicate label " ++ show lbl ++ " in graph"
67
68
69 -- ---------------------------------------------------------------------------
70 -- Graph
71
72 -- | A control-flow graph, which may take any of four shapes (O/O,
73 -- O/C, C/O, C/C). A graph open at the entry has a single,
74 -- distinguished, anonymous entry point; if a graph is closed at the
75 -- entry, its entry point(s) are supplied by a context.
76 type Graph = Graph' Block
77
78 -- | @Graph'@ is abstracted over the block type, so that we can build
79 -- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow
80 -- needs this).
81 data Graph' block (n :: Extensibility -> Extensibility -> Type) e x where
82 GNil :: Graph' block n O O
83 GUnit :: block n O O -> Graph' block n O O
84 GMany :: MaybeO e (block n O C)
85 -> Body' block n
86 -> MaybeO x (block n C O)
87 -> Graph' block n e x
88
89
90 -- -----------------------------------------------------------------------------
91 -- Mapping over graphs
92
93 -- | Maps over all nodes in a graph.
94 mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x
95 mapGraph f = mapGraphBlocks (mapBlock f)
96
97 -- | Function 'mapGraphBlocks' enables a change of representation of blocks,
98 -- nodes, or both. It lifts a polymorphic block transform into a polymorphic
99 -- graph transform. When the block representation stabilizes, a similar
100 -- function should be provided for blocks.
101 mapGraphBlocks :: forall block n block' n' e x .
102 (forall e x . block n e x -> block' n' e x)
103 -> (Graph' block n e x -> Graph' block' n' e x)
104
105 mapGraphBlocks f = map
106 where map :: Graph' block n e x -> Graph' block' n' e x
107 map GNil = GNil
108 map (GUnit b) = GUnit (f b)
109 map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)
110
111 -- -----------------------------------------------------------------------------
112 -- Extracting Labels from graphs
113
114 labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x
115 -> LabelSet
116 labelsDefined GNil = setEmpty
117 labelsDefined (GUnit{}) = setEmpty
118 labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body
119 where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet
120 addEntry labels label _ = setInsert label labels
121 exitLabel :: MaybeO x (block n C O) -> LabelSet
122 exitLabel NothingO = setEmpty
123 exitLabel (JustO b) = setSingleton (entryLabel b)
124
125
126 ----------------------------------------------------------------
127
128 -- | Returns a list of blocks reachable from the provided Labels in the reverse
129 -- postorder.
130 --
131 -- This is the most important traversal over this data structure. It drops
132 -- unreachable code and puts blocks in an order that is good for solving forward
133 -- dataflow problems quickly. The reverse order is good for solving backward
134 -- dataflow problems quickly. The forward order is also reasonably good for
135 -- emitting instructions, except that it will not usually exploit Forrest
136 -- Baskett's trick of eliminating the unconditional branch from a loop. For
137 -- that you would need a more serious analysis, probably based on dominators, to
138 -- identify loop headers.
139 --
140 -- For forward analyses we want reverse postorder visitation, consider:
141 -- @
142 -- A -> [B,C]
143 -- B -> D
144 -- C -> D
145 -- @
146 -- Postorder: [D, C, B, A] (or [D, B, C, A])
147 -- Reverse postorder: [A, B, C, D] (or [A, C, B, D])
148 -- This matters for, e.g., forward analysis, because we want to analyze *both*
149 -- B and C before we analyze D.
150 revPostorderFrom
151 :: forall block. (NonLocal block)
152 => LabelMap (block C C) -> Label -> [block C C]
153 revPostorderFrom graph start = go start_worklist setEmpty []
154 where
155 start_worklist = lookup_for_descend start Nil
156
157 -- To compute the postorder we need to "visit" a block (mark as done)
158 -- *after* visiting all its successors. So we need to know whether we
159 -- already processed all successors of each block (and @NonLocal@ allows
160 -- arbitrary many successors). So we use an explicit stack with an extra bit
161 -- of information:
162 -- * @ConsTodo@ means to explore the block if it wasn't visited before
163 -- * @ConsMark@ means that all successors were already done and we can add
164 -- the block to the result.
165 --
166 -- NOTE: We add blocks to the result list in postorder, but we *prepend*
167 -- them (i.e., we use @(:)@), which means that the final list is in reverse
168 -- postorder.
169 go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]
170 go Nil !_ !result = result
171 go (ConsMark block rest) !wip_or_done !result =
172 go rest wip_or_done (block : result)
173 go (ConsTodo block rest) !wip_or_done !result
174 | entryLabel block `setMember` wip_or_done = go rest wip_or_done result
175 | otherwise =
176 let new_worklist =
177 foldr lookup_for_descend
178 (ConsMark block rest)
179 (successors block)
180 in go new_worklist (setInsert (entryLabel block) wip_or_done) result
181
182 lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C)
183 lookup_for_descend label wl
184 | Just b <- mapLookup label graph = ConsTodo b wl
185 | otherwise =
186 error $ "Label that doesn't have a block?! " ++ show label
187
188 data DfsStack a = ConsTodo a (DfsStack a) | ConsMark a (DfsStack a) | Nil