X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmZipUtil.hs;h=c414d496ebdb6d9ce24d879e88e737aa3f1bf59d;hb=044ba2360d602a5d4e3dc709b91b21d184a37f64;hp=2dcb55fe2ef0526563f115435d022bf32d1d7967;hpb=8b7eaa404043294bd4cb4a0322ac1f7115bad6a0;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmZipUtil.hs b/compiler/cmm/CmmZipUtil.hs
index 2dcb55f..c414d49 100644
--- a/compiler/cmm/CmmZipUtil.hs
+++ b/compiler/cmm/CmmZipUtil.hs
@@ -1,11 +1,15 @@
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
-module CmmZipUtil 
+
+module CmmZipUtil
   ( zipPreds
+  , givesUniquePredecessorTo
   )
 where
+import BlockId
 import Prelude hiding (last, unzip)
-import ZipCfg 
+import ZipCfg
+
 import Maybes
+import UniqSet
 
 -- | Compute the predecessors of each *reachable* block
 zipPreds :: LastNode l => LGraph m l -> BlockEnv BlockSet
@@ -15,3 +19,22 @@ zipPreds g = foldl add emptyBlockEnv (postorder_dfs g)
                        let preds = lookupBlockEnv env sid `orElse` emptyBlockSet
                        in  extendBlockEnv env sid (extendBlockSet preds id))
             env (succs block)
+
+-- | Tell if a graph gives a block a unique predecessor.  For
+-- efficiency, this function is designed to be partially applied.
+
+givesUniquePredecessorTo :: LastNode l => LGraph m l -> BlockId -> Bool
+givesUniquePredecessorTo g = \id -> elemBlockSet id singlePreds
+    -- accumulates a pair of sets: the set of all blocks containing a single
+    -- predecessor, and the set of all blocks containing at least two predecessors
+    where (singlePreds, _) = fold_blocks add (emptyBlockSet, emptyBlockSet) g
+          add b (single, multi) = foldl add_pred (single, multi) (succs b)
+          add_pred pair@(single, multi) id =
+              if elemBlockSet id multi then pair
+              else if elemBlockSet id single then
+                       (delOneFromUniqSet single id, extendBlockSet multi id)
+                   else
+                       (extendBlockSet single id, multi)
+              
+    
+