Interruptible FFI calls with pthread_kill and CancelSynchronousIO. v4
[ghc.git] / compiler / cmm / PprCmm.hs
1 ----------------------------------------------------------------------------
2 --
3 -- Pretty-printing of Cmm as (a superset of) C--
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 --
10 -- This is where we walk over Cmm emitting an external representation,
11 -- suitable for parsing, in a syntax strongly reminiscent of C--. This
12 -- is the "External Core" for the Cmm layer.
13 --
14 -- As such, this should be a well-defined syntax: we want it to look nice.
15 -- Thus, we try wherever possible to use syntax defined in [1],
16 -- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
17 -- slightly, in some cases. For one, we use I8 .. I64 for types, rather
18 -- than C--'s bits8 .. bits64.
19 --
20 -- We try to ensure that all information available in the abstract
21 -- syntax is reproduced, or reproducible, in the concrete syntax.
22 -- Data that is not in printed out can be reconstructed according to
23 -- conventions used in the pretty printer. There are at least two such
24 -- cases:
25 -- 1) if a value has wordRep type, the type is not appended in the
26 -- output.
27 -- 2) MachOps that operate over wordRep type are printed in a
28 -- C-style, rather than as their internal MachRep name.
29 --
30 -- These conventions produce much more readable Cmm output.
31 --
32 -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
33 --
34
35 module PprCmm
36 ( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr,
37 pprSection, pprStatic, pprLit
38 )
39 where
40
41 import BlockId
42 import Cmm
43 import CmmUtils
44 import CLabel
45 import BasicTypes
46
47
48 import ForeignCall
49 import Outputable
50 import FastString
51
52 import Data.List
53 import System.IO
54 import Data.Maybe
55
56 -- Temp Jan08
57 import SMRep
58 import ClosureInfo
59 #include "../includes/rts/storage/FunTypes.h"
60
61
62 pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc
63 pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
64 where
65 separator = space $$ ptext (sLit "-------------------") $$ space
66
67 writeCmms :: Handle -> [Cmm] -> IO ()
68 writeCmms handle cmms = printForC handle (pprCmms cmms)
69
70 -----------------------------------------------------------------------------
71
72 instance (Outputable d, Outputable info, Outputable g)
73 => Outputable (GenCmm d info g) where
74 ppr c = pprCmm c
75
76 instance (Outputable d, Outputable info, Outputable i)
77 => Outputable (GenCmmTop d info i) where
78 ppr t = pprTop t
79
80 instance (Outputable instr) => Outputable (ListGraph instr) where
81 ppr (ListGraph blocks) = vcat (map ppr blocks)
82
83 instance (Outputable instr) => Outputable (GenBasicBlock instr) where
84 ppr b = pprBBlock b
85
86 instance Outputable CmmStmt where
87 ppr s = pprStmt s
88
89 instance Outputable CmmExpr where
90 ppr e = pprExpr e
91
92 instance Outputable CmmReg where
93 ppr e = pprReg e
94
95 instance Outputable CmmLit where
96 ppr l = pprLit l
97
98 instance Outputable LocalReg where
99 ppr e = pprLocalReg e
100
101 instance Outputable Area where
102 ppr e = pprArea e
103
104 instance Outputable GlobalReg where
105 ppr e = pprGlobalReg e
106
107 instance Outputable CmmStatic where
108 ppr e = pprStatic e
109
110 instance Outputable CmmInfo where
111 ppr e = pprInfo e
112
113
114
115 -----------------------------------------------------------------------------
116
117 pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc
118 pprCmm (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops
119
120 -- --------------------------------------------------------------------------
121 -- Top level `procedure' blocks.
122 --
123 pprTop :: (Outputable d, Outputable info, Outputable i)
124 => GenCmmTop d info i -> SDoc
125
126 pprTop (CmmProc info lbl params graph )
127
128 = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params)
129 , nest 8 $ lbrace <+> ppr info $$ rbrace
130 , nest 4 $ ppr graph
131 , rbrace ]
132
133 -- --------------------------------------------------------------------------
134 -- We follow [1], 4.5
135 --
136 -- section "data" { ... }
137 --
138 pprTop (CmmData section ds) =
139 (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
140 $$ rbrace
141
142 -- --------------------------------------------------------------------------
143 instance Outputable CmmSafety where
144 ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
145 ppr (CmmSafe srt) = ppr srt
146 ppr CmmInterruptible = ptext (sLit "_interruptible_call_")
147
148 -- --------------------------------------------------------------------------
149 -- Info tables. The current pretty printer needs refinement
150 -- but will work for now.
151 --
152 -- For ideas on how to refine it, they used to be printed in the
153 -- style of C--'s 'stackdata' declaration, just inside the proc body,
154 -- and were labelled with the procedure name ++ "_info".
155 pprInfo :: CmmInfo -> SDoc
156 pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
157 vcat [{-ptext (sLit "gc_target: ") <>
158 maybe (ptext (sLit "<none>")) ppr gc_target,-}
159 ptext (sLit "update_frame: ") <>
160 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
161 pprInfo (CmmInfo _gc_target update_frame
162 (CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info)) =
163 vcat [{-ptext (sLit "gc_target: ") <>
164 maybe (ptext (sLit "<none>")) ppr gc_target,-}
165 ptext (sLit "has static closure: ") <> ppr stat_clos <+>
166 ptext (sLit "update_frame: ") <>
167 maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
168 ptext (sLit "type: ") <> pprLit closure_type,
169 ptext (sLit "desc: ") <> pprLit closure_desc,
170 ptext (sLit "tag: ") <> integer (toInteger tag),
171 pprTypeInfo info]
172
173 pprTypeInfo :: ClosureTypeInfo -> SDoc
174 pprTypeInfo (ConstrInfo layout constr descr) =
175 vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
176 ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
177 ptext (sLit "constructor: ") <> integer (toInteger constr),
178 pprLit descr]
179 pprTypeInfo (FunInfo layout srt arity _args slow_entry) =
180 vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
181 ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
182 ptext (sLit "srt: ") <> ppr srt,
183 -- Temp Jan08
184 ptext (sLit ("fun_type: ")) <> integer (toInteger (argDescrType _args)),
185
186 ptext (sLit "arity: ") <> integer (toInteger arity),
187 --ptext (sLit "args: ") <> ppr args, -- TODO: needs to be printed
188 ptext (sLit "slow: ") <> pprLit slow_entry
189 ]
190 pprTypeInfo (ThunkInfo layout srt) =
191 vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
192 ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
193 ptext (sLit "srt: ") <> ppr srt]
194 pprTypeInfo (ThunkSelectorInfo offset srt) =
195 vcat [ptext (sLit "ptrs: ") <> integer (toInteger offset),
196 ptext (sLit "srt: ") <> ppr srt]
197 pprTypeInfo (ContInfo stack srt) =
198 vcat [ptext (sLit "stack: ") <> ppr stack,
199 ptext (sLit "srt: ") <> ppr srt]
200
201 -- Temp Jan08
202 argDescrType :: ArgDescr -> StgHalfWord
203 -- The "argument type" RTS field type
204 argDescrType (ArgSpec n) = n
205 argDescrType (ArgGen liveness)
206 | isBigLiveness liveness = ARG_GEN_BIG
207 | otherwise = ARG_GEN
208
209 -- Temp Jan08
210 isBigLiveness :: Liveness -> Bool
211 isBigLiveness (BigLiveness _) = True
212 isBigLiveness (SmallLiveness _) = False
213
214
215 pprUpdateFrame :: UpdateFrame -> SDoc
216 pprUpdateFrame (UpdateFrame expr args) =
217 hcat [ ptext (sLit "jump")
218 , space
219 , if isTrivialCmmExpr expr
220 then pprExpr expr
221 else case expr of
222 CmmLoad (CmmReg _) _ -> pprExpr expr
223 _ -> parens (pprExpr expr)
224 , space
225 , parens ( commafy $ map ppr args ) ]
226
227
228 -- --------------------------------------------------------------------------
229 -- Basic blocks look like assembly blocks.
230 -- lbl: stmt ; stmt ; ..
231 pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
232 pprBBlock (BasicBlock ident stmts) =
233 hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
234
235 -- --------------------------------------------------------------------------
236 -- Statements. C-- usually, exceptions to this should be obvious.
237 --
238 pprStmt :: CmmStmt -> SDoc
239 pprStmt stmt = case stmt of
240
241 -- ;
242 CmmNop -> semi
243
244 -- // text
245 CmmComment s -> text "//" <+> ftext s
246
247 -- reg = expr;
248 CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
249
250 -- rep[lv] = expr;
251 CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
252 where
253 rep = ppr ( cmmExprType expr )
254
255 -- call "ccall" foo(x, y)[r1, r2];
256 -- ToDo ppr volatile
257 CmmCall (CmmCallee fn cconv) results args safety ret ->
258 sep [ pp_lhs <+> pp_conv
259 , nest 2 (pprExpr9 fn <>
260 parens (commafy (map ppr_ar args)))
261 <> brackets (ppr safety)
262 , case ret of CmmMayReturn -> empty
263 CmmNeverReturns -> ptext $ sLit (" never returns")
264 ] <> semi
265 where
266 pp_lhs | null results = empty
267 | otherwise = commafy (map ppr_ar results) <+> equals
268 -- Don't print the hints on a native C-- call
269
270 ppr_ar :: Outputable a => CmmHinted a -> SDoc
271 ppr_ar (CmmHinted ar k) = case cconv of
272 CmmCallConv -> ppr ar
273 _ -> ppr (ar,k)
274 pp_conv = case cconv of
275 CmmCallConv -> empty
276 _ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
277
278 -- Call a CallishMachOp, like sin or cos that might be implemented as a library call.
279 CmmCall (CmmPrim op) results args safety ret ->
280 pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
281 results args safety ret)
282 where
283 -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we
284 -- use one to get the label printed.
285 lbl = CmmLabel (mkForeignLabel
286 (mkFastString (show op))
287 Nothing ForeignLabelInThisPackage IsFunction)
288
289 CmmBranch ident -> genBranch ident
290 CmmCondBranch expr ident -> genCondBranch expr ident
291 CmmJump expr params -> genJump expr params
292 CmmReturn params -> genReturn params
293 CmmSwitch arg ids -> genSwitch arg ids
294
295 instance Outputable ForeignHint where
296 ppr NoHint = empty
297 ppr SignedHint = quotes(text "signed")
298 -- ppr AddrHint = quotes(text "address")
299 -- Temp Jan08
300 ppr AddrHint = (text "PtrHint")
301
302 -- Just look like a tuple, since it was a tuple before
303 -- ... is that a good idea? --Isaac Dupree
304 instance (Outputable a) => Outputable (CmmHinted a) where
305 ppr (CmmHinted a k) = ppr (a, k)
306
307 -- --------------------------------------------------------------------------
308 -- goto local label. [1], section 6.6
309 --
310 -- goto lbl;
311 --
312 genBranch :: BlockId -> SDoc
313 genBranch ident =
314 ptext (sLit "goto") <+> ppr ident <> semi
315
316 -- --------------------------------------------------------------------------
317 -- Conditional. [1], section 6.4
318 --
319 -- if (expr) { goto lbl; }
320 --
321 genCondBranch :: CmmExpr -> BlockId -> SDoc
322 genCondBranch expr ident =
323 hsep [ ptext (sLit "if")
324 , parens(ppr expr)
325 , ptext (sLit "goto")
326 , ppr ident <> semi ]
327
328 -- --------------------------------------------------------------------------
329 -- A tail call. [1], Section 6.9
330 --
331 -- jump foo(a, b, c);
332 --
333 genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc
334 genJump expr args =
335 hcat [ ptext (sLit "jump")
336 , space
337 , if isTrivialCmmExpr expr
338 then pprExpr expr
339 else case expr of
340 CmmLoad (CmmReg _) _ -> pprExpr expr
341 _ -> parens (pprExpr expr)
342 , space
343 , parens ( commafy $ map ppr args )
344 , semi ]
345
346
347 -- --------------------------------------------------------------------------
348 -- Return from a function. [1], Section 6.8.2 of version 1.128
349 --
350 -- return (a, b, c);
351 --
352 genReturn :: [CmmHinted CmmExpr] -> SDoc
353 genReturn args =
354 hcat [ ptext (sLit "return")
355 , space
356 , parens ( commafy $ map ppr args )
357 , semi ]
358
359 -- --------------------------------------------------------------------------
360 -- Tabled jump to local label
361 --
362 -- The syntax is from [1], section 6.5
363 --
364 -- switch [0 .. n] (expr) { case ... ; }
365 --
366 genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
367 genSwitch expr maybe_ids
368
369 = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
370
371 in hang (hcat [ ptext (sLit "switch [0 .. ")
372 , int (length maybe_ids - 1)
373 , ptext (sLit "] ")
374 , if isTrivialCmmExpr expr
375 then pprExpr expr
376 else parens (pprExpr expr)
377 , ptext (sLit " {")
378 ])
379 4 (vcat ( map caseify pairs )) $$ rbrace
380
381 where
382 snds a b = (snd a) == (snd b)
383
384 caseify :: [(Int,Maybe BlockId)] -> SDoc
385 caseify ixs@((_,Nothing):_)
386 = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
387 <> ptext (sLit " */")
388 caseify as
389 = let (is,ids) = unzip as
390 in hsep [ ptext (sLit "case")
391 , hcat (punctuate comma (map int is))
392 , ptext (sLit ": goto")
393 , ppr (head [ id | Just id <- ids]) <> semi ]
394
395 -- --------------------------------------------------------------------------
396 -- Expressions
397 --
398
399 pprExpr :: CmmExpr -> SDoc
400 pprExpr e
401 = case e of
402 CmmRegOff reg i ->
403 pprExpr (CmmMachOp (MO_Add rep)
404 [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
405 where rep = typeWidth (cmmRegType reg)
406 CmmLit lit -> pprLit lit
407 _other -> pprExpr1 e
408
409 -- Here's the precedence table from CmmParse.y:
410 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
411 -- %left '|'
412 -- %left '^'
413 -- %left '&'
414 -- %left '>>' '<<'
415 -- %left '-' '+'
416 -- %left '/' '*' '%'
417 -- %right '~'
418
419 -- We just cope with the common operators for now, the rest will get
420 -- a default conservative behaviour.
421
422 -- %nonassoc '>=' '>' '<=' '<' '!=' '=='
423 pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
424 pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
425 = pprExpr7 x <+> doc <+> pprExpr7 y
426 pprExpr1 e = pprExpr7 e
427
428 infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
429
430 infixMachOp1 (MO_Eq _) = Just (ptext (sLit "=="))
431 infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!="))
432 infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<"))
433 infixMachOp1 (MO_U_Shr _) = Just (ptext (sLit ">>"))
434 infixMachOp1 (MO_U_Ge _) = Just (ptext (sLit ">="))
435 infixMachOp1 (MO_U_Le _) = Just (ptext (sLit "<="))
436 infixMachOp1 (MO_U_Gt _) = Just (char '>')
437 infixMachOp1 (MO_U_Lt _) = Just (char '<')
438 infixMachOp1 _ = Nothing
439
440 -- %left '-' '+'
441 pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
442 = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
443 pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
444 = pprExpr7 x <+> doc <+> pprExpr8 y
445 pprExpr7 e = pprExpr8 e
446
447 infixMachOp7 (MO_Add _) = Just (char '+')
448 infixMachOp7 (MO_Sub _) = Just (char '-')
449 infixMachOp7 _ = Nothing
450
451 -- %left '/' '*' '%'
452 pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
453 = pprExpr8 x <+> doc <+> pprExpr9 y
454 pprExpr8 e = pprExpr9 e
455
456 infixMachOp8 (MO_U_Quot _) = Just (char '/')
457 infixMachOp8 (MO_Mul _) = Just (char '*')
458 infixMachOp8 (MO_U_Rem _) = Just (char '%')
459 infixMachOp8 _ = Nothing
460
461 pprExpr9 :: CmmExpr -> SDoc
462 pprExpr9 e =
463 case e of
464 CmmLit lit -> pprLit1 lit
465 CmmLoad expr rep -> ppr rep <> brackets( ppr expr )
466 CmmReg reg -> ppr reg
467 CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
468 CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)
469 CmmMachOp mop args -> genMachOp mop args
470
471 genMachOp :: MachOp -> [CmmExpr] -> SDoc
472 genMachOp mop args
473 | Just doc <- infixMachOp mop = case args of
474 -- dyadic
475 [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
476
477 -- unary
478 [x] -> doc <> pprExpr9 x
479
480 _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
481 (pprMachOp mop <+>
482 parens (hcat $ punctuate comma (map pprExpr args)))
483 empty
484
485 | isJust (infixMachOp1 mop)
486 || isJust (infixMachOp7 mop)
487 || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
488
489 | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
490 where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
491 (show mop))
492 -- replace spaces in (show mop) with underscores,
493
494 --
495 -- Unsigned ops on the word size of the machine get nice symbols.
496 -- All else get dumped in their ugly format.
497 --
498 infixMachOp :: MachOp -> Maybe SDoc
499 infixMachOp mop
500 = case mop of
501 MO_And _ -> Just $ char '&'
502 MO_Or _ -> Just $ char '|'
503 MO_Xor _ -> Just $ char '^'
504 MO_Not _ -> Just $ char '~'
505 MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
506 _ -> Nothing
507
508 -- --------------------------------------------------------------------------
509 -- Literals.
510 -- To minimise line noise we adopt the convention that if the literal
511 -- has the natural machine word size, we do not append the type
512 --
513 pprLit :: CmmLit -> SDoc
514 pprLit lit = case lit of
515 CmmInt i rep ->
516 hcat [ (if i < 0 then parens else id)(integer i)
517 , ppUnless (rep == wordWidth) $
518 space <> dcolon <+> ppr rep ]
519
520 CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
521 CmmLabel clbl -> pprCLabel clbl
522 CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
523 CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
524 <> pprCLabel clbl2 <> ppr_offset i
525 CmmBlock id -> ppr id
526 CmmHighStackMark -> text "<highSp>"
527
528 pprLit1 :: CmmLit -> SDoc
529 pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
530 pprLit1 lit = pprLit lit
531
532 ppr_offset :: Int -> SDoc
533 ppr_offset i
534 | i==0 = empty
535 | i>=0 = char '+' <> int i
536 | otherwise = char '-' <> int (-i)
537
538 -- --------------------------------------------------------------------------
539 -- Static data.
540 -- Strings are printed as C strings, and we print them as I8[],
541 -- following C--
542 --
543 pprStatic :: CmmStatic -> SDoc
544 pprStatic s = case s of
545 CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi
546 CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
547 CmmAlign i -> nest 4 $ text "align" <+> int i
548 CmmDataLabel clbl -> pprCLabel clbl <> colon
549 CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
550
551 -- --------------------------------------------------------------------------
552 -- Registers, whether local (temps) or global
553 --
554 pprReg :: CmmReg -> SDoc
555 pprReg r
556 = case r of
557 CmmLocal local -> pprLocalReg local
558 CmmGlobal global -> pprGlobalReg global
559
560 --
561 -- We only print the type of the local reg if it isn't wordRep
562 --
563 pprLocalReg :: LocalReg -> SDoc
564 pprLocalReg (LocalReg uniq rep)
565 -- = ppr rep <> char '_' <> ppr uniq
566 -- Temp Jan08
567 = char '_' <> ppr uniq <>
568 (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh
569 then dcolon <> ptr <> ppr rep
570 else dcolon <> ptr <> ppr rep)
571 where
572 ptr = empty
573 --if isGcPtrType rep
574 -- then doubleQuotes (text "ptr")
575 -- else empty
576
577 -- Stack areas
578 pprArea :: Area -> SDoc
579 pprArea (RegSlot r) = hcat [ text "slot<", ppr r, text ">" ]
580 pprArea (CallArea id) = pprAreaId id
581
582 pprAreaId :: AreaId -> SDoc
583 pprAreaId Old = text "old"
584 pprAreaId (Young id) = hcat [ text "young<", ppr id, text ">" ]
585
586 -- needs to be kept in syn with Cmm.hs.GlobalReg
587 --
588 pprGlobalReg :: GlobalReg -> SDoc
589 pprGlobalReg gr
590 = case gr of
591 VanillaReg n _ -> char 'R' <> int n
592 -- Temp Jan08
593 -- VanillaReg n VNonGcPtr -> char 'R' <> int n
594 -- VanillaReg n VGcPtr -> char 'P' <> int n
595 FloatReg n -> char 'F' <> int n
596 DoubleReg n -> char 'D' <> int n
597 LongReg n -> char 'L' <> int n
598 Sp -> ptext (sLit "Sp")
599 SpLim -> ptext (sLit "SpLim")
600 Hp -> ptext (sLit "Hp")
601 HpLim -> ptext (sLit "HpLim")
602 CurrentTSO -> ptext (sLit "CurrentTSO")
603 CurrentNursery -> ptext (sLit "CurrentNursery")
604 HpAlloc -> ptext (sLit "HpAlloc")
605 EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
606 GCEnter1 -> ptext (sLit "stg_gc_enter_1")
607 GCFun -> ptext (sLit "stg_gc_fun")
608 BaseReg -> ptext (sLit "BaseReg")
609 PicBaseReg -> ptext (sLit "PicBaseReg")
610
611 -- --------------------------------------------------------------------------
612 -- data sections
613 --
614 pprSection :: Section -> SDoc
615 pprSection s = case s of
616 Text -> section <+> doubleQuotes (ptext (sLit "text"))
617 Data -> section <+> doubleQuotes (ptext (sLit "data"))
618 ReadOnlyData -> section <+> doubleQuotes (ptext (sLit "readonly"))
619 ReadOnlyData16 -> section <+> doubleQuotes (ptext (sLit "readonly16"))
620 RelocatableReadOnlyData
621 -> section <+> doubleQuotes (ptext (sLit "relreadonly"))
622 UninitialisedData -> section <+> doubleQuotes (ptext (sLit "uninitialised"))
623 OtherSection s' -> section <+> doubleQuotes (text s')
624 where
625 section = ptext (sLit "section")
626
627 -----------------------------------------------------------------------------
628
629 commafy :: [SDoc] -> SDoc
630 commafy xs = fsep $ punctuate comma xs