fcb220d74c6be96fcc3edacdb0c9911969f2a6b0
[ghc.git] / compiler / cmm / CmmCvt.hs
1 {-# LANGUAGE GADTs #-}
2 -- ToDo: remove
3 {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
4
5 module CmmCvt
6 ( cmmToZgraph, cmmOfZgraph )
7 where
8
9 import BlockId
10 import Cmm
11 import CmmDecl
12 import CmmExpr
13 import MkGraph
14 import qualified OldCmm as Old
15 import OldPprCmm ()
16 import Platform
17
18 import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch)
19 import Control.Monad
20 import Data.Maybe
21 import Maybes
22 import Outputable
23 import UniqSupply
24
25 cmmToZgraph :: Platform -> Old.Cmm -> UniqSM Cmm
26 cmmOfZgraph :: Cmm -> Old.Cmm
27
28 cmmToZgraph platform (Cmm tops) = liftM Cmm $ mapM mapTop tops
29 where mapTop (CmmProc (Old.CmmInfo _ _ info_tbl) l g) =
30 do (stack_info, g) <- toZgraph platform (showSDoc $ ppr l) g
31 return $ CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) l g
32 mapTop (CmmData s ds) = return $ CmmData s ds
33 cmmOfZgraph (Cmm tops) = Cmm $ map mapTop tops
34 where mapTop (CmmProc h l g) = CmmProc (Old.CmmInfo Nothing Nothing (info_tbl h)) l (ofZgraph g)
35 mapTop (CmmData s ds) = CmmData s ds
36
37 toZgraph :: Platform -> String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
38 toZgraph _ _ (Old.ListGraph []) =
39 do g <- lgraphOfAGraph emptyAGraph
40 return (StackInfo {arg_space=0, updfr_space=Nothing}, g)
41 toZgraph platform fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) =
42 let (offset, entry) = mkCallEntry NativeNodeCall [] in
43 do g <- labelAGraph id $
44 entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
45 return (StackInfo {arg_space = offset, updfr_space = Nothing}, g)
46 where addBlock (Old.BasicBlock id ss) g =
47 mkLabel id <*> mkStmts ss <*> g
48 updfr_sz = 0 -- panic "upd frame size lost in cmm conversion"
49 mkStmts (Old.CmmNop : ss) = mkNop <*> mkStmts ss
50 mkStmts (Old.CmmComment s : ss) = mkComment s <*> mkStmts ss
51 mkStmts (Old.CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss
52 mkStmts (Old.CmmStore l r : ss) = mkStore l r <*> mkStmts ss
53 mkStmts (Old.CmmCall (Old.CmmCallee f conv) res args (Old.CmmSafe _) Old.CmmMayReturn : ss) =
54 mkCall f (conv', conv') (map Old.hintlessCmm res) (map Old.hintlessCmm args) updfr_sz
55 <*> mkStmts ss
56 where conv' = Foreign (ForeignConvention conv [] []) -- JD: DUBIOUS
57 mkStmts (Old.CmmCall (Old.CmmPrim {}) _ _ (Old.CmmSafe _) _ : _) =
58 panic "safe call to a primitive CmmPrim CallishMachOp"
59 mkStmts (Old.CmmCall f res args Old.CmmUnsafe Old.CmmMayReturn : ss) =
60 mkUnsafeCall (convert_target f res args)
61 (strip_hints res) (strip_hints args)
62 <*> mkStmts ss
63 mkStmts (Old.CmmCondBranch e l : fbranch) =
64 mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch)
65 mkStmts (last : []) = mkLast last
66 mkStmts [] = bad "fell off end"
67 mkStmts (_ : _ : _) = bad "last node not at end"
68 bad msg = pprPanic (msg ++ " in function " ++ fun_name) (pprPlatform platform g)
69 mkLast (Old.CmmCall (Old.CmmCallee f conv) [] args _ Old.CmmNeverReturns) =
70 mkFinalCall f conv (map Old.hintlessCmm args) updfr_sz
71 mkLast (Old.CmmCall (Old.CmmPrim {}) _ _ _ Old.CmmNeverReturns) =
72 panic "Call to CmmPrim never returns?!"
73 mkLast (Old.CmmSwitch scrutinee table) = mkSwitch scrutinee table
74 -- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING
75 -- CONVENTIONS ARE HONORED?
76 mkLast (Old.CmmJump tgt args) = mkJump tgt (map Old.hintlessCmm args) updfr_sz
77 mkLast (Old.CmmReturn ress) =
78 mkReturnSimple (map Old.hintlessCmm ress) updfr_sz
79 mkLast (Old.CmmBranch tgt) = mkBranch tgt
80 mkLast (Old.CmmCall _f (_:_) _args _ Old.CmmNeverReturns) =
81 panic "Call never returns but has results?!"
82 mkLast _ = panic "fell off end of block"
83
84 strip_hints :: [Old.CmmHinted a] -> [a]
85 strip_hints = map Old.hintlessCmm
86
87 convert_target :: Old.CmmCallTarget -> [Old.HintedCmmFormal] -> [Old.HintedCmmActual] -> ForeignTarget
88 convert_target (Old.CmmCallee e cc) ress args = ForeignTarget e (ForeignConvention cc (map Old.cmmHint args) (map Old.cmmHint ress))
89 convert_target (Old.CmmPrim op) _ress _args = PrimTarget op
90
91 data ValueDirection = Arguments | Results
92
93 add_hints :: Convention -> ValueDirection -> [a] -> [Old.CmmHinted a]
94 add_hints conv vd args = zipWith Old.CmmHinted args (get_hints conv vd)
95
96 get_hints :: Convention -> ValueDirection -> [ForeignHint]
97 get_hints (Foreign (ForeignConvention _ hints _)) Arguments = hints
98 get_hints (Foreign (ForeignConvention _ _ hints)) Results = hints
99 get_hints _other_conv _vd = repeat NoHint
100
101 get_conv :: ForeignTarget -> Convention
102 get_conv (PrimTarget _) = NativeNodeCall -- JD: SUSPICIOUS
103 get_conv (ForeignTarget _ fc) = Foreign fc
104
105 cmm_target :: ForeignTarget -> Old.CmmCallTarget
106 cmm_target (PrimTarget op) = Old.CmmPrim op
107 cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = Old.CmmCallee e cc
108
109 ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt
110 ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
111 -- We catenated some blocks in the conversion process,
112 -- because of the CmmCondBranch -- the machine code does not have
113 -- 'jump here or there' instruction, but has 'jump if true' instruction.
114 -- As OldCmm has the same instruction, so we use it.
115 -- When we are doing this, we also catenate normal goto-s (it is for free).
116
117 -- Exactly, we catenate blocks with nonentry labes, that are
118 -- a) mentioned exactly once as a successor
119 -- b) any of 1) are a target of a goto
120 -- 2) are false branch target of a conditional jump
121 -- 3) are true branch target of a conditional jump, and
122 -- the false branch target is a successor of at least 2 blocks
123 -- and the condition can be inverted
124 -- The complicated rule 3) is here because we need to assign at most one
125 -- catenable block to a CmmCondBranch.
126 where preds :: BlockEnv [CmmNode O C]
127 preds = mapFold add mapEmpty $ toBlockMap g
128 where add block env = foldr (add' $ lastNode block) env (successors block)
129 add' :: CmmNode O C -> BlockId -> BlockEnv [CmmNode O C] -> BlockEnv [CmmNode O C]
130 add' node succ env = mapInsert succ (node : (mapLookup succ env `orElse` [])) env
131
132 to_be_catenated :: BlockId -> Bool
133 to_be_catenated id | id == g_entry g = False
134 | Just [CmmBranch _] <- mapLookup id preds = True
135 | Just [CmmCondBranch _ _ f] <- mapLookup id preds
136 , f == id = True
137 | Just [CmmCondBranch e t f] <- mapLookup id preds
138 , t == id
139 , Just (_:_:_) <- mapLookup f preds
140 , Just _ <- maybeInvertCmmExpr e = True
141 to_be_catenated _ = False
142
143 convert_block block | to_be_catenated (entryLabel block) = Nothing
144 convert_block block = Just $ foldBlockNodesB3 (first, middle, last) block ()
145 where first :: CmmNode C O -> [Old.CmmStmt] -> Old.CmmBasicBlock
146 first (CmmEntry bid) stmts = Old.BasicBlock bid stmts
147
148 middle :: CmmNode O O -> [Old.CmmStmt] -> [Old.CmmStmt]
149 middle node stmts = stmt : stmts
150 where stmt :: Old.CmmStmt
151 stmt = case node of
152 CmmComment s -> Old.CmmComment s
153 CmmAssign l r -> Old.CmmAssign l r
154 CmmStore l r -> Old.CmmStore l r
155 CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
156 CmmUnsafeForeignCall target ress args ->
157 Old.CmmCall (cmm_target target)
158 (add_hints (get_conv target) Results ress)
159 (add_hints (get_conv target) Arguments args)
160 Old.CmmUnsafe Old.CmmMayReturn
161
162 last :: CmmNode O C -> () -> [Old.CmmStmt]
163 last node _ = stmts
164 where stmts :: [Old.CmmStmt]
165 stmts = case node of
166 CmmBranch tgt | to_be_catenated tgt -> tail_of tgt
167 | otherwise -> [Old.CmmBranch tgt]
168 CmmCondBranch expr tid fid
169 | to_be_catenated fid -> Old.CmmCondBranch expr tid : tail_of fid
170 | to_be_catenated tid
171 , Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid
172 | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
173 CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
174 CmmCall e _ _ _ _ -> [Old.CmmJump e []]
175 CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
176 tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
177 Old.BasicBlock _ stmts -> stmts
178 where Just block = mapLookup bid $ toBlockMap g