Implement a capi calling convention; fixes #2979
[ghc.git] / compiler / cmm / PprC.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Pretty-printing of Cmm as C, suitable for feeding gcc
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -- Print Cmm as real C, for -fvia-C
8 --
9 -- See wiki:Commentary/Compiler/Backends/PprC
10 --
11 -- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"
12 -- relative to the old AbstractC, and many oddities/decorations have
13 -- disappeared from the data type.
14 --
15 -- This code generator is only supported in unregisterised mode.
16 --
17 -----------------------------------------------------------------------------
18
19 module PprC (
20 writeCs,
21 pprStringInCStyle
22 ) where
23
24 #include "HsVersions.h"
25
26 -- Cmm stuff
27 import BlockId
28 import CLabel
29 import ForeignCall
30 import OldCmm
31 import OldPprCmm ()
32
33 -- Utils
34 import Constants
35 import CPrim
36 import DynFlags
37 import FastString
38 import Outputable
39 import Platform
40 import UniqSet
41 import Unique
42 import Util
43
44 -- The rest
45 import Control.Monad.ST
46 import Data.Bits
47 import Data.Char
48 import Data.List
49 import Data.Map (Map)
50 import Data.Word
51 import System.IO
52 import qualified Data.Map as Map
53
54 #if __GLASGOW_HASKELL__ >= 703
55 import Data.Array.Unsafe ( castSTUArray )
56 import Data.Array.ST hiding ( castSTUArray )
57 #else
58 import Data.Array.ST
59 #endif
60
61 -- --------------------------------------------------------------------------
62 -- Top level
63
64 pprCs :: DynFlags -> [RawCmmGroup] -> SDoc
65 pprCs dflags cmms
66 = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC (targetPlatform dflags) c) cmms)
67 where
68 split_marker
69 | dopt Opt_SplitObjs dflags = ptext (sLit "__STG_SPLIT_MARKER")
70 | otherwise = empty
71
72 writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO ()
73 writeCs dflags handle cmms
74 = printForC handle (pprCs dflags cmms)
75
76 -- --------------------------------------------------------------------------
77 -- Now do some real work
78 --
79 -- for fun, we could call cmmToCmm over the tops...
80 --
81
82 pprC :: Platform -> RawCmmGroup -> SDoc
83 pprC platform tops = vcat $ intersperse blankLine $ map (pprTop platform) tops
84
85 --
86 -- top level procs
87 --
88 pprTop :: Platform -> RawCmmDecl -> SDoc
89 pprTop platform (CmmProc mb_info clbl (ListGraph blocks)) =
90 (case mb_info of
91 Nothing -> empty
92 Just (Statics info_clbl info_dat) -> pprDataExterns platform info_dat $$
93 pprWordArray platform info_clbl info_dat) $$
94 (vcat [
95 blankLine,
96 extern_decls,
97 (if (externallyVisibleCLabel clbl)
98 then mkFN_ else mkIF_) (pprCLabel platform clbl) <+> lbrace,
99 nest 8 temp_decls,
100 nest 8 mkFB_,
101 case blocks of
102 [] -> empty
103 -- the first block doesn't get a label:
104 (BasicBlock _ stmts : rest) ->
105 nest 8 (vcat (map (pprStmt platform) stmts)) $$
106 vcat (map (pprBBlock platform) rest),
107 nest 8 mkFE_,
108 rbrace ]
109 )
110 where
111 (temp_decls, extern_decls) = pprTempAndExternDecls platform blocks
112
113
114 -- Chunks of static data.
115
116 -- We only handle (a) arrays of word-sized things and (b) strings.
117
118 pprTop platform (CmmData _section (Statics lbl [CmmString str])) =
119 hcat [
120 pprLocalness lbl, ptext (sLit "char "), pprCLabel platform lbl,
121 ptext (sLit "[] = "), pprStringInCStyle str, semi
122 ]
123
124 pprTop platform (CmmData _section (Statics lbl [CmmUninitialised size])) =
125 hcat [
126 pprLocalness lbl, ptext (sLit "char "), pprCLabel platform lbl,
127 brackets (int size), semi
128 ]
129
130 pprTop platform (CmmData _section (Statics lbl lits)) =
131 pprDataExterns platform lits $$
132 pprWordArray platform lbl lits
133
134 -- --------------------------------------------------------------------------
135 -- BasicBlocks are self-contained entities: they always end in a jump.
136 --
137 -- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn
138 -- as many jumps as possible into fall throughs.
139 --
140
141 pprBBlock :: Platform -> CmmBasicBlock -> SDoc
142 pprBBlock platform (BasicBlock lbl stmts) =
143 if null stmts then
144 pprTrace "pprC.pprBBlock: curious empty code block for"
145 (pprBlockId lbl) empty
146 else
147 nest 4 (pprBlockId lbl <> colon) $$
148 nest 8 (vcat (map (pprStmt platform) stmts))
149
150 -- --------------------------------------------------------------------------
151 -- Info tables. Just arrays of words.
152 -- See codeGen/ClosureInfo, and nativeGen/PprMach
153
154 pprWordArray :: Platform -> CLabel -> [CmmStatic] -> SDoc
155 pprWordArray platform lbl ds
156 = hcat [ pprLocalness lbl, ptext (sLit "StgWord")
157 , space, pprCLabel platform lbl, ptext (sLit "[] = {") ]
158 $$ nest 8 (commafy (pprStatics platform ds))
159 $$ ptext (sLit "};")
160
161 --
162 -- has to be static, if it isn't globally visible
163 --
164 pprLocalness :: CLabel -> SDoc
165 pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ")
166 | otherwise = empty
167
168 -- --------------------------------------------------------------------------
169 -- Statements.
170 --
171
172 pprStmt :: Platform -> CmmStmt -> SDoc
173
174 pprStmt platform stmt = case stmt of
175 CmmReturn _ -> panic "pprStmt: return statement should have been cps'd away"
176 CmmNop -> empty
177 CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/")
178 -- XXX if the string contains "*/", we need to fix it
179 -- XXX we probably want to emit these comments when
180 -- some debugging option is on. They can get quite
181 -- large.
182
183 CmmAssign dest src -> pprAssign platform dest src
184
185 CmmStore dest src
186 | typeWidth rep == W64 && wordWidth /= W64
187 -> (if isFloatType rep then ptext (sLit "ASSIGN_DBL")
188 else ptext (sLit ("ASSIGN_Word64"))) <>
189 parens (mkP_ <> pprExpr1 platform dest <> comma <> pprExpr platform src) <> semi
190
191 | otherwise
192 -> hsep [ pprExpr platform (CmmLoad dest rep), equals, pprExpr platform src <> semi ]
193 where
194 rep = cmmExprType src
195
196 CmmCall (CmmCallee fn cconv) results args safety ret ->
197 maybe_proto $$
198 fnCall
199 where
200 cast_fn = parens (cCast platform (pprCFunType (char '*') cconv results args) fn)
201
202 real_fun_proto lbl = char ';' <>
203 pprCFunType (pprCLabel platform lbl) cconv results args <>
204 noreturn_attr <> semi
205
206 fun_proto lbl = ptext (sLit ";EF_(") <>
207 pprCLabel platform lbl <> char ')' <> semi
208
209 noreturn_attr = case ret of
210 CmmNeverReturns -> text "__attribute__ ((noreturn))"
211 CmmMayReturn -> empty
212
213 -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
214 (maybe_proto, fnCall) =
215 case fn of
216 CmmLit (CmmLabel lbl)
217 | StdCallConv <- cconv ->
218 let myCall = pprCall platform (pprCLabel platform lbl) cconv results args safety
219 in (real_fun_proto lbl, myCall)
220 -- stdcall functions must be declared with
221 -- a function type, otherwise the C compiler
222 -- doesn't add the @n suffix to the label. We
223 -- can't add the @n suffix ourselves, because
224 -- it isn't valid C.
225 | CmmNeverReturns <- ret ->
226 let myCall = pprCall platform (pprCLabel platform lbl) cconv results args safety
227 in (real_fun_proto lbl, myCall)
228 | not (isMathFun lbl) ->
229 let myCall = braces (
230 pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
231 $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
232 $$ pprCall platform (text "ghcFunPtr") cconv results args safety <> semi
233 )
234 in (fun_proto lbl, myCall)
235 _ ->
236 (empty {- no proto -},
237 pprCall platform cast_fn cconv results args safety <> semi)
238 -- for a dynamic call, no declaration is necessary.
239
240 CmmCall (CmmPrim op) results args safety _ret ->
241 pprCall platform ppr_fn CCallConv results args' safety
242 where
243 ppr_fn = pprCallishMachOp_for_C op
244 -- The mem primops carry an extra alignment arg, must drop it.
245 -- We could maybe emit an alignment directive using this info.
246 args' | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = init args
247 | otherwise = args
248
249 CmmBranch ident -> pprBranch ident
250 CmmCondBranch expr ident -> pprCondBranch platform expr ident
251 CmmJump lbl _params -> mkJMP_(pprExpr platform lbl) <> semi
252 CmmSwitch arg ids -> pprSwitch platform arg ids
253
254 pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
255 pprCFunType ppr_fn cconv ress args
256 = res_type ress <+>
257 parens (ccallConvAttribute cconv <> ppr_fn) <>
258 parens (commafy (map arg_type args))
259 where
260 res_type [] = ptext (sLit "void")
261 res_type [CmmHinted one hint] = machRepHintCType (localRegType one) hint
262 res_type _ = panic "pprCFunType: only void or 1 return value supported"
263
264 arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType expr) hint
265
266 -- ---------------------------------------------------------------------
267 -- unconditional branches
268 pprBranch :: BlockId -> SDoc
269 pprBranch ident = ptext (sLit "goto") <+> pprBlockId ident <> semi
270
271
272 -- ---------------------------------------------------------------------
273 -- conditional branches to local labels
274 pprCondBranch :: Platform -> CmmExpr -> BlockId -> SDoc
275 pprCondBranch platform expr ident
276 = hsep [ ptext (sLit "if") , parens(pprExpr platform expr) ,
277 ptext (sLit "goto") , (pprBlockId ident) <> semi ]
278
279
280 -- ---------------------------------------------------------------------
281 -- a local table branch
282 --
283 -- we find the fall-through cases
284 --
285 -- N.B. we remove Nothing's from the list of branches, as they are
286 -- 'undefined'. However, they may be defined one day, so we better
287 -- document this behaviour.
288 --
289 pprSwitch :: Platform -> CmmExpr -> [ Maybe BlockId ] -> SDoc
290 pprSwitch platform e maybe_ids
291 = let pairs = [ (ix, ident) | (ix,Just ident) <- zip [0..] maybe_ids ]
292 pairs2 = [ (map fst as, snd (head as)) | as <- groupBy sndEq pairs ]
293 in
294 (hang (ptext (sLit "switch") <+> parens ( pprExpr platform e ) <+> lbrace)
295 4 (vcat ( map caseify pairs2 )))
296 $$ rbrace
297
298 where
299 sndEq (_,x) (_,y) = x == y
300
301 -- fall through case
302 caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
303 where
304 do_fallthrough ix =
305 hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon ,
306 ptext (sLit "/* fall through */") ]
307
308 final_branch ix =
309 hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon ,
310 ptext (sLit "goto") , (pprBlockId ident) <> semi ]
311
312 caseify (_ , _ ) = panic "pprSwtich: swtich with no cases!"
313
314 -- ---------------------------------------------------------------------
315 -- Expressions.
316 --
317
318 -- C Types: the invariant is that the C expression generated by
319 --
320 -- pprExpr e
321 --
322 -- has a type in C which is also given by
323 --
324 -- machRepCType (cmmExprType e)
325 --
326 -- (similar invariants apply to the rest of the pretty printer).
327
328 pprExpr :: Platform -> CmmExpr -> SDoc
329 pprExpr platform e = case e of
330 CmmLit lit -> pprLit platform lit
331
332
333 CmmLoad e ty -> pprLoad platform e ty
334 CmmReg reg -> pprCastReg reg
335 CmmRegOff reg 0 -> pprCastReg reg
336
337 CmmRegOff reg i
338 | i > 0 -> pprRegOff (char '+') i
339 | otherwise -> pprRegOff (char '-') (-i)
340 where
341 pprRegOff op i' = pprCastReg reg <> op <> int i'
342
343 CmmMachOp mop args -> pprMachOpApp platform mop args
344
345 CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!"
346
347
348 pprLoad :: Platform -> CmmExpr -> CmmType -> SDoc
349 pprLoad platform e ty
350 | width == W64, wordWidth /= W64
351 = (if isFloatType ty then ptext (sLit "PK_DBL")
352 else ptext (sLit "PK_Word64"))
353 <> parens (mkP_ <> pprExpr1 platform e)
354
355 | otherwise
356 = case e of
357 CmmReg r | isPtrReg r && width == wordWidth && not (isFloatType ty)
358 -> char '*' <> pprAsPtrReg r
359
360 CmmRegOff r 0 | isPtrReg r && width == wordWidth && not (isFloatType ty)
361 -> char '*' <> pprAsPtrReg r
362
363 CmmRegOff r off | isPtrReg r && width == wordWidth
364 , off `rem` wORD_SIZE == 0 && not (isFloatType ty)
365 -- ToDo: check that the offset is a word multiple?
366 -- (For tagging to work, I had to avoid unaligned loads. --ARY)
367 -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift))
368
369 _other -> cLoad platform e ty
370 where
371 width = typeWidth ty
372
373 pprExpr1 :: Platform -> CmmExpr -> SDoc
374 pprExpr1 platform (CmmLit lit) = pprLit1 platform lit
375 pprExpr1 platform e@(CmmReg _reg) = pprExpr platform e
376 pprExpr1 platform other = parens (pprExpr platform other)
377
378 -- --------------------------------------------------------------------------
379 -- MachOp applications
380
381 pprMachOpApp :: Platform -> MachOp -> [CmmExpr] -> SDoc
382
383 pprMachOpApp platform op args
384 | isMulMayOfloOp op
385 = ptext (sLit "mulIntMayOflo") <> parens (commafy (map (pprExpr platform) args))
386 where isMulMayOfloOp (MO_U_MulMayOflo _) = True
387 isMulMayOfloOp (MO_S_MulMayOflo _) = True
388 isMulMayOfloOp _ = False
389
390 pprMachOpApp platform mop args
391 | Just ty <- machOpNeedsCast mop
392 = ty <> parens (pprMachOpApp' platform mop args)
393 | otherwise
394 = pprMachOpApp' platform mop args
395
396 -- Comparisons in C have type 'int', but we want type W_ (this is what
397 -- resultRepOfMachOp says). The other C operations inherit their type
398 -- from their operands, so no casting is required.
399 machOpNeedsCast :: MachOp -> Maybe SDoc
400 machOpNeedsCast mop
401 | isComparisonMachOp mop = Just mkW_
402 | otherwise = Nothing
403
404 pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc
405 pprMachOpApp' platform mop args
406 = case args of
407 -- dyadic
408 [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y
409
410 -- unary
411 [x] -> pprMachOp_for_C mop <> parens (pprArg x)
412
413 _ -> panic "PprC.pprMachOp : machop with wrong number of args"
414
415 where
416 -- Cast needed for signed integer ops
417 pprArg e | signedOp mop = cCast platform (machRep_S_CType (typeWidth (cmmExprType e))) e
418 | needsFCasts mop = cCast platform (machRep_F_CType (typeWidth (cmmExprType e))) e
419 | otherwise = pprExpr1 platform e
420 needsFCasts (MO_F_Eq _) = False
421 needsFCasts (MO_F_Ne _) = False
422 needsFCasts (MO_F_Neg _) = True
423 needsFCasts (MO_F_Quot _) = True
424 needsFCasts mop = floatComparison mop
425
426 -- --------------------------------------------------------------------------
427 -- Literals
428
429 pprLit :: Platform -> CmmLit -> SDoc
430 pprLit platform lit = case lit of
431 CmmInt i rep -> pprHexVal i rep
432
433 CmmFloat f w -> parens (machRep_F_CType w) <> str
434 where d = fromRational f :: Double
435 str | isInfinite d && d < 0 = ptext (sLit "-INFINITY")
436 | isInfinite d = ptext (sLit "INFINITY")
437 | isNaN d = ptext (sLit "NAN")
438 | otherwise = text (show d)
439 -- these constants come from <math.h>
440 -- see #1861
441
442 CmmBlock bid -> mkW_ <> pprCLabelAddr (infoTblLbl bid)
443 CmmHighStackMark -> panic "PprC printing high stack mark"
444 CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl
445 CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
446 CmmLabelDiffOff clbl1 _ i
447 -- WARNING:
448 -- * the lit must occur in the info table clbl2
449 -- * clbl1 must be an SRT, a slow entry point or a large bitmap
450 -- The Mangler is expected to convert any reference to an SRT,
451 -- a slow entry point or a large bitmap
452 -- from an info table to an offset.
453 -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i
454
455 where
456 pprCLabelAddr lbl = char '&' <> pprCLabel platform lbl
457
458 pprLit1 :: Platform -> CmmLit -> SDoc
459 pprLit1 platform lit@(CmmLabelOff _ _) = parens (pprLit platform lit)
460 pprLit1 platform lit@(CmmLabelDiffOff _ _ _) = parens (pprLit platform lit)
461 pprLit1 platform lit@(CmmFloat _ _) = parens (pprLit platform lit)
462 pprLit1 platform other = pprLit platform other
463
464 -- ---------------------------------------------------------------------------
465 -- Static data
466
467 pprStatics :: Platform -> [CmmStatic] -> [SDoc]
468 pprStatics _ [] = []
469 pprStatics platform (CmmStaticLit (CmmFloat f W32) : rest)
470 -- floats are padded to a word, see #1852
471 | wORD_SIZE == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest
472 = pprLit1 platform (floatToWord f) : pprStatics platform rest'
473 | wORD_SIZE == 4
474 = pprLit1 platform (floatToWord f) : pprStatics platform rest
475 | otherwise
476 = pprPanic "pprStatics: float" (vcat (map ppr' rest))
477 where ppr' (CmmStaticLit l) = ppr (cmmLitType l)
478 ppr' _other = ptext (sLit "bad static!")
479 pprStatics platform (CmmStaticLit (CmmFloat f W64) : rest)
480 = map (pprLit1 platform) (doubleToWords f) ++ pprStatics platform rest
481 pprStatics platform (CmmStaticLit (CmmInt i W64) : rest)
482 | wordWidth == W32
483 #ifdef WORDS_BIGENDIAN
484 = pprStatics platform (CmmStaticLit (CmmInt q W32) :
485 CmmStaticLit (CmmInt r W32) : rest)
486 #else
487 = pprStatics platform (CmmStaticLit (CmmInt r W32) :
488 CmmStaticLit (CmmInt q W32) : rest)
489 #endif
490 where r = i .&. 0xffffffff
491 q = i `shiftR` 32
492 pprStatics _ (CmmStaticLit (CmmInt _ w) : _)
493 | w /= wordWidth
494 = panic "pprStatics: cannot emit a non-word-sized static literal"
495 pprStatics platform (CmmStaticLit lit : rest)
496 = pprLit1 platform lit : pprStatics platform rest
497 pprStatics platform (other : _)
498 = pprPanic "pprWord" (pprStatic platform other)
499
500 pprStatic :: Platform -> CmmStatic -> SDoc
501 pprStatic platform s = case s of
502
503 CmmStaticLit lit -> nest 4 (pprLit platform lit)
504 CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))
505
506 -- these should be inlined, like the old .hc
507 CmmString s' -> nest 4 (mkW_ <> parens(pprStringInCStyle s'))
508
509
510 -- ---------------------------------------------------------------------------
511 -- Block Ids
512
513 pprBlockId :: BlockId -> SDoc
514 pprBlockId b = char '_' <> ppr (getUnique b)
515
516 -- --------------------------------------------------------------------------
517 -- Print a MachOp in a way suitable for emitting via C.
518 --
519
520 pprMachOp_for_C :: MachOp -> SDoc
521
522 pprMachOp_for_C mop = case mop of
523
524 -- Integer operations
525 MO_Add _ -> char '+'
526 MO_Sub _ -> char '-'
527 MO_Eq _ -> ptext (sLit "==")
528 MO_Ne _ -> ptext (sLit "!=")
529 MO_Mul _ -> char '*'
530
531 MO_S_Quot _ -> char '/'
532 MO_S_Rem _ -> char '%'
533 MO_S_Neg _ -> char '-'
534
535 MO_U_Quot _ -> char '/'
536 MO_U_Rem _ -> char '%'
537
538 -- & Floating-point operations
539 MO_F_Add _ -> char '+'
540 MO_F_Sub _ -> char '-'
541 MO_F_Neg _ -> char '-'
542 MO_F_Mul _ -> char '*'
543 MO_F_Quot _ -> char '/'
544
545 -- Signed comparisons
546 MO_S_Ge _ -> ptext (sLit ">=")
547 MO_S_Le _ -> ptext (sLit "<=")
548 MO_S_Gt _ -> char '>'
549 MO_S_Lt _ -> char '<'
550
551 -- & Unsigned comparisons
552 MO_U_Ge _ -> ptext (sLit ">=")
553 MO_U_Le _ -> ptext (sLit "<=")
554 MO_U_Gt _ -> char '>'
555 MO_U_Lt _ -> char '<'
556
557 -- & Floating-point comparisons
558 MO_F_Eq _ -> ptext (sLit "==")
559 MO_F_Ne _ -> ptext (sLit "!=")
560 MO_F_Ge _ -> ptext (sLit ">=")
561 MO_F_Le _ -> ptext (sLit "<=")
562 MO_F_Gt _ -> char '>'
563 MO_F_Lt _ -> char '<'
564
565 -- Bitwise operations. Not all of these may be supported at all
566 -- sizes, and only integral MachReps are valid.
567 MO_And _ -> char '&'
568 MO_Or _ -> char '|'
569 MO_Xor _ -> char '^'
570 MO_Not _ -> char '~'
571 MO_Shl _ -> ptext (sLit "<<")
572 MO_U_Shr _ -> ptext (sLit ">>") -- unsigned shift right
573 MO_S_Shr _ -> ptext (sLit ">>") -- signed shift right
574
575 -- Conversions. Some of these will be NOPs, but never those that convert
576 -- between ints and floats.
577 -- Floating-point conversions use the signed variant.
578 -- We won't know to generate (void*) casts here, but maybe from
579 -- context elsewhere
580
581 -- noop casts
582 MO_UU_Conv from to | from == to -> empty
583 MO_UU_Conv _from to -> parens (machRep_U_CType to)
584
585 MO_SS_Conv from to | from == to -> empty
586 MO_SS_Conv _from to -> parens (machRep_S_CType to)
587
588 MO_FF_Conv from to | from == to -> empty
589 MO_FF_Conv _from to -> parens (machRep_F_CType to)
590
591 MO_SF_Conv _from to -> parens (machRep_F_CType to)
592 MO_FS_Conv _from to -> parens (machRep_S_CType to)
593
594 MO_S_MulMayOflo _ -> pprTrace "offending mop:"
595 (ptext $ sLit "MO_S_MulMayOflo")
596 (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo"
597 ++ " should have been handled earlier!")
598 MO_U_MulMayOflo _ -> pprTrace "offending mop:"
599 (ptext $ sLit "MO_U_MulMayOflo")
600 (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo"
601 ++ " should have been handled earlier!")
602
603 signedOp :: MachOp -> Bool -- Argument type(s) are signed ints
604 signedOp (MO_S_Quot _) = True
605 signedOp (MO_S_Rem _) = True
606 signedOp (MO_S_Neg _) = True
607 signedOp (MO_S_Ge _) = True
608 signedOp (MO_S_Le _) = True
609 signedOp (MO_S_Gt _) = True
610 signedOp (MO_S_Lt _) = True
611 signedOp (MO_S_Shr _) = True
612 signedOp (MO_SS_Conv _ _) = True
613 signedOp (MO_SF_Conv _ _) = True
614 signedOp _ = False
615
616 floatComparison :: MachOp -> Bool -- comparison between float args
617 floatComparison (MO_F_Eq _) = True
618 floatComparison (MO_F_Ne _) = True
619 floatComparison (MO_F_Ge _) = True
620 floatComparison (MO_F_Le _) = True
621 floatComparison (MO_F_Gt _) = True
622 floatComparison (MO_F_Lt _) = True
623 floatComparison _ = False
624
625 -- ---------------------------------------------------------------------
626 -- tend to be implemented by foreign calls
627
628 pprCallishMachOp_for_C :: CallishMachOp -> SDoc
629
630 pprCallishMachOp_for_C mop
631 = case mop of
632 MO_F64_Pwr -> ptext (sLit "pow")
633 MO_F64_Sin -> ptext (sLit "sin")
634 MO_F64_Cos -> ptext (sLit "cos")
635 MO_F64_Tan -> ptext (sLit "tan")
636 MO_F64_Sinh -> ptext (sLit "sinh")
637 MO_F64_Cosh -> ptext (sLit "cosh")
638 MO_F64_Tanh -> ptext (sLit "tanh")
639 MO_F64_Asin -> ptext (sLit "asin")
640 MO_F64_Acos -> ptext (sLit "acos")
641 MO_F64_Atan -> ptext (sLit "atan")
642 MO_F64_Log -> ptext (sLit "log")
643 MO_F64_Exp -> ptext (sLit "exp")
644 MO_F64_Sqrt -> ptext (sLit "sqrt")
645 MO_F32_Pwr -> ptext (sLit "powf")
646 MO_F32_Sin -> ptext (sLit "sinf")
647 MO_F32_Cos -> ptext (sLit "cosf")
648 MO_F32_Tan -> ptext (sLit "tanf")
649 MO_F32_Sinh -> ptext (sLit "sinhf")
650 MO_F32_Cosh -> ptext (sLit "coshf")
651 MO_F32_Tanh -> ptext (sLit "tanhf")
652 MO_F32_Asin -> ptext (sLit "asinf")
653 MO_F32_Acos -> ptext (sLit "acosf")
654 MO_F32_Atan -> ptext (sLit "atanf")
655 MO_F32_Log -> ptext (sLit "logf")
656 MO_F32_Exp -> ptext (sLit "expf")
657 MO_F32_Sqrt -> ptext (sLit "sqrtf")
658 MO_WriteBarrier -> ptext (sLit "write_barrier")
659 MO_Memcpy -> ptext (sLit "memcpy")
660 MO_Memset -> ptext (sLit "memset")
661 MO_Memmove -> ptext (sLit "memmove")
662 (MO_PopCnt w) -> ptext (sLit $ popCntLabel w)
663
664 MO_Touch -> panic $ "pprCallishMachOp_for_C: MO_Touch not supported!"
665
666 -- ---------------------------------------------------------------------
667 -- Useful #defines
668 --
669
670 mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc
671
672 mkJMP_ i = ptext (sLit "JMP_") <> parens i
673 mkFN_ i = ptext (sLit "FN_") <> parens i -- externally visible function
674 mkIF_ i = ptext (sLit "IF_") <> parens i -- locally visible
675
676
677 mkFB_, mkFE_ :: SDoc
678 mkFB_ = ptext (sLit "FB_") -- function code begin
679 mkFE_ = ptext (sLit "FE_") -- function code end
680
681 -- from includes/Stg.h
682 --
683 mkC_,mkW_,mkP_ :: SDoc
684
685 mkC_ = ptext (sLit "(C_)") -- StgChar
686 mkW_ = ptext (sLit "(W_)") -- StgWord
687 mkP_ = ptext (sLit "(P_)") -- StgWord*
688
689 -- ---------------------------------------------------------------------
690 --
691 -- Assignments
692 --
693 -- Generating assignments is what we're all about, here
694 --
695 pprAssign :: Platform -> CmmReg -> CmmExpr -> SDoc
696
697 -- dest is a reg, rhs is a reg
698 pprAssign _ r1 (CmmReg r2)
699 | isPtrReg r1 && isPtrReg r2
700 = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]
701
702 -- dest is a reg, rhs is a CmmRegOff
703 pprAssign _ r1 (CmmRegOff r2 off)
704 | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE == 0)
705 = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
706 where
707 off1 = off `shiftR` wordShift
708
709 (op,off') | off >= 0 = (char '+', off1)
710 | otherwise = (char '-', -off1)
711
712 -- dest is a reg, rhs is anything.
713 -- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting
714 -- the lvalue elicits a warning from new GCC versions (3.4+).
715 pprAssign platform r1 r2
716 | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 platform r2)
717 | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 platform r2)
718 | otherwise = mkAssign (pprExpr platform r2)
719 where mkAssign x = if r1 == CmmGlobal BaseReg
720 then ptext (sLit "ASSIGN_BaseReg") <> parens x <> semi
721 else pprReg r1 <> ptext (sLit " = ") <> x <> semi
722
723 -- ---------------------------------------------------------------------
724 -- Registers
725
726 pprCastReg :: CmmReg -> SDoc
727 pprCastReg reg
728 | isStrangeTypeReg reg = mkW_ <> pprReg reg
729 | otherwise = pprReg reg
730
731 -- True if (pprReg reg) will give an expression with type StgPtr. We
732 -- need to take care with pointer arithmetic on registers with type
733 -- StgPtr.
734 isFixedPtrReg :: CmmReg -> Bool
735 isFixedPtrReg (CmmLocal _) = False
736 isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r
737
738 -- True if (pprAsPtrReg reg) will give an expression with type StgPtr
739 -- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST.
740 -- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT;
741 -- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY.
742 isPtrReg :: CmmReg -> Bool
743 isPtrReg (CmmLocal _) = False
744 isPtrReg (CmmGlobal (VanillaReg _ VGcPtr)) = True -- if we print via pprAsPtrReg
745 isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg
746 isPtrReg (CmmGlobal reg) = isFixedPtrGlobalReg reg
747
748 -- True if this global reg has type StgPtr
749 isFixedPtrGlobalReg :: GlobalReg -> Bool
750 isFixedPtrGlobalReg Sp = True
751 isFixedPtrGlobalReg Hp = True
752 isFixedPtrGlobalReg HpLim = True
753 isFixedPtrGlobalReg SpLim = True
754 isFixedPtrGlobalReg _ = False
755
756 -- True if in C this register doesn't have the type given by
757 -- (machRepCType (cmmRegType reg)), so it has to be cast.
758 isStrangeTypeReg :: CmmReg -> Bool
759 isStrangeTypeReg (CmmLocal _) = False
760 isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g
761
762 isStrangeTypeGlobal :: GlobalReg -> Bool
763 isStrangeTypeGlobal CurrentTSO = True
764 isStrangeTypeGlobal CurrentNursery = True
765 isStrangeTypeGlobal BaseReg = True
766 isStrangeTypeGlobal r = isFixedPtrGlobalReg r
767
768 strangeRegType :: CmmReg -> Maybe SDoc
769 strangeRegType (CmmGlobal CurrentTSO) = Just (ptext (sLit "struct StgTSO_ *"))
770 strangeRegType (CmmGlobal CurrentNursery) = Just (ptext (sLit "struct bdescr_ *"))
771 strangeRegType (CmmGlobal BaseReg) = Just (ptext (sLit "struct StgRegTable_ *"))
772 strangeRegType _ = Nothing
773
774 -- pprReg just prints the register name.
775 --
776 pprReg :: CmmReg -> SDoc
777 pprReg r = case r of
778 CmmLocal local -> pprLocalReg local
779 CmmGlobal global -> pprGlobalReg global
780
781 pprAsPtrReg :: CmmReg -> SDoc
782 pprAsPtrReg (CmmGlobal (VanillaReg n gcp))
783 = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> ptext (sLit ".p")
784 pprAsPtrReg other_reg = pprReg other_reg
785
786 pprGlobalReg :: GlobalReg -> SDoc
787 pprGlobalReg gr = case gr of
788 VanillaReg n _ -> char 'R' <> int n <> ptext (sLit ".w")
789 -- pprGlobalReg prints a VanillaReg as a .w regardless
790 -- Example: R1.w = R1.w & (-0x8UL);
791 -- JMP_(*R1.p);
792 FloatReg n -> char 'F' <> int n
793 DoubleReg n -> char 'D' <> int n
794 LongReg n -> char 'L' <> int n
795 Sp -> ptext (sLit "Sp")
796 SpLim -> ptext (sLit "SpLim")
797 Hp -> ptext (sLit "Hp")
798 HpLim -> ptext (sLit "HpLim")
799 CurrentTSO -> ptext (sLit "CurrentTSO")
800 CurrentNursery -> ptext (sLit "CurrentNursery")
801 HpAlloc -> ptext (sLit "HpAlloc")
802 BaseReg -> ptext (sLit "BaseReg")
803 EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
804 GCEnter1 -> ptext (sLit "stg_gc_enter_1")
805 GCFun -> ptext (sLit "stg_gc_fun")
806 other -> panic $ "pprGlobalReg: Unsupported register: " ++ show other
807
808 pprLocalReg :: LocalReg -> SDoc
809 pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
810
811 -- -----------------------------------------------------------------------------
812 -- Foreign Calls
813
814 pprCall :: Platform -> SDoc -> CCallConv
815 -> [HintedCmmFormal] -> [HintedCmmActual] -> CmmSafety
816 -> SDoc
817
818 pprCall platform ppr_fn cconv results args _
819 | not (is_cishCC cconv)
820 = panic $ "pprCall: unknown calling convention"
821
822 | otherwise
823 =
824 ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
825 where
826 ppr_assign [] rhs = rhs
827 ppr_assign [CmmHinted one hint] rhs
828 = pprLocalReg one <> ptext (sLit " = ")
829 <> pprUnHint hint (localRegType one) <> rhs
830 ppr_assign _other _rhs = panic "pprCall: multiple results"
831
832 pprArg (CmmHinted expr AddrHint)
833 = cCast platform (ptext (sLit "void *")) expr
834 -- see comment by machRepHintCType below
835 pprArg (CmmHinted expr SignedHint)
836 = cCast platform (machRep_S_CType $ typeWidth $ cmmExprType expr) expr
837 pprArg (CmmHinted expr _other)
838 = pprExpr platform expr
839
840 pprUnHint AddrHint rep = parens (machRepCType rep)
841 pprUnHint SignedHint rep = parens (machRepCType rep)
842 pprUnHint _ _ = empty
843
844 -- Currently we only have these two calling conventions, but this might
845 -- change in the future...
846 is_cishCC :: CCallConv -> Bool
847 is_cishCC CCallConv = True
848 is_cishCC CApiConv = True
849 is_cishCC StdCallConv = True
850 is_cishCC CmmCallConv = False
851 is_cishCC PrimCallConv = False
852
853 -- ---------------------------------------------------------------------
854 -- Find and print local and external declarations for a list of
855 -- Cmm statements.
856 --
857 pprTempAndExternDecls :: Platform -> [CmmBasicBlock]
858 -> (SDoc{-temps-}, SDoc{-externs-})
859 pprTempAndExternDecls platform stmts
860 = (vcat (map pprTempDecl (uniqSetToList temps)),
861 vcat (map (pprExternDecl platform False{-ToDo-}) (Map.keys lbls)))
862 where (temps, lbls) = runTE (mapM_ te_BB stmts)
863
864 pprDataExterns :: Platform -> [CmmStatic] -> SDoc
865 pprDataExterns platform statics
866 = vcat (map (pprExternDecl platform False{-ToDo-}) (Map.keys lbls))
867 where (_, lbls) = runTE (mapM_ te_Static statics)
868
869 pprTempDecl :: LocalReg -> SDoc
870 pprTempDecl l@(LocalReg _ rep)
871 = hcat [ machRepCType rep, space, pprLocalReg l, semi ]
872
873 pprExternDecl :: Platform -> Bool -> CLabel -> SDoc
874 pprExternDecl platform _in_srt lbl
875 -- do not print anything for "known external" things
876 | not (needsCDecl lbl) = empty
877 | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
878 | otherwise =
879 hcat [ visibility, label_type lbl,
880 lparen, pprCLabel platform lbl, text ");" ]
881 where
882 label_type lbl | isCFunctionLabel lbl = ptext (sLit "F_")
883 | otherwise = ptext (sLit "I_")
884
885 visibility
886 | externallyVisibleCLabel lbl = char 'E'
887 | otherwise = char 'I'
888
889 -- If the label we want to refer to is a stdcall function (on Windows) then
890 -- we must generate an appropriate prototype for it, so that the C compiler will
891 -- add the @n suffix to the label (#2276)
892 stdcall_decl sz =
893 ptext (sLit "extern __attribute__((stdcall)) void ") <> pprCLabel platform lbl
894 <> parens (commafy (replicate (sz `quot` wORD_SIZE) (machRep_U_CType wordWidth)))
895 <> semi
896
897 type TEState = (UniqSet LocalReg, Map CLabel ())
898 newtype TE a = TE { unTE :: TEState -> (a, TEState) }
899
900 instance Monad TE where
901 TE m >>= k = TE $ \s -> case m s of (a, s') -> unTE (k a) s'
902 return a = TE $ \s -> (a, s)
903
904 te_lbl :: CLabel -> TE ()
905 te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls))
906
907 te_temp :: LocalReg -> TE ()
908 te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))
909
910 runTE :: TE () -> TEState
911 runTE (TE m) = snd (m (emptyUniqSet, Map.empty))
912
913 te_Static :: CmmStatic -> TE ()
914 te_Static (CmmStaticLit lit) = te_Lit lit
915 te_Static _ = return ()
916
917 te_BB :: CmmBasicBlock -> TE ()
918 te_BB (BasicBlock _ ss) = mapM_ te_Stmt ss
919
920 te_Lit :: CmmLit -> TE ()
921 te_Lit (CmmLabel l) = te_lbl l
922 te_Lit (CmmLabelOff l _) = te_lbl l
923 te_Lit (CmmLabelDiffOff l1 _ _) = te_lbl l1
924 te_Lit _ = return ()
925
926 te_Stmt :: CmmStmt -> TE ()
927 te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e
928 te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r
929 te_Stmt (CmmCall _ rs es _ _) = mapM_ (te_temp.hintlessCmm) rs >>
930 mapM_ (te_Expr.hintlessCmm) es
931 te_Stmt (CmmCondBranch e _) = te_Expr e
932 te_Stmt (CmmSwitch e _) = te_Expr e
933 te_Stmt (CmmJump e _) = te_Expr e
934 te_Stmt _ = return ()
935
936 te_Expr :: CmmExpr -> TE ()
937 te_Expr (CmmLit lit) = te_Lit lit
938 te_Expr (CmmLoad e _) = te_Expr e
939 te_Expr (CmmReg r) = te_Reg r
940 te_Expr (CmmMachOp _ es) = mapM_ te_Expr es
941 te_Expr (CmmRegOff r _) = te_Reg r
942 te_Expr (CmmStackSlot _ _) = panic "te_Expr: CmmStackSlot not supported!"
943
944 te_Reg :: CmmReg -> TE ()
945 te_Reg (CmmLocal l) = te_temp l
946 te_Reg _ = return ()
947
948
949 -- ---------------------------------------------------------------------
950 -- C types for MachReps
951
952 cCast :: Platform -> SDoc -> CmmExpr -> SDoc
953 cCast platform ty expr = parens ty <> pprExpr1 platform expr
954
955 cLoad :: Platform -> CmmExpr -> CmmType -> SDoc
956 cLoad platform expr rep
957 | bewareLoadStoreAlignment (platformArch platform)
958 = let decl = machRepCType rep <+> ptext (sLit "x") <> semi
959 struct = ptext (sLit "struct") <+> braces (decl)
960 packed_attr = ptext (sLit "__attribute__((packed))")
961 cast = parens (struct <+> packed_attr <> char '*')
962 in parens (cast <+> pprExpr1 platform expr) <> ptext (sLit "->x")
963 | otherwise
964 = char '*' <> parens (cCast platform (machRepPtrCType rep) expr)
965 where -- On these platforms, unaligned loads are known to cause problems
966 bewareLoadStoreAlignment (ArchARM {}) = True
967 bewareLoadStoreAlignment _ = False
968
969 isCmmWordType :: CmmType -> Bool
970 -- True of GcPtrReg/NonGcReg of native word size
971 isCmmWordType ty = not (isFloatType ty)
972 && typeWidth ty == wordWidth
973
974 -- This is for finding the types of foreign call arguments. For a pointer
975 -- argument, we always cast the argument to (void *), to avoid warnings from
976 -- the C compiler.
977 machRepHintCType :: CmmType -> ForeignHint -> SDoc
978 machRepHintCType _ AddrHint = ptext (sLit "void *")
979 machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep)
980 machRepHintCType rep _other = machRepCType rep
981
982 machRepPtrCType :: CmmType -> SDoc
983 machRepPtrCType r | isCmmWordType r = ptext (sLit "P_")
984 | otherwise = machRepCType r <> char '*'
985
986 machRepCType :: CmmType -> SDoc
987 machRepCType ty | isFloatType ty = machRep_F_CType w
988 | otherwise = machRep_U_CType w
989 where
990 w = typeWidth ty
991
992 machRep_F_CType :: Width -> SDoc
993 machRep_F_CType W32 = ptext (sLit "StgFloat") -- ToDo: correct?
994 machRep_F_CType W64 = ptext (sLit "StgDouble")
995 machRep_F_CType _ = panic "machRep_F_CType"
996
997 machRep_U_CType :: Width -> SDoc
998 machRep_U_CType w | w == wordWidth = ptext (sLit "W_")
999 machRep_U_CType W8 = ptext (sLit "StgWord8")
1000 machRep_U_CType W16 = ptext (sLit "StgWord16")
1001 machRep_U_CType W32 = ptext (sLit "StgWord32")
1002 machRep_U_CType W64 = ptext (sLit "StgWord64")
1003 machRep_U_CType _ = panic "machRep_U_CType"
1004
1005 machRep_S_CType :: Width -> SDoc
1006 machRep_S_CType w | w == wordWidth = ptext (sLit "I_")
1007 machRep_S_CType W8 = ptext (sLit "StgInt8")
1008 machRep_S_CType W16 = ptext (sLit "StgInt16")
1009 machRep_S_CType W32 = ptext (sLit "StgInt32")
1010 machRep_S_CType W64 = ptext (sLit "StgInt64")
1011 machRep_S_CType _ = panic "machRep_S_CType"
1012
1013
1014 -- ---------------------------------------------------------------------
1015 -- print strings as valid C strings
1016
1017 pprStringInCStyle :: [Word8] -> SDoc
1018 pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
1019
1020 -- ---------------------------------------------------------------------------
1021 -- Initialising static objects with floating-point numbers. We can't
1022 -- just emit the floating point number, because C will cast it to an int
1023 -- by rounding it. We want the actual bit-representation of the float.
1024
1025 -- This is a hack to turn the floating point numbers into ints that we
1026 -- can safely initialise to static locations.
1027
1028 big_doubles :: Bool
1029 big_doubles
1030 | widthInBytes W64 == 2 * wORD_SIZE = True
1031 | widthInBytes W64 == wORD_SIZE = False
1032 | otherwise = panic "big_doubles"
1033
1034 castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
1035 castFloatToIntArray = castSTUArray
1036
1037 castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int)
1038 castDoubleToIntArray = castSTUArray
1039
1040 -- floats are always 1 word
1041 floatToWord :: Rational -> CmmLit
1042 floatToWord r
1043 = runST (do
1044 arr <- newArray_ ((0::Int),0)
1045 writeArray arr 0 (fromRational r)
1046 arr' <- castFloatToIntArray arr
1047 i <- readArray arr' 0
1048 return (CmmInt (toInteger i) wordWidth)
1049 )
1050
1051 doubleToWords :: Rational -> [CmmLit]
1052 doubleToWords r
1053 | big_doubles -- doubles are 2 words
1054 = runST (do
1055 arr <- newArray_ ((0::Int),1)
1056 writeArray arr 0 (fromRational r)
1057 arr' <- castDoubleToIntArray arr
1058 i1 <- readArray arr' 0
1059 i2 <- readArray arr' 1
1060 return [ CmmInt (toInteger i1) wordWidth
1061 , CmmInt (toInteger i2) wordWidth
1062 ]
1063 )
1064 | otherwise -- doubles are 1 word
1065 = runST (do
1066 arr <- newArray_ ((0::Int),0)
1067 writeArray arr 0 (fromRational r)
1068 arr' <- castDoubleToIntArray arr
1069 i <- readArray arr' 0
1070 return [ CmmInt (toInteger i) wordWidth ]
1071 )
1072
1073 -- ---------------------------------------------------------------------------
1074 -- Utils
1075
1076 wordShift :: Int
1077 wordShift = widthInLog wordWidth
1078
1079 commafy :: [SDoc] -> SDoc
1080 commafy xs = hsep $ punctuate comma xs
1081
1082 -- Print in C hex format: 0x13fa
1083 pprHexVal :: Integer -> Width -> SDoc
1084 pprHexVal 0 _ = ptext (sLit "0x0")
1085 pprHexVal w rep
1086 | w < 0 = parens (char '-' <> ptext (sLit "0x") <> go (-w) <> repsuffix rep)
1087 | otherwise = ptext (sLit "0x") <> go w <> repsuffix rep
1088 where
1089 -- type suffix for literals:
1090 -- Integer literals are unsigned in Cmm/C. We explicitly cast to
1091 -- signed values for doing signed operations, but at all other
1092 -- times values are unsigned. This also helps eliminate occasional
1093 -- warnings about integer overflow from gcc.
1094
1095 -- on 32-bit platforms, add "ULL" to 64-bit literals
1096 repsuffix W64 | wORD_SIZE == 4 = ptext (sLit "ULL")
1097 -- on 64-bit platforms with 32-bit int, add "L" to 64-bit literals
1098 repsuffix W64 | cINT_SIZE == 4 = ptext (sLit "UL")
1099 repsuffix _ = char 'U'
1100
1101 go 0 = empty
1102 go w' = go q <> dig
1103 where
1104 (q,r) = w' `quotRem` 16
1105 dig | r < 10 = char (chr (fromInteger r + ord '0'))
1106 | otherwise = char (chr (fromInteger r - 10 + ord 'a'))
1107