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