module CmmCvt
( cmmToZgraph, cmmOfZgraph )
where
import BlockId
import Cmm
import CmmDecl
import CmmExpr
import MkGraph
import qualified OldCmm as Old
import OldPprCmm ()
import Platform
import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch)
import Control.Monad
import Data.Maybe
import Maybes
import Outputable
import UniqSupply
cmmToZgraph :: Platform -> Old.Cmm -> UniqSM Cmm
cmmOfZgraph :: Cmm -> Old.Cmm
cmmToZgraph platform (Cmm tops) = liftM Cmm $ mapM mapTop tops
where mapTop (CmmProc (Old.CmmInfo _ _ info_tbl) l g) =
do (stack_info, g) <- toZgraph platform (showSDoc $ ppr l) g
return $ CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) l g
mapTop (CmmData s ds) = return $ CmmData s ds
cmmOfZgraph (Cmm tops) = Cmm $ map mapTop tops
where mapTop (CmmProc h l g) = CmmProc (Old.CmmInfo Nothing Nothing (info_tbl h)) l (ofZgraph g)
mapTop (CmmData s ds) = CmmData s ds
toZgraph :: Platform -> String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
toZgraph _ _ (Old.ListGraph []) =
do g <- lgraphOfAGraph emptyAGraph
return (StackInfo {arg_space=0, updfr_space=Nothing}, g)
toZgraph platform fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) =
let (offset, entry) = mkCallEntry NativeNodeCall [] in
do g <- labelAGraph id $
entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
return (StackInfo {arg_space = offset, updfr_space = Nothing}, g)
where addBlock (Old.BasicBlock id ss) g =
mkLabel id <*> mkStmts ss <*> g
updfr_sz = 0
mkStmts (Old.CmmNop : ss) = mkNop <*> mkStmts ss
mkStmts (Old.CmmComment s : ss) = mkComment s <*> mkStmts ss
mkStmts (Old.CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss
mkStmts (Old.CmmStore l r : ss) = mkStore l r <*> mkStmts ss
mkStmts (Old.CmmCall (Old.CmmCallee f conv) res args (Old.CmmSafe _) Old.CmmMayReturn : ss) =
mkCall f (conv', conv') (map Old.hintlessCmm res) (map Old.hintlessCmm args) updfr_sz
<*> mkStmts ss
where conv' = Foreign (ForeignConvention conv [] [])
mkStmts (Old.CmmCall (Old.CmmPrim {}) _ _ (Old.CmmSafe _) _ : _) =
panic "safe call to a primitive CmmPrim CallishMachOp"
mkStmts (Old.CmmCall f res args Old.CmmUnsafe Old.CmmMayReturn : ss) =
mkUnsafeCall (convert_target f res args)
(strip_hints res) (strip_hints args)
<*> mkStmts ss
mkStmts (Old.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) (pprPlatform platform g)
mkLast (Old.CmmCall (Old.CmmCallee f conv) [] args _ Old.CmmNeverReturns) =
mkFinalCall f conv (map Old.hintlessCmm args) updfr_sz
mkLast (Old.CmmCall (Old.CmmPrim {}) _ _ _ Old.CmmNeverReturns) =
panic "Call to CmmPrim never returns?!"
mkLast (Old.CmmSwitch scrutinee table) = mkSwitch scrutinee table
mkLast (Old.CmmJump tgt args) = mkJump tgt (map Old.hintlessCmm args) updfr_sz
mkLast (Old.CmmReturn ress) =
mkReturnSimple (map Old.hintlessCmm ress) updfr_sz
mkLast (Old.CmmBranch tgt) = mkBranch tgt
mkLast (Old.CmmCall _f (_:_) _args _ Old.CmmNeverReturns) =
panic "Call never returns but has results?!"
mkLast _ = panic "fell off end of block"
strip_hints :: [Old.CmmHinted a] -> [a]
strip_hints = map Old.hintlessCmm
convert_target :: Old.CmmCallTarget -> [Old.HintedCmmFormal] -> [Old.HintedCmmActual] -> ForeignTarget
convert_target (Old.CmmCallee e cc) ress args = ForeignTarget e (ForeignConvention cc (map Old.cmmHint args) (map Old.cmmHint ress))
convert_target (Old.CmmPrim op) _ress _args = PrimTarget op
data ValueDirection = Arguments | Results
add_hints :: Convention -> ValueDirection -> [a] -> [Old.CmmHinted a]
add_hints conv vd args = zipWith Old.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 :: ForeignTarget -> Convention
get_conv (PrimTarget _) = NativeNodeCall
get_conv (ForeignTarget _ fc) = Foreign fc
cmm_target :: ForeignTarget -> Old.CmmCallTarget
cmm_target (PrimTarget op) = Old.CmmPrim op
cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = Old.CmmCallee e cc
ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt
ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
where preds :: BlockEnv [CmmNode O C]
preds = mapFold add mapEmpty $ toBlockMap g
where add block env = foldr (add' $ lastNode block) env (successors block)
add' :: CmmNode O C -> BlockId -> BlockEnv [CmmNode O C] -> BlockEnv [CmmNode O C]
add' node succ env = mapInsert succ (node : (mapLookup succ env `orElse` [])) env
to_be_catenated :: BlockId -> Bool
to_be_catenated id | id == g_entry g = False
| Just [CmmBranch _] <- mapLookup id preds = True
| Just [CmmCondBranch _ _ f] <- mapLookup id preds
, f == id = True
| Just [CmmCondBranch e t f] <- mapLookup id preds
, t == id
, Just (_:_:_) <- mapLookup f preds
, Just _ <- maybeInvertCmmExpr e = True
to_be_catenated _ = False
convert_block block | to_be_catenated (entryLabel block) = Nothing
convert_block block = Just $ foldBlockNodesB3 (first, middle, last) block ()
where first :: CmmNode C O -> [Old.CmmStmt] -> Old.CmmBasicBlock
first (CmmEntry bid) stmts = Old.BasicBlock bid stmts
middle :: CmmNode O O -> [Old.CmmStmt] -> [Old.CmmStmt]
middle node stmts = stmt : stmts
where stmt :: Old.CmmStmt
stmt = case node of
CmmComment s -> Old.CmmComment s
CmmAssign l r -> Old.CmmAssign l r
CmmStore l r -> Old.CmmStore l r
CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
CmmUnsafeForeignCall target ress args ->
Old.CmmCall (cmm_target target)
(add_hints (get_conv target) Results ress)
(add_hints (get_conv target) Arguments args)
Old.CmmUnsafe Old.CmmMayReturn
last :: CmmNode O C -> () -> [Old.CmmStmt]
last node _ = stmts
where stmts :: [Old.CmmStmt]
stmts = case node of
CmmBranch tgt | to_be_catenated tgt -> tail_of tgt
| otherwise -> [Old.CmmBranch tgt]
CmmCondBranch expr tid fid
| to_be_catenated fid -> Old.CmmCondBranch expr tid : tail_of fid
| to_be_catenated tid
, Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid
| otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
CmmCall e _ _ _ _ -> [Old.CmmJump e []]
CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
Old.BasicBlock _ stmts -> stmts
where Just block = mapLookup bid $ toBlockMap g