Produce new-style Cmm from the Cmm parser
[ghc.git] / compiler / cmm / CmmCvt.hs
1 {-# LANGUAGE GADTs #-}
2 -- ToDo: remove -fno-warn-incomplete-patterns
3 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
4
5 module CmmCvt
6 ( cmmOfZgraph )
7 where
8
9 import BlockId
10 import Cmm
11 import CmmUtils
12 import qualified OldCmm as Old
13 import OldPprCmm ()
14
15 import Hoopl
16 import Data.Maybe
17 import Maybes
18 import Outputable
19
20 cmmOfZgraph :: CmmGroup -> Old.CmmGroup
21 cmmOfZgraph tops = map mapTop tops
22 where mapTop (CmmProc h l g) = CmmProc (info_tbls h) l (ofZgraph g)
23 mapTop (CmmData s ds) = CmmData s ds
24
25 add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a]
26 add_hints args hints = zipWith Old.CmmHinted args hints
27
28 get_hints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
29 get_hints (PrimTarget op) = (res_hints ++ repeat NoHint,
30 arg_hints ++ repeat NoHint)
31 where (res_hints, arg_hints) = callishMachOpHints op
32 get_hints (ForeignTarget _ (ForeignConvention _ arg_hints res_hints _))
33 = (res_hints, arg_hints)
34
35 cmm_target :: ForeignTarget -> Old.CmmCallTarget
36 cmm_target (PrimTarget op) = Old.CmmPrim op Nothing
37 cmm_target (ForeignTarget e (ForeignConvention cc _ _ _)) = Old.CmmCallee e cc
38
39 get_ret :: ForeignTarget -> CmmReturnInfo
40 get_ret (PrimTarget _) = CmmMayReturn
41 get_ret (ForeignTarget _ (ForeignConvention _ _ _ ret)) = ret
42
43 ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt
44 ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
45 -- We catenated some blocks in the conversion process,
46 -- because of the CmmCondBranch -- the machine code does not have
47 -- 'jump here or there' instruction, but has 'jump if true' instruction.
48 -- As OldCmm has the same instruction, so we use it.
49 -- When we are doing this, we also catenate normal goto-s (it is for free).
50
51 -- Exactly, we catenate blocks with nonentry labes, that are
52 -- a) mentioned exactly once as a successor
53 -- b) any of 1) are a target of a goto
54 -- 2) are false branch target of a conditional jump
55 -- 3) are true branch target of a conditional jump, and
56 -- the false branch target is a successor of at least 2 blocks
57 -- and the condition can be inverted
58 -- The complicated rule 3) is here because we need to assign at most one
59 -- catenable block to a CmmCondBranch.
60 where preds :: BlockEnv [CmmNode O C]
61 preds = mapFold add mapEmpty $ toBlockMap g
62 where add block env = foldr (add' $ lastNode block) env (successors block)
63 add' :: CmmNode O C -> BlockId -> BlockEnv [CmmNode O C] -> BlockEnv [CmmNode O C]
64 add' node succ env = mapInsert succ (node : (mapLookup succ env `orElse` [])) env
65
66 to_be_catenated :: BlockId -> Bool
67 to_be_catenated id | id == g_entry g = False
68 | Just [CmmBranch _] <- mapLookup id preds = True
69 | Just [CmmCondBranch _ _ f] <- mapLookup id preds
70 , f == id = True
71 | Just [CmmCondBranch e t f] <- mapLookup id preds
72 , t == id
73 , Just (_:_:_) <- mapLookup f preds
74 , Just _ <- maybeInvertCmmExpr e = True
75 to_be_catenated _ = False
76
77 convert_block block | to_be_catenated (entryLabel block) = Nothing
78 convert_block block = Just $ foldBlockNodesB3 (first, middle, last) block ()
79 where first :: CmmNode C O -> [Old.CmmStmt] -> Old.CmmBasicBlock
80 first (CmmEntry bid) stmts = Old.BasicBlock bid stmts
81
82 middle :: CmmNode O O -> [Old.CmmStmt] -> [Old.CmmStmt]
83 middle node stmts = stmt : stmts
84 where stmt :: Old.CmmStmt
85 stmt = case node of
86 CmmComment s -> Old.CmmComment s
87 CmmAssign l r -> Old.CmmAssign l r
88 CmmStore l r -> Old.CmmStore l r
89 CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
90 CmmUnsafeForeignCall target ress args ->
91 Old.CmmCall (cmm_target target)
92 (add_hints ress res_hints)
93 (add_hints args arg_hints)
94 (get_ret target)
95 where
96 (res_hints, arg_hints) = get_hints target
97
98
99 last :: CmmNode O C -> () -> [Old.CmmStmt]
100 last node _ = stmts
101 where stmts :: [Old.CmmStmt]
102 stmts = case node of
103 CmmBranch tgt | to_be_catenated tgt -> tail_of tgt
104 | otherwise -> [Old.CmmBranch tgt]
105 CmmCondBranch expr tid fid
106 | to_be_catenated fid -> Old.CmmCondBranch expr tid : tail_of fid
107 | to_be_catenated tid
108 , Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid
109 | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
110 CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
111 -- ToDo: STG Live
112 CmmCall e _ r _ _ _ -> [Old.CmmJump e (Just r)]
113 CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
114 tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
115 Old.BasicBlock _ stmts -> stmts
116 where Just block = mapLookup bid $ toBlockMap g
117