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

diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs
index 0b549fa..fa93f76 100644
--- a/compiler/cmm/MkZipCfg.hs
+++ b/compiler/cmm/MkZipCfg.hs
@@ -6,16 +6,15 @@ module MkZipCfg
     , mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo
     , outOfLine
     , emptyGraph, graphOfMiddles, graphOfZTail
-    , lgraphOfAGraph, graphOfAGraph, labelAGraph
+    , lgraphOfAGraph, graphOfAGraph, labelAGraph, pprAGraph
     )
 where
 
-import BlockId (BlockId(..), emptyBlockEnv)
+import BlockId (BlockId(..), emptyBlockEnv, plusBlockEnv)
 import ZipCfg
 
 import Outputable
 import Unique
-import UniqFM
 import UniqSupply
 import Util
 
@@ -166,8 +165,7 @@ catAGraphs :: [AGraph m l] -> AGraph m l
 -- splicing operation <*>, are constant-time operations.
 
 emptyAGraph :: AGraph m l
-mkLabel     :: (LastNode l) =>
-               BlockId -> Maybe Int -> AGraph m l -- graph contains the label
+mkLabel     :: (LastNode l) => BlockId -> 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
@@ -231,9 +229,9 @@ mkWhileDo    :: (Outputable m, Outputable l, LastNode l)
 -- because it may require the allocation of fresh, unique labels.
 
 graphOfAGraph  :: AGraph m l -> UniqSM (Graph  m l)
-lgraphOfAGraph :: Int -> AGraph m l -> UniqSM (LGraph m l)
+lgraphOfAGraph :: AGraph m l -> UniqSM (LGraph m l)
   -- ^ allocate a fresh label for the entry point
-labelAGraph    :: BlockId -> Int -> AGraph m l -> UniqSM (LGraph m l)
+labelAGraph    :: BlockId -> AGraph m l -> UniqSM (LGraph m l)
   -- ^ use the given BlockId as the label of the entry point
 
 
@@ -262,20 +260,20 @@ emptyAGraph = AGraph return
 graphOfAGraph (AGraph f) = f emptyGraph
 emptyGraph = Graph (ZLast LastExit) emptyBlockEnv
 
-labelAGraph id args g =
+labelAGraph id g =
     do Graph tail blocks <- graphOfAGraph g
-       return $ LGraph id args $ insertBlock (Block id Nothing tail) blocks
+       return $ LGraph id $ insertBlock (Block id tail) blocks
 
-lgraphOfAGraph args g = do id <- freshBlockId "graph entry"
-                           labelAGraph id args g
+lgraphOfAGraph g = do id <- freshBlockId "graph entry"
+                      labelAGraph id g
 
 -------------------------------------
 -- constructors
 
-mkLabel id args = AGraph f
+mkLabel id = AGraph f
     where f (Graph tail blocks) =
             return $ Graph (ZLast (mkBranchNode id))
-                           (insertBlock (Block id args tail) blocks)
+                           (insertBlock (Block id tail) blocks)
 
 mkBranch target = mkLast $ mkBranchNode target
 
@@ -291,12 +289,12 @@ graphOfZTail   t  = Graph t emptyBlockEnv
 
 mkLast l = AGraph f
     where f (Graph tail blocks) =
-            do note_this_code_becomes_unreachable tail
+            do note_this_code_becomes_unreachable "mkLast" (ppr l <+> ppr blocks) tail
                return $ Graph (ZLast (LastOther l)) blocks
 
 mkZTail tail = AGraph f
     where f (Graph utail blocks) =
-            do note_this_code_becomes_unreachable utail
+            do note_this_code_becomes_unreachable "mkZTail" (ppr tail) utail
                return $ Graph tail blocks
 
 withFreshLabel name ofId = AGraph f
@@ -312,34 +310,52 @@ withUnique ofU = AGraph f
 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')
-                                                       
+               note_this_code_becomes_unreachable "outOfLine" (ppr tail') emptyEntrance
+               return $ Graph tail' (blocks `plusBlockEnv` 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 Nothing <*> tbranch <*> mkBranch endif <*>
-        mkLabel fid Nothing <*> fbranch <*> mkLabel endif Nothing
+        mkLabel tid <*> tbranch <*> mkBranch endif <*>
+        mkLabel fid <*> fbranch <*>
+        mkLabel endif
 
 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 Nothing <*> body <*> mkLabel test Nothing
-                   <*> cbranch head endwhile <*> mkLabel endwhile Nothing
+     mkBranch test <*> mkLabel head <*> body
+                   <*> mkLabel test <*> cbranch head endwhile
+                   <*> mkLabel endwhile
 
 -- | 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 ()
+    (Monad m, LastNode l, Outputable middle, Outputable l) =>
+       String -> SDoc -> ZTail middle l -> m ()
 
-note_this_code_becomes_unreachable = if debugIsOn then u else \_ -> return ()
+note_this_code_becomes_unreachable str old = 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))
+          u tail = fail ("unreachable code in " ++ str ++ ": " ++
+                         (showSDoc ((ppr tail) <+> old)))
+
+-- | 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
+
+-------------------------------------
+-- Debugging
+
+pprAGraph :: (Outputable m, LastNode l, Outputable l) => AGraph m l -> UniqSM SDoc
+pprAGraph g = graphOfAGraph g >>= return . ppr
 
 {-
 Note [Branch follows branch]
@@ -353,11 +369,3 @@ Emitting a Branch at this point is fine:
 -}
 
 
--- | 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
-