root/compiler/cmm/PprC.hs

Revision 40c1106c338e209f07023d165f32bff0f75e2e54, 41.1 KB (checked in by Paolo Capriotti <p.capriotti@…>, 4 weeks ago)

Cast memory primops in the C backend (#5976)

To prevent conflicts with GCC builtins, generate identical code for
calls to mem primos and FFI calls.

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