ZipCfg.hs 26.6 KB
Newer Older
1
module ZipCfg
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
2
    ( 	-- These data types and names are carefully thought out
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
3
      Graph(..), LGraph(..), FGraph(..)
4
    , Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
5
    , insertBlock
6
7
8
9
    , HavingSuccessors, succs, fold_succs
    , LastNode, mkBranchNode, isBranchNode, branchNodeTarget

        -- Observers and transformers
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
10
	-- (open to renaming suggestions here)
11
    , blockId, zip, unzip, last, goto_end, zipht, tailOfLast
12
    , splice_tail, splice_head, splice_head_only', splice_head'
13
    , of_block_list, to_block_list
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
14
    , graphOfLGraph
15
    , map_blocks, map_nodes, mapM_blocks
16
    , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
17
    , fold_layout
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
18
    , fold_blocks, fold_fwd_block
19
    , translate
20

21
    , pprLgraph, pprGraph
22

23
    , entry -- exported for the convenience of ZipDataflow0, at least for now
24

25
26
27
28
    {-
    -- the following functions might one day be useful and can be found
    -- either below or in ZipCfgExtras:
    , entry, exit, focus, focusp, unfocus
29
    , ht_to_block, ht_to_last, 
30
    , splice_focus_entry, splice_focus_exit
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
31
    , foldM_fwd_block
32
33
    -}

34
35
36
    )
where

37
38
#include "HsVersions.h"

39
40
import BlockId ( BlockId, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv
               , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet)
41
42
import CmmExpr ( UserOfLocalRegs(..) ) --for an instance

43
44
45
46
47
import Outputable hiding (empty)
import Panic
import UniqFM
import UniqSet

48
49
50
import Maybe
import Prelude hiding (zip, unzip, last)

51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
-------------------------------------------------------------------------
--               GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH               --
-------------------------------------------------------------------------
{-

This module defines datatypes used to represent control-flow graphs,
along with some functions for analyzing and splicing graphs.
Functions for building graphs are found in a separate module 'MkZipCfg'.

Every graph has a distinguished entry point.  A graph has at least one
exit; most exits are instructions (or statements) like 'jump' or
'return', which transfer control to other procedures, but a graph may
have up to one 'fall through' exit.  (A graph that represents an
entire Haskell or C-- procedure does not have a 'fall through' exit.)

A graph is a collection of basic blocks.  A basic block begins with a
label (unique id; see Note [Unique BlockId]) which is followed by a
sequence of zero or more 'middle' nodes; the basic block ends with a
'last' node.  Each 'middle' node is a single-entry, single-exit,
uninterruptible computation.  A 'last' node is a single-entry,
multiple-exit computation.  A last node may have zero or more successors,
which are identified by their unique ids.

A special case of last node is the ``default exit,'' which represents
'falling off the end' of the graph.  Such a node is always represented by
the data constructor 'LastExit'.  A graph may contain at most one
'LastExit' node, and a graph representing a full procedure should not
contain any 'LastExit' nodes.  'LastExit' nodes are used only to splice
graphs together, either during graph construction (see module 'MkZipCfg')
80
or during optimization (see module 'ZipDataflow0').
81
82
83

A graph is parameterized over the types of middle and last nodes.  Each of
these types will typically be instantiated with a subset of C-- statements
84
(see module 'ZipCfgCmmRep') or a subset of machine instructions (yet to be
85
86
87
implemented as of August 2007).


simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
88
89
Note [Kinds of Graphs]
~~~~~~~~~~~~~~~~~~~~~~
90
91
92
93
94
95
96
97
98
99
100
101
This module exposes three representations of graphs.  In order of
increasing complexity, they are:

  Graph  m l      The basic graph with its distinguished entry point

  LGraph m l      A graph with a *labelled* entry point

  FGraph m l      A labelled graph with the *focus* on a particular edge

There are three types because each type offers a slightly different
invariant or cost model.  

102
103
104
105
106
107
108
  * The distinguished entry of a Graph has no label.  Because labels must be
    unique, acquiring one requires a supply of Unique labels (BlockId's).
    The primary advantage of the Graph representation is that we can build a
    small Graph purely functionally, without needing a fresh BlockId or
    Unique.  For example, during optimization we can easily rewrite a single
    middle node into a Graph containing a sequence of two middle nodes
    followed by LastExit.
109
110
111
112
113
114
115

  * In an LGraph, every basic block is labelled.  The primary advantage of
    this representation is its simplicity: each basic block can be treated
    like any other.  This representation is used for mapping, folding, and
    translation, as well as layout.

    Like any graph, an LGraph still has a distinguished entry point, 
116
    which you can discover using 'lg_entry'.
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131

  * An FGraph is an LGraph with the *focus* on one particular edge.  The
    primary advantage of this representation is that it provides
    constant-time access to the nodes connected by that edge, and it also
    allows constant-time, functional *replacement* of those nodes---in the
    style of Huet's 'zipper'.

None of these representations is ideally suited to the incremental
construction of large graphs.  A separate module, 'MkZipCfg', provides a
fourth representation that is asymptotically optimal for such construction.
    
-}

--------------- Representation --------------------

132
133
-- | A basic block is a 'first' node, followed by zero or more 'middle'
-- nodes, followed by a 'last' node.
134
135
136
137
138
139
140
141
142
143
144

-- eventually this module should probably replace the original Cmm, but for
-- now we leave it to dynamic invariants what can be found where

data ZLast l
  = LastExit     -- fall through; used for the block that has no last node
                 -- LastExit is a device used only for graphs under 
                 -- construction, or framgments of graph under optimisation,
                 -- so we don't want to pollute the 'l' type parameter with it
  | LastOther l

145
146
147
148
149
150
151
152
--So that we don't have orphan instances, this goes here or in CmmExpr.
--At least UserOfLocalRegs (ZLast Last) is needed (Last defined elsewhere),
--but there's no need for non-Haskell98 instances for that.
instance UserOfLocalRegs a => UserOfLocalRegs (ZLast a) where
    foldRegsUsed  f z (LastOther l) = foldRegsUsed f z l
    foldRegsUsed _f z LastExit      = z


153
154
155
156
157
data ZHead m   = ZFirst BlockId  | ZHead (ZHead m) m
    -- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
    -- ZTail is a sequence of middle nodes followed by a last node

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
158
-- | Blocks and flow graphs; see Note [Kinds of graphs]
159
160
data Block m l = Block BlockId (ZTail m l)

161
data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) }
162

163
164
data LGraph m l = LGraph  { lg_entry  :: BlockId
                          , lg_blocks :: BlockEnv (Block m l) }
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
165
	-- Invariant: lg_entry is in domain( lg_blocks )
166
167

-- | And now the zipper.  The focus is between the head and tail.
168
-- We cannot ever focus on an inter-block edge.
169
data ZBlock m l = ZBlock (ZHead m) (ZTail m l)
170
171
172
173
174
data FGraph m l = FGraph { fg_entry  :: BlockId
                         , fg_focus  :: ZBlock m l
                         , fg_others :: BlockEnv (Block m l) }
                    -- Invariant: the block represented by 'fg_focus' is *not*
                    -- in the map 'fg_others'
175
176
177
178

----  Utility functions ---

blockId   :: Block  m l -> BlockId
179
180
zip       :: ZBlock m l -> Block  m l
unzip     :: Block  m l -> ZBlock m l
181

182
183
last      :: ZBlock m l -> ZLast l
goto_end  :: ZBlock m l -> (ZHead m, ZLast l)
184
185
186

tailOfLast :: l -> ZTail m l

187
188
189
-- | Take a head and tail and go to beginning or end.  The asymmetry
-- in the types and names is a bit unfortunate, but 'Block m l' is
-- effectively '(BlockId, ZTail m l)' and is accepted in many more places.
190

191
192
ht_to_block, zipht :: ZHead m -> ZTail m l -> Block m l
ht_to_last         :: ZHead m -> ZTail m l -> (ZHead m, ZLast l)
193
194

-- | We can splice a single-entry, single-exit LGraph onto a head or a tail.
195
196
197
-- For a head, we have a head 'h' followed by a LGraph 'g'.
-- The entry node of 'g' gets joined to 'h', forming the entry into
-- the new LGraph.  The exit of 'g' becomes the new head.
198
199
200
201
202
203
-- For both arguments and results, the order of values is the order of
-- control flow: before splicing, the head flows into the LGraph; after
-- splicing, the LGraph flows into the head.
-- Splicing a tail is the dual operation.
-- (In order to maintain the order-means-control-flow convention, the
-- orders are reversed.)
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
--
-- For example, assume
--	head = [L: x:=0]
--	grph = (M, [M: <stuff>,
--		    <blocks>,
--                  N: y:=x; LastExit])
--	tail = [return (y,x)]
--
-- Then 	splice_head head grph
--		= ((L, [L: x:=0; goto M,
--			M: <stuff>,
--			<blocks>])
--		   , N: y:=x)
--
-- Then 	splice_tail grph tail
--		= ( <stuff>
--		  , (???, [<blocks>,
--			   N: y:=x; return (y,x)])
222

223
224
225
splice_head  :: ZHead m    -> LGraph m l -> (LGraph m l, ZHead  m)
splice_head' :: ZHead m -> Graph m l -> (BlockEnv (Block m l), ZHead m)
splice_tail  :: Graph m l -> ZTail  m l -> Graph m l
226

227
-- | We can also splice a single-entry, no-exit Graph into a head.
228
splice_head_only :: ZHead m -> LGraph m l -> LGraph m l
229
splice_head_only' :: ZHead m -> Graph m l -> LGraph m l
230

231
232

-- | A safe operation 
233

234
235
236
237
-- | Conversion to and from the environment form is convenient.  For
-- layout or dataflow, however, one will want to use 'postorder_dfs'
-- in order to get the blocks in an order that relates to the control
-- flow in the procedure.
238
239
240
of_block_list :: BlockId -> [Block m l] -> LGraph m l  -- N log N
to_block_list :: LGraph m l -> [Block m l]  -- N log N

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
241
242
243
244
245
-- | Conversion from LGraph to Graph
graphOfLGraph :: LastNode l => LGraph m l -> Graph m l
graphOfLGraph (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks


246
-- | Traversal: 'postorder_dfs' returns a list of blocks reachable
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
247
248
249
250
251
252
253
254
-- from the entry node.  This list has the following property:
--
--	Say a "back reference" exists if one of a block's
--	control-flow successors precedes it in the output list
--
--	Then there are as few back references as possible
--
-- The output is suitable for use in
255
-- a forward dataflow problem.  For a backward problem, simply reverse
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
256
-- the list.  ('postorder_dfs' is sufficiently tricky to implement that
257
258
-- one doesn't want to try and maintain both forward and backward
-- versions.)
259

260
postorder_dfs :: LastNode l => LGraph m l -> [Block m l]
261

262
263
264
265
266
-- | For layout, we fold over pairs of 'Block m l' and 'Maybe BlockId'
-- in layout order.  The 'Maybe BlockId', if present, identifies the
-- block that will be the layout successor of the current block.  This
-- may be useful to help an emitter omit the final 'goto' of a block
-- that flows directly to its layout successor.
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
267
268
269
270
271
272
--
-- For example: fold_layout f z [ L1:B1, L2:B2, L3:B3 ]
--		= z <$> f (L1:B1) (Just L2)
--		    <$> f (L2:B2) (Just L3)
--		    <$> f (L3:B3) Nothing
-- where a <$> f = f a
273
274
275
fold_layout ::
    LastNode l => (Block m l -> Maybe BlockId -> a -> a) -> a -> LGraph m l-> a

276
277
278
-- | We can also fold over blocks in an unspecified order.  The
-- 'ZipCfgExtras' module provides a monadic version, which we
-- haven't needed (else it would be here).
279
280
fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
281
282
283
284
-- | Fold from first to last
fold_fwd_block ::
  (BlockId -> a -> a) -> (m -> a -> a) -> (ZLast l -> a -> a) -> Block m l -> a -> a

285
286
map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
   -- mapping includes the entry id!
287

288
289
290
map_blocks  :: (Block m l -> Block m' l') -> LGraph m l -> LGraph m' l'
mapM_blocks :: Monad mm
            => (Block m l -> mm (Block m' l')) -> LGraph m l -> mm (LGraph m' l')
nr@eecs.harvard.edu's avatar
nr@eecs.harvard.edu committed
291

292
293
-- | These translation functions are speculative.  I hope eventually
-- they will be used in the native-code back ends ---NR
294
295
296
297
translate :: Monad tm =>
             (m          -> tm (LGraph m' l')) ->
             (l          -> tm (LGraph m' l')) ->
             (LGraph m l -> tm (LGraph m' l'))
298
299

{-
300
-- | It's possible that another form of translation would be more suitable:
301
translateA :: (m -> Agraph m' l') -> (l -> AGraph m' l') -> LGraph m l -> LGraph m' l'
302
303
304
305
-}

------------------- Last nodes

306
307
308
309
310
-- | We can't make a graph out of just any old 'last node' type.  A last node
-- has to be able to find its successors, and we need to be able to create and
-- identify unconditional branches.  We put these capabilities in a type class.
-- Moreover, the property of having successors is also shared by 'Block's and
-- 'ZTails', so it is useful to have that property in a type class of its own.
311
312

class HavingSuccessors b where
313
314
    succs :: b -> [BlockId]
    fold_succs :: (BlockId -> a -> a) -> b -> a -> a
315

316
    fold_succs add l z = foldr add z $ succs l
317
318

class HavingSuccessors l => LastNode l where
319
320
321
322
323
    mkBranchNode     :: BlockId -> l
    isBranchNode     :: l -> Bool
    branchNodeTarget :: l -> BlockId  -- panics if not branch node
      -- ^ N.B. This interface seems to make for more congenial clients than a
      -- single function of type 'l -> Maybe BlockId'
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343

instance HavingSuccessors l => HavingSuccessors (ZLast l) where
    succs LastExit = []
    succs (LastOther l) = succs l
    fold_succs _ LastExit z = z
    fold_succs f (LastOther l) z = fold_succs f l z

instance LastNode l => LastNode (ZLast l) where
    mkBranchNode id = LastOther $ mkBranchNode id
    isBranchNode LastExit = False
    isBranchNode (LastOther l) = isBranchNode l
    branchNodeTarget LastExit = panic "branchNodeTarget LastExit"
    branchNodeTarget (LastOther l) = branchNodeTarget l

instance LastNode l => HavingSuccessors (ZBlock m l) where
    succs b = succs (last b)

instance LastNode l => HavingSuccessors (Block m l) where
    succs b = succs (unzip b)

344
345
346
347
instance LastNode l => HavingSuccessors (ZTail m l) where
    succs b = succs (lastTail b)


348
349
350

-- ================ IMPLEMENTATION ================--

351
352
----- block manipulations

353
354
355
356
357
358
blockId (Block id _) = id

-- | Convert block between forms.
-- These functions are tail-recursive, so we can go as deep as we like
-- without fear of stack overflow.  

359
ht_to_block head tail = case head of
360
  ZFirst id -> Block id tail
361
  ZHead h m -> ht_to_block h (ZTail m tail) 
362
363
364
365

ht_to_last head (ZLast l)   = (head, l)
ht_to_last head (ZTail m t) = ht_to_last (ZHead head m) t 

366
367
368
zipht            h t  = ht_to_block h t
zip      (ZBlock h t) = ht_to_block h t
goto_end (ZBlock h t) = ht_to_last  h t
369
370
371

unzip (Block id t) = ZBlock (ZFirst id) t

372
373
374
375
head_id :: ZHead m -> BlockId
head_id (ZFirst id) = id
head_id (ZHead h _) = head_id h

376
377
378
379
380
last (ZBlock _ t) = lastTail t

lastTail :: ZTail m l -> ZLast l
lastTail (ZLast l) = l
lastTail (ZTail _ t) = lastTail t
381

Thomas Schilling's avatar
Thomas Schilling committed
382
tailOfLast l = ZLast (LastOther l) -- tedious to write in every client
383
384
385
386


------------------ simple graph manipulations

387
focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id 
388
389
390
391
392
focus id (LGraph entry blocks) =
    case lookupBlockEnv blocks id of
      Just b -> FGraph entry (unzip b) (delFromUFM blocks id)
      Nothing -> panic "asked for nonexistent block in flow graph"

393
394
395
396
entry   :: LGraph m l -> FGraph m l         -- focus on edge out of entry node 
entry g@(LGraph eid _) = focus eid g

-- | pull out a block satisfying the predicate, if any
397
398
399
400
401
402
403
404
405
406
407
splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
                 Maybe (Block m l, BlockEnv (Block m l))
splitp_blocks p blocks = lift $ foldUFM scan (Nothing, emptyBlockEnv) blocks 
    where scan b (yes, no) =
              case yes of
                Nothing | p b -> (Just b, no)
                        | otherwise -> (yes, insertBlock b no)
                Just _ -> (yes, insertBlock b no)
          lift (Nothing, _) = Nothing
          lift (Just b, bs) = Just (b, bs)

batterseapower's avatar
batterseapower committed
408
-- | 'insertBlock' should not be used to /replace/ an existing block
409
410
411
-- but only to insert a new one
insertBlock :: Block m l -> BlockEnv (Block m l) -> BlockEnv (Block m l)
insertBlock b bs =
412
413
      ASSERT (isNothing $ lookupBlockEnv bs id)
      extendBlockEnv bs id b
414
415
    where id = blockId b

416
417
418
419
420
421
422
-- | Used in assertions; tells if a graph has exactly one exit
single_exit :: LGraph l m -> Bool
single_exit g = foldUFM check 0 (lg_blocks g) == 1
    where check block count = case last (unzip block) of
                                LastExit -> count + (1 :: Int)
                                _ -> count

423
424
425
426
427
428
429
-- | Used in assertions; tells if a graph has exactly one exit
single_exitg :: Graph l m -> Bool
single_exitg (Graph tail blocks) = foldUFM add (exit_count (lastTail tail)) blocks == 1
    where add block count = count + exit_count (last (unzip block))
          exit_count LastExit = 1 :: Int
          exit_count _        = 0

430
431
432
433
434
435
436
437
438
439
440
441
442
443
------------------ graph traversals

-- | This is the most important traversal over this data structure.  It drops
-- unreachable code and puts blocks in an order that is good for solving forward
-- dataflow problems quickly.  The reverse order is good for solving backward
-- dataflow problems quickly.  The forward order is also reasonably good for
-- emitting instructions, except that it will not usually exploit Forrest
-- Baskett's trick of eliminating the unconditional branch from a loop.  For
-- that you would need a more serious analysis, probably based on dominators, to
-- identify loop headers.
--
-- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
-- representation, when for most purposes the plain 'Graph' representation is
-- more mathematically elegant (but results in more complicated code).
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
444
445
--
-- Here's an easy way to go wrong!  Consider
Thomas Schilling's avatar
Thomas Schilling committed
446
-- @
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
447
448
449
--	A -> [B,C]
--	B -> D
--	C -> D
Thomas Schilling's avatar
Thomas Schilling committed
450
-- @
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
451
452
453
-- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
-- Better to geot [A,B,C,D]

454
455

postorder_dfs g@(LGraph _ blockenv) =
456
457
    let FGraph id eblock _ = entry g in
     zip eblock : postorder_dfs_from_except blockenv eblock (unitUniqSet id)
458

459
460
postorder_dfs_from_except :: (HavingSuccessors b, LastNode l)
                          => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
postorder_dfs_from_except blocks b visited =
  vchildren (get_children b) (\acc _visited -> acc) [] visited
  where
    -- vnode ::
    --    Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
    vnode block@(Block id _) cont acc visited =
        if elemBlockSet id visited then
            cont acc visited
        else
            let cont' acc visited = cont (block:acc) visited in
            vchildren (get_children block) cont' acc (extendBlockSet visited id)
    vchildren bs cont acc visited =
        let next children acc visited =
                case children of []     -> cont acc visited
                                 (b:bs) -> vnode b (next bs) acc visited
        in next bs acc visited
    get_children block = foldl add_id [] (succs block)
    add_id rst id = case lookupBlockEnv blocks id of
                      Just b -> b : rst
                      Nothing -> rst

482
483
484
485
486
postorder_dfs_from
    :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> [Block m l]
postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet


487
488
489
490
491

-- | Slightly more complicated than the usual fold because we want to tell block
-- 'b1' what its inline successor is going to be, so that if 'b1' ends with
-- 'goto b2', the goto can be omitted.

492
493
494
495
496
497
498
499
500
fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z
  where fold blocks z =
            case blocks of [] -> z
                           [b] -> f b Nothing z
                           b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z)
        nextlabel (Block id _) =
            if id == eid then panic "entry as successor"
            else Just id

501
-- | The rest of the traversals are straightforward
502

nr@eecs.harvard.edu's avatar
nr@eecs.harvard.edu committed
503
504
map_blocks f (LGraph eid blocks) = LGraph eid (mapUFM f blocks)

505
506
507
508
509
510
map_nodes idm middle last (LGraph eid blocks) = LGraph (idm eid) (mapUFM block blocks)
    where block (Block id t) = Block (idm id) (tail t)
          tail (ZTail m t) = ZTail (middle m) (tail t)
          tail (ZLast LastExit) = ZLast LastExit
          tail (ZLast (LastOther l)) = ZLast (LastOther (last l))

511
512
513
514
515
516
517
518

mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid 
    where blocks' =
            foldUFM (\b mblocks -> do { blocks <- mblocks
                                      ; b <- f b
                                      ; return $ insertBlock b blocks })
                    (return emptyBlockEnv) blocks

519
fold_blocks f z (LGraph _ blocks) = foldUFM f z blocks
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
520
521
522
fold_fwd_block first middle last (Block id t) z = tail t (first id z)
    where tail (ZTail m t) z = tail t (middle m z)
          tail (ZLast l)   z = last l z
523

524
525
526
527
of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks 
to_block_list (LGraph _ blocks) = eltsUFM blocks


528
529
530
531
532


-- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
-- splicing purposes.  There are two useful cases: the 'LGraph' is a single block
-- or it isn't.  We use continuation-passing style.
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551

prepare_for_splicing ::
  LGraph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
  -> a
prepare_for_splicing g single multi =
  let FGraph _ gentry gblocks = entry g 
      ZBlock _ etail = gentry
  in if isNullUFM gblocks then
         case last gentry of
           LastExit -> single etail
           _ -> panic "bad single block"
     else
       case splitp_blocks is_exit gblocks of
         Nothing -> panic "Can't find an exit block"
         Just (gexit, gblocks) ->
              let (gh, gl) = goto_end $ unzip gexit in
              case gl of LastExit -> multi etail gh gblocks
                         _ -> panic "exit is not exit?!"

552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
prepare_for_splicing' ::
  Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
  -> a
prepare_for_splicing' (Graph etail gblocks) single multi =
   if isNullUFM gblocks then
       case lastTail etail of
         LastExit -> single etail
         _ -> panic "bad single block"
   else
     case splitp_blocks is_exit gblocks of
       Nothing -> panic "Can't find an exit block"
       Just (gexit, gblocks) ->
            let (gh, gl) = goto_end $ unzip gexit in
            case gl of LastExit -> multi etail gh gblocks
                       _ -> panic "exit is not exit?!"

568
569
570
571
572
573
574
575
576
577
578
579
is_exit :: Block m l -> Bool
is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }

splice_head head g = 
  ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
   where eid = head_id head
         splice_one_block tail' =
             case ht_to_last head tail' of
               (head, LastExit) -> (LGraph eid emptyBlockEnv, head)
               _ -> panic "spliced LGraph without exit" 
         splice_many_blocks entry exit others =
             (LGraph eid (insertBlock (zipht head entry) others), exit)
580

581
582
583
584
585
586
587
588
589
590
splice_head' head g = 
  ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
   where splice_one_block tail' = 
             case ht_to_last head tail' of
               (head, LastExit) -> (emptyBlockEnv, head)
               _ -> panic "spliced LGraph without exit" 
         splice_many_blocks entry exit others =
             (insertBlock (zipht head entry) others, exit)

-- splice_tail :: Graph m l -> ZTail m l -> Graph m l
591
splice_tail g tail =
592
593
594
595
596
597
598
599
600
601
602
  ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
    where splice_one_block tail' = Graph (tail' `append_tails` tail) emptyBlockEnv
          append_tails (ZLast LastExit) tail = tail
          append_tails (ZLast _) _ = panic "spliced single block without LastExit"
          append_tails (ZTail m t) tail = ZTail m (append_tails t tail)
          splice_many_blocks entry exit others =
              Graph entry (insertBlock (zipht exit tail) others)

{-
splice_tail g tail =
  AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
603
604
605
606
607
608
609
610
611
    where splice_one_block tail' =  -- return tail' .. tail 
            case ht_to_last (ZFirst (lg_entry g)) tail' of
              (head', LastExit) ->
                  case ht_to_block head' tail of
                     Block id t | id == lg_entry g -> (t, LGraph id emptyBlockEnv)
                     _ -> panic "entry in; garbage out"
              _ -> panic "spliced single block without Exit" 
          splice_many_blocks entry exit others =
              (entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others))
612
-}
613
614
615
616
617
618
619

splice_head_only head g =
  let FGraph eid gentry gblocks = entry g
  in case gentry of
       ZBlock (ZFirst _) tail -> LGraph eid (insertBlock (zipht head tail) gblocks)
       _ -> panic "entry not at start of block?!"

620
621
622
623
splice_head_only' head (Graph tail gblocks) =
  let eblock = zipht head tail in
  LGraph (blockId eblock) (insertBlock eblock gblocks)

624
625
626
627
628
629
630

--- Translation

translate txm txl (LGraph eid blocks) =
    do blocks' <- foldUFM txblock (return emptyBlockEnv) blocks
       return $ LGraph eid blocks'
    where
631
      -- txblock ::
632
      -- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l'))
633
634
635
      txblock (Block id t) expanded =
        do blocks' <- expanded
           txtail (ZFirst id) t blocks'
636
      -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
637
      --           tm (BlockEnv (Block m' l'))
638
639
640
      txtail h (ZTail m t) blocks' =
        do m' <- txm m 
           let (g, h') = splice_head h m' 
641
           txtail h' t (plusUFM (lg_blocks g) blocks')
642
643
      txtail h (ZLast (LastOther l)) blocks' =
        do l' <- txl l
644
           return $ plusUFM (lg_blocks (splice_head_only h l')) blocks'
645
646
647
648
      txtail h (ZLast LastExit) blocks' =
        return $ insertBlock (zipht h (ZLast LastExit)) blocks'

----------------------------------------------------------------
649
650
651
---- Prettyprinting
----------------------------------------------------------------

652
653
654
655
656
-- putting this code in PprCmmZ leads to circular imports :-(

instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
    ppr = pprTail

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
657
658
659
instance (Outputable m, Outputable l, LastNode l) => Outputable (Graph m l) where
    ppr = pprGraph

660
661
662
instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where
    ppr = pprLgraph

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
663
664
665
instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where
    ppr = pprBlock

666
667
668
instance (Outputable l) => Outputable (ZLast l) where
    ppr = pprLast

669
670
pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc 
pprTail (ZTail m t) = ppr m $$ ppr t
671
672
673
674
675
pprTail (ZLast l) = ppr l

pprLast :: (Outputable l) => ZLast l -> SDoc
pprLast LastExit = text "<exit>"
pprLast (LastOther l) = ppr l
676

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
677
678
679
pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc
pprBlock (Block id tail) = ppr id <> colon $$ ppr tail

680
pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
681
682
pprLgraph g = text "{" $$ nest 2 (vcat $ map ppr blocks) $$ text "}"
    where blocks = postorder_dfs g
683

684
685
pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc
pprGraph (Graph tail blockenv) =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
686
687
        text "{" $$ nest 2 (ppr tail $$ (vcat $ map ppr blocks)) $$ text "}"
    where blocks = postorder_dfs_from blockenv tail
688