X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCvt.hs;h=0bfa396b9b3e0eaecba0b29fb101b9c47df4b77a;hb=2ebfd25540026b754d6ae61831ade31af83dbb72;hp=42859abd7f4bc93266d512b9ad443a32bd395cff;hpb=ffd3598eae8af63e350179498cf150ed5e0604b8;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs
index 42859ab..0bfa396 100644
--- a/compiler/cmm/CmmCvt.hs
+++ b/compiler/cmm/CmmCvt.hs
@@ -4,8 +4,10 @@ module CmmCvt
   ( cmmToZgraph, cmmOfZgraph )
 where
 
+import BlockId
 import Cmm
 import CmmExpr
+import MkZipCfg
 import MkZipCfgCmm hiding (CmmGraph)
 import ZipCfgCmmRep -- imported for reverse conversion
 import CmmZipUtil
@@ -14,6 +16,7 @@ import PprCmmZ()
 import qualified ZipCfg as G
 
 import FastString
+import Monad
 import Outputable
 import Panic
 import UniqSet
@@ -24,14 +27,18 @@ import Maybe
 cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h CmmGraph)
 cmmOfZgraph :: GenCmm d h (CmmGraph)          ->         GenCmm d h (ListGraph CmmStmt)
 
-cmmToZgraph = cmmMapGraphM toZgraph
+cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops
+  where mapTop (CmmProc h l args g) =
+          toZgraph (showSDoc $ ppr l) args g >>= return . CmmProc h l args
+        mapTop (CmmData s ds) = return $ CmmData s ds
 cmmOfZgraph = cmmMapGraph  ofZgraph
 
 
-toZgraph :: String -> ListGraph CmmStmt -> UniqSM CmmGraph
-toZgraph _ (ListGraph []) = lgraphOfAGraph emptyAGraph
-toZgraph fun_name g@(ListGraph (BasicBlock id ss : other_blocks)) = 
-           labelAGraph id $ mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
+toZgraph :: String -> CmmFormalsWithoutKinds -> ListGraph CmmStmt -> UniqSM CmmGraph
+toZgraph _ _ (ListGraph []) = lgraphOfAGraph emptyAGraph
+toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = 
+           labelAGraph id $ mkMiddles (mkEntry area undefined args) <*>
+                            mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
   where addBlock (BasicBlock id ss) g = mkLabel id   <*> mkStmts ss <*> g
         mkStmts (CmmNop        : ss)  = mkNop        <*> mkStmts ss 
         mkStmts (CmmComment s  : ss)  = mkComment s  <*> mkStmts ss
@@ -54,12 +61,28 @@ toZgraph fun_name g@(ListGraph (BasicBlock id ss : other_blocks)) =
         mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) =
             panic "Call to CmmPrim never returns?!"
         mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
-        mkLast (CmmJump tgt args)          = mkJump tgt args
-        mkLast (CmmReturn ress)            = mkReturn ress
+        mkLast (CmmJump tgt args)          = mkJump   area tgt args
+        mkLast (CmmReturn ress)            = mkReturn area ress
         mkLast (CmmBranch tgt)             = mkBranch tgt
         mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
                    panic "Call never returns but has results?!"
         mkLast _ = panic "fell off end of block"
+        -- The entry, jump, and return areas should be the same.
+        -- This code is horrible, but there's no point trying to fix it until we've figured
+        -- out our interface for calling conventions.
+        -- All return statements are required to use return areas of equal size.
+        -- This isn't necessarily required to write correct programs, but it's sane.
+        area = case foldr retBlock (retStmts ss Nothing) other_blocks of
+                 Just (as, _)  -> mkCallArea id as $ Just args
+                 Nothing       -> mkCallArea id [] $ Just args
+        retBlock (BasicBlock _ ss) z = retStmts ss z
+        retStmts [CmmReturn ress] z@(Just (_, n)) =
+          if size ress == n then z
+          else panic "return statements in C-- procs must return the same results"
+        retStmts [CmmReturn ress] Nothing  = Just (ress, size ress)
+        retStmts (_ : rst) z = retStmts rst z
+        retStmts [] z = z
+        size args = areaSize $ mkCallArea id args Nothing
 
 ofZgraph :: CmmGraph -> ListGraph CmmStmt
 ofZgraph g = ListGraph $ swallow blocks
@@ -85,8 +108,9 @@ ofZgraph g = ListGraph $ swallow blocks
           mid (MidAssign l r) = CmmAssign l r
           mid (MidStore  l r) = CmmStore  l r
           mid (MidUnsafeCall f ress args) = CmmCall f ress args CmmUnsafe CmmMayReturn
-          mid m@(CopyOut {})  = pcomment (ppr m)
-          mid m@(CopyIn {})   = pcomment (ppr m <+> text "(proc point)")
+          mid m@(MidAddToContext {}) = pcomment (ppr m)
+          mid m@(CopyOut {})         = pcomment (ppr m)
+          mid m@(CopyIn {})          = pcomment (ppr m <+> text "(proc point)")
           pcomment p = scomment $ showSDoc p
           block' id prev'
               | id == G.lg_entry g = BasicBlock id $ extend_entry    (reverse prev')
@@ -101,7 +125,7 @@ ofZgraph g = ListGraph $ swallow blocks
                         -> tail id prev' out t bs -- optimize out redundant labels
                     _ -> if isNothing out then endblock (CmmBranch tgt)
                          else pprPanic "can't convert LGraph with pending CopyOut"
-                                  (ppr g)
+                                  (text "target" <+> ppr tgt <+> ppr g)
               LastCondBranch expr tid fid ->
                 if isJust out then pprPanic "CopyOut before conditional branch" (ppr g)
                 else
@@ -155,13 +179,13 @@ ofZgraph g = ListGraph $ swallow blocks
           single_preds =
               let add b single =
                     let id = G.blockId b
-                    in  case G.lookupBlockEnv preds id of
+                    in  case lookupBlockEnv preds id of
                           Nothing -> single
                           Just s -> if sizeUniqSet s == 1 then
-                                        G.extendBlockSet single id
+                                        extendBlockSet single id
                                     else single
-              in  G.fold_blocks add G.emptyBlockSet g
-          unique_pred id = G.elemBlockSet id single_preds
+              in  G.fold_blocks add emptyBlockSet g
+          unique_pred id = elemBlockSet id single_preds
           call_succs = 
               let add b succs =
                       case G.last (G.unzip b) of