X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCvt.hs;h=0bfa396b9b3e0eaecba0b29fb101b9c47df4b77a;hb=0f5e104c36b1dc3d8deeec5fef3d65e7b3a1b5ad;hp=ae336b56a37efa7c65bb8bb71e311c2906cc4fcc;hpb=1241c26f3552a2037263769e5ef7fa68d9f3be36;p=ghc-hetmet.git diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index ae336b5..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 @@ -81,13 +104,13 @@ ofZgraph g = ListGraph $ swallow blocks tail id prev' out (G.ZTail m t) rest = tail id (mid m : prev') out t rest tail id prev' out (G.ZLast G.LastExit) rest = exit id prev' out rest tail id prev' out (G.ZLast (G.LastOther l)) rest = last id prev' out l rest - mid (MidNop) = CmmNop mid (MidComment s) = CmmComment s 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') @@ -95,15 +118,14 @@ ofZgraph g = ListGraph $ swallow blocks last id prev' out l n = let endblock stmt = block' id (stmt : prev') : swallow n in case l of - LastBranch _ (_:_) -> panic "unrepresentable branch" - LastBranch tgt [] -> + LastBranch tgt -> case n of G.Block id' t : bs | tgt == id', unique_pred id' -> 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 @@ -116,8 +138,8 @@ ofZgraph g = ListGraph $ swallow blocks tail id (CmmCondBranch e' fid : prev') Nothing t bs _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev' in block' id instrs' : swallow n - LastJump expr params -> endblock $ CmmJump expr params - LastReturn params -> endblock $ CmmReturn params + LastJump expr -> endblock $ with_out out $ CmmJump expr + LastReturn -> endblock $ with_out out $ CmmReturn LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids LastCall e cont | Just (conv, args) <- out @@ -137,6 +159,8 @@ ofZgraph g = ListGraph $ swallow blocks in tail id (delayed : call : prev') Nothing t bs | otherwise -> panic "unrepairable call" | otherwise -> panic "call with no CopyOut" + with_out (Just (_conv, actuals)) f = f actuals + with_out Nothing f = pprPanic "unrepairable data flow to" (ppr $ f []) findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt) findCopyIn (G.ZTail _ t) = findCopyIn t findCopyIn (G.ZLast _) = panic "missing CopyIn after call" @@ -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