X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FMkZipCfgCmm.hs;h=d52b32ed56889f8fcaf3e7fa25a855e70e26d02b;hb=814d2f506d63f785dbfe33189dde606a06e60285;hp=f6521b3e1ed6d162015e5977005b86039f52a19d;hpb=4ddba4629c5396bec766b598fe32d874a378d7bb;p=ghc-hetmet.git

diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs
index f6521b3..d52b32e 100644
--- a/compiler/cmm/MkZipCfgCmm.hs
+++ b/compiler/cmm/MkZipCfgCmm.hs
@@ -6,10 +6,11 @@
 -- complain to Norman Ramsey.
 
 module MkZipCfgCmm
-  ( mkNop, mkAssign, mkStore, mkCall, mkUnsafeCall, mkFinalCall
-         , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, mkCmmIfThenElse
-         , mkCmmWhileDo
-  , (<*>), mkLabel, mkBranch
+  ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall
+         , 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(..)
@@ -38,34 +39,59 @@ type CmmBlock  = Block  Middle Last
 type CmmZ      = GenCmm    CmmStatic CmmInfo CmmGraph
 type CmmTopZ   = GenCmmTop CmmStatic CmmInfo CmmGraph
 
+---------- No-ops
 mkNop        :: CmmAGraph
+mkComment    :: FastString -> CmmAGraph
+
+---------- Assignment and store
 mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
+
+---------- Calls
 mkCall       :: CmmExpr -> CCallConv -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
+mkCmmCall    :: CmmExpr -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
+			-- Native C-- calling convention
 mkUnsafeCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
 mkFinalCall  :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph
 		 -- Never returns; like exit() or barf()
-mkJump       :: CmmExpr -> CmmActuals -> CmmAGraph
-mkCbranch    :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
-mkSwitch     :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
-mkReturn     :: CmmActuals -> CmmAGraph
-mkComment    :: FastString -> CmmAGraph
 
--- Not to be forgotten, but exported by MkZipCfg:
---mkBranch      :: BlockId -> CmmAGraph
---mkLabel       :: BlockId -> CmmAGraph
+---------- Context manipulation ('return via')
+mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph
+
+---------- Control transfer
+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:
+-- mkBranch   	  :: BlockId -> CmmAGraph
+-- mkLabel    	  :: BlockId -> CmmAGraph
+-- outOfLine  	  :: CmmAGraph -> CmmAGraph
+-- withUnique 	  :: (Unique -> CmmAGraph) -> CmmAGraph
+-- withFreshLabel :: String -> (BlockId -> 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 ================--
 
-mkNop                     = mkMiddle $ MidNop
+mkNop                     = emptyAGraph
 mkComment fs              = mkMiddle $ MidComment fs
 mkAssign l r              = mkMiddle $ MidAssign l r
 mkStore  l r              = mkMiddle $ MidStore  l r
@@ -74,6 +100,7 @@ mkCbranch pred ifso ifnot = mkLast   $ LastCondBranch pred ifso ifnot
 mkSwitch e tbl            = mkLast   $ LastSwitch e tbl
 
 mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
+mkAddToContext ra actuals         = mkMiddle $ MidAddToContext ra actuals
 
 cmmArgConv, cmmResConv :: Convention
 cmmArgConv = ConventionStandard CmmCallConv Arguments
@@ -86,6 +113,8 @@ mkFinalCall  f conv actuals =
     mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>
     mkLast   (LastCall f Nothing)
 
+mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt
+
 mkCall f conv results actuals srt = 
     withFreshLabel "call successor" $ \k ->
       mkMiddle (CopyOut (ConventionStandard conv Arguments) actuals) <*>