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