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