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