-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE GADTs #-}
+-- ToDo: remove
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module CmmCvt
( cmmToZgraph, cmmOfZgraph )
where
+import BlockId
import Cmm
+import CmmDecl
import CmmExpr
-import MkZipCfgCmm hiding (CmmGraph)
-import ZipCfgCmmRep -- imported for reverse conversion
-import CmmZipUtil
-import PprCmm()
-import PprCmmZ()
-import qualified ZipCfg as G
-
-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 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 :: Old.Cmm -> UniqSM Cmm
+cmmOfZgraph :: Cmm -> Old.Cmm
-cmmToZgraph = cmmMapGraphM toZgraph
-cmmOfZgraph = cmmMapGraph ofZgraph
+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 -> 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 (CmmCallee f conv) res args (CmmSafe srt) CmmMayReturn : ss) =
- mkCall f conv res args srt <*> mkStmts ss
- mkStmts (CmmCall (CmmPrim {}) _ _ (CmmSafe _) _ : _) =
+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 (CmmCall f res args CmmUnsafe CmmMayReturn : ss) =
- mkUnsafeCall f res args <*> mkStmts ss
- mkStmts (CmmCondBranch e l : fbranch) =
+ 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 (CmmCallee f conv) [] args _ CmmNeverReturns) =
- mkFinalCall f conv args
- mkLast (CmmCall (CmmPrim {}) _ _ _ 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 (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.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 [] Nothing t rest
- tail id prev' out (G.ZTail (CopyOut conv actuals) t) rest =
- case out of
- Nothing -> tail id prev' (Just (conv, actuals)) t rest
- Just _ -> panic "multiple CopyOut nodes in one basic block"
- tail id prev' out (G.ZTail m t) rest = tail id (mid m : prev') out t rest
- tail id prev' out (G.ZLast G.LastExit) rest = exit id prev' out rest
- tail id prev' out (G.ZLast (G.LastOther l)) rest = last id prev' out 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@(MidAddToContext {}) = pcomment (ppr m)
- 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.lg_entry g = BasicBlock id $ extend_entry (reverse prev')
- | otherwise = BasicBlock id $ extend_block id (reverse prev')
- last id prev' out l n =
- let endblock stmt = block' id (stmt : prev') : swallow n in
- case l of
- LastBranch tgt ->
- case n of
- G.Block id' t : bs
- | tgt == id', unique_pred id'
- -> tail id prev' out t bs -- optimize out redundant labels
- _ -> if isNothing out then endblock (CmmBranch tgt)
- else pprPanic "can't convert LGraph with pending CopyOut"
- (ppr g)
- LastCondBranch expr tid fid ->
- if isJust out then pprPanic "CopyOut before conditional branch" (ppr g)
- else
- case n of
- G.Block id' t : bs
- | id' == fid, unique_pred id' ->
- tail id (CmmCondBranch expr tid : prev') Nothing t bs
- | id' == tid, unique_pred id',
- Just e' <- maybeInvertCmmExpr expr ->
- tail id (CmmCondBranch e' fid : prev') Nothing t bs
- _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
- in block' id instrs' : swallow n
- LastJump expr -> endblock $ with_out out $ CmmJump expr
- LastReturn -> endblock $ with_out out $ CmmReturn
- LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
- LastCall e cont
- | Just (conv, args) <- out
- -> let tgt = CmmCallee e (conv_to_cconv conv) in
- case cont of
- Nothing ->
- endblock $ CmmCall tgt [] args CmmUnsafe CmmNeverReturns
- 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') Nothing 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 prev. call"
- in tail id (delayed : call : prev') Nothing t bs
- | otherwise -> panic "unrepairable call"
- | otherwise -> panic "call with no CopyOut"
- with_out (Just (_conv, actuals)) f = f actuals
- with_out Nothing f = pprPanic "unrepairable data flow to" (ppr $ f [])
- 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' out 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') out t bs
- else
- endblock (CmmBranch id')
- conv_to_cconv (ConventionStandard c _) = c
- conv_to_cconv (ConventionPrivate {}) =
- panic "tried to convert private calling convention back to Cmm"
- 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