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