1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
|
{-# LANGUAGE GADTs #-}
-- ToDo: remove -fno-warn-incomplete-patterns
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module CmmCvt
( cmmOfZgraph )
where
import BlockId
import Cmm
import CmmUtils
import qualified OldCmm as Old
import OldPprCmm ()
import Hoopl
import Data.Maybe
import Maybes
import Outputable
cmmOfZgraph :: CmmGroup -> Old.CmmGroup
cmmOfZgraph tops = map mapTop tops
where mapTop (CmmProc h l g) = CmmProc (info_tbls h) l (ofZgraph g)
mapTop (CmmData s ds) = CmmData s ds
add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a]
add_hints args hints = zipWith Old.CmmHinted args hints
get_hints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
get_hints (PrimTarget op) = (res_hints ++ repeat NoHint,
arg_hints ++ repeat NoHint)
where (res_hints, arg_hints) = callishMachOpHints op
get_hints (ForeignTarget _ (ForeignConvention _ arg_hints res_hints _))
= (res_hints, arg_hints)
cmm_target :: ForeignTarget -> Old.CmmCallTarget
cmm_target (PrimTarget op) = Old.CmmPrim op Nothing
cmm_target (ForeignTarget e (ForeignConvention cc _ _ _)) = Old.CmmCallee e cc
get_ret :: ForeignTarget -> CmmReturnInfo
get_ret (PrimTarget _) = CmmMayReturn
get_ret (ForeignTarget _ (ForeignConvention _ _ _ ret)) = ret
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 ress res_hints)
(add_hints args arg_hints)
(get_ret target)
where
(res_hints, arg_hints) = get_hints target
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]
-- ToDo: STG Live
CmmCall e _ r _ _ _ -> [Old.CmmJump e (Just r)]
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
|
