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