02aaab94dc5c721b81d2a89a1af7cf35254cbcc7
[packages/hoopl.git] / src / Compiler / Hoopl / Util.hs
1 {-# LANGUAGE GADTs, ScopedTypeVariables, FlexibleInstances, RankNTypes #-}
2
3 module Compiler.Hoopl.Util
4 ( gUnitOO, gUnitOC, gUnitCO, gUnitCC
5 , catGraphNodeOC, catGraphNodeOO
6 , catNodeCOGraph, catNodeOOGraph
7 , graphMapBlocks
8 , blockGraph
9 , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
10 , preorder_dfs, preorder_dfs_from_except
11 , labelsDefined, labelsUsed, externalEntryLabels
12 , LabelsPtr(..)
13 )
14 where
15
16 import Control.Monad
17
18 import Compiler.Hoopl.Graph
19 import Compiler.Hoopl.Label
20
21
22 ----------------------------------------------------------------
23
24 gUnitOO :: block n O O -> Graph' block n O O
25 gUnitOC :: block n O C -> Graph' block n O C
26 gUnitCO :: block n C O -> Graph' block n C O
27 gUnitCC :: Edges (block n) => block n C C -> Graph' block n C C
28 gUnitOO b = GUnit b
29 gUnitOC b = GMany (JustO b) emptyBody NothingO
30 gUnitCO b = GMany NothingO emptyBody (JustO b)
31 gUnitCC b = GMany NothingO (addBlock b $ emptyBody) NothingO
32
33
34 catGraphNodeOO :: Graph n e O -> n O O -> Graph n e O
35 catGraphNodeOC :: Edges n => Graph n e O -> n O C -> Graph n e C
36 catNodeOOGraph :: n O O -> Graph n O x -> Graph n O x
37 catNodeCOGraph :: Edges n => n C O -> Graph n O x -> Graph n C x
38
39 catGraphNodeOO GNil n = gUnitOO $ BMiddle n
40 catGraphNodeOO (GUnit b) n = gUnitOO $ b `BCat` BMiddle n
41 catGraphNodeOO (GMany e body (JustO x)) n = GMany e body (JustO $ x `BHead` n)
42
43 catGraphNodeOC GNil n = gUnitOC $ BLast n
44 catGraphNodeOC (GUnit b) n = gUnitOC $ addToLeft b $ BLast n
45 where addToLeft :: Block n O O -> Block n O C -> Block n O C
46 addToLeft (BMiddle m) g = m `BTail` g
47 addToLeft (b1 `BCat` b2) g = addToLeft b1 $ addToLeft b2 g
48 catGraphNodeOC (GMany e body (JustO x)) n = GMany e body' NothingO
49 where body' = addBlock (x `BClosed` BLast n) body
50
51 catNodeOOGraph n GNil = gUnitOO $ BMiddle n
52 catNodeOOGraph n (GUnit b) = gUnitOO $ BMiddle n `BCat` b
53 catNodeOOGraph n (GMany (JustO e) body x) = GMany (JustO $ n `BTail` e) body x
54
55 catNodeCOGraph n GNil = gUnitCO $ BFirst n
56 catNodeCOGraph n (GUnit b) = gUnitCO $ addToRight (BFirst n) b
57 where addToRight :: Block n C O -> Block n O O -> Block n C O
58 addToRight g (BMiddle m) = g `BHead` m
59 addToRight g (b1 `BCat` b2) = addToRight (addToRight g b1) b2
60 catNodeCOGraph n (GMany (JustO e) body x) = GMany NothingO body' x
61 where body' = addBlock (BFirst n `BClosed` e) body
62
63
64
65
66
67 blockGraph :: Edges n => Block n e x -> Graph n e x
68 blockGraph b@(BFirst {}) = gUnitCO b
69 blockGraph b@(BMiddle {}) = gUnitOO b
70 blockGraph b@(BLast {}) = gUnitOC b
71 blockGraph b@(BCat {}) = gUnitOO b
72 blockGraph b@(BHead {}) = gUnitCO b
73 blockGraph b@(BTail {}) = gUnitOC b
74 blockGraph b@(BClosed {}) = gUnitCC b
75
76
77 -- | Function 'graphMapBlocks' enables a change of representation of blocks,
78 -- nodes, or both. It lifts a polymorphic block transform into a polymorphic
79 -- graph transform. When the block representation stabilizes, a similar
80 -- function should be provided for blocks.
81 graphMapBlocks :: forall block n block' n' e x .
82 (forall e x . block n e x -> block' n' e x)
83 -> (Graph' block n e x -> Graph' block' n' e x)
84 bodyMapBlocks :: forall block n block' n' .
85 (block n C C -> block' n' C C)
86 -> (Body' block n -> Body' block' n')
87
88 graphMapBlocks f = map
89 where map :: Graph' block n e x -> Graph' block' n' e x
90 map GNil = GNil
91 map (GUnit b) = GUnit (f b)
92 map (GMany e b x) = GMany (fmap f e) (bodyMapBlocks f b) (fmap f x)
93
94 bodyMapBlocks f (Body body) = Body $ mapLabelMap f body
95
96
97 ----------------------------------------------------------------
98
99 class LabelsPtr l where
100 targetLabels :: l -> [Label]
101
102 instance Edges n => LabelsPtr (n e C) where
103 targetLabels n = successors n
104
105 instance LabelsPtr Label where
106 targetLabels l = [l]
107
108 instance LabelsPtr LabelSet where
109 targetLabels = labelSetElems
110
111 instance LabelsPtr l => LabelsPtr [l] where
112 targetLabels = concatMap targetLabels
113
114
115 -- | Traversal: 'postorder_dfs' returns a list of blocks reachable
116 -- from the entry of enterable graph. The entry and exit are *not* included.
117 -- The list has the following property:
118 --
119 -- Say a "back reference" exists if one of a block's
120 -- control-flow successors precedes it in the output list
121 --
122 -- Then there are as few back references as possible
123 --
124 -- The output is suitable for use in
125 -- a forward dataflow problem. For a backward problem, simply reverse
126 -- the list. ('postorder_dfs' is sufficiently tricky to implement that
127 -- one doesn't want to try and maintain both forward and backward
128 -- versions.)
129
130 postorder_dfs :: Edges (block n) => Graph' block n O x -> [block n C C]
131 preorder_dfs :: Edges (block n) => Graph' block n O x -> [block n C C]
132
133 -- | This is the most important traversal over this data structure. It drops
134 -- unreachable code and puts blocks in an order that is good for solving forward
135 -- dataflow problems quickly. The reverse order is good for solving backward
136 -- dataflow problems quickly. The forward order is also reasonably good for
137 -- emitting instructions, except that it will not usually exploit Forrest
138 -- Baskett's trick of eliminating the unconditional branch from a loop. For
139 -- that you would need a more serious analysis, probably based on dominators, to
140 -- identify loop headers.
141 --
142 -- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
143 -- representation, when for most purposes the plain 'Graph' representation is
144 -- more mathematically elegant (but results in more complicated code).
145 --
146 -- Here's an easy way to go wrong! Consider
147 -- @
148 -- A -> [B,C]
149 -- B -> D
150 -- C -> D
151 -- @
152 -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
153 -- Better to get [A,B,C,D]
154
155
156 graphDfs :: (Edges (block n))
157 => (LabelMap (block n C C) -> block n O C -> LabelSet -> [block n C C])
158 -> (Graph' block n O x -> [block n C C])
159 graphDfs _ (GNil) = []
160 graphDfs _ (GUnit{}) = []
161 graphDfs order (GMany (JustO entry) (Body body) _) = order body entry emptyLabelSet
162
163 postorder_dfs = graphDfs postorder_dfs_from_except
164 preorder_dfs = graphDfs preorder_dfs_from_except
165
166 postorder_dfs_from_except :: forall block e . (Edges block, LabelsPtr e)
167 => LabelMap (block C C) -> e -> LabelSet -> [block C C]
168 postorder_dfs_from_except blocks b visited =
169 vchildren (get_children b) (\acc _visited -> acc) [] visited
170 where
171 vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a
172 vnode block cont acc visited =
173 if elemLabelSet id visited then
174 cont acc visited
175 else
176 let cont' acc visited = cont (block:acc) visited in
177 vchildren (get_children block) cont' acc (extendLabelSet visited id)
178 where id = entryLabel block
179 vchildren bs cont acc visited = next bs acc visited
180 where next children acc visited =
181 case children of [] -> cont acc visited
182 (b:bs) -> vnode b (next bs) acc visited
183 get_children block = foldr add_id [] $ targetLabels block
184 add_id id rst = case lookupFact blocks id of
185 Just b -> b : rst
186 Nothing -> rst
187
188 postorder_dfs_from
189 :: (Edges block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C]
190 postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyLabelSet
191
192
193 ----------------------------------------------------------------
194
195 data VM a = VM { unVM :: LabelSet -> (a, LabelSet) }
196 marked :: Label -> VM Bool
197 mark :: Label -> VM ()
198 instance Monad VM where
199 return a = VM $ \visited -> (a, visited)
200 m >>= k = VM $ \visited -> let (a, v') = unVM m visited in unVM (k a) v'
201 marked l = VM $ \v -> (elemLabelSet l v, v)
202 mark l = VM $ \v -> ((), extendLabelSet v l)
203
204 preorder_dfs_from_except :: forall block e . (Edges block, LabelsPtr e)
205 => LabelMap (block C C) -> e -> LabelSet -> [block C C]
206 preorder_dfs_from_except blocks b visited =
207 (fst $ unVM (children (get_children b)) visited) []
208 where children [] = return id
209 children (b:bs) = liftM2 (.) (visit b) (children bs)
210 visit :: block C C -> VM (HL (block C C))
211 visit b = do already <- marked (entryLabel b)
212 if already then return id
213 else do mark (entryLabel b)
214 bs <- children $ get_children b
215 return $ b `cons` bs
216 get_children block = foldr add_id [] $ targetLabels block
217 add_id id rst = case lookupFact blocks id of
218 Just b -> b : rst
219 Nothing -> rst
220
221 type HL a = [a] -> [a] -- Hughes list (constant-time concatenation)
222 cons :: a -> HL a -> HL a
223 cons a as tail = a : as tail
224
225 ----------------------------------------------------------------
226
227 labelsDefined :: forall block n e x . Edges (block n) => Graph' block n e x -> LabelSet
228 labelsDefined GNil = emptyLabelSet
229 labelsDefined (GUnit{}) = emptyLabelSet
230 labelsDefined (GMany _ body x) = foldBodyBlocks addEntry body $ exitLabel x
231 where addEntry block labels = extendLabelSet labels (entryLabel block)
232 exitLabel :: MaybeO x (block n C O) -> LabelSet
233 exitLabel NothingO = emptyLabelSet
234 exitLabel (JustO b) = mkLabelSet [entryLabel b]
235
236 labelsUsed :: forall block n e x. Edges (block n) => Graph' block n e x -> LabelSet
237 labelsUsed GNil = emptyLabelSet
238 labelsUsed (GUnit{}) = emptyLabelSet
239 labelsUsed (GMany e body _) = foldBodyBlocks addTargets body $ entryTargets e
240 where addTargets block labels = foldl extendLabelSet labels (successors block)
241 entryTargets :: MaybeO e (block n O C) -> LabelSet
242 entryTargets NothingO = emptyLabelSet
243 entryTargets (JustO b) = addTargets b emptyLabelSet
244
245 foldBodyBlocks :: (block n C C -> a -> a) -> Body' block n -> a -> a
246 foldBodyBlocks f (Body body) z = foldLabelMap f z body
247
248 externalEntryLabels :: Edges (block n) => Body' block n -> LabelSet
249 externalEntryLabels body = defined `minusLabelSet` used
250 where defined = labelsDefined g
251 used = labelsUsed g
252 g = GMany NothingO body NothingO