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