minor changes to Cmm left over from September 2007

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

diff --git a/compiler/cmm/ZipCfg.hs b/compiler/cmm/ZipCfg.hs
index 75f3b79..67a4ecd 100644 (file)
--- a/compiler/cmm/ZipCfg.hs
+++ b/compiler/cmm/ZipCfg.hs
@@ -1,6 +1,6 @@
 module ZipCfg
     (  -- These data types and names are carefully thought out
-      BlockId(..)      -- ToDo: BlockId should be abstract, but it isn't yet
+      BlockId(..), mkBlockId   -- ToDo: BlockId should be abstract, but it isn't yet
     , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, insertBlock, mkBlockEnv
     , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, mkBlockSet
     , Graph(..), LGraph(..), FGraph(..)
@@ -13,7 +13,7 @@ module ZipCfg
     , blockId, zip, unzip, last, goto_end, zipht, tailOfLast
     , splice_tail, splice_head, splice_head_only', splice_head'
     , of_block_list, to_block_list
-    , map_nodes
+    , map_blocks, map_nodes, mapM_blocks
     , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
     , fold_layout
     , fold_blocks
@@ -21,7 +21,7 @@ module ZipCfg
 
     , pprLgraph, pprGraph
 
-    , entry -- exported for the convenience of ZipDataflow, at least for now
+    , entry -- exported for the convenience of ZipDataflow0, at least for now
 
     {-
     -- the following functions might one day be useful and can be found
@@ -37,6 +37,8 @@ where
 
 #include "HsVersions.h"
 
+import CmmExpr ( UserOfLocalRegs(..) ) --for an instance
+
 import Outputable hiding (empty)
 import Panic
 import Unique
@@ -75,7 +77,7 @@ the data constructor 'LastExit'.  A graph may contain at most one
 'LastExit' node, and a graph representing a full procedure should not
 contain any 'LastExit' nodes.  'LastExit' nodes are used only to splice
 graphs together, either during graph construction (see module 'MkZipCfg')
-or during optimization (see module 'ZipDataflow').
+or during optimization (see module 'ZipDataflow0').
 
 A graph is parameterized over the types of middle and last nodes.  Each of
 these types will typically be instantiated with a subset of C-- statements
@@ -140,6 +142,14 @@ data ZLast l
                  -- so we don't want to pollute the 'l' type parameter with it
   | LastOther l
 
+--So that we don't have orphan instances, this goes here or in CmmExpr.
+--At least UserOfLocalRegs (ZLast Last) is needed (Last defined elsewhere),
+--but there's no need for non-Haskell98 instances for that.
+instance UserOfLocalRegs a => UserOfLocalRegs (ZLast a) where
+    foldRegsUsed  f z (LastOther l) = foldRegsUsed f z l
+    foldRegsUsed _f z LastExit      = z
+
+
 data ZHead m   = ZFirst BlockId  | ZHead (ZHead m) m
     -- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
 data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
@@ -266,7 +276,9 @@ fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a
 map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
    -- mapping includes the entry id!
 
-map_blocks :: (Block m l -> Block m' l') -> LGraph m' l' -> LGraph m' l'
+map_blocks  :: (Block m l -> Block m' l') -> LGraph m l -> LGraph m' l'
+mapM_blocks :: Monad mm
+            => (Block m l -> mm (Block m' l')) -> LGraph m l -> mm (LGraph m' l')
 
 -- | These translation functions are speculative.  I hope eventually
 -- they will be used in the native-code back ends ---NR
@@ -485,6 +497,14 @@ map_nodes idm middle last (LGraph eid blocks) = LGraph (idm eid) (mapUFM block b
           tail (ZLast LastExit) = ZLast LastExit
           tail (ZLast (LastOther l)) = ZLast (LastOther (last l))
 
+
+mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid 
+    where blocks' =
+            foldUFM (\b mblocks -> do { blocks <- mblocks
+                                      ; b <- f b
+                                      ; return $ insertBlock b blocks })
+                    (return emptyBlockEnv) blocks
+
 fold_blocks f z (LGraph _ blocks) = foldUFM f z blocks
 
 of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks 
@@ -629,6 +649,9 @@ newtype BlockId = BlockId Unique
 instance Uniquable BlockId where
   getUnique (BlockId u) = u
 
+mkBlockId :: Unique -> BlockId
+mkBlockId uniq = BlockId uniq
+
 instance Show BlockId where
   show (BlockId u) = show u
 
@@ -665,10 +688,19 @@ mkBlockSet = mkUniqSet
 instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
     ppr = pprTail
 
+instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where
+    ppr = pprLgraph
+
+instance (Outputable l) => Outputable (ZLast l) where
+    ppr = pprLast
+
 pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc 
 pprTail (ZTail m t) = ppr m $$ ppr t
-pprTail (ZLast LastExit) = text "<exit>"
-pprTail (ZLast (LastOther l)) = ppr l
+pprTail (ZLast l) = ppr l
+
+pprLast :: (Outputable l) => ZLast l -> SDoc
+pprLast LastExit = text "<exit>"
+pprLast (LastOther l) = ppr l
 
 pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
 pprLgraph g = text "{" $$ nest 2 (vcat $ map pprBlock blocks) $$ text "}"
@@ -681,5 +713,3 @@ pprGraph (Graph tail blockenv) =
     where pprBlock (Block id tail) = ppr id <> colon $$ ppr tail
           blocks = postorder_dfs_from blockenv tail
 
-_unused :: FS.FastString
-_unused = undefined