Remove the implementation of gmp primops from the rts
[ghc-hetmet.git] / compiler / cmm / MkZipCfg.hs
1 {-# LANGUAGE ScopedTypeVariables #-}
2 module MkZipCfg
3     ( AGraph, (<*>), catAGraphs
4     , freshBlockId
5     , emptyAGraph, withFreshLabel, withUnique
6     , mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo
7     , outOfLine
8     , emptyGraph, graphOfMiddles, graphOfZTail
9     , lgraphOfAGraph, graphOfAGraph, labelAGraph, pprAGraph
10     )
11 where
12
13 import BlockId (BlockId(..), emptyBlockEnv, plusBlockEnv)
14 import ZipCfg
15
16 import Outputable
17 import Unique
18 import UniqSupply
19 import Util
20
21 import Prelude hiding (zip, unzip, last)
22
23 #include "HsVersions.h"
24
25 -------------------------------------------------------------------------
26 --     GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH (CONSTRUCTOR VIEW)      --
27 -------------------------------------------------------------------------
28
29 {-
30
31 You can think of an AGraph like this: it is the program built by
32 composing in sequence three kinds of nodes:
33   * Label nodes (e.g. L2:)
34   * Middle nodes (e.g. x = y*3)
35   * Last nodes (e.g. if b then goto L1 else goto L2)
36
37 The constructors mkLabel, mkMiddle, and mkLast build single-node
38 AGraphs of the indicated type.  The composition operator <*> glues
39 AGraphs together in sequence (in constant time).
40
41 For example:
42        x = 0
43   L1:  
44        x = x+1
45        if x<10 then goto L1 else goto L2
46   L2:  
47        y = y*x
48        x = 0
49
50 Notice that the AGraph may begin without a label, and may end without
51 a control transfer.  Control *always* falls through a label and middle
52 node, and *never* falls through a Last node.
53
54 A 'AGraph m l' is simply an abstract version of a 'Graph m l' from
55 module 'ZipCfg'.  The only difference is that the 'AGraph m l'
56 supports a constant-time splicing operation, written infix <*>.
57 That splicing operation, together with the constructor functions in
58 this module (and with 'labelAGraph'), is the recommended way to build
59 large graphs.  Each construction or splice has constant cost, and to
60 turn an AGraph into a Graph requires time linear in the number of
61 nodes and N log N in the number of basic blocks.
62
63 The splicing operation warrants careful explanation.  Like a Graph, an
64 AGraph is a control-flow graph which begins with a distinguished,
65 unlabelled sequence of middle nodes called the *entry*.  An unlabelled
66 graph may also end with a sequence of middle nodes called the *exit*.
67 The entry may fall straight through to the exit, or it may fall into 
68 the rest of the graph, which may include arbitrary control flow.
69
70 Using ASCII art, here are examples of the two kinds of graph.  On the
71 left, the entry and exit sequences are labelled A and B, where the
72 control flow in the middle is labelled X.   On the right, there is no
73 exit sequence:
74                                               
75         |                      |              
76         | A                    | C            
77         |                      |              
78        / \                    / \
79       /   \                  /   \
80      |  X  |                |  Y  |           
81       \   /                  \   /            
82        \ /                    \_/             
83         |                      
84         | B                    
85         |                      
86
87
88 The AGraph has these properties:
89
90   * A AGraph is opaque; nothing about its structure can be observed.
91
92   * A AGraph may be turned into a LGraph in time linear in the number
93     of nodes and O(N log N) in the number of basic blocks.
94
95   * Two AGraphs may be spliced in constant time by writing  g1 <*> g2
96
97 There are two rules for splicing, depending on whether the left-hand
98 graph falls through.  If it does, the rule is as follows:
99                                               
100         |                      |                          |      
101         | A                    | C                        | A    
102         |                      |                          |      
103        / \                    / \                        / \
104       /   \                  /   \                      /   \
105      |  X  |      <*>       |  Y  |           =        |  X  |   
106       \   /                  \   /                      \   /    
107        \ /                    \_/                        \ /     
108         |                      |                          |          
109         | B                    | D                        | B        
110         |                      |                          |          
111                                                           |      
112                                                           | C
113                                                           |      
114                                                          / \
115                                                         /   \
116                                                        |  Y  |   
117                                                         \   /    
118                                                          \ /     
119                                                           |      
120                                                           | D    
121                                                           |      
122
123 And in the case where the left-hand graph does not fall through, the
124 rule is
125
126                                               
127         |                      |                          |      
128         | A                    | C                        | A    
129         |                      |                          |      
130        / \                    / \                        / \
131       /   \                  /   \                      /   \
132      |  X  |      <*>       |  Y  |           =        |  X  |   
133       \   /                  \   /                      \   /    
134        \_/                    \_/                        \_/     
135                                |                                    
136                                | D                        _      
137                                |                         / \
138                                                         /   \
139                                                        |  Y  |   
140                                                         \   /    
141                                                          \ /     
142                                                           |      
143                                                           | D    
144                                                           |      
145
146 In this case C will become unreachable and is lost; when such a graph
147 is converted into a data structure, the system will bleat about
148 unreachable code.  Also it must be assumed that there are branches
149 from somewhere in X to labelled blocks in Y; otherwise Y and D are
150 unreachable as well.   (However, it may be the case that X branches
151 into some third AGraph, which in turn branches into D; the
152 representation is agnostic on this point.)
153
154 -}
155
156 infixr 3 <*>
157 (<*>) :: AGraph m l -> AGraph m l -> AGraph m l
158
159 catAGraphs :: [AGraph m l] -> AGraph m l
160
161 -- | A graph is built up by splicing together graphs each containing a
162 -- single node (where a label is considered a 'first' node.  The empty
163 -- graph is a left and right unit for splicing.  All of the AGraph
164 -- constructors (even complex ones like 'mkIfThenElse', as well as the
165 -- splicing operation <*>, are constant-time operations.
166
167 emptyAGraph :: AGraph m l
168 mkLabel     :: (LastNode l) => BlockId -> AGraph m l -- graph contains the label
169 mkMiddle    :: m -> AGraph m l   -- graph contains the node
170 mkLast      :: (Outputable m, Outputable l, LastNode l) =>
171                l       -> AGraph m l              -- graph contains the node
172
173 -- | This function provides access to fresh labels without requiring
174 -- clients to be programmed monadically.
175 withFreshLabel :: String -> (BlockId -> AGraph m l) -> AGraph m l
176 withUnique     :: (Unique -> AGraph m l) -> AGraph m l
177
178
179 outOfLine :: (LastNode l, Outputable m, Outputable l)
180           => AGraph m l -> AGraph m l
181 -- ^ The argument is an AGraph that has an 
182 -- empty entry sequence and no exit sequence.
183 -- The result is a new AGraph that has an empty entry sequence
184 -- connected to an empty exit sequence, with the original graph
185 -- sitting to the side out-of-line.
186 --
187 -- Example:  mkMiddle (x = 3)
188 --           <*> outOfLine (mkLabel L <*> ...stuff...)
189 --           <*> mkMiddle (y = x)
190 -- Control will flow directly from x=3 to y=x;
191 -- the block starting with L is "on the side".
192 --
193 -- N.B. algebraically forall g g' : g <*> outOfLine g' == outOfLine g' <*> g
194
195
196
197 -- below for convenience
198 mkMiddles :: [m] -> AGraph m l
199 mkZTail   :: (Outputable m, Outputable l, LastNode l) =>
200   ZTail m l -> AGraph m l
201 mkBranch  :: (Outputable m, Outputable l, LastNode l) =>
202   BlockId   -> AGraph m l
203
204 -- | For the structured control-flow constructs, a condition is
205 -- represented as a function that takes as arguments the labels to
206 -- goto on truth or falsehood.
207 --
208 --      mkIfThenElse mk_cond then else
209 --      = (mk_cond L1 L2) <*> L1: then <*> goto J
210 --                        <*> L2: else <*> goto J
211 --        <*> J:
212 --
213 -- where L1, L2, J are fresh
214
215 mkIfThenElse :: (Outputable m, Outputable l, LastNode l)
216                 => (BlockId -> BlockId -> AGraph m l) -- branch condition
217                 -> AGraph m l   -- code in the 'then' branch
218                 -> AGraph m l   -- code in the 'else' branch 
219                 -> AGraph m l   -- resulting if-then-else construct
220
221 mkWhileDo    :: (Outputable m, Outputable l, LastNode l)
222                 => (BlockId -> BlockId -> AGraph m l) -- loop condition
223                 -> AGraph m l  -- body of the bloop
224                 -> AGraph m l  -- the final while loop
225
226 -- | Converting an abstract graph to a concrete form is expensive: the
227 -- cost is linear in the number of nodes in the answer, plus N log N
228 -- in the number of basic blocks.  The conversion is also monadic
229 -- because it may require the allocation of fresh, unique labels.
230
231 graphOfAGraph  :: AGraph m l -> UniqSM (Graph  m l)
232 lgraphOfAGraph :: AGraph m l -> UniqSM (LGraph m l)
233   -- ^ allocate a fresh label for the entry point
234 labelAGraph    :: BlockId -> AGraph m l -> UniqSM (LGraph m l)
235   -- ^ use the given BlockId as the label of the entry point
236
237
238 -- | The functions below build Graphs directly; for convenience, they
239 -- are included here with the rest of the constructor functions.
240
241 emptyGraph     ::              Graph m l
242 graphOfMiddles :: [m]       -> Graph m l
243 graphOfZTail   :: ZTail m l -> Graph m l
244
245
246 -- ================================================================
247 --                          IMPLEMENTATION
248 -- ================================================================
249
250 newtype AGraph m l = AGraph (Graph m l -> UniqSM (Graph m l))
251   -- an AGraph is a monadic function from a successor Graph to a new Graph
252
253 AGraph f1 <*> AGraph f2 = AGraph f 
254     where f g = f2 g >>= f1 -- note right associativity
255
256 catAGraphs = foldr (<*>) emptyAGraph
257
258 emptyAGraph = AGraph return
259
260 graphOfAGraph (AGraph f) = f emptyGraph
261 emptyGraph = Graph (ZLast LastExit) emptyBlockEnv
262
263 labelAGraph id g =
264     do Graph tail blocks <- graphOfAGraph g
265        return $ LGraph id $ insertBlock (Block id tail) blocks
266
267 lgraphOfAGraph g = do id <- freshBlockId "graph entry"
268                       labelAGraph id g
269
270 -------------------------------------
271 -- constructors
272
273 mkLabel id = AGraph f
274     where f (Graph tail blocks) =
275             return $ Graph (ZLast (mkBranchNode id))
276                            (insertBlock (Block id tail) blocks)
277
278 mkBranch target = mkLast $ mkBranchNode target
279
280 mkMiddle m = AGraph f
281     where f (Graph tail blocks) = return $ Graph (ZTail m tail) blocks
282
283 mkMiddles ms = AGraph f
284     where f (Graph tail blocks) = return $ Graph (foldr ZTail tail ms) blocks
285
286 graphOfMiddles ms = Graph (foldr ZTail (ZLast LastExit) ms) emptyBlockEnv
287 graphOfZTail   t  = Graph t emptyBlockEnv
288
289
290 mkLast l = AGraph f
291     where f (Graph tail blocks) =
292             do note_this_code_becomes_unreachable "mkLast" (ppr l <+> ppr blocks) tail
293                return $ Graph (ZLast (LastOther l)) blocks
294
295 mkZTail tail = AGraph f
296     where f (Graph utail blocks) =
297             do note_this_code_becomes_unreachable "mkZTail" (ppr tail) utail
298                return $ Graph tail blocks
299
300 withFreshLabel name ofId = AGraph f
301   where f g = do id <- freshBlockId name
302                  let AGraph f' = ofId id
303                  f' g
304
305 withUnique ofU = AGraph f
306   where f g = do u <- getUniqueM
307                  let AGraph f' = ofU u
308                  f' g
309
310 outOfLine (AGraph f) = AGraph f'
311     where f' (Graph tail' blocks') =
312             do Graph emptyEntrance blocks <- f emptyGraph
313                note_this_code_becomes_unreachable "outOfLine" (ppr tail') emptyEntrance
314                return $ Graph tail' (blocks `plusBlockEnv` blocks')
315
316 mkIfThenElse cbranch tbranch fbranch = 
317     withFreshLabel "end of if"     $ \endif ->
318     withFreshLabel "start of then" $ \tid ->
319     withFreshLabel "start of else" $ \fid ->
320         cbranch tid fid <*>
321         mkLabel tid <*> tbranch <*> mkBranch endif <*>
322         mkLabel fid <*> fbranch <*>
323         mkLabel endif
324
325 mkWhileDo cbranch body = 
326   withFreshLabel "loop test" $ \test ->
327   withFreshLabel "loop head" $ \head ->
328   withFreshLabel "end while" $ \endwhile ->
329      -- Forrest Baskett's while-loop layout
330      mkBranch test <*> mkLabel head <*> body
331                    <*> mkLabel test <*> cbranch head endwhile
332                    <*> mkLabel endwhile
333
334 -- | Bleat if the insertion of a last node will create unreachable code
335 note_this_code_becomes_unreachable ::
336     (Monad m, LastNode l, Outputable middle, Outputable l) =>
337        String -> SDoc -> ZTail middle l -> m ()
338
339 note_this_code_becomes_unreachable str old = if debugIsOn then u else \_ -> return ()
340     where u (ZLast LastExit)                       = return ()
341           u (ZLast (LastOther l)) | isBranchNode l = return ()
342                                     -- Note [Branch follows branch]
343           u tail = fail ("unreachable code in " ++ str ++ ": " ++
344                          (showSDoc ((ppr tail) <+> old)))
345
346 -- | The string argument to 'freshBlockId' was originally helpful in debugging
347 -- the Quick C-- compiler, so I have kept it here even though at present it is
348 -- thrown away at this spot---there's no reason a BlockId couldn't one day carry
349 -- a string.  
350
351 freshBlockId :: MonadUnique m => String -> m BlockId
352 freshBlockId _s = getUniqueM >>= return . BlockId
353
354 -------------------------------------
355 -- Debugging
356
357 pprAGraph :: (Outputable m, LastNode l, Outputable l) => AGraph m l -> UniqSM SDoc
358 pprAGraph g = graphOfAGraph g >>= return . ppr
359
360 {-
361 Note [Branch follows branch]
362 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
363 Why do we say it's ok for a Branch to follow a Branch?
364 Because the standard constructor mkLabel-- has fall-through
365 semantics. So if you do a mkLabel, you finish the current block,
366 giving it a label, and start a new one that branches to that label.
367 Emitting a Branch at this point is fine: 
368        goto L1; L2: ...stuff... 
369 -}
370
371