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