X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fcmm%2FMkZipCfg.hs;h=067e74956c8e08750f451dd51ea3323583014192;hb=30c122df62ec75f9ed7f392f24c2925675bf1d06;hp=10068b89f56645d95350bef7983cd9191cda539d;hpb=4a7fff22295bfc4da3b86ba0659e78b429cdc854;p=ghc-hetmet.git

diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs
index 10068b8..067e749 100644
--- a/compiler/cmm/MkZipCfg.hs
+++ b/compiler/cmm/MkZipCfg.hs
@@ -1,9 +1,9 @@
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
 module MkZipCfg
-    ( AGraph, (<*>), emptyAGraph, withFreshLabel, withUnique
+    ( AGraph, (<*>), catAGraphs
+    , emptyAGraph, withFreshLabel, withUnique
     , mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo
-    , mkBlock
+    , outOfLine
     , emptyGraph, graphOfMiddles, graphOfZTail
     , lgraphOfAGraph, graphOfAGraph, labelAGraph
     )
@@ -13,10 +13,13 @@ import ZipCfg
 
 import Outputable
 import Unique
+import UniqFM
 import UniqSupply
+import Util
 
 import Prelude hiding (zip, unzip, last)
 
+#include "HsVersions.h"
 
 -------------------------------------------------------------------------
 --     GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH (CONSTRUCTOR VIEW)      --
@@ -152,6 +155,8 @@ representation is agnostic on this point.)
 infixr 3 <*>
 (<*>) :: AGraph m l -> AGraph m l -> AGraph m l
 
+catAGraphs :: [AGraph m l] -> AGraph m l
+
 -- | A graph is built up by splicing together graphs each containing a
 -- single node (where a label is considered a 'first' node.  The empty
 -- graph is a left and right unit for splicing.  All of the AGraph
@@ -171,21 +176,21 @@ withFreshLabel :: String -> (BlockId -> AGraph m l) -> AGraph m l
 withUnique     :: (Unique -> AGraph m l) -> AGraph m l
 
 
-mkBlock :: AGraph m l -> AGraph m l
--- ^ 
--- The argument is an AGraph that has an 
+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)
---           <*> mkBlock (mkLabel L <*> ...stuff...)
+--           <*> 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 for any g, g'   g <*> mkBlock g' == mkBlock g' <*> g
+-- N.B. algebraically forall g g' : g <*> outOfLine g' == outOfLine g' <*> g
 
 
 
@@ -197,6 +202,13 @@ mkBranch  :: (Outputable m, Outputable l, LastNode l) => BlockId   -> AGraph m l
 -- | For the structured control-flow constructs, a condition is
 -- represented as a function that takes as arguments the labels to
 -- goto on truth or falsehood.
+--
+--	mkIfThenElse mk_cond then else
+--	= (mk_cond L1 L2) <*> L1: then <*> goto J
+--		          <*> L2: else <*> goto J
+--	  <*> J:
+--
+-- where L1, L2, J are fresh
 
 mkIfThenElse :: (Outputable m, Outputable l, LastNode l)
                 => (BlockId -> BlockId -> AGraph m l) -- branch condition
@@ -239,6 +251,8 @@ newtype AGraph m l = AGraph (Graph m l -> UniqSM (Graph m l))
 AGraph f1 <*> AGraph f2 = AGraph f 
     where f g = f2 g >>= f1 -- note right associativity
 
+catAGraphs = foldr (<*>) emptyAGraph
+
 emptyAGraph = AGraph return
 
 graphOfAGraph (AGraph f) = f emptyGraph
@@ -291,7 +305,12 @@ withUnique ofU = AGraph f
                  let AGraph f' = ofU u
                  f' g
 
-mkBlock = undefined
+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 ->
@@ -315,11 +334,12 @@ mkWhileDo cbranch body =
 note_this_code_becomes_unreachable ::
     (Monad m, LastNode l, Outputable middle, Outputable l) => ZTail middle l -> m ()
 
-note_this_code_becomes_unreachable = u
+note_this_code_becomes_unreachable = if debugIsOn then u else \_ -> return ()
     where u (ZLast LastExit)                       = return ()
           u (ZLast (LastOther l)) | isBranchNode l = return ()
                                     -- Note [Branch follows branch]
           u tail = fail ("unreachable code: " ++ showSDoc (ppr tail))
+
 {-
 Note [Branch follows branch]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -330,3 +350,13 @@ giving it a label, and start a new one that branches to that label.
 Emitting a Branch at this point is fine: 
        goto L1; L2: ...stuff... 
 -}
+
+
+-- | The string argument to 'freshBlockId' was originally helpful in debugging
+-- the Quick C-- compiler, so I have kept it here even though at present it is
+-- thrown away at this spot---there's no reason a BlockId couldn't one day carry
+-- a string.  
+
+freshBlockId :: String -> UniqSM BlockId
+freshBlockId _ = do { u <- getUniqueUs; return $ BlockId u }
+