1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
3 ( mkNop, mkAssign, mkStore, mkCall, mkUnsafeCall, mkFinalCall
4 , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, mkCmmIfThenElse
7 , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..)
11 #include "HsVersions.h"
14 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
15 , CmmCallTarget(..), CmmActuals, CmmFormalsWithoutKinds, CmmFormals
16 , CmmStmt(CmmJump, CmmSwitch) -- imported in order to call ppr
25 import qualified ZipDataflow as DF
30 import Outputable hiding (empty)
31 import qualified Outputable as PP
32 import Prelude hiding (zip, unzip, last)
34 type CmmGraph = LGraph Middle Last
35 type CmmAGraph = AGraph Middle Last
36 type CmmBlock = Block Middle Last
37 type CmmZ = GenCmm CmmStatic CmmInfo CmmGraph
38 type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph
41 mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
42 mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
43 mkCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph
44 mkUnsafeCall :: CmmCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
45 mkFinalCall :: CmmCallTarget -> CmmActuals -> CmmAGraph -- never returns
46 mkJump :: CmmExpr -> CmmActuals -> CmmAGraph
47 mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
48 mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
49 mkReturn :: CmmActuals -> CmmAGraph
50 mkComment :: FastString -> CmmAGraph
52 -- Not to be forgotten, but exported by MkZipCfg:
53 --mkBranch :: BlockId -> CmmAGraph
54 --mkLabel :: BlockId -> CmmAGraph
55 mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
56 mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph
58 --------------------------------------------------------------------------
60 mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
61 mkCmmWhileDo e = mkWhileDo (mkCbranch e)
63 mkCopyIn :: Convention -> CmmFormals -> C_SRT -> CmmAGraph
64 mkCopyOut :: Convention -> CmmFormals -> CmmAGraph
66 -- ^ XXX: Simon or Simon thinks maybe the hints are being abused and
67 -- we should have CmmFormalsWithoutKinds here, but for now it is CmmFormals
68 -- for consistency with the rest of the back end ---NR
70 mkComment fs = mkMiddle (MidComment fs)
74 | MidComment FastString
76 | MidAssign CmmReg CmmExpr -- Assign to register
78 | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is
79 -- given by cmmExprRep of the rhs.
81 | MidUnsafeCall -- An "unsafe" foreign call;
82 CmmCallTarget -- just a fat machine instructoin
83 CmmFormals -- zero or more results
84 CmmActuals -- zero or more arguments
86 | CopyIn -- Move parameters or results from conventional locations to registers
87 -- Note [CopyIn invariant]
90 C_SRT -- Static things kept alive by this block
91 | CopyOut Convention CmmFormals
94 = LastReturn CmmActuals -- Return from a function,
95 -- with these return values.
97 | LastJump CmmExpr CmmActuals
98 -- Tail call to another procedure
100 | LastBranch BlockId CmmFormalsWithoutKinds
101 -- To another block in the same procedure
102 -- The parameters are unused at present.
104 | LastCall { -- A call (native or safe foreign)
105 cml_target :: CmmCallTarget,
106 cml_actual :: CmmActuals, -- Zero or more arguments
107 cml_next :: Maybe BlockId } -- BlockId of continuation, if call returns
109 | LastCondBranch { -- conditional branch
111 cml_true, cml_false :: BlockId
114 | LastSwitch CmmExpr [Maybe BlockId] -- Table branch
115 -- The scrutinee is zero-based;
116 -- zero -> first block
117 -- one -> second block etc
118 -- Undefined outside range, and when there's a Nothing
121 = Argument CCallConv -- Used for function formal params
122 | Result CCallConv -- Used for function results
124 | Local -- Used for control transfers within a (pre-CPS) procedure
125 -- All jump sites known, never pushed on the stack (hence no SRT)
126 -- You can choose whatever calling convention
127 -- you please (provided you make sure
128 -- all the call sites agree)!
131 -- ^ In a complete LGraph for a procedure, the [[Exit]] node should not
132 -- appear, but it is useful in a subgraph (e.g., replacement for a node).
135 Note [CopyIn invariant]
136 ~~~~~~~~~~~~~~~~~~~~~~~
137 In principle, CopyIn ought to be a First node, but in practice, the
138 possibility raises all sorts of hairy issues with graph splicing,
139 rewriting, and so on. In the end, NR finds it better to make the
140 placement of CopyIn a dynamic invariant. This change will complicate
141 the dataflow fact for the proc-point calculation, but it should make
142 things easier in many other respects.
146 -- ================ IMPLEMENTATION ================--
148 mkNop = mkMiddle $ MidNop
149 mkAssign l r = mkMiddle $ MidAssign l r
150 mkStore l r = mkMiddle $ MidStore l r
151 mkCopyIn conv args srt = mkMiddle $ CopyIn conv args srt
152 mkCopyOut conv args = mkMiddle $ CopyOut conv args
154 mkJump e args = mkLast $ LastJump e args
155 mkCbranch pred ifso ifnot = mkLast $ LastCondBranch pred ifso ifnot
156 mkReturn actuals = mkLast $ LastReturn actuals
157 mkSwitch e tbl = mkLast $ LastSwitch e tbl
159 mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals
160 mkFinalCall tgt actuals = mkLast $ LastCall tgt actuals Nothing
162 mkCall tgt results actuals srt =
163 withFreshLabel "call successor" $ \k ->
164 mkLast (LastCall tgt actuals (Just k)) <*>
166 mkCopyIn (Result CmmCallConv) results srt
168 instance HavingSuccessors Last where
170 fold_succs = fold_cmm_succs
172 instance LastNode Last where
173 mkBranchNode id = LastBranch id []
174 isBranchNode (LastBranch _ []) = True
175 isBranchNode _ = False
176 branchNodeTarget (LastBranch id []) = id
177 branchNodeTarget _ = panic "asked for target of non-branch"
179 cmmSuccs :: Last -> [BlockId]
180 cmmSuccs (LastReturn {}) = []
181 cmmSuccs (LastJump {}) = []
182 cmmSuccs (LastBranch id _) = [id]
183 cmmSuccs (LastCall _ _ (Just id)) = [id]
184 cmmSuccs (LastCall _ _ Nothing) = []
185 cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
186 cmmSuccs (LastSwitch _ edges) = catMaybes edges
188 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
189 fold_cmm_succs _f (LastReturn {}) z = z
190 fold_cmm_succs _f (LastJump {}) z = z
191 fold_cmm_succs f (LastBranch id _) z = f id z
192 fold_cmm_succs f (LastCall _ _ (Just id)) z = f id z
193 fold_cmm_succs _f (LastCall _ _ Nothing) z = z
194 fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
195 fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
198 ----------------------------------------------------------------
199 -- prettyprinting (avoids recursive imports)
201 instance Outputable Middle where
204 instance Outputable Last where
207 instance Outputable Convention where
210 pprMiddle :: Middle -> SDoc
211 pprMiddle stmt = case stmt of
215 CopyIn conv args _ ->
216 if null args then ptext SLIT("empty CopyIn")
217 else commafy (map pprHinted args) <+> equals <+>
218 ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
221 if null args then PP.empty
222 else ptext SLIT("CopyOut") <+> doubleQuotes(ppr conv) <+>
223 parens (commafy (map pprHinted args))
226 MidComment s -> text "//" <+> ftext s
229 MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
232 MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
234 rep = ppr ( cmmExprRep expr )
236 -- call "ccall" foo(x, y)[r1, r2];
238 MidUnsafeCall (CmmCallee fn cconv) results args ->
239 hcat [ if null results
241 else parens (commafy $ map ppr results) <>
243 ptext SLIT("call"), space,
244 doubleQuotes(ppr cconv), space,
245 target fn, parens ( commafy $ map ppr args ),
248 target t@(CmmLit _) = ppr t
249 target fn' = parens (ppr fn')
251 MidUnsafeCall (CmmPrim op) results args ->
252 pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
254 lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
257 pprHinted :: Outputable a => (a, MachHint) -> SDoc
258 pprHinted (a, NoHint) = ppr a
259 pprHinted (a, PtrHint) = doubleQuotes (text "address") <+> ppr a
260 pprHinted (a, SignedHint) = doubleQuotes (text "signed") <+> ppr a
261 pprHinted (a, FloatHint) = doubleQuotes (text "float") <+> ppr a
263 LastBranch ident args -> genBranchWithArgs ident args
264 LastCondBranch expr t f -> genFullCondBranch expr t f
265 LastJump expr params -> ppr $ CmmJump expr params
266 LastReturn params -> ppr $ CmmReturn params
267 LastSwitch arg ids -> ppr $ CmmSwitch arg ids
268 LastCall tgt params k -> genCall tgt params k
270 genCall :: CmmCallTarget -> CmmActuals -> Maybe BlockId -> SDoc
271 genCall (CmmCallee fn cconv) args k =
272 hcat [ ptext SLIT("foreign"), space
273 , doubleQuotes(ppr cconv), space
274 , target fn, parens ( commafy $ map pprHinted args ), space
275 , case k of Nothing -> ptext SLIT("never returns")
276 Just k -> ptext SLIT("returns to") <+> ppr k
279 target t@(CmmLit _) = ppr t
280 target fn' = parens (ppr fn')
282 genCall (CmmPrim op) args k =
283 hcat [ text "%", text (show op), parens ( commafy $ map pprHinted args ),
284 ptext SLIT("returns to"), space, ppr k,
287 genBranchWithArgs :: (Outputable id, Outputable arg) => id -> [arg] -> SDoc
288 genBranchWithArgs ident [] = ptext SLIT("goto") <+> ppr ident <> semi
289 genBranchWithArgs ident args = ptext SLIT("goto") <+> ppr ident <+>
290 parens (commafy (map ppr args)) <> semi
292 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
293 genFullCondBranch expr t f =
294 hsep [ ptext SLIT("if")
298 , ptext SLIT("else goto")
302 pprConvention :: Convention -> SDoc
303 pprConvention (Argument c) = ppr c
304 pprConvention (Result c) = ppr c
305 pprConvention Local = text "<local>"
307 commafy :: [SDoc] -> SDoc
308 commafy xs = hsep $ punctuate comma xs