X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmCvt.hs;h=9382d8d1ed3d0e698208cc898b1beb0ca655761b;hp=7b22958f2414e5cc8e233585f8fc0f2c6bdc280d;hb=b2bd63f99d643f6b3eb30bb72bb9ae26d4183252;hpb=45cbf5e1207b4850dcaf7b94b053cc397f5642fe diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 7b22958..9382d8d 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -1,150 +1,177 @@ -{-# LANGUAGE PatternGuards #-} -{-# OPTIONS -Wall -fno-warn-name-shadowing #-} +{-# LANGUAGE GADTs #-} +-- ToDo: remove +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} module CmmCvt ( cmmToZgraph, cmmOfZgraph ) where + +import BlockId import Cmm +import CmmDecl import CmmExpr -import ZipCfgCmm -import MkZipCfg -import CmmZipUtil -import FastString +import MkGraph +import qualified OldCmm as Old +import OldPprCmm () + +import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch) +import Control.Monad +import Data.Maybe +import Maybes import Outputable -import Panic -import PprCmm() -import PprCmmZ() -import UniqSet import UniqSupply -import qualified ZipCfg as G - -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 - - -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 - 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 - 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 f res args CmmUnsafe CmmMayReturn : ss) = - mkUnsafeCall f res args <*> mkStmts ss - mkStmts (CmmCondBranch e l : fbranch) = - mkIfThenElse (mkCbranch e) (mkBranch l) (mkStmts fbranch) + +cmmToZgraph :: Old.Cmm -> UniqSM Cmm +cmmOfZgraph :: Cmm -> Old.Cmm + +cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops + where mapTop (CmmProc (Old.CmmInfo _ _ info_tbl) l g) = + do (stack_info, g) <- toZgraph (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 :: 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 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 -- panic "upd frame size lost in cmm conversion" + 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 [] []) -- JD: DUBIOUS + 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) (ppr g) - mkLast (CmmCall f [] args _ CmmNeverReturns) = mkFinalCall f args - mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table - mkLast (CmmJump tgt args) = mkJump tgt args - mkLast (CmmReturn ress) = mkReturn ress - mkLast (CmmBranch tgt) = mkBranch tgt - mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) = + 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 + -- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING + -- CONVENTIONS ARE HONORED? + 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" -ofZgraph :: CmmGraph -> ListGraph CmmStmt -ofZgraph g = ListGraph $ swallow blocks - where blocks = G.postorder_dfs g - -- | the next two functions are hooks on which to hang debugging info - 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) $ 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 - 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)") - pcomment p = scomment $ showSDoc p - block' id prev' - | id == G.gr_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 -> - case n of - G.Block id' 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 - 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" - 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 -> - 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 G.lookupBlockEnv preds id of - Nothing -> single - Just s -> if sizeUniqSet s == 1 then - G.extendBlockSet single id - else single - in G.fold_blocks add G.emptyBlockSet g - unique_pred id = G.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 +strip_hints :: [Old.CmmHinted a] -> [a] +strip_hints = map Old.hintlessCmm + +convert_target :: Old.CmmCallTarget -> Old.HintedCmmFormals -> Old.HintedCmmActuals -> 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 -- JD: SUSPICIOUS +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 + -- We catenated some blocks in the conversion process, + -- because of the CmmCondBranch -- the machine code does not have + -- 'jump here or there' instruction, but has 'jump if true' instruction. + -- As OldCmm has the same instruction, so we use it. + -- When we are doing this, we also catenate normal goto-s (it is for free). + + -- Exactly, we catenate blocks with nonentry labes, that are + -- a) mentioned exactly once as a successor + -- b) any of 1) are a target of a goto + -- 2) are false branch target of a conditional jump + -- 3) are true branch target of a conditional jump, and + -- the false branch target is a successor of at least 2 blocks + -- and the condition can be inverted + -- The complicated rule 3) is here because we need to assign at most one + -- catenable block to a CmmCondBranch. + 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