From c105c74926393accbccf8a826714fde8d6440370 Mon Sep 17 00:00:00 2001 From: Norman Ramsey Date: Tue, 11 Sep 2007 15:45:33 +0000 Subject: [PATCH] scrape some unused barnacles off of ZipCfg and put them into ZipCfgExtras --- compiler/cmm/ZipCfg.hs | 86 +++++++++++------------------------------- compiler/cmm/ZipCfgCmmRep.hs | 7 +--- compiler/cmm/ZipCfgExtras.hs | 80 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 104 insertions(+), 69 deletions(-) create mode 100644 compiler/cmm/ZipCfgExtras.hs diff --git a/compiler/cmm/ZipCfg.hs b/compiler/cmm/ZipCfg.hs index 0c2b84b..e9d474d 100644 --- a/compiler/cmm/ZipCfg.hs +++ b/compiler/cmm/ZipCfg.hs @@ -9,22 +9,30 @@ module ZipCfg , 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) @@ -111,21 +119,6 @@ fourth representation that is asymptotically optimal for such construction. -} -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]] @@ -269,18 +262,6 @@ instance LastNode l => HavingSuccessors (Block m l) where 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 @@ -313,14 +294,12 @@ last (ZBlock _ t) = lastt t 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 @@ -332,12 +311,6 @@ 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 } @@ -350,8 +323,6 @@ insertBlock b bs = 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 @@ -366,6 +337,11 @@ check_single_exit g = 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 @@ -395,14 +371,6 @@ fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z 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) @@ -465,14 +433,6 @@ splice_tail g tail = (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 diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index 71e206e..4c35a92 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -157,12 +157,7 @@ instance Outputable Convention where instance DF.DebugNodes Middle Last instance Outputable CmmGraph where - ppr = pprCmmGraphAsRep - -pprCmmGraphAsRep :: CmmGraph -> SDoc -pprCmmGraphAsRep g = vcat (map ppr_block blocks) - where blocks = postorder_dfs g - ppr_block (Block id tail) = hang (ppr id <> colon) 4 (ppr tail) + ppr = pprLgraph pprMiddle :: Middle -> SDoc pprMiddle stmt = (case stmt of diff --git a/compiler/cmm/ZipCfgExtras.hs b/compiler/cmm/ZipCfgExtras.hs new file mode 100644 index 0000000..1cd2fa9 --- /dev/null +++ b/compiler/cmm/ZipCfgExtras.hs @@ -0,0 +1,80 @@ +{-# OPTIONS -Wall -fno-warn-name-shadowing #-} + +-- This module contains code related to the zipcfg representation. +-- The code either has been used or has been thought to be useful +-- within the Quick C-- compiler, but as yet no use has been found for +-- it within GHC. This module should therefore be considered to be +-- full of code that need not be maintained. Should a function in +-- this module prove useful, it should not be exported, but rather +-- should be migrated back into ZipCfg (or possibly ZipCfgUtil), where +-- it can be maintained. + +module ZipCfgExtras + () +where +import Maybes +import Panic +import ZipCfg + +import UniqFM + +import Prelude hiding (zip, unzip, last) + + +exit :: LGraph m l -> FGraph m l -- focus on edge into default exit node + -- (fails if there isn't one) +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 + +_unused :: () +_unused = all `seq` () + where all = ( exit, focusp, unfocus, splice_focus_entry, splice_focus_exit + , fold_fwd_block, foldM_fwd_block (\_ a -> Just a) + ) + +unfocus (FGraph e bz bs) = LGraph e (insertBlock (zip bz) bs) + +focusp p (LGraph entry blocks) = + fmap (\(b, bs) -> FGraph entry (unzip b) bs) (splitp_blocks p blocks) + +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 + +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) + +-- | 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 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 + +-- | 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 +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 + +splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) -> + Maybe (Block m l, BlockEnv (Block m l)) +splitp_blocks = undefined -- implemented in ZipCfg but not exported +is_exit :: Block m l -> Bool +is_exit = undefined -- implemented in ZipCfg but not exported -- 1.7.10.4