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