-{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module ZipCfg
( BlockId(..), freshBlockId
, LastNode, mkBranchNode, isBranchNode, branchNodeTarget
-- Observers and transformers
- , entry, exit, focus, focusp, unfocus
- , blockId, zip, unzip, last, goto_end, ht_to_first, ht_to_last, zipht
- , tailOfLast
- , splice_head, splice_tail, splice_head_only, splice_focus_entry
- , splice_focus_exit, remove_entry_label
+ , blockId, zip, unzip, last, goto_end, zipht, tailOfLast
+ , remove_entry_label
+ , splice_tail, splice_head, splice_head_only
, of_block_list, to_block_list
+ , map_nodes
, postorder_dfs
- , fold_layout, fold_blocks
- , fold_fwd_block, foldM_fwd_block
- , map_nodes, translate
+ , fold_layout
+ , fold_blocks
+ , translate
, pprLgraph
+
+ {-
+ -- the following functions might one day be useful and can be found
+ -- either below or in ZipCfgExtras:
+ , entry, exit, focus, focusp, unfocus
+ , ht_to_first, ht_to_last,
+ , splice_focus_entry, splice_focus_exit
+ , fold_fwd_block, foldM_fwd_block
+ -}
+
)
where
-import Maybes
import Outputable hiding (empty)
import Panic
import Prelude hiding (zip, unzip, last)
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
-(see module 'ZipCfgCmm') or a subset of machine instructions (yet to be
+(see module 'ZipCfgCmmRep') or a subset of machine instructions (yet to be
implemented as of August 2007).
-}
-entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node
-exit :: LGraph m l -> FGraph m l -- focus on edge into default exit node
- -- (fails if there isn't one)
-focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
-focusp :: (Block m l -> Bool) -> LGraph m l -> Maybe (FGraph m l)
- -- focus on start of block satisfying predicate
-unfocus :: FGraph m l -> LGraph m l -- lose focus
-
--- | We can insert a single-entry, single-exit subgraph at
--- the current focus.
--- The new focus can be at either the entry edge or the exit edge.
-
-splice_focus_entry :: FGraph m l -> LGraph m l -> FGraph m l
-splice_focus_exit :: FGraph m l -> LGraph m l -> FGraph m l
-
--------------- Representation --------------------
-- | A basic block is a [[first]] node, followed by zero or more [[middle]]
-- The postorder depth-first-search order means the list is in roughly
-- first-to-last order, as suitable for use in a forward dataflow problem.
-postorder_dfs :: forall m l . LastNode l => LGraph m l -> [Block m l]
+postorder_dfs :: LastNode l => LGraph m l -> [Block m l]
-- | For layout, we fold over pairs of [[Block m l]] and [[Maybe BlockId]]
-- in layout order. The [[BlockId]], if any, identifies the block that
map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
-- mapping includes the entry id!
-translate :: forall m l m' l' .
- (m -> UniqSM (LGraph m' l')) -> (l -> UniqSM (LGraph m' l')) ->
+translate :: (m -> UniqSM (LGraph m' l')) -> (l -> UniqSM (LGraph m' l')) ->
LGraph m l -> UniqSM (LGraph m' l')
{-
-translateA :: forall m l m' l' .
- (m -> Agraph m' l') -> (l -> AGraph m' l') -> LGraph m l -> LGraph m' l'
+translateA :: (m -> Agraph m' l') -> (l -> AGraph m' l') -> LGraph m l -> LGraph m' l'
-}
------------------- Last nodes
succs b = succs (unzip b)
-------------------- Observing nodes
-
--- | Fold from first to last
-fold_fwd_block ::
- (BlockId -> a -> a) -> (m -> a -> a) -> (ZLast l -> a -> a) ->
- Block m l -> a -> a
-
--- | iterate from first to last
-foldM_fwd_block ::
- Monad m => (BlockId -> a -> m a) -> (mid -> a -> m a) -> (ZLast l -> a -> m a) ->
- Block mid l -> a -> m a
-
-- ================ IMPLEMENTATION ================--
blockId (Block id _) = id
where lastt (ZLast l) = l
lastt (ZTail _ t) = lastt t
+focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
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"
-focusp p (LGraph entry blocks) =
- fmap (\(b, bs) -> FGraph entry (unzip b) bs) (splitp_blocks p blocks)
-
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
lift (Nothing, _) = Nothing
lift (Just b, bs) = Just (b, bs)
-entry g@(LGraph eid _) = focus eid g
-
-exit g@(LGraph eid _) = FGraph eid (ZBlock h (ZLast l)) others
- where FGraph _ b others = focusp is_exit g `orElse` panic "no exit in flow graph"
- (h, l) = goto_end b
-
is_exit :: Block m l -> Bool
is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }
Just _ -> panic ("duplicate labels " ++ show id ++ " in ZipCfg graph")
where id = blockId b
-unfocus (FGraph e bz bs) = LGraph e (insertBlock (zip bz) bs)
-
check_single_exit :: LGraph l m -> a -> a
check_single_exit g =
let check block found = case last (unzip block) of
freshBlockId :: String -> UniqSM BlockId
freshBlockId _ = do { u <- getUniqueUs; return $ BlockId u }
+entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node
+entry g@(LGraph eid _) = focus eid g
+
+
+
postorder_dfs g@(LGraph _ blocks) =
let FGraph _ eblock _ = entry g
in vnode (zip eblock) (\acc _visited -> acc) [] emptyBlockSet
where
- vnode :: Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet ->a
+ -- 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
if id == eid then panic "entry as successor"
else Just id
-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
-
-foldM_fwd_block first middle last (Block id t) z = do { z <- first id z; tail t z }
- where tail (ZTail m t) z = do { z <- middle m z; tail t z }
- tail (ZLast l) z = last l z
-
fold_blocks f z (LGraph _ blocks) = foldUFM f z blocks
map_nodes idm middle last (LGraph eid blocks) = LGraph (idm eid) (mapUFM block blocks)
(entry, LGraph (gr_entry g) (insertBlock (zipht exit tail) others))
in prepare_for_splicing g splice_one_block splice_many_blocks
-splice_focus_entry (FGraph eid (ZBlock head tail) blocks) g =
- let (tail', g') = splice_tail g tail in
- FGraph eid (ZBlock head tail') (plusUFM (gr_blocks g') blocks)
-
-splice_focus_exit (FGraph eid (ZBlock head tail) blocks) g =
- let (g', head') = splice_head head g in
- FGraph eid (ZBlock head' tail) (plusUFM (gr_blocks g') blocks)
-
splice_head_only head g =
let FGraph eid gentry gblocks = entry g
in case gentry of
do blocks' <- foldUFM txblock (return emptyBlockEnv) blocks
return $ LGraph eid blocks'
where
- txblock ::
- Block m l -> UniqSM (BlockEnv (Block m' l')) -> UniqSM (BlockEnv (Block m' l'))
+ -- txblock ::
+ -- Block m l -> UniqSM (BlockEnv (Block m' l')) -> UniqSM (BlockEnv (Block m' l'))
txblock (Block id t) expanded =
do blocks' <- expanded
txtail (ZFirst id) t blocks'
- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
- UniqSM (BlockEnv (Block m' l'))
+ -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
+ -- UniqSM (BlockEnv (Block m' l'))
txtail h (ZTail m t) blocks' =
do m' <- txm m
let (g, h') = splice_head h m'
projects / ghc-hetmet.git / blobdiff