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