bb925260da346126676d66cc2d49684ba7448f45
[packages/hoopl.git] / src / Compiler / Hoopl / MkGraph.hs
1 {-# LANGUAGE ScopedTypeVariables, GADTs, TypeSynonymInstances, FlexibleInstances #-}
2 module Compiler.Hoopl.MkGraph
3 ( AGraph, graphOfAGraph, aGraphOfGraph
4 , (<*>), (|*><*|), catGraphs, addEntrySeq, addExitSeq, addBlocks, unionBlocks
5 , emptyGraph, emptyClosedGraph, withFresh
6 , mkFirst, mkMiddle, mkMiddles, mkLast, mkBranch, mkLabel, mkWhileDo
7 , IfThenElseable(mkIfThenElse)
8 , mkEntry, mkExit
9 , HooplNode(mkLabelNode, mkBranchNode)
10 )
11 where
12
13 import Compiler.Hoopl.Label (Label, lblOfUniq)
14 import Compiler.Hoopl.Graph
15 import qualified Compiler.Hoopl.GraphUtil as U
16 import Compiler.Hoopl.Label (unionLabelMap)
17 import Compiler.Hoopl.Unique
18 import Control.Monad (liftM2)
19
20 {-|
21 As noted in the paper, we can define a single, polymorphic type of
22 splicing operation with the very polymorphic type
23 @
24 AGraph m n e a -> AGraph m n a x -> AGraph m n e x
25 @
26 However, we feel that this operation is a bit /too/ polymorphic,
27 and that it's too easy for clients to use it blindly without
28 thinking. We therfore split it into two operations, '<*>' and '|*><*|',
29 which are supplemented by other functions:
30
31 * The '<*>' operator is true concatenation, for connecting open graphs.
32 Control flows from the left graph to the right graph.
33
34 * The '|*><*|' operator splices together two graphs at a closed
35 point. Nothing is known about control flow. The vertical bar
36 stands for "closed point" just as the angle brackets above stand
37 for "open point". Unlike the <*> operator, the |*><*| can create
38 a control-flow graph with dangling outedges or unreachable blocks.
39 The operator must be used carefully, so we have chosen a long name
40 on purpose, to help call people's attention to what they're doing.
41
42 * The operator 'addBlocks' adds a set of basic blocks (represented
43 as a closed/closed 'AGraph' to an existing graph, without changing
44 the shape of the existing graph. In some cases, it's necessary to
45 introduce a branch and a label to 'get around' the blocks added,
46 so this operator, and other functions based on it, requires a
47 'HooplNode' type-class constraint and is available only on AGraph,
48 not Graph.
49
50 * We have discussed a dynamic assertion about dangling outedges and
51 unreachable blocks, but nothing is implemented yet.
52
53 -}
54
55
56
57 class GraphRep g where
58 -- | An empty graph that is open at entry and exit.
59 -- It is the left and right identity of '<*>'.
60 emptyGraph :: g n O O
61 -- | An empty graph that is closed at entry and exit.
62 -- It is the left and right identity of '|*><*|'.
63 emptyClosedGraph :: g n C C
64 -- | Create a graph from a first node
65 mkFirst :: n C O -> g n C O
66 -- | Create a graph from a middle node
67 mkMiddle :: n O O -> g n O O
68 -- | Create a graph from a last node
69 mkLast :: n O C -> g n O C
70 mkFirst = mkExit . BFirst
71 mkLast = mkEntry . BLast
72 infixl 3 <*>
73 infixl 2 |*><*|
74 -- | Concatenate two graphs; control flows from left to right.
75 (<*>) :: Edges n => g n e O -> g n O x -> g n e x
76 -- | Splice together two graphs at a closed point; nothing is known
77 -- about control flow.
78 (|*><*|) :: Edges n => g n e C -> g n C x -> g n e x
79 -- | Conveniently concatenate a sequence of open/open graphs using '<*>'.
80 catGraphs :: Edges n => [g n O O] -> g n O O
81 catGraphs = foldr (<*>) emptyGraph
82
83 -- | Create a graph that defines a label
84 mkLabel :: HooplNode n => Label -> g n C O -- definition of the label
85 -- | Create a graph that branches to a label
86 mkBranch :: HooplNode n => Label -> g n O C -- unconditional branch to the label
87
88 -- | Conveniently concatenate a sequence of middle nodes to form
89 -- an open/open graph.
90 mkMiddles :: Edges n => [n O O] -> g n O O
91
92 mkLabel id = mkFirst $ mkLabelNode id
93 mkBranch target = mkLast $ mkBranchNode target
94 mkMiddles ms = catGraphs $ map mkMiddle ms
95
96 -- | Create a graph containing only an entry sequence
97 mkEntry :: Block n O C -> g n O C
98 -- | Create a graph containing only an exit sequence
99 mkExit :: Block n C O -> g n C O
100
101 instance GraphRep Graph where
102 emptyGraph = GNil
103 emptyClosedGraph = GMany NothingO emptyBody NothingO
104 (<*>) = U.gSplice
105 (|*><*|) = U.gSplice
106 mkMiddle = GUnit . BMiddle
107 mkExit block = GMany NothingO emptyBody (JustO block)
108 mkEntry block = GMany (JustO block) emptyBody NothingO
109
110 instance Monad m => GraphRep (AGraph m) where
111 emptyGraph = aGraphOfGraph emptyGraph
112 emptyClosedGraph = aGraphOfGraph emptyClosedGraph
113 (<*>) = liftA2 (<*>)
114 (|*><*|) = liftA2 (|*><*|)
115 mkMiddle = aGraphOfGraph . mkMiddle
116 mkExit = aGraphOfGraph . mkExit
117 mkEntry = aGraphOfGraph . mkEntry
118
119
120 -- | The type of abstract graphs. Offers extra "smart constructors"
121 -- that may consume fresh labels during construction.
122 newtype AGraph m n e x =
123 A { graphOfAGraph :: m (Graph n e x) -- ^ Take an abstract 'AGraph'
124 -- and make a concrete (if monadic)
125 -- 'Graph'.
126 }
127
128 -- | Take a graph and make it abstract.
129 aGraphOfGraph :: Monad m => Graph n e x -> AGraph m n e x
130 aGraphOfGraph = A . return
131
132
133 -- | The 'Labels' class defines things that can be lambda-bound
134 -- by an argument to 'withFreshLabels'. Such an argument may
135 -- lambda-bind a single 'Label', or if multiple labels are needed,
136 -- it can bind a tuple. Tuples can be nested, so arbitrarily many
137 -- fresh labels can be acquired in a single call.
138 --
139 -- For example usage see implementations of 'mkIfThenElse' and 'mkWhileDo'.
140 class Uniques u where
141 withFresh :: HooplMonad m => (u -> AGraph m n e x) -> AGraph m n e x
142
143 instance Uniques Unique where
144 withFresh f = A $ freshUnique >>= (graphOfAGraph . f)
145
146 instance Uniques Label where
147 withFresh f = A $ freshUnique >>= (graphOfAGraph . f . lblOfUniq)
148
149 -- | Lifts binary 'Graph' functions into 'AGraph' functions.
150 liftA2 :: Monad m
151 => (Graph n a b -> Graph n c d -> Graph n e f)
152 -> (AGraph m n a b -> AGraph m n c d -> AGraph m n e f)
153 liftA2 f (A g) (A g') = A (liftM2 f g g')
154
155 -- | Extend an existing 'AGraph' with extra basic blocks "out of line".
156 -- No control flow is implied. Simon PJ should give example use case.
157 addBlocks :: (HooplNode n, HooplMonad m)
158 => AGraph m n e x -> AGraph m n C C -> AGraph m n e x
159 addBlocks (A g) (A blocks) = A $ g >>= \g -> blocks >>= add g
160 where add :: (HooplMonad m, HooplNode n)
161 => Graph n e x -> Graph n C C -> m (Graph n e x)
162 add (GMany e (Body body) x) (GMany NothingO (Body body') NothingO) =
163 return $ GMany e (Body $ unionLabelMap body body') x
164 add g@GNil blocks = spliceOO g blocks
165 add g@(GUnit _) blocks = spliceOO g blocks
166 spliceOO :: (HooplNode n, HooplMonad m)
167 => Graph n O O -> Graph n C C -> m (Graph n O O)
168 spliceOO g blocks = graphOfAGraph $ withFresh $ \l ->
169 A (return g) <*> mkBranch l |*><*| A (return blocks) |*><*| mkLabel l
170
171 -- | For some graph-construction operations and some optimizations,
172 -- Hoopl must be able to create control-flow edges using a given node
173 -- type 'n'.
174 class Edges n => HooplNode n where
175 -- | Create a branch node, the source of a control-flow edge.
176 mkBranchNode :: Label -> n O C
177 -- | Create a label node, the target (destination) of a control-flow edge.
178 mkLabelNode :: Label -> n C O
179
180 --------------------------------------------------------------
181 -- Shiny Things
182 --------------------------------------------------------------
183
184 class IfThenElseable x where
185 -- | Translate a high-level if-then-else construct into an 'AGraph'.
186 -- The condition takes as arguments labels on the true-false branch
187 -- and returns a single-entry, two-exit graph which exits to
188 -- the two labels.
189 mkIfThenElse :: (HooplNode n, HooplMonad m)
190 => (Label -> Label -> AGraph m n O C) -- ^ branch condition
191 -> AGraph m n O x -- ^ code in the "then" branch
192 -> AGraph m n O x -- ^ code in the "else" branch
193 -> AGraph m n O x -- ^ resulting if-then-else construct
194
195 mkWhileDo :: (HooplNode n, HooplMonad m)
196 => (Label -> Label -> AGraph m n O C) -- ^ loop condition
197 -> AGraph m n O O -- ^ body of the loop
198 -> AGraph m n O O -- ^ the final while loop
199
200 instance IfThenElseable O where
201 mkIfThenElse cbranch tbranch fbranch = withFresh $ \(endif, ltrue, lfalse) ->
202 cbranch ltrue lfalse |*><*|
203 mkLabel ltrue <*> tbranch <*> mkBranch endif |*><*|
204 mkLabel lfalse <*> fbranch <*> mkBranch endif |*><*|
205 mkLabel endif
206
207 instance IfThenElseable C where
208 mkIfThenElse cbranch tbranch fbranch = withFresh $ \(ltrue, lfalse) ->
209 cbranch ltrue lfalse |*><*|
210 mkLabel ltrue <*> tbranch |*><*|
211 mkLabel lfalse <*> fbranch
212
213 mkWhileDo cbranch body = withFresh $ \(test, head, endwhile) ->
214 -- Forrest Baskett's while-loop layout
215 mkBranch test |*><*|
216 mkLabel head <*> body <*> mkBranch test |*><*|
217 mkLabel test <*> cbranch head endwhile |*><*|
218 mkLabel endwhile
219
220 --------------------------------------------------------------
221 -- Boring instance declarations
222 --------------------------------------------------------------
223
224
225 instance (Uniques u1, Uniques u2) => Uniques (u1, u2) where
226 withFresh f = withFresh $ \u1 ->
227 withFresh $ \u2 ->
228 f (u1, u2)
229
230 instance (Uniques u1, Uniques u2, Uniques u3) => Uniques (u1, u2, u3) where
231 withFresh f = withFresh $ \u1 ->
232 withFresh $ \u2 ->
233 withFresh $ \u3 ->
234 f (u1, u2, u3)
235
236 instance (Uniques u1, Uniques u2, Uniques u3, Uniques u4) => Uniques (u1, u2, u3, u4) where
237 withFresh f = withFresh $ \u1 ->
238 withFresh $ \u2 ->
239 withFresh $ \u3 ->
240 withFresh $ \u4 ->
241 f (u1, u2, u3, u4)
242
243 ---------------------------------------------
244 -- deprecated legacy functions
245
246 {-# DEPRECATED addEntrySeq, addExitSeq, unionBlocks "use |*><*| instead" #-}
247 addEntrySeq :: (Monad m, Edges n) => AGraph m n O C -> AGraph m n C x -> AGraph m n O x
248 addExitSeq :: (Monad m, Edges n) => AGraph m n e C -> AGraph m n C O -> AGraph m n e O
249 unionBlocks :: (Monad m, Edges n) => AGraph m n C C -> AGraph m n C C -> AGraph m n C C
250
251 addEntrySeq = (|*><*|)
252 addExitSeq = (|*><*|)
253 unionBlocks = (|*><*|)