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