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