1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
3 -- This module contains code related to the zipcfg representation.
4 -- The code either has been used or has been thought to be useful
5 -- within the Quick C-- compiler, but as yet no use has been found for
6 -- it within GHC. This module should therefore be considered to be
7 -- full of code that need not be maintained. Should a function in
8 -- this module prove useful, it should not be exported, but rather
9 -- should be migrated back into ZipCfg (or possibly ZipCfgUtil), where
10 -- it can be maintained.
19 import Prelude hiding (zip, unzip, last)
22 exit :: LGraph m l -> FGraph m l -- focus on edge into default exit node
23 -- (fails if there isn't one)
24 focusp :: (Block m l -> Bool) -> LGraph m l -> Maybe (FGraph m l)
25 -- focus on start of block satisfying predicate
26 unfocus :: FGraph m l -> LGraph m l -- lose focus
28 -- | We can insert a single-entry, single-exit subgraph at
30 -- The new focus can be at either the entry edge or the exit edge.
33 splice_focus_entry :: FGraph m l -> LGraph m l -> FGraph m l
34 splice_focus_exit :: FGraph m l -> LGraph m l -> FGraph m l
38 _unused = all `seq` ()
39 where all = ( exit, focusp, unfocus {- , splice_focus_entry, splice_focus_exit -}
40 , fold_fwd_block, foldM_fwd_block (\_ a -> Just a)
43 unfocus (FGraph e bz bs) = LGraph e (insertBlock (zip bz) bs)
45 focusp p (LGraph entry blocks) =
46 fmap (\(b, bs) -> FGraph entry (unzip b) bs) (splitp_blocks p blocks)
48 exit g@(LGraph eid _) = FGraph eid (ZBlock h (ZLast l)) others
49 where FGraph _ b others = focusp is_exit g `orElse` panic "no exit in flow graph"
54 splice_focus_entry (FGraph eid (ZBlock head tail) blocks) g =
55 let (tail', g') = splice_tail g tail in
56 FGraph eid (ZBlock head tail') (plusUFM (lg_blocks g') blocks)
58 splice_focus_exit (FGraph eid (ZBlock head tail) blocks) g =
59 let (g', head') = splice_head head g in
60 FGraph eid (ZBlock head' tail) (plusUFM (lg_blocks g') blocks)
63 -- | Fold from first to last
65 (BlockId -> a -> a) -> (m -> a -> a) -> (ZLast l -> a -> a) ->
67 fold_fwd_block first middle last (Block id t) z = tail t (first id z)
68 where tail (ZTail m t) z = tail t (middle m z)
69 tail (ZLast l) z = last l z
71 -- | iterate from first to last
73 Monad m => (BlockId -> a -> m a) -> (mid -> a -> m a) -> (ZLast l -> a -> m a) ->
74 Block mid l -> a -> m a
75 foldM_fwd_block first middle last (Block id t) z = do { z <- first id z; tail t z }
76 where tail (ZTail m t) z = do { z <- middle m z; tail t z }
77 tail (ZLast l) z = last l z
79 splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
80 Maybe (Block m l, BlockEnv (Block m l))
81 splitp_blocks = undefined -- implemented in ZipCfg but not exported
82 is_exit :: Block m l -> Bool
83 is_exit = undefined -- implemented in ZipCfg but not exported