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