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