From: simonpj@microsoft.com <unknown>
Date: Wed, 19 Sep 2007 15:05:44 +0000 (+0000)
Subject: Small changes to mk-ing flow graphs
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=c92fecad2314baf305292174a14ba383465157a4

Small changes to mk-ing flow graphs

- ZipCfg: add mkBlockId :: Unique -> BlockId
- MkZipCfg: change sequence --> catAGrpahs
- MkZipCfgCmm: add mkCmmIfThen

Not fully validated, but I don't think anything will break
---

diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index fef00c7..b535c8d 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -21,8 +21,8 @@ module Cmm (
         CmmSafety(..),
 	CmmCallTarget(..),
 	CmmStatic(..), Section(..),
-        module CmmExpr,
-        BlockId(..), 
+
+        BlockId(..), mkBlockId,
         BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv,
         BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet,
   ) where
@@ -40,7 +40,7 @@ import FastString
 
 import Data.Word
 
-import ZipCfg (	BlockId(..)
+import ZipCfg (	BlockId(..), mkBlockId
               , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv
               , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet
               )
diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs
index d098bb6..6019549 100644
--- a/compiler/cmm/MkZipCfg.hs
+++ b/compiler/cmm/MkZipCfg.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module MkZipCfg
-    ( AGraph, (<*>), sequence
+    ( AGraph, (<*>), catAGraphs
     , emptyAGraph, withFreshLabel, withUnique
     , mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo
     , outOfLine
@@ -16,7 +16,7 @@ import Unique
 import UniqFM
 import UniqSupply
 
-import Prelude hiding (zip, unzip, last, sequence)
+import Prelude hiding (zip, unzip, last)
 
 #include "HsVersions.h"
 
@@ -154,7 +154,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
@@ -250,7 +250,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
 
diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs
index 890b37c..d52b32e 100644
--- a/compiler/cmm/MkZipCfgCmm.hs
+++ b/compiler/cmm/MkZipCfgCmm.hs
@@ -7,9 +7,10 @@
 
 module MkZipCfgCmm
   ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall
-         , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, mkCmmIfThenElse
-         , mkCmmWhileDo, mkAddToContext
-  , (<*>), sequence, mkLabel, mkBranch
+         , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment 
+	 , mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
+	 , mkAddToContext
+  , (<*>), catAGraphs, mkLabel, mkBranch
   , emptyAGraph, withFreshLabel, withUnique, outOfLine
   , lgraphOfAGraph, graphOfAGraph, labelAGraph
   , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle, Last, Convention(..)
@@ -31,7 +32,6 @@ import FastString
 import ForeignCall
 import ZipCfg 
 import MkZipCfg
-import Prelude hiding( sequence )
 
 type CmmGraph  = LGraph Middle Last
 type CmmAGraph = AGraph Middle Last
@@ -63,7 +63,9 @@ mkJump       	:: CmmExpr -> CmmActuals -> CmmAGraph
 mkCbranch    	:: CmmExpr -> BlockId -> BlockId -> CmmAGraph
 mkSwitch     	:: CmmExpr -> [Maybe BlockId] -> CmmAGraph
 mkReturn     	:: CmmActuals -> CmmAGraph
+
 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
+mkCmmIfThen     :: CmmExpr -> CmmAGraph -> CmmAGraph
 mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph 
 
 -- Not to be forgotten, but exported by MkZipCfg:
@@ -75,8 +77,16 @@ mkCmmWhileDo    :: CmmExpr -> CmmAGraph -> CmmAGraph
 
 --------------------------------------------------------------------------
 
+mkCmmWhileDo    e = mkWhileDo (mkCbranch e)
 mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
-mkCmmWhileDo    e = mkWhileDo    (mkCbranch e)
+
+mkCmmIfThen e tbranch
+  = withFreshLabel "end of if"     $ \endif ->
+    withFreshLabel "start of then" $ \tid ->
+    mkCbranch e tid endif <*>
+    mkLabel tid <*> tbranch <*> mkBranch endif <*>
+    mkLabel endif
+
 
 
 -- ================ IMPLEMENTATION ================--
diff --git a/compiler/cmm/ZipCfg.hs b/compiler/cmm/ZipCfg.hs
index 8001776..30843e5 100644
--- 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(..)
@@ -639,6 +639,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