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