X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FMkZipCfg.hs;h=0b549fad9db862a8c1edc0a050968c4d24eafb23;hp=385b41d5b9e7159b81e049a1fcfba3794052df52;hb=176fa33f17dd78355cc572e006d2ab26898e2c69;hpb=0967b989b62abe69e0cd74ac563dbde200f7f3c5

diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs
index 385b41d..0b549fa 100644
--- a/compiler/cmm/MkZipCfg.hs
+++ b/compiler/cmm/MkZipCfg.hs
@@ -1,7 +1,8 @@
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
 module MkZipCfg
-    ( AGraph, (<*>), emptyAGraph, withFreshLabel, withUnique
+    ( AGraph, (<*>), catAGraphs
+    , freshBlockId
+    , emptyAGraph, withFreshLabel, withUnique
     , mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo
     , outOfLine
     , emptyGraph, graphOfMiddles, graphOfZTail
@@ -9,15 +10,18 @@ module MkZipCfg
     )
 where
 
+import BlockId (BlockId(..), emptyBlockEnv)
 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)      --
@@ -153,6 +157,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
@@ -160,9 +166,9 @@ infixr 3 <*>
 -- splicing operation <*>, are constant-time operations.
 
 emptyAGraph :: AGraph m l
-mkLabel     :: LastNode l =>
-               BlockId -> AGraph m l              -- graph contains the label
-mkMiddle    :: m       -> AGraph m l              -- graph contains the node
+mkLabel     :: (LastNode l) =>
+               BlockId -> Maybe Int -> AGraph m l -- graph contains the label
+mkMiddle    :: m -> AGraph m l   -- graph contains the node
 mkLast      :: (Outputable m, Outputable l, LastNode l) =>
                l       -> AGraph m l              -- graph contains the node
 
@@ -191,13 +197,22 @@ outOfLine :: (LastNode l, Outputable m, Outputable l)
 
 
 -- below for convenience
-mkMiddles ::                                             [m]       -> AGraph m l
-mkZTail   :: (Outputable m, Outputable l, LastNode l) => ZTail m l -> AGraph m l
-mkBranch  :: (Outputable m, Outputable l, LastNode l) => BlockId   -> AGraph m l
+mkMiddles :: [m] -> AGraph m l
+mkZTail   :: (Outputable m, Outputable l, LastNode l) =>
+  ZTail m l -> AGraph m l
+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
@@ -215,10 +230,10 @@ mkWhileDo    :: (Outputable m, Outputable l, LastNode l)
 -- in the number of basic blocks.  The conversion is also monadic
 -- because it may require the allocation of fresh, unique labels.
 
-graphOfAGraph  ::            AGraph m l -> UniqSM (Graph  m l)
-lgraphOfAGraph ::            AGraph m l -> UniqSM (LGraph m l)
+graphOfAGraph  :: AGraph m l -> UniqSM (Graph  m l)
+lgraphOfAGraph :: Int -> AGraph m l -> UniqSM (LGraph m l)
   -- ^ allocate a fresh label for the entry point
-labelAGraph    :: BlockId -> AGraph m l -> UniqSM (LGraph m l)
+labelAGraph    :: BlockId -> Int -> AGraph m l -> UniqSM (LGraph m l)
   -- ^ use the given BlockId as the label of the entry point
 
 
@@ -240,25 +255,27 @@ 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
 emptyGraph = Graph (ZLast LastExit) emptyBlockEnv
 
-labelAGraph id g =
+labelAGraph id args g =
     do Graph tail blocks <- graphOfAGraph g
-       return $ LGraph id $ insertBlock (Block id tail) blocks
+       return $ LGraph id args $ insertBlock (Block id Nothing tail) blocks
 
-lgraphOfAGraph g = do id <- freshBlockId "graph entry"
-                      labelAGraph id g
+lgraphOfAGraph args g = do id <- freshBlockId "graph entry"
+                           labelAGraph id args g
 
 -------------------------------------
 -- constructors
 
-mkLabel id = AGraph f
+mkLabel id args = AGraph f
     where f (Graph tail blocks) =
             return $ Graph (ZLast (mkBranchNode id))
-                           (insertBlock (Block id tail) blocks)
+                           (insertBlock (Block id args tail) blocks)
 
 mkBranch target = mkLast $ mkBranchNode target
 
@@ -288,7 +305,7 @@ withFreshLabel name ofId = AGraph f
                  f' g
 
 withUnique ofU = AGraph f
-  where f g = do u <- getUniqueUs
+  where f g = do u <- getUniqueM
                  let AGraph f' = ofU u
                  f' g
 
@@ -298,34 +315,32 @@ outOfLine (AGraph f) = AGraph f'
                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 ->
     withFreshLabel "start of else" $ \fid ->
         cbranch tid fid <*>
-        mkLabel tid <*> tbranch <*> mkBranch endif <*>
-        mkLabel fid <*> fbranch <*> mkLabel endif
-
+        mkLabel tid Nothing <*> tbranch <*> mkBranch endif <*>
+        mkLabel fid Nothing <*> fbranch <*> mkLabel endif Nothing
 
 mkWhileDo cbranch body = 
   withFreshLabel "loop test" $ \test ->
   withFreshLabel "loop head" $ \head ->
   withFreshLabel "end while" $ \endwhile ->
      -- Forrest Baskett's while-loop layout
-     mkBranch test <*> mkLabel head <*> body <*> mkLabel test
-                   <*> cbranch head endwhile <*> mkLabel endwhile
-
+     mkBranch test <*> mkLabel head Nothing <*> body <*> mkLabel test Nothing
+                   <*> cbranch head endwhile <*> mkLabel endwhile Nothing
 
 -- | Bleat if the insertion of a last node will create unreachable code
 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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -336,3 +351,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 :: MonadUnique m => String -> m BlockId
+freshBlockId _s = getUniqueM >>= return . BlockId
+