cd838821b31894bd2c92567d375a25cfd503424e
[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 data ValueDirection = Arguments | Results
26
27 add_hints :: ForeignTarget -> ValueDirection -> [a] -> [Old.CmmHinted a]
28 add_hints conv vd args = zipWith Old.CmmHinted args (get_hints conv vd)
29
30 get_hints :: ForeignTarget -> ValueDirection -> [ForeignHint]
31 get_hints (ForeignTarget _ (ForeignConvention _ hints _)) Arguments = hints
32 get_hints (ForeignTarget _ (ForeignConvention _ _ hints)) Results = hints
33 get_hints (PrimTarget _) _vd = repeat NoHint
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 ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt
40 ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
41 -- We catenated some blocks in the conversion process,
42 -- because of the CmmCondBranch -- the machine code does not have
43 -- 'jump here or there' instruction, but has 'jump if true' instruction.
44 -- As OldCmm has the same instruction, so we use it.
45 -- When we are doing this, we also catenate normal goto-s (it is for free).
46
47 -- Exactly, we catenate blocks with nonentry labes, that are
48 -- a) mentioned exactly once as a successor
49 -- b) any of 1) are a target of a goto
50 -- 2) are false branch target of a conditional jump
51 -- 3) are true branch target of a conditional jump, and
52 -- the false branch target is a successor of at least 2 blocks
53 -- and the condition can be inverted
54 -- The complicated rule 3) is here because we need to assign at most one
55 -- catenable block to a CmmCondBranch.
56 where preds :: BlockEnv [CmmNode O C]
57 preds = mapFold add mapEmpty $ toBlockMap g
58 where add block env = foldr (add' $ lastNode block) env (successors block)
59 add' :: CmmNode O C -> BlockId -> BlockEnv [CmmNode O C] -> BlockEnv [CmmNode O C]
60 add' node succ env = mapInsert succ (node : (mapLookup succ env `orElse` [])) env
61
62 to_be_catenated :: BlockId -> Bool
63 to_be_catenated id | id == g_entry g = False
64 | Just [CmmBranch _] <- mapLookup id preds = True
65 | Just [CmmCondBranch _ _ f] <- mapLookup id preds
66 , f == id = True
67 | Just [CmmCondBranch e t f] <- mapLookup id preds
68 , t == id
69 , Just (_:_:_) <- mapLookup f preds
70 , Just _ <- maybeInvertCmmExpr e = True
71 to_be_catenated _ = False
72
73 convert_block block | to_be_catenated (entryLabel block) = Nothing
74 convert_block block = Just $ foldBlockNodesB3 (first, middle, last) block ()
75 where first :: CmmNode C O -> [Old.CmmStmt] -> Old.CmmBasicBlock
76 first (CmmEntry bid) stmts = Old.BasicBlock bid stmts
77
78 middle :: CmmNode O O -> [Old.CmmStmt] -> [Old.CmmStmt]
79 middle node stmts = stmt : stmts
80 where stmt :: Old.CmmStmt
81 stmt = case node of
82 CmmComment s -> Old.CmmComment s
83 CmmAssign l r -> Old.CmmAssign l r
84 CmmStore l r -> Old.CmmStore l r
85 CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
86 CmmUnsafeForeignCall target ress args ->
87 Old.CmmCall (cmm_target target)
88 (add_hints target Results ress)
89 (add_hints target Arguments args)
90 Old.CmmMayReturn
91
92 last :: CmmNode O C -> () -> [Old.CmmStmt]
93 last node _ = stmts
94 where stmts :: [Old.CmmStmt]
95 stmts = case node of
96 CmmBranch tgt | to_be_catenated tgt -> tail_of tgt
97 | otherwise -> [Old.CmmBranch tgt]
98 CmmCondBranch expr tid fid
99 | to_be_catenated fid -> Old.CmmCondBranch expr tid : tail_of fid
100 | to_be_catenated tid
101 , Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid
102 | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
103 CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
104 -- ToDo: STG Live
105 CmmCall e _ r _ _ _ -> [Old.CmmJump e (Just r)]
106 CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
107 tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
108 Old.BasicBlock _ stmts -> stmts
109 where Just block = mapLookup bid $ toBlockMap g
110