3b824f375f9907a298dd487ba3ca09b29779c7a4
[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_Clz w) -> ptext (sLit $ clzLabel w)
757 (MO_Ctz w) -> ptext (sLit $ ctzLabel w)
758 (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)
759 (MO_Cmpxchg w) -> ptext (sLit $ cmpxchgLabel w)
760 (MO_AtomicRead w) -> ptext (sLit $ atomicReadLabel w)
761 (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)
762 (MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w)
763
764 MO_S_QuotRem {} -> unsupported
765 MO_U_QuotRem {} -> unsupported
766 MO_U_QuotRem2 {} -> unsupported
767 MO_Add2 {} -> unsupported
768 MO_AddIntC {} -> unsupported
769 MO_SubIntC {} -> unsupported
770 MO_U_Mul2 {} -> unsupported
771 MO_Touch -> unsupported
772 (MO_Prefetch_Data _ ) -> unsupported
773 --- we could support prefetch via "__builtin_prefetch"
774 --- Not adding it for now
775 where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop
776 ++ " not supported!")
777
778 -- ---------------------------------------------------------------------
779 -- Useful #defines
780 --
781
782 mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc
783
784 mkJMP_ i = ptext (sLit "JMP_") <> parens i
785 mkFN_ i = ptext (sLit "FN_") <> parens i -- externally visible function
786 mkIF_ i = ptext (sLit "IF_") <> parens i -- locally visible
787
788
789 mkFB_, mkFE_ :: SDoc
790 mkFB_ = ptext (sLit "FB_") -- function code begin
791 mkFE_ = ptext (sLit "FE_") -- function code end
792
793 -- from includes/Stg.h
794 --
795 mkC_,mkW_,mkP_ :: SDoc
796
797 mkC_ = ptext (sLit "(C_)") -- StgChar
798 mkW_ = ptext (sLit "(W_)") -- StgWord
799 mkP_ = ptext (sLit "(P_)") -- StgWord*
800
801 -- ---------------------------------------------------------------------
802 --
803 -- Assignments
804 --
805 -- Generating assignments is what we're all about, here
806 --
807 pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc
808
809 -- dest is a reg, rhs is a reg
810 pprAssign _ r1 (CmmReg r2)
811 | isPtrReg r1 && isPtrReg r2
812 = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]
813
814 -- dest is a reg, rhs is a CmmRegOff
815 pprAssign dflags r1 (CmmRegOff r2 off)
816 | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0)
817 = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
818 where
819 off1 = off `shiftR` wordShift dflags
820
821 (op,off') | off >= 0 = (char '+', off1)
822 | otherwise = (char '-', -off1)
823
824 -- dest is a reg, rhs is anything.
825 -- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting
826 -- the lvalue elicits a warning from new GCC versions (3.4+).
827 pprAssign _ r1 r2
828 | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 r2)
829 | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)
830 | otherwise = mkAssign (pprExpr r2)
831 where mkAssign x = if r1 == CmmGlobal BaseReg
832 then ptext (sLit "ASSIGN_BaseReg") <> parens x <> semi
833 else pprReg r1 <> ptext (sLit " = ") <> x <> semi
834
835 -- ---------------------------------------------------------------------
836 -- Registers
837
838 pprCastReg :: CmmReg -> SDoc
839 pprCastReg reg
840 | isStrangeTypeReg reg = mkW_ <> pprReg reg
841 | otherwise = pprReg reg
842
843 -- True if (pprReg reg) will give an expression with type StgPtr. We
844 -- need to take care with pointer arithmetic on registers with type
845 -- StgPtr.
846 isFixedPtrReg :: CmmReg -> Bool
847 isFixedPtrReg (CmmLocal _) = False
848 isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r
849
850 -- True if (pprAsPtrReg reg) will give an expression with type StgPtr
851 -- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST.
852 -- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT;
853 -- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY.
854 isPtrReg :: CmmReg -> Bool
855 isPtrReg (CmmLocal _) = False
856 isPtrReg (CmmGlobal (VanillaReg _ VGcPtr)) = True -- if we print via pprAsPtrReg
857 isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg
858 isPtrReg (CmmGlobal reg) = isFixedPtrGlobalReg reg
859
860 -- True if this global reg has type StgPtr
861 isFixedPtrGlobalReg :: GlobalReg -> Bool
862 isFixedPtrGlobalReg Sp = True
863 isFixedPtrGlobalReg Hp = True
864 isFixedPtrGlobalReg HpLim = True
865 isFixedPtrGlobalReg SpLim = True
866 isFixedPtrGlobalReg _ = False
867
868 -- True if in C this register doesn't have the type given by
869 -- (machRepCType (cmmRegType reg)), so it has to be cast.
870 isStrangeTypeReg :: CmmReg -> Bool
871 isStrangeTypeReg (CmmLocal _) = False
872 isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g
873
874 isStrangeTypeGlobal :: GlobalReg -> Bool
875 isStrangeTypeGlobal CCCS = True
876 isStrangeTypeGlobal CurrentTSO = True
877 isStrangeTypeGlobal CurrentNursery = True
878 isStrangeTypeGlobal BaseReg = True
879 isStrangeTypeGlobal r = isFixedPtrGlobalReg r
880
881 strangeRegType :: CmmReg -> Maybe SDoc
882 strangeRegType (CmmGlobal CCCS) = Just (ptext (sLit "struct CostCentreStack_ *"))
883 strangeRegType (CmmGlobal CurrentTSO) = Just (ptext (sLit "struct StgTSO_ *"))
884 strangeRegType (CmmGlobal CurrentNursery) = Just (ptext (sLit "struct bdescr_ *"))
885 strangeRegType (CmmGlobal BaseReg) = Just (ptext (sLit "struct StgRegTable_ *"))
886 strangeRegType _ = Nothing
887
888 -- pprReg just prints the register name.
889 --
890 pprReg :: CmmReg -> SDoc
891 pprReg r = case r of
892 CmmLocal local -> pprLocalReg local
893 CmmGlobal global -> pprGlobalReg global
894
895 pprAsPtrReg :: CmmReg -> SDoc
896 pprAsPtrReg (CmmGlobal (VanillaReg n gcp))
897 = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> ptext (sLit ".p")
898 pprAsPtrReg other_reg = pprReg other_reg
899
900 pprGlobalReg :: GlobalReg -> SDoc
901 pprGlobalReg gr = case gr of
902 VanillaReg n _ -> char 'R' <> int n <> ptext (sLit ".w")
903 -- pprGlobalReg prints a VanillaReg as a .w regardless
904 -- Example: R1.w = R1.w & (-0x8UL);
905 -- JMP_(*R1.p);
906 FloatReg n -> char 'F' <> int n
907 DoubleReg n -> char 'D' <> int n
908 LongReg n -> char 'L' <> int n
909 Sp -> ptext (sLit "Sp")
910 SpLim -> ptext (sLit "SpLim")
911 Hp -> ptext (sLit "Hp")
912 HpLim -> ptext (sLit "HpLim")
913 CCCS -> ptext (sLit "CCCS")
914 CurrentTSO -> ptext (sLit "CurrentTSO")
915 CurrentNursery -> ptext (sLit "CurrentNursery")
916 HpAlloc -> ptext (sLit "HpAlloc")
917 BaseReg -> ptext (sLit "BaseReg")
918 EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
919 GCEnter1 -> ptext (sLit "stg_gc_enter_1")
920 GCFun -> ptext (sLit "stg_gc_fun")
921 other -> panic $ "pprGlobalReg: Unsupported register: " ++ show other
922
923 pprLocalReg :: LocalReg -> SDoc
924 pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
925
926 -- -----------------------------------------------------------------------------
927 -- Foreign Calls
928
929 pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
930 pprCall ppr_fn cconv results args
931 | not (is_cishCC cconv)
932 = panic $ "pprCall: unknown calling convention"
933
934 | otherwise
935 =
936 ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
937 where
938 ppr_assign [] rhs = rhs
939 ppr_assign [(one,hint)] rhs
940 = pprLocalReg one <> ptext (sLit " = ")
941 <> pprUnHint hint (localRegType one) <> rhs
942 ppr_assign _other _rhs = panic "pprCall: multiple results"
943
944 pprArg (expr, AddrHint)
945 = cCast (ptext (sLit "void *")) expr
946 -- see comment by machRepHintCType below
947 pprArg (expr, SignedHint)
948 = sdocWithDynFlags $ \dflags ->
949 cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr
950 pprArg (expr, _other)
951 = pprExpr expr
952
953 pprUnHint AddrHint rep = parens (machRepCType rep)
954 pprUnHint SignedHint rep = parens (machRepCType rep)
955 pprUnHint _ _ = empty
956
957 -- Currently we only have these two calling conventions, but this might
958 -- change in the future...
959 is_cishCC :: CCallConv -> Bool
960 is_cishCC CCallConv = True
961 is_cishCC CApiConv = True
962 is_cishCC StdCallConv = True
963 is_cishCC PrimCallConv = False
964 is_cishCC JavaScriptCallConv = False
965
966 -- ---------------------------------------------------------------------
967 -- Find and print local and external declarations for a list of
968 -- Cmm statements.
969 --
970 pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})
971 pprTempAndExternDecls stmts
972 = (vcat (map pprTempDecl (uniqSetToList temps)),
973 vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls)))
974 where (temps, lbls) = runTE (mapM_ te_BB stmts)
975
976 pprDataExterns :: [CmmStatic] -> SDoc
977 pprDataExterns statics
978 = vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls))
979 where (_, lbls) = runTE (mapM_ te_Static statics)
980
981 pprTempDecl :: LocalReg -> SDoc
982 pprTempDecl l@(LocalReg _ rep)
983 = hcat [ machRepCType rep, space, pprLocalReg l, semi ]
984
985 pprExternDecl :: Bool -> CLabel -> SDoc
986 pprExternDecl _in_srt lbl
987 -- do not print anything for "known external" things
988 | not (needsCDecl lbl) = empty
989 | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz
990 | otherwise =
991 hcat [ visibility, label_type lbl,
992 lparen, ppr lbl, text ");" ]
993 where
994 label_type lbl | isCFunctionLabel lbl = ptext (sLit "F_")
995 | otherwise = ptext (sLit "I_")
996
997 visibility
998 | externallyVisibleCLabel lbl = char 'E'
999 | otherwise = char 'I'
1000
1001 -- If the label we want to refer to is a stdcall function (on Windows) then
1002 -- we must generate an appropriate prototype for it, so that the C compiler will
1003 -- add the @n suffix to the label (#2276)
1004 stdcall_decl sz = sdocWithDynFlags $ \dflags ->
1005 ptext (sLit "extern __attribute__((stdcall)) void ") <> ppr lbl
1006 <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags))))
1007 <> semi
1008
1009 type TEState = (UniqSet LocalReg, Map CLabel ())
1010 newtype TE a = TE { unTE :: TEState -> (a, TEState) }
1011
1012 instance Functor TE where
1013 fmap = liftM
1014
1015 instance Applicative TE where
1016 pure = return
1017 (<*>) = ap
1018
1019 instance Monad TE where
1020 TE m >>= k = TE $ \s -> case m s of (a, s') -> unTE (k a) s'
1021 return a = TE $ \s -> (a, s)
1022
1023 te_lbl :: CLabel -> TE ()
1024 te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls))
1025
1026 te_temp :: LocalReg -> TE ()
1027 te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))
1028
1029 runTE :: TE () -> TEState
1030 runTE (TE m) = snd (m (emptyUniqSet, Map.empty))
1031
1032 te_Static :: CmmStatic -> TE ()
1033 te_Static (CmmStaticLit lit) = te_Lit lit
1034 te_Static _ = return ()
1035
1036 te_BB :: CmmBlock -> TE ()
1037 te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last
1038 where (_, mid, last) = blockSplit block
1039
1040 te_Lit :: CmmLit -> TE ()
1041 te_Lit (CmmLabel l) = te_lbl l
1042 te_Lit (CmmLabelOff l _) = te_lbl l
1043 te_Lit (CmmLabelDiffOff l1 _ _) = te_lbl l1
1044 te_Lit _ = return ()
1045
1046 te_Stmt :: CmmNode e x -> TE ()
1047 te_Stmt (CmmAssign r e) = te_Reg r >> te_Expr e
1048 te_Stmt (CmmStore l r) = te_Expr l >> te_Expr r
1049 te_Stmt (CmmUnsafeForeignCall target rs es)
1050 = do te_Target target
1051 mapM_ te_temp rs
1052 mapM_ te_Expr es
1053 te_Stmt (CmmCondBranch e _ _) = te_Expr e
1054 te_Stmt (CmmSwitch e _) = te_Expr e
1055 te_Stmt (CmmCall { cml_target = e }) = te_Expr e
1056 te_Stmt _ = return ()
1057
1058 te_Target :: ForeignTarget -> TE ()
1059 te_Target (ForeignTarget e _) = te_Expr e
1060 te_Target (PrimTarget{}) = return ()
1061
1062 te_Expr :: CmmExpr -> TE ()
1063 te_Expr (CmmLit lit) = te_Lit lit
1064 te_Expr (CmmLoad e _) = te_Expr e
1065 te_Expr (CmmReg r) = te_Reg r
1066 te_Expr (CmmMachOp _ es) = mapM_ te_Expr es
1067 te_Expr (CmmRegOff r _) = te_Reg r
1068 te_Expr (CmmStackSlot _ _) = panic "te_Expr: CmmStackSlot not supported!"
1069
1070 te_Reg :: CmmReg -> TE ()
1071 te_Reg (CmmLocal l) = te_temp l
1072 te_Reg _ = return ()
1073
1074
1075 -- ---------------------------------------------------------------------
1076 -- C types for MachReps
1077
1078 cCast :: SDoc -> CmmExpr -> SDoc
1079 cCast ty expr = parens ty <> pprExpr1 expr
1080
1081 cLoad :: CmmExpr -> CmmType -> SDoc
1082 cLoad expr rep
1083 = sdocWithPlatform $ \platform ->
1084 if bewareLoadStoreAlignment (platformArch platform)
1085 then let decl = machRepCType rep <+> ptext (sLit "x") <> semi
1086 struct = ptext (sLit "struct") <+> braces (decl)
1087 packed_attr = ptext (sLit "__attribute__((packed))")
1088 cast = parens (struct <+> packed_attr <> char '*')
1089 in parens (cast <+> pprExpr1 expr) <> ptext (sLit "->x")
1090 else char '*' <> parens (cCast (machRepPtrCType rep) expr)
1091 where -- On these platforms, unaligned loads are known to cause problems
1092 bewareLoadStoreAlignment ArchAlpha = True
1093 bewareLoadStoreAlignment ArchMipseb = True
1094 bewareLoadStoreAlignment ArchMipsel = True
1095 bewareLoadStoreAlignment (ArchARM {}) = True
1096 -- Pessimistically assume that they will also cause problems
1097 -- on unknown arches
1098 bewareLoadStoreAlignment ArchUnknown = True
1099 bewareLoadStoreAlignment _ = False
1100
1101 isCmmWordType :: DynFlags -> CmmType -> Bool
1102 -- True of GcPtrReg/NonGcReg of native word size
1103 isCmmWordType dflags ty = not (isFloatType ty)
1104 && typeWidth ty == wordWidth dflags
1105
1106 -- This is for finding the types of foreign call arguments. For a pointer
1107 -- argument, we always cast the argument to (void *), to avoid warnings from
1108 -- the C compiler.
1109 machRepHintCType :: CmmType -> ForeignHint -> SDoc
1110 machRepHintCType _ AddrHint = ptext (sLit "void *")
1111 machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep)
1112 machRepHintCType rep _other = machRepCType rep
1113
1114 machRepPtrCType :: CmmType -> SDoc
1115 machRepPtrCType r
1116 = sdocWithDynFlags $ \dflags ->
1117 if isCmmWordType dflags r then ptext (sLit "P_")
1118 else machRepCType r <> char '*'
1119
1120 machRepCType :: CmmType -> SDoc
1121 machRepCType ty | isFloatType ty = machRep_F_CType w
1122 | otherwise = machRep_U_CType w
1123 where
1124 w = typeWidth ty
1125
1126 machRep_F_CType :: Width -> SDoc
1127 machRep_F_CType W32 = ptext (sLit "StgFloat") -- ToDo: correct?
1128 machRep_F_CType W64 = ptext (sLit "StgDouble")
1129 machRep_F_CType _ = panic "machRep_F_CType"
1130
1131 machRep_U_CType :: Width -> SDoc
1132 machRep_U_CType w
1133 = sdocWithDynFlags $ \dflags ->
1134 case w of
1135 _ | w == wordWidth dflags -> ptext (sLit "W_")
1136 W8 -> ptext (sLit "StgWord8")
1137 W16 -> ptext (sLit "StgWord16")
1138 W32 -> ptext (sLit "StgWord32")
1139 W64 -> ptext (sLit "StgWord64")
1140 _ -> panic "machRep_U_CType"
1141
1142 machRep_S_CType :: Width -> SDoc
1143 machRep_S_CType w
1144 = sdocWithDynFlags $ \dflags ->
1145 case w of
1146 _ | w == wordWidth dflags -> ptext (sLit "I_")
1147 W8 -> ptext (sLit "StgInt8")
1148 W16 -> ptext (sLit "StgInt16")
1149 W32 -> ptext (sLit "StgInt32")
1150 W64 -> ptext (sLit "StgInt64")
1151 _ -> panic "machRep_S_CType"
1152
1153
1154 -- ---------------------------------------------------------------------
1155 -- print strings as valid C strings
1156
1157 pprStringInCStyle :: [Word8] -> SDoc
1158 pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
1159
1160 -- ---------------------------------------------------------------------------
1161 -- Initialising static objects with floating-point numbers. We can't
1162 -- just emit the floating point number, because C will cast it to an int
1163 -- by rounding it. We want the actual bit-representation of the float.
1164
1165 -- This is a hack to turn the floating point numbers into ints that we
1166 -- can safely initialise to static locations.
1167
1168 big_doubles :: DynFlags -> Bool
1169 big_doubles dflags
1170 | widthInBytes W64 == 2 * wORD_SIZE dflags = True
1171 | widthInBytes W64 == wORD_SIZE dflags = False
1172 | otherwise = panic "big_doubles"
1173
1174 castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
1175 castFloatToIntArray = U.castSTUArray
1176
1177 castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int)
1178 castDoubleToIntArray = U.castSTUArray
1179
1180 -- floats are always 1 word
1181 floatToWord :: DynFlags -> Rational -> CmmLit
1182 floatToWord dflags r
1183 = runST (do
1184 arr <- newArray_ ((0::Int),0)
1185 writeArray arr 0 (fromRational r)
1186 arr' <- castFloatToIntArray arr
1187 i <- readArray arr' 0
1188 return (CmmInt (toInteger i) (wordWidth dflags))
1189 )
1190
1191 doubleToWords :: DynFlags -> Rational -> [CmmLit]
1192 doubleToWords dflags r
1193 | big_doubles dflags -- doubles are 2 words
1194 = runST (do
1195 arr <- newArray_ ((0::Int),1)
1196 writeArray arr 0 (fromRational r)
1197 arr' <- castDoubleToIntArray arr
1198 i1 <- readArray arr' 0
1199 i2 <- readArray arr' 1
1200 return [ CmmInt (toInteger i1) (wordWidth dflags)
1201 , CmmInt (toInteger i2) (wordWidth dflags)
1202 ]
1203 )
1204 | otherwise -- doubles are 1 word
1205 = runST (do
1206 arr <- newArray_ ((0::Int),0)
1207 writeArray arr 0 (fromRational r)
1208 arr' <- castDoubleToIntArray arr
1209 i <- readArray arr' 0
1210 return [ CmmInt (toInteger i) (wordWidth dflags) ]
1211 )
1212
1213 -- ---------------------------------------------------------------------------
1214 -- Utils
1215
1216 wordShift :: DynFlags -> Int
1217 wordShift dflags = widthInLog (wordWidth dflags)
1218
1219 commafy :: [SDoc] -> SDoc
1220 commafy xs = hsep $ punctuate comma xs
1221
1222 -- Print in C hex format: 0x13fa
1223 pprHexVal :: Integer -> Width -> SDoc
1224 pprHexVal 0 _ = ptext (sLit "0x0")
1225 pprHexVal w rep
1226 | w < 0 = parens (char '-' <> ptext (sLit "0x") <> go (-w) <> repsuffix rep)
1227 | otherwise = ptext (sLit "0x") <> go w <> repsuffix rep
1228 where
1229 -- type suffix for literals:
1230 -- Integer literals are unsigned in Cmm/C. We explicitly cast to
1231 -- signed values for doing signed operations, but at all other
1232 -- times values are unsigned. This also helps eliminate occasional
1233 -- warnings about integer overflow from gcc.
1234
1235 repsuffix W64 = sdocWithDynFlags $ \dflags ->
1236 if cINT_SIZE dflags == 8 then char 'U'
1237 else if cLONG_SIZE dflags == 8 then ptext (sLit "UL")
1238 else if cLONG_LONG_SIZE dflags == 8 then ptext (sLit "ULL")
1239 else panic "pprHexVal: Can't find a 64-bit type"
1240 repsuffix _ = char 'U'
1241
1242 go 0 = empty
1243 go w' = go q <> dig
1244 where
1245 (q,r) = w' `quotRem` 16
1246 dig | r < 10 = char (chr (fromInteger r + ord '0'))
1247 | otherwise = char (chr (fromInteger r - 10 + ord 'a'))
1248