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