Big collection of patches for the new codegen branch.

[ghc-hetmet.git] / compiler / cmm / MkZipCfg.hs

diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs
index 0b549fa..332b464 100644 (file)
--- 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
 
@@ -167,7 +166,7 @@ catAGraphs :: [AGraph m l] -> AGraph m l
 
 emptyAGraph :: AGraph m l
 mkLabel     :: (LastNode l) =>
-               BlockId -> Maybe Int -> AGraph m l -- graph contains the label
+               BlockId -> StackInfo -> 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
@@ -264,7 +263,8 @@ emptyGraph = Graph (ZLast LastExit) emptyBlockEnv
 
 labelAGraph id args g =
     do Graph tail blocks <- graphOfAGraph g
-       return $ LGraph id args $ insertBlock (Block id Nothing tail) blocks
+       return $ LGraph id args $ insertBlock (Block id stackInfo tail) blocks
+    where stackInfo = StackInfo Nothing Nothing
 
 lgraphOfAGraph args g = do id <- freshBlockId "graph entry"
                            labelAGraph id args g
@@ -291,12 +291,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
@@ -310,36 +310,54 @@ withUnique ofU = AGraph f
                  f' g
 
 outOfLine (AGraph f) = AGraph f'
-    where f' (Graph tail' blocks') =
+    where f' g@(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 emptyStackInfo <*> tbranch <*> mkBranch endif <*>
+        mkLabel fid emptyStackInfo <*> fbranch <*>
+        mkLabel endif emptyStackInfo 
 
 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 emptyStackInfo <*> body
+                   <*> mkLabel test emptyStackInfo <*> cbranch head endwhile
+                   <*> mkLabel endwhile emptyStackInfo 
 
 -- | 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 +371,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
-