module CmmCvt
( cmmToZgraph, cmmOfZgraph )
where
import BlockId
import Cmm
import MkZipCfgCmm hiding (CmmGraph)
import ZipCfgCmmRep
import CmmZipUtil
import PprCmm()
import qualified ZipCfg as G
import FastString
import Control.Monad
import Outputable
import UniqSupply
cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h (CmmStackInfo, CmmGraph))
cmmOfZgraph :: GenCmm d h (CmmStackInfo, CmmGraph) -> GenCmm d h (ListGraph CmmStmt)
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 . snd)
toZgraph :: String -> CmmFormals -> ListGraph CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
toZgraph _ _ (ListGraph []) =
do g <- lgraphOfAGraph emptyAGraph
return ((0, Nothing), g)
toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
let (offset, entry) = mkEntry id NativeNodeCall args in
do g <- labelAGraph id $
entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
return ((offset, Nothing), g)
where addBlock (BasicBlock id ss) g =
mkLabel id <*> mkStmts ss <*> g
updfr_sz = 0
mkStmts (CmmNop : ss) = mkNop <*> mkStmts ss
mkStmts (CmmComment s : ss) = mkComment s <*> mkStmts ss
mkStmts (CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss
mkStmts (CmmStore l r : ss) = mkStore l r <*> mkStmts ss
mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe _) CmmMayReturn : ss) =
mkCall f (conv', conv') (map hintlessCmm res) (map hintlessCmm args) updfr_sz
<*> mkStmts ss
where conv' = Foreign (ForeignConvention conv [] [])
mkStmts (CmmCall (CmmPrim {}) _ _ (CmmSafe _) _ : _) =
panic "safe call to a primitive CmmPrim CallishMachOp"
mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) =
mkUnsafeCall (convert_target f res args)
(strip_hints res) (strip_hints args)
<*> mkStmts ss
mkStmts (CmmCondBranch e l : fbranch) =
mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch)
mkStmts (last : []) = mkLast last
mkStmts [] = bad "fell off end"
mkStmts (_ : _ : _) = bad "last node not at end"
bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
mkLast (CmmCall (CmmCallee f conv) [] args _ CmmNeverReturns) =
mkFinalCall f conv (map hintlessCmm args) updfr_sz
mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) =
panic "Call to CmmPrim never returns?!"
mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
mkLast (CmmJump tgt args) = mkJump tgt (map hintlessCmm args) updfr_sz
mkLast (CmmReturn ress) =
mkReturnSimple (map hintlessCmm ress) updfr_sz
mkLast (CmmBranch tgt) = mkBranch tgt
mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
panic "Call never returns but has results?!"
mkLast _ = panic "fell off end of block"
strip_hints :: [CmmHinted a] -> [a]
strip_hints = map hintlessCmm
convert_target :: CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals -> MidCallTarget
convert_target (CmmCallee e cc) ress args = ForeignTarget e (ForeignConvention cc (map cmmHint args) (map cmmHint ress))
convert_target (CmmPrim op) _ress _args = PrimTarget op
add_hints :: Convention -> ValueDirection -> [a] -> [CmmHinted a]
add_hints conv vd args = zipWith CmmHinted args (get_hints conv vd)
get_hints :: Convention -> ValueDirection -> [ForeignHint]
get_hints (Foreign (ForeignConvention _ hints _)) Arguments = hints
get_hints (Foreign (ForeignConvention _ _ hints)) Results = hints
get_hints _other_conv _vd = repeat NoHint
get_conv :: MidCallTarget -> Convention
get_conv (PrimTarget _) = NativeNodeCall
get_conv (ForeignTarget _ fc) = Foreign fc
cmm_target :: MidCallTarget -> CmmCallTarget
cmm_target (PrimTarget op) = CmmPrim op
cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = CmmCallee e cc
ofZgraph :: CmmGraph -> ListGraph CmmStmt
ofZgraph g = ListGraph $ swallow blocks
where blocks = G.postorder_dfs g
extend_entry stmts = stmts
extend_block _id stmts = stmts
_extend_entry stmts = scomment showblocks : scomment cscomm : stmts
showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
concat (map (\(G.Block id _) -> " " ++ show id) blocks)
cscomm = "Call successors are" ++
(concat $ map (\id -> " " ++ show id) $ blockSetToList call_succs)
swallow [] = []
swallow (G.Block id t : rest) = tail id [] t rest
tail id prev' (G.ZTail m t) rest = tail id (mid m : prev') t rest
tail id prev' (G.ZLast G.LastExit) rest = exit id prev' rest
tail id prev' (G.ZLast (G.LastOther l)) rest = last id prev' l rest
mid (MidComment s) = CmmComment s
mid (MidAssign l r) = CmmAssign l r
mid (MidStore l r) = CmmStore l r
mid (MidForeignCall _ (PrimTarget MO_Touch) _ _) = CmmNop
mid (MidForeignCall _ target ress args)
= CmmCall (cmm_target target)
(add_hints conv Results ress)
(add_hints conv Arguments args)
CmmUnsafe CmmMayReturn
where
conv = get_conv target
block' id prev'
| id == G.lg_entry g = BasicBlock id $ extend_entry (reverse prev')
| otherwise = BasicBlock id $ extend_block id (reverse prev')
last id prev' l n =
let endblock stmt = block' id (stmt : prev') : swallow n in
case l of
LastBranch tgt ->
case n of
_ -> endblock (CmmBranch tgt)
LastCondBranch expr tid fid ->
case n of
G.Block id' t : bs
| id' == fid, tid == fid, unique_pred id' ->
tail id prev' t bs
| id' == fid, unique_pred id' ->
tail id (CmmCondBranch expr tid : prev') t bs
| id' == tid, unique_pred id',
Just e' <- maybeInvertCmmExpr expr ->
tail id (CmmCondBranch e' fid : prev') t bs
_ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
in block' id instrs' : swallow n
LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
LastCall e _ _ _ _ -> endblock $ CmmJump e []
exit id prev' n =
let endblock stmt = block' id (stmt : prev') : swallow n in
case n of [] -> endblock (scomment "procedure falls off end")
G.Block id' t : bs ->
if unique_pred id' then
tail id (scomment "went thru exit" : prev') t bs
else
endblock (CmmBranch id')
preds = zipPreds g
single_preds =
let add b single =
let id = G.blockId b
in case lookupBlockEnv preds id of
Nothing -> single
Just s -> if sizeBlockSet s == 1 then
extendBlockSet single id
else single
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
G.LastOther (LastCall _ (Just id) _ _ _) ->
extendBlockSet succs id
_ -> succs
in G.fold_blocks add emptyBlockSet g
_is_call_succ id = elemBlockSet id call_succs
scomment :: String -> CmmStmt
scomment s = CmmComment $ mkFastString s