X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FMkZipCfg.hs;h=9b9989c465f95d4396f6f463aad8524eed98e4b9;hb=1241c26f3552a2037263769e5ef7fa68d9f3be36;hp=33fd6cb1ac469b0facf04ab1f8746b7286a8eb52;hpb=8b7eaa404043294bd4cb4a0322ac1f7115bad6a0;p=ghc-hetmet.git

diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs
index 33fd6cb..9b9989c 100644
--- a/compiler/cmm/MkZipCfg.hs
+++ b/compiler/cmm/MkZipCfg.hs
@@ -1,17 +1,22 @@
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
 module MkZipCfg
-    ( AGraph, (<*>), emptyAGraph, withFreshLabel
+    ( AGraph, (<*>), emptyAGraph, withFreshLabel, withUnique
     , mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo
+    , outOfLine
     , emptyGraph, graphOfMiddles, graphOfZTail
     , lgraphOfAGraph, graphOfAGraph, labelAGraph
     )
 where
 
+import ZipCfg
+
 import Outputable
-import Prelude hiding (zip, unzip, last)
+import Unique
+import UniqFM
 import UniqSupply
-import ZipCfg
+
+import Prelude hiding (zip, unzip, last)
+
 
 -------------------------------------------------------------------------
 --     GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH (CONSTRUCTOR VIEW)      --
@@ -163,6 +168,26 @@ mkLast      :: (Outputable m, Outputable l, LastNode l) =>
 -- | This function provides access to fresh labels without requiring
 -- clients to be programmed monadically.
 withFreshLabel :: String -> (BlockId -> AGraph m l) -> AGraph m l
+withUnique     :: (Unique -> AGraph m l) -> AGraph m l
+
+
+outOfLine :: (LastNode l, Outputable m, Outputable l)
+          => AGraph m l -> AGraph m l
+-- ^ The argument is an AGraph that has an 
+-- empty entry sequence and no exit sequence.
+-- The result is a new AGraph that has an empty entry sequence
+-- connected to an empty exit sequence, with the original graph
+-- sitting to the side out-of-line.
+--
+-- Example:  mkMiddle (x = 3)
+--           <*> outOfLine (mkLabel L <*> ...stuff...)
+--           <*> mkMiddle (y = x)
+-- Control will flow directly from x=3 to y=x;
+-- the block starting with L is "on the side".
+--
+-- N.B. algebraically forall g g' : g <*> outOfLine g' == outOfLine g' <*> g
+
+
 
 -- below for convenience
 mkMiddles ::                                             [m]       -> AGraph m l
@@ -261,6 +286,18 @@ withFreshLabel name ofId = AGraph f
                  let AGraph f' = ofId id
                  f' g
 
+withUnique ofU = AGraph f
+  where f g = do u <- getUniqueUs
+                 let AGraph f' = ofU u
+                 f' g
+
+outOfLine (AGraph f) = AGraph f'
+    where f' (Graph tail' blocks') =
+            do Graph emptyEntrance blocks <- f emptyGraph
+               note_this_code_becomes_unreachable emptyEntrance
+               return $ Graph tail' (blocks `plusUFM` blocks')
+                                                       
+
 mkIfThenElse cbranch tbranch fbranch = 
     withFreshLabel "end of if"     $ \endif ->
     withFreshLabel "start of then" $ \tid ->
@@ -283,11 +320,16 @@ mkWhileDo cbranch body =
 note_this_code_becomes_unreachable ::
     (Monad m, LastNode l, Outputable middle, Outputable l) => ZTail middle l -> m ()
 
+#ifdef DEBUG
 note_this_code_becomes_unreachable = u
     where u (ZLast LastExit)                       = return ()
           u (ZLast (LastOther l)) | isBranchNode l = return ()
                                     -- Note [Branch follows branch]
           u tail = fail ("unreachable code: " ++ showSDoc (ppr tail))
+#else
+note_this_code_becomes_unreachable _ = return ()
+#endif
+
 {-
 Note [Branch follows branch]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~