{-# LANGUAGE PatternGuards #-}
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
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
import qualified ZipCfg as G
import FastString
+import Monad
import Outputable
import Panic
import UniqSet
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
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
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')
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
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
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"
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