X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FZipCfg.hs;h=1001f23b77611bfaf70117ecfe94b23e51c3cee3;hp=5681694aeed5fb0e35a631789fd8bbbffa2f51c8;hb=8b104b69acda45c272a2faed0f1a2dd7e6972d87;hpb=4a6f2bc7c3da7e74192339502704877bfc12ccc1 diff --git a/compiler/cmm/ZipCfg.hs b/compiler/cmm/ZipCfg.hs index 5681694..1001f23 100644 --- a/compiler/cmm/ZipCfg.hs +++ b/compiler/cmm/ZipCfg.hs @@ -12,7 +12,7 @@ module ZipCfg , splice_tail, splice_head, splice_head_only', splice_head' , of_block_list, to_block_list , graphOfLGraph - , map_blocks, map_nodes, mapM_blocks + , map_blocks, map_one_block, map_nodes, mapM_blocks , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except , fold_layout , fold_blocks, fold_fwd_block @@ -37,15 +37,15 @@ where #include "HsVersions.h" import BlockId ( BlockId, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv - , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet) -import CmmExpr ( UserOfLocalRegs(..) ) --for an instance + , BlockSet, emptyBlockSet, unitBlockSet, elemBlockSet, extendBlockSet + , delFromBlockEnv, foldBlockEnv', mapBlockEnv + , eltsBlockEnv, isNullBEnv, plusBlockEnv) +import CmmExpr ( UserOfLocalRegs(..) ) +import PprCmm() import Outputable hiding (empty) -import Panic -import UniqFM -import UniqSet -import Maybe +import Data.Maybe import Prelude hiding (zip, unzip, last) ------------------------------------------------------------------------- @@ -77,7 +77,7 @@ 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') -or during optimization (see module 'ZipDataflow0'). +or during optimization (see module 'ZipDataflow'). 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 @@ -150,18 +150,21 @@ instance UserOfLocalRegs a => UserOfLocalRegs (ZLast a) where foldRegsUsed _f z LastExit = z -data ZHead m = ZFirst BlockId | ZHead (ZHead m) m +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 -- | Blocks and flow graphs; see Note [Kinds of graphs] -data Block m l = Block BlockId (ZTail m l) + +data Block m l = Block { bid :: BlockId + , tail :: ZTail m l } data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) } -data LGraph m l = LGraph { lg_entry :: BlockId - , lg_blocks :: BlockEnv (Block m l) } +data LGraph m l = LGraph { lg_entry :: BlockId + , lg_blocks :: BlockEnv (Block m l)} -- Invariant: lg_entry is in domain( lg_blocks ) -- | And now the zipper. The focus is between the head and tail. @@ -220,13 +223,13 @@ ht_to_last :: ZHead m -> ZTail m l -> (ZHead m, ZLast l) -- , (???, [, -- N: y:=x; return (y,x)]) -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_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 -- | We can also splice a single-entry, no-exit Graph into a head. -splice_head_only :: ZHead m -> LGraph m l -> LGraph m l -splice_head_only' :: ZHead m -> Graph m l -> LGraph m l +splice_head_only :: ZHead m -> LGraph m l -> LGraph m l +splice_head_only' :: ZHead m -> Graph m l -> LGraph m l -- | A safe operation @@ -279,8 +282,10 @@ fold_layout :: fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a -- | Fold from first to last -fold_fwd_block :: - (BlockId -> a -> a) -> (m -> a -> a) -> (ZLast l -> a -> a) -> Block m l -> a -> a +fold_fwd_block :: (BlockId -> a -> a) -> (m -> a -> a) -> + (ZLast l -> a -> a) -> Block m l -> a -> a + +map_one_block :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> Block m l -> Block m' l' map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l' -- mapping includes the entry id! @@ -371,7 +376,7 @@ unzip (Block id t) = ZBlock (ZFirst id) t head_id :: ZHead m -> BlockId head_id (ZFirst id) = id -head_id (ZHead h _) = head_id h +head_id (ZHead h _) = head_id h last (ZBlock _ t) = lastTail t @@ -387,7 +392,7 @@ tailOfLast l = ZLast (LastOther l) -- tedious to write in every client 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) + Just b -> FGraph entry (unzip b) (delFromBlockEnv blocks id) Nothing -> panic "asked for nonexistent block in flow graph" entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node @@ -396,7 +401,7 @@ entry g@(LGraph eid _) = focus eid g -- | pull out a block satisfying the predicate, if any 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 +splitp_blocks p blocks = lift $ foldBlockEnv' scan (Nothing, emptyBlockEnv) blocks where scan b (yes, no) = case yes of Nothing | p b -> (Just b, no) @@ -405,7 +410,7 @@ splitp_blocks p blocks = lift $ foldUFM scan (Nothing, emptyBlockEnv) blocks lift (Nothing, _) = Nothing lift (Just b, bs) = Just (b, bs) --- | 'insertBlock' should not be used to *replace* an existing block +-- | 'insertBlock' should not be used to /replace/ an existing block -- but only to insert a new one insertBlock :: Block m l -> BlockEnv (Block m l) -> BlockEnv (Block m l) insertBlock b bs = @@ -415,14 +420,14 @@ insertBlock b bs = -- | 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 +single_exit g = foldBlockEnv' check 0 (lg_blocks g) == 1 where check block count = case last (unzip block) of LastExit -> count + (1 :: Int) _ -> count -- | 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 +single_exitg (Graph tail blocks) = foldBlockEnv' 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 @@ -449,32 +454,39 @@ single_exitg (Graph tail blocks) = foldUFM add (exit_count (lastTail tail)) bloc -- C -> D -- @ -- 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] +-- Better to get [A,B,C,D] postorder_dfs g@(LGraph _ blockenv) = let FGraph id eblock _ = entry g in - zip eblock : postorder_dfs_from_except blockenv eblock (unitUniqSet id) + zip eblock : postorder_dfs_from_except blockenv eblock (unitBlockSet id) -postorder_dfs_from_except :: (HavingSuccessors b, LastNode l) +postorder_dfs_from_except :: forall m b l. (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l] -postorder_dfs_from_except blocks b visited = - vchildren (get_children b) (\acc _visited -> acc) [] visited +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 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 :: [Block m l] -> ([Block m l] -> BlockSet -> a) + -> [Block m l] -> BlockSet -> a 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 :: HavingSuccessors c => c -> [Block m l] get_children block = foldl add_id [] (succs block) + + add_id :: [Block m l] -> BlockId -> [Block m l] add_id rst id = case lookupBlockEnv blocks id of Just b -> b : rst Nothing -> rst @@ -500,31 +512,31 @@ fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z -- | The rest of the traversals are straightforward -map_blocks f (LGraph eid blocks) = LGraph eid (mapUFM f blocks) +map_blocks f (LGraph eid blocks) = LGraph eid (mapBlockEnv f blocks) + +map_nodes idm middle last (LGraph eid blocks) = + LGraph (idm eid) (mapBlockEnv (map_one_block idm middle last) blocks) -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) +map_one_block idm middle last (Block id t) = Block (idm id) (tail t) + where tail (ZTail m t) = ZTail (middle m) (tail t) tail (ZLast LastExit) = ZLast LastExit tail (ZLast (LastOther l)) = ZLast (LastOther (last l)) -mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid +mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid where blocks' = - foldUFM (\b mblocks -> do { blocks <- mblocks + foldBlockEnv' (\b mblocks -> do { blocks <- mblocks ; b <- f b ; return $ insertBlock b blocks }) (return emptyBlockEnv) blocks -fold_blocks f z (LGraph _ blocks) = foldUFM f z blocks +fold_blocks f z (LGraph _ blocks) = foldBlockEnv' f z blocks 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 of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks -to_block_list (LGraph _ blocks) = eltsUFM blocks - - +to_block_list (LGraph _ blocks) = eltsBlockEnv blocks -- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for @@ -537,7 +549,7 @@ prepare_for_splicing :: prepare_for_splicing g single multi = let FGraph _ gentry gblocks = entry g ZBlock _ etail = gentry - in if isNullUFM gblocks then + in if isNullBEnv gblocks then case last gentry of LastExit -> single etail _ -> panic "bad single block" @@ -553,7 +565,7 @@ 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 + if isNullBEnv gblocks then case lastTail etail of LastExit -> single etail _ -> panic "bad single block" @@ -568,7 +580,7 @@ prepare_for_splicing' (Graph etail gblocks) single multi = is_exit :: Block m l -> Bool is_exit b = case last (unzip b) of { LastExit -> True; _ -> False } -splice_head head g = +splice_head head g@(LGraph _ _) = ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks where eid = head_id head splice_one_block tail' = @@ -614,18 +626,20 @@ splice_tail g tail = 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) + ZBlock (ZFirst _) tail -> + LGraph eid (insertBlock (zipht head tail) gblocks) _ -> panic "entry not at start of block?!" splice_head_only' head (Graph tail gblocks) = let eblock = zipht head tail in LGraph (blockId eblock) (insertBlock eblock gblocks) + -- the offset probably should never be used, but well, it's correct for this LGraph --- Translation translate txm txl (LGraph eid blocks) = - do blocks' <- foldUFM txblock (return emptyBlockEnv) blocks + do blocks' <- foldBlockEnv' txblock (return emptyBlockEnv) blocks return $ LGraph eid blocks' where -- txblock :: @@ -638,10 +652,10 @@ translate txm txl (LGraph eid blocks) = txtail h (ZTail m t) blocks' = do m' <- txm m let (g, h') = splice_head h m' - txtail h' t (plusUFM (lg_blocks g) blocks') + txtail h' t (plusBlockEnv (lg_blocks g) blocks') txtail h (ZLast (LastOther l)) blocks' = do l' <- txl l - return $ plusUFM (lg_blocks (splice_head_only h l')) blocks' + return $ plusBlockEnv (lg_blocks (splice_head_only h l')) blocks' txtail h (ZLast LastExit) blocks' = return $ insertBlock (zipht h (ZLast LastExit)) blocks' @@ -675,10 +689,13 @@ pprLast LastExit = text "" pprLast (LastOther l) = ppr l pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc -pprBlock (Block id tail) = ppr id <> colon $$ ppr tail +pprBlock (Block id tail) = + ppr id <> colon + $$ (nest 3 (ppr tail)) pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc -pprLgraph g = text "{" $$ nest 2 (vcat $ map ppr blocks) $$ text "}" +pprLgraph g = text "{" <> text "offset" $$ + nest 2 (vcat $ map ppr blocks) $$ text "}" where blocks = postorder_dfs g pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc