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