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