Abstracting collections of Uniques and Labels.
[packages/hoopl.git] / src / Compiler / Hoopl / XUtil.hs
1 {-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-}
2
3 -- | Utilities for clients of Hoopl, not used internally.
4
5 module Compiler.Hoopl.XUtil
6 ( firstXfer, distributeXfer
7 , distributeFact, distributeFactBwd
8 , successorFacts
9 , foldGraphNodes, foldBlockNodesF, foldBlockNodesB, foldBlockNodesF', foldBlockNodesB'
10 , analyzeAndRewriteFwdBody, analyzeAndRewriteBwdBody
11 , analyzeAndRewriteFwdOx, analyzeAndRewriteBwdOx
12 , noEntries
13 , BlockResult(..), lookupBlock
14 )
15 where
16
17 import Data.Maybe
18
19 import Compiler.Hoopl.Collections
20 import Compiler.Hoopl.Dataflow
21 import Compiler.Hoopl.Fuel
22 import Compiler.Hoopl.Graph
23 import Compiler.Hoopl.Label
24 import Compiler.Hoopl.Util
25
26
27 -- | Forward dataflow analysis and rewriting for the special case of a Body.
28 -- A set of entry points must be supplied; blocks not reachable from
29 -- the set are thrown away.
30 analyzeAndRewriteFwdBody
31 :: forall m n f entries. (FuelMonad m, Edges n, LabelsPtr entries)
32 => FwdPass m n f
33 -> entries -> Body n -> FactBase f
34 -> m (Body n, FactBase f)
35
36 -- | Backward dataflow analysis and rewriting for the special case of a Body.
37 -- A set of entry points must be supplied; blocks not reachable from
38 -- the set are thrown away.
39 analyzeAndRewriteBwdBody
40 :: forall m n f entries. (FuelMonad m, Edges n, LabelsPtr entries)
41 => BwdPass m n f
42 -> entries -> Body n -> FactBase f
43 -> m (Body n, FactBase f)
44
45 analyzeAndRewriteFwdBody pass en = mapBodyFacts (analyzeAndRewriteFwd pass (JustC en))
46 analyzeAndRewriteBwdBody pass en = mapBodyFacts (analyzeAndRewriteBwd pass (JustC en))
47
48 mapBodyFacts :: (Monad m)
49 => (Graph n C C -> Fact C f -> m (Graph n C C, Fact C f, MaybeO C f))
50 -> (Body n -> FactBase f -> m (Body n, FactBase f))
51 -- ^ Internal utility; should not escape
52 mapBodyFacts anal b f = anal (GMany NothingO b NothingO) f >>= bodyFacts
53 where -- the type constraint is needed for the pattern match;
54 -- if it were not, we would use do-notation here.
55 bodyFacts :: Monad m => (Graph n C C, Fact C f, MaybeO C f) -> m (Body n, Fact C f)
56 bodyFacts (GMany NothingO body NothingO, fb, NothingO) = return (body, fb)
57
58 {-
59 Can't write:
60
61 do (GMany NothingO body NothingO, fb, NothingO) <- anal (....) f
62 return (body, fb)
63
64 because we need an explicit type signature in order to do the GADT
65 pattern matches on NothingO
66 -}
67
68
69
70 -- | Forward dataflow analysis and rewriting for the special case of a
71 -- graph open at the entry. This special case relieves the client
72 -- from having to specify a type signature for 'NothingO', which beginners
73 -- might find confusing and experts might find annoying.
74 analyzeAndRewriteFwdOx
75 :: forall m n f x. (FuelMonad m, Edges n)
76 => FwdPass m n f -> Graph n O x -> f -> m (Graph n O x, FactBase f, MaybeO x f)
77
78 -- | Backward dataflow analysis and rewriting for the special case of a
79 -- graph open at the entry. This special case relieves the client
80 -- from having to specify a type signature for 'NothingO', which beginners
81 -- might find confusing and experts might find annoying.
82 analyzeAndRewriteBwdOx
83 :: forall m n f x. (FuelMonad m, Edges n)
84 => BwdPass m n f -> Graph n O x -> Fact x f -> m (Graph n O x, FactBase f, f)
85
86 -- | A value that can be used for the entry point of a graph open at the entry.
87 noEntries :: MaybeC O Label
88 noEntries = NothingC
89
90 analyzeAndRewriteFwdOx pass g f = analyzeAndRewriteFwd pass noEntries g f
91 analyzeAndRewriteBwdOx pass g fb = analyzeAndRewriteBwd pass noEntries g fb >>= strip
92 where strip :: forall m a b c . Monad m => (a, b, MaybeO O c) -> m (a, b, c)
93 strip (a, b, JustO c) = return (a, b, c)
94
95
96
97
98
99 -- | A utility function so that a transfer function for a first
100 -- node can be given just a fact; we handle the lookup. This
101 -- function is planned to be made obsolete by changes in the dataflow
102 -- interface.
103
104 firstXfer :: Edges n => (n C O -> f -> f) -> (n C O -> FactBase f -> f)
105 firstXfer xfer n fb = xfer n $ fromJust $ lookupFact (entryLabel n) fb
106
107 -- | This utility function handles a common case in which a transfer function
108 -- produces a single fact out of a last node, which is then distributed
109 -- over the outgoing edges.
110 distributeXfer :: Edges n => (n O C -> f -> f) -> (n O C -> f -> FactBase f)
111 distributeXfer xfer n f = mkFactBase [ (l, xfer n f) | l <- successors n ]
112
113 -- | This utility function handles a common case in which a transfer function
114 -- for a last node takes the incoming fact unchanged and simply distributes
115 -- that fact over the outgoing edges.
116 distributeFact :: Edges n => n O C -> f -> FactBase f
117 distributeFact n f = mkFactBase [ (l, f) | l <- successors n ]
118
119 -- | This utility function handles a common case in which a backward transfer
120 -- function takes the incoming fact unchanged and tags it with the node's label.
121 distributeFactBwd :: Edges n => n C O -> f -> FactBase f
122 distributeFactBwd n f = mkFactBase [ (entryLabel n, f) ]
123
124 -- | List of (unlabelled) facts from the successors of a last node
125 successorFacts :: Edges n => n O C -> FactBase f -> [f]
126 successorFacts n fb = [ f | id <- successors n, let Just f = lookupFact id fb ]
127
128
129 -- | Fold a function over every node in a block, forward or backward.
130 -- The fold function must be polymorphic in the shape of the nodes.
131 foldBlockNodesF :: forall n a b c .
132 ( n C O -> a -> b
133 , n O O -> b -> b
134 , n O C -> b -> c)
135 -> (forall e x . Block n e x -> EitherCO e a b -> EitherCO x c b)
136 foldBlockNodesF' :: forall n a .
137 (forall e x . n e x -> a -> a)
138 -> (forall e x . Block n e x -> EitherCO e a a -> EitherCO x a a)
139 foldBlockNodesB :: forall n a b c .
140 ( n C O -> b -> c
141 , n O O -> b -> b
142 , n O C -> a -> b)
143 -> (forall e x . Block n e x -> EitherCO x a b -> EitherCO e c b)
144 foldBlockNodesB' :: forall n a .
145 (forall e x . n e x -> a -> a)
146 -> (forall e x . Block n e x -> EitherCO x a a -> EitherCO e a a)
147 -- | Fold a function over every node in a graph.
148 -- The fold function must be polymorphic in the shape of the nodes.
149
150 foldGraphNodes :: forall n a .
151 (forall e x . n e x -> a -> a)
152 -> (forall e x . Graph n e x -> a -> a)
153
154
155 foldBlockNodesF (ff, fm, fl) = block
156 where block :: forall e x . Block n e x -> EitherCO e a b -> EitherCO x c b
157 block (BFirst node) = ff node
158 block (BMiddle node) = fm node
159 block (BLast node) = fl node
160 block (b1 `BCat` b2) = block b1 `cat` block b2
161 block (b1 `BClosed` b2) = block b1 `cat` block b2
162 block (b1 `BHead` n) = block b1 `cat` fm n
163 block (n `BTail` b2) = fm n `cat` block b2
164 cat f f' = f' . f
165 foldBlockNodesF' f = foldBlockNodesF (f, f, f)
166
167 foldBlockNodesB (ff, fm, fl) = block
168 where block :: forall e x . Block n e x -> EitherCO x a b -> EitherCO e c b
169 block (BFirst node) = ff node
170 block (BMiddle node) = fm node
171 block (BLast node) = fl node
172 block (b1 `BCat` b2) = block b1 `cat` block b2
173 block (b1 `BClosed` b2) = block b1 `cat` block b2
174 block (b1 `BHead` n) = block b1 `cat` fm n
175 block (n `BTail` b2) = fm n `cat` block b2
176 cat f f' = f . f'
177 foldBlockNodesB' f = foldBlockNodesB (f, f, f)
178
179
180 foldGraphNodes f = graph
181 where graph :: forall e x . Graph n e x -> a -> a
182 lift :: forall thing ex . (thing -> a -> a) -> (MaybeO ex thing -> a -> a)
183
184 graph GNil = id
185 graph (GUnit b) = block b
186 graph (GMany e b x) = lift block e . body b . lift block x
187 body :: Body n -> a -> a
188 body (Body bdy) = \a -> foldMap block a bdy
189 lift _ NothingO = id
190 lift f (JustO thing) = f thing
191
192 block = foldBlockNodesF' f
193
194
195 data BlockResult n x where
196 NoBlock :: BlockResult n x
197 BodyBlock :: Block n C C -> BlockResult n x
198 ExitBlock :: Block n C O -> BlockResult n O
199
200 lookupBlock :: Edges n => Graph n e x -> Label -> BlockResult n x
201 lookupBlock (GMany _ _ (JustO exit)) lbl
202 | entryLabel exit == lbl = ExitBlock exit
203 lookupBlock (GMany _ (Body body) _) lbl =
204 case lookupMap lbl body of
205 Just b -> BodyBlock b
206 Nothing -> NoBlock
207 lookupBlock GNil _ = NoBlock
208 lookupBlock (GUnit _) _ = NoBlock