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