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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
|
{-# LANGUAGE PatternGuards #-}
module CmmCvt
( cmmToZgraph, cmmOfZgraph )
where
import BlockId
import Cmm
import CmmExpr
import MkZipCfg
import MkZipCfgCmm hiding (CmmGraph)
import ZipCfgCmmRep -- imported for reverse conversion
import CmmZipUtil
import PprCmm()
import PprCmmZ()
import qualified ZipCfg as G
import FastString
import Monad
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 (Cmm tops) = liftM Cmm $ mapM mapTop tops
where mapTop (CmmProc h l args g) =
toZgraph (showSDoc $ ppr l) args g >>= return . CmmProc h l args
mapTop (CmmData s ds) = return $ CmmData s ds
cmmOfZgraph = cmmMapGraph ofZgraph
toZgraph :: String -> CmmFormalsWithoutKinds -> ListGraph CmmStmt -> UniqSM CmmGraph
toZgraph _ _ (ListGraph []) = lgraphOfAGraph emptyAGraph
toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
labelAGraph id $ mkMiddles (mkEntry area undefined args) <*>
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 _) _ : _) =
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) =
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) =
panic "Call to CmmPrim never returns?!"
mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
mkLast (CmmJump tgt args) = mkJump area tgt args
mkLast (CmmReturn ress) = mkReturn area ress
mkLast (CmmBranch tgt) = mkBranch tgt
mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
panic "Call never returns but has results?!"
mkLast _ = panic "fell off end of block"
-- The entry, jump, and return areas should be the same.
-- This code is horrible, but there's no point trying to fix it until we've figured
-- out our interface for calling conventions.
-- All return statements are required to use return areas of equal size.
-- This isn't necessarily required to write correct programs, but it's sane.
area = case foldr retBlock (retStmts ss Nothing) other_blocks of
Just (as, _) -> mkCallArea id as $ Just args
Nothing -> mkCallArea id [] $ Just args
retBlock (BasicBlock _ ss) z = retStmts ss z
retStmts [CmmReturn ress] z@(Just (_, n)) =
if size ress == n then z
else panic "return statements in C-- procs must return the same results"
retStmts [CmmReturn ress] Nothing = Just (ress, size ress)
retStmts (_ : rst) z = retStmts rst z
retStmts [] z = z
size args = areaSize $ mkCallArea id args Nothing
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"
(text "target" <+> ppr tgt <+> 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 lookupBlockEnv preds id of
Nothing -> single
Just s -> if sizeUniqSet s == 1 then
extendBlockSet single id
else single
in G.fold_blocks add emptyBlockSet g
unique_pred id = 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
|
