X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCvt.hs;h=7f5de60f995681e35bc7eeae49b282ed383d2980;hp=0f0ccd2d1b77d824f13c3a176525975a9fdfca60;hb=1e50fd4185479a62e02d987bdfcb1c62712859ca;hpb=176fa33f17dd78355cc572e006d2ab26898e2c69 diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 0f0ccd2..7f5de60 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -5,52 +5,53 @@ module CmmCvt where import BlockId -import ClosureInfo (C_SRT(..)) import Cmm -import CmmExpr 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 Control.Monad import Outputable -import Panic -import UniqSet import UniqSupply -import Maybe - -cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h CmmGraph) -cmmOfZgraph :: GenCmm d h (CmmGraph) -> GenCmm d h (ListGraph CmmStmt) +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 +cmmOfZgraph = cmmMapGraph (ofZgraph . snd) -toZgraph :: String -> CmmFormals -> ListGraph CmmStmt -> UniqSM CmmGraph -toZgraph _ _ (ListGraph []) = lgraphOfAGraph 0 emptyAGraph +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 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 + 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 -- panic "upd frame size lost in cmm conversion" 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 srt) CmmMayReturn : ss) = - mkCall f conv (map hintlessCmm res) (map hintlessCmm args) srt <*> 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 [] []) -- JD: DUBIOUS 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 + (strip_hints res) (strip_hints args) + <*> mkStmts ss mkStmts (CmmCondBranch e l : fbranch) = mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch) mkStmts (last : []) = mkLast last @@ -58,14 +59,15 @@ toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = 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 + 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 -- 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 (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?!" @@ -87,7 +89,7 @@ get_hints (Foreign (ForeignConvention _ _ hints)) Results = hints get_hints _other_conv _vd = repeat NoHint get_conv :: MidCallTarget -> Convention -get_conv (PrimTarget _) = Native +get_conv (PrimTarget _) = NativeNodeCall -- JD: SUSPICIOUS get_conv (ForeignTarget _ fc) = Foreign fc cmm_target :: MidCallTarget -> CmmCallTarget @@ -102,26 +104,24 @@ ofZgraph g = ListGraph $ swallow blocks 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) + (concat $ map (\id -> " " ++ show id) $ blockSetToList call_succs) swallow [] = [] - swallow (G.Block id _ t : rest) = tail id [] t rest + 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 target ress args) + 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 - mid m@(MidAddToContext {}) = pcomment (ppr m) - pcomment p = scomment $ showSDoc p block' id prev' | id == G.lg_entry g = BasicBlock id $ extend_entry (reverse prev') | otherwise = BasicBlock id $ extend_block id (reverse prev') @@ -130,14 +130,18 @@ ofZgraph g = ListGraph $ swallow blocks case l of LastBranch tgt -> case n of - -- THIS IS NOW WRONG -- LABELS CAN SHOW UP ELSEWHERE IN THE GRAPH + -- THIS OPT IS 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 + G.Block id' t : bs + -- It would be better to handle earlier, but we still must + -- generate correct code here. + | 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', @@ -145,20 +149,12 @@ ofZgraph g = ListGraph $ swallow blocks tail id (CmmCondBranch e' fid : prev') t bs _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev' in block' id instrs' : swallow n - 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 + LastCall e _ _ _ _ -> endblock $ CmmJump e [] 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 @@ -169,7 +165,7 @@ ofZgraph g = ListGraph $ swallow blocks let id = G.blockId b in case lookupBlockEnv preds id of Nothing -> single - Just s -> if sizeUniqSet s == 1 then + Just s -> if sizeBlockSet s == 1 then extendBlockSet single id else single in G.fold_blocks add emptyBlockSet g @@ -177,7 +173,8 @@ ofZgraph g = ListGraph $ swallow blocks 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