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

diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs
index a0dcf11..fa93f76 100644
--- a/compiler/cmm/MkZipCfg.hs
+++ b/compiler/cmm/MkZipCfg.hs
@@ -1,22 +1,24 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module MkZipCfg
-    ( AGraph, (<*>), sequence
+    ( AGraph, (<*>), catAGraphs
+    , freshBlockId
     , emptyAGraph, withFreshLabel, withUnique
     , mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo
     , outOfLine
     , emptyGraph, graphOfMiddles, graphOfZTail
-    , lgraphOfAGraph, graphOfAGraph, labelAGraph
+    , lgraphOfAGraph, graphOfAGraph, labelAGraph, pprAGraph
     )
 where
 
+import BlockId (BlockId(..), emptyBlockEnv, plusBlockEnv)
 import ZipCfg
 
 import Outputable
 import Unique
-import UniqFM
 import UniqSupply
+import Util
 
-import Prelude hiding (zip, unzip, last, sequence)
+import Prelude hiding (zip, unzip, last)
 
 #include "HsVersions.h"
 
@@ -154,7 +156,7 @@ representation is agnostic on this point.)
 infixr 3 <*>
 (<*>) :: AGraph m l -> AGraph m l -> AGraph m l
 
-sequence :: [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
@@ -163,9 +165,8 @@ sequence :: [AGraph m l] -> AGraph m l
 -- 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 -> 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
 
@@ -194,9 +195,11 @@ 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
@@ -225,8 +228,8 @@ 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 :: AGraph m l -> UniqSM (LGraph m l)
   -- ^ allocate a fresh label for the entry point
 labelAGraph    :: BlockId -> AGraph m l -> UniqSM (LGraph m l)
   -- ^ use the given BlockId as the label of the entry point
@@ -250,7 +253,7 @@ 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
 
-sequence = foldr (<*>) emptyAGraph
+catAGraphs = foldr (<*>) emptyAGraph
 
 emptyAGraph = AGraph return
 
@@ -286,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
@@ -300,16 +303,15 @@ 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
 
 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 ->
@@ -317,27 +319,43 @@ mkIfThenElse cbranch tbranch fbranch =
     withFreshLabel "start of else" $ \fid ->
         cbranch tid fid <*>
         mkLabel tid <*> tbranch <*> mkBranch endif <*>
-        mkLabel fid <*> fbranch <*> mkLabel 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 <*> body <*> mkLabel test
-                   <*> cbranch head endwhile <*> mkLabel endwhile
-
+     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]
@@ -350,5 +368,4 @@ Emitting a Branch at this point is fine:
        goto L1; L2: ...stuff... 
 -}
 
-_unused :: FS.FastString
-_unused = undefined
+