X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FZipCfgExtras.hs;h=660f8e5af322942f1c21d52282c7be230496be1a;hb=74f14cbc3c51135809977b29427c7c6a2af2cc34;hp=787a58abfe2977ce4ab417d4e856c5b7647396ad;hpb=b9bcf6e71abe0d861c99618ee5a7ae9e2c45d26c;p=ghc-hetmet.git diff --git a/compiler/cmm/ZipCfgExtras.hs b/compiler/cmm/ZipCfgExtras.hs index 787a58a..660f8e5 100644 --- a/compiler/cmm/ZipCfgExtras.hs +++ b/compiler/cmm/ZipCfgExtras.hs @@ -12,6 +12,7 @@ module ZipCfgExtras () where +import BlockId import Maybes import Panic import ZipCfg @@ -23,7 +24,7 @@ exit :: LGraph m l -> FGraph m l -- focus on edge into default exit n -- (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 +-- unfocus :: FGraph m l -> LGraph m l -- lose focus -- | We can insert a single-entry, single-exit subgraph at -- the current focus. @@ -36,16 +37,16 @@ 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) + where all = ( exit, focusp --, unfocus {- , splice_focus_entry, splice_focus_exit -} + , foldM_fwd_block (\_ a -> Just a) ) -unfocus (FGraph e bz bs) = LGraph e (insertBlock (zip bz) bs) +--unfocus (FGraph e bz bs) = LGraph e (insertBlock (zip bz) bs) -focusp p (LGraph entry blocks) = +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 +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 @@ -60,24 +61,16 @@ splice_focus_exit (FGraph eid (ZBlock head tail) blocks) g = FGraph eid (ZBlock head' tail) (plusUFM (lg_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 } +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 +splitp_blocks = panic "splitp_blocks" -- implemented in ZipCfg but not exported is_exit :: Block m l -> Bool -is_exit = undefined -- implemented in ZipCfg but not exported +is_exit = panic "is_exit" -- implemented in ZipCfg but not exported