{-# LANGUAGE PatternGuards #-}
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
module CmmCvt
( cmmToZgraph, cmmOfZgraph )
where
+
+import BlockId
+import ClosureInfo (C_SRT(..))
import Cmm
import CmmExpr
-import ZipCfgCmm
-import MkZipCfg
+import MkZipCfgCmm hiding (CmmGraph)
+import ZipCfgCmmRep -- imported for reverse conversion
import CmmZipUtil
+import ForeignCall
+import PprCmm()
+import qualified ZipCfg as G
+
import FastString
+import Monad
import Outputable
import Panic
-import PprCmm()
-import PprCmmZ()
import UniqSet
import UniqSupply
-import qualified ZipCfg as G
+
+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
-cmmOfZgraph = cmmMapGraph ofZgraph
+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 (ListGraph (BasicBlock id ss : other_blocks)) =
- labelAGraph id $ mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
- where addBlock (BasicBlock id ss) g = mkLabel id <*> mkStmts ss <*> g
+toZgraph :: String -> CmmFormals -> ListGraph CmmStmt -> UniqSM CmmGraph
+toZgraph _ _ (ListGraph []) = lgraphOfAGraph 0 emptyAGraph
+toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
+ let (offset, entry) = mkEntry id Native args in
+ labelAGraph id offset $
+ entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
+ where addBlock (BasicBlock id ss) g = mkLabel id Nothing <*> mkStmts ss <*> g
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 f res args (CmmSafe srt) CmmMayReturn : ss) =
- mkCall f res args srt <*> mkStmts ss
+ mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe srt) CmmMayReturn : ss) =
+ mkCall f conv (map hintlessCmm res) (map hintlessCmm args) srt <*> mkStmts ss
+ mkStmts (CmmCall (CmmPrim {}) _ _ (CmmSafe _) _ : _) =
+ panic "safe call to a primitive CmmPrim CallishMachOp"
mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) =
- mkUnsafeCall f res args <*> mkStmts ss
+ mkUnsafeCall (convert_target f res args)
+ (strip_hints res) (strip_hints args) <*> mkStmts ss
mkStmts (CmmCondBranch e l : fbranch) =
- mkIfThenElse (mkCbranch e) (mkBranch l) (mkStmts 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 = panic (msg {- ++ " in block " ++ showSDoc (ppr b) -}
- ++ " in function " ++ fun_name)
- mkLast (CmmCall f [] args _ CmmNeverReturns) = mkFinalCall f args
+ bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
+ mkLast (CmmCall (CmmCallee f conv) [] args _ CmmNeverReturns) =
+ mkFinalCall f conv $ map hintlessCmm args
+ 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
+ -- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING
+ -- CONVENTIONS ARE HONORED?
+ mkLast (CmmJump tgt args) = mkJump tgt $ map hintlessCmm args
+ mkLast (CmmReturn ress) = mkReturn $ map hintlessCmm 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"
+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 _) = Native
+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_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)
+ concat (map (\(G.Block id _ _) -> " " ++ show id) blocks)
cscomm = "Call successors are" ++
(concat $ map (\id -> " " ++ show id) $ uniqSetToList 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 (MidNop) = CmmNop
+ 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 (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 (MidUnsafeCall target ress args)
+ = CmmCall (cmm_target target)
+ (add_hints conv Results ress)
+ (add_hints conv Arguments args)
+ CmmUnsafe CmmMayReturn
+ where
+ conv = get_conv target
+ mid m@(MidAddToContext {}) = pcomment (ppr m)
pcomment p = scomment $ showSDoc p
block' id prev'
- | id == G.gr_entry g = BasicBlock id $ extend_entry (reverse 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 _ (_:_) -> panic "unrepresentable branch"
- LastBranch tgt [] ->
- case n of
- G.Block id' t : bs
- | tgt == id', unique_pred id'
- -> tail id prev' t bs -- optimize out redundant labels
- _ -> endblock (CmmBranch tgt)
- LastCondBranch expr tid fid ->
+ let endblock stmt = block' id (stmt : prev') : swallow n in
+ case l of
+ LastBranch tgt ->
case n of
- G.Block id' t : bs
+ -- THIS IS NOW WRONG -- LABELS CAN SHOW UP ELSEWHERE IN THE GRAPH
+ --G.Block id' _ t : bs
+ -- | tgt == id', unique_pred id'
+ -- -> tail id prev' t bs -- optimize out redundant labels
+ _ -> endblock (CmmBranch tgt)
+ LastCondBranch expr tid fid ->
+ case n of
+ G.Block id' _ t : bs
| id' == fid, unique_pred id' ->
- tail id (CmmCondBranch expr tid : prev') t bs
+ 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
+ tail id (CmmCondBranch e' fid : prev') 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
- LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
- LastCall tgt args Nothing ->
- endblock $ CmmCall tgt [] args CmmUnsafe CmmNeverReturns
- LastCall tgt args (Just k)
- | G.Block id' (G.ZTail (CopyIn _ ress srt) t) : bs <- n,
- id' == k, unique_pred k ->
- let call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
- in tail id (call : prev') t bs
- | G.Block id' t : bs <- n, id' == k, unique_pred k ->
- let (ress, srt) = findCopyIn t
- call = CmmCall tgt ress args (CmmSafe srt) CmmMayReturn
- delayed = scomment "delayed CopyIn follows previous call"
- in tail id (delayed : call : prev') t bs
- | otherwise -> panic "unrepairable call"
- findCopyIn (G.ZTail (CopyIn _ ress srt) _) = (ress, srt)
- findCopyIn (G.ZTail _ t) = findCopyIn t
- findCopyIn (G.ZLast _) = panic "missing CopyIn after call"
+ LastJump expr _ -> endblock $ CmmJump expr []
+ LastReturn _ -> endblock $ CmmReturn []
+ LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
+ LastCall e cont _ ->
+ let tgt = CmmCallee e CCallConv in
+ case cont of
+ Nothing ->
+ endblock $ CmmCall tgt [] [] CmmUnsafe CmmNeverReturns
+ Just _ ->
+ endblock $ CmmCall tgt [] [] (CmmSafe NoC_SRT) CmmMayReturn
exit id prev' n = -- highly irregular (assertion violation?)
let endblock stmt = block' id (stmt : prev') : swallow n in
case n of [] -> endblock (scomment "procedure falls off end")
- G.Block id' t : bs ->
+ G.Block id' _ t : bs ->
if unique_pred id' then
tail id (scomment "went thru exit" : prev') t bs
else
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
- G.LastOther (LastCall _ _ (Just id)) -> extendBlockSet succs id
+ G.LastOther (LastCall _ (Just id) _) -> extendBlockSet succs id
_ -> succs
in G.fold_blocks add emptyBlockSet g
_is_call_succ id = elemBlockSet id call_succs
projects / ghc-hetmet.git / blobdiff