CmmToC.hs 51.2 KB
Newer Older
1
{-# LANGUAGE CPP, DeriveFunctor, GADTs, PatternSynonyms #-}
2

3 4 5 6
-----------------------------------------------------------------------------
--
-- Pretty-printing of Cmm as C, suitable for feeding gcc
--
Simon Marlow's avatar
Simon Marlow committed
7
-- (c) The University of Glasgow 2004-2006
8 9 10
--
-- Print Cmm as real C, for -fvia-C
--
11
-- See wiki:commentary/compiler/backends/ppr-c
12
--
13 14 15 16
-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"
-- relative to the old AbstractC, and many oddities/decorations have
-- disappeared from the data type.
--
dterei's avatar
dterei committed
17 18 19
-- This code generator is only supported in unregisterised mode.
--
-----------------------------------------------------------------------------
Ian Lynagh's avatar
Ian Lynagh committed
20

21
module GHC.CmmToC (
22
        writeC
23 24
  ) where

25 26
#include "HsVersions.h"

27
-- Cmm stuff
28 29
import GhcPrelude

30 31
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
32
import ForeignCall
33 34 35 36 37 38 39
import GHC.Cmm hiding (pprBBlock)
import GHC.Cmm.Ppr () -- For Outputable instances
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Utils
import GHC.Cmm.Switch
40 41

-- Utils
dterei's avatar
dterei committed
42
import CPrim
Simon Marlow's avatar
Simon Marlow committed
43
import DynFlags
44 45
import FastString
import Outputable
John Ericson's avatar
John Ericson committed
46
import GHC.Platform
dterei's avatar
dterei committed
47
import UniqSet
niteria's avatar
niteria committed
48
import UniqFM
dterei's avatar
dterei committed
49
import Unique
50
import Util
51 52

-- The rest
53 54
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
dterei's avatar
dterei committed
55
import Control.Monad.ST
Simon Marlow's avatar
Simon Marlow committed
56 57
import Data.Bits
import Data.Char
dterei's avatar
dterei committed
58
import Data.List
59
import Data.Map (Map)
Simon Marlow's avatar
Simon Marlow committed
60
import Data.Word
dterei's avatar
dterei committed
61 62
import System.IO
import qualified Data.Map as Map
63
import Control.Monad (ap)
64 65
import qualified Data.Array.Unsafe as U ( castSTUArray )
import Data.Array.ST
66

67 68 69
-- --------------------------------------------------------------------------
-- Top level

70 71
writeC :: DynFlags -> Handle -> RawCmmGroup -> IO ()
writeC dflags handle cmm = printForC dflags handle (pprC cmm $$ blankLine)
72 73 74 75 76 77 78

-- --------------------------------------------------------------------------
-- Now do some real work
--
-- for fun, we could call cmmToCmm over the tops...
--

79 80
pprC :: RawCmmGroup -> SDoc
pprC tops = vcat $ intersperse blankLine $ map pprTop tops
81 82 83

--
-- top level procs
dterei's avatar
dterei committed
84
--
85
pprTop :: RawCmmDecl -> SDoc
86
pprTop (CmmProc infos clbl _in_live_regs graph) =
87 88

    (case mapLookup (g_entry graph) infos of
89
       Nothing -> empty
90 91 92
       Just (Statics info_clbl info_dat) ->
           pprDataExterns info_dat $$
           pprWordArray info_is_in_rodata info_clbl info_dat) $$
93
    (vcat [
dterei's avatar
dterei committed
94 95
           blankLine,
           extern_decls,
96
           (if (externallyVisibleCLabel clbl)
97
                    then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,
98
           nest 8 temp_decls,
99
           vcat (map pprBBlock blocks),
100 101 102
           rbrace ]
    )
  where
103 104
        -- info tables are always in .rodata
        info_is_in_rodata = True
105
        blocks = toBlockListEntryFirst graph
106
        (temp_decls, extern_decls) = pprTempAndExternDecls blocks
107 108 109 110 111 112


-- Chunks of static data.

-- We only handle (a) arrays of word-sized things and (b) strings.

113 114
pprTop (CmmData section (Statics lbl [CmmString str])) =
  pprExternDecl lbl $$
115
  hcat [
116
    pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
117
    text "[] = ", pprStringInCStyle str, semi
118 119
  ]

120 121
pprTop (CmmData section (Statics lbl [CmmUninitialised size])) =
  pprExternDecl lbl $$
122
  hcat [
123
    pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,
124 125 126
    brackets (int size), semi
  ]

127
pprTop (CmmData section (Statics lbl lits)) =
128
  pprDataExterns lits $$
129
  pprWordArray (isSecConstant section) lbl lits
130 131 132 133 134 135 136 137

-- --------------------------------------------------------------------------
-- BasicBlocks are self-contained entities: they always end in a jump.
--
-- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn
-- as many jumps as possible into fall throughs.
--

138 139
pprBBlock :: CmmBlock -> SDoc
pprBBlock block =
Peter Wortmann's avatar
Peter Wortmann committed
140
  nest 4 (pprBlockId (entryLabel block) <> colon) $$
141 142
  nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last)
 where
Peter Wortmann's avatar
Peter Wortmann committed
143
  (_, nodes, last)  = blockSplit block
144 145

-- --------------------------------------------------------------------------
dterei's avatar
dterei committed
146
-- Info tables. Just arrays of words.
147 148
-- See codeGen/ClosureInfo, and nativeGen/PprMach

149 150
pprWordArray :: Bool -> CLabel -> [CmmStatic] -> SDoc
pprWordArray is_ro lbl ds
151
  = sdocWithDynFlags $ \dflags ->
152 153 154
    -- TODO: align closures only
    pprExternDecl lbl $$
    hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord"
155 156 157 158
         , space, ppr lbl, text "[]"
         -- See Note [StgWord alignment]
         , pprAlignment (wordWidth dflags)
         , text "= {" ]
159
    $$ nest 8 (commafy (pprStatics dflags ds))
160
    $$ text "};"
161

162 163 164 165 166 167 168 169 170 171 172 173 174 175
pprAlignment :: Width -> SDoc
pprAlignment words =
     text "__attribute__((aligned(" <> int (widthInBytes words) <> text ")))"

-- Note [StgWord alignment]
-- C codegen builds static closures as StgWord C arrays (pprWordArray).
-- Their real C type is 'StgClosure'. Macros like UNTAG_CLOSURE assume
-- pointers to 'StgClosure' are aligned at pointer size boundary:
--  4 byte boundary on 32 systems
--  and 8 bytes on 64-bit systems
-- see TAG_MASK and TAG_BITS definition and usage.
--
-- It's a reasonable assumption also known as natural alignment.
-- Although some architectures have different alignment rules.
176
-- One of known exceptions is m68k (#11395, comment:16) where:
177 178 179 180 181 182
--   __alignof__(StgWord) == 2, sizeof(StgWord) == 4
--
-- Thus we explicitly increase alignment by using
--    __attribute__((aligned(4)))
-- declaration.

183 184 185 186
--
-- has to be static, if it isn't globally visible
--
pprLocalness :: CLabel -> SDoc
187
pprLocalness lbl | not $ externallyVisibleCLabel lbl = text "static "
188 189
                 | otherwise = empty

190 191 192 193
pprConstness :: Bool -> SDoc
pprConstness is_ro | is_ro = text "const "
                   | otherwise = empty

194 195 196 197
-- --------------------------------------------------------------------------
-- Statements.
--

198
pprStmt :: CmmNode e x -> SDoc
199

200 201 202
pprStmt stmt =
    sdocWithDynFlags $ \dflags ->
    case stmt of
Peter Wortmann's avatar
Peter Wortmann committed
203
    CmmEntry{}   -> empty
204
    CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/")
Simon Marlow's avatar
Simon Marlow committed
205 206 207 208
                          -- XXX if the string contains "*/", we need to fix it
                          -- XXX we probably want to emit these comments when
                          -- some debugging option is on.  They can get quite
                          -- large.
209

Peter Wortmann's avatar
Peter Wortmann committed
210
    CmmTick _ -> empty
211
    CmmUnwind{} -> empty
Peter Wortmann's avatar
Peter Wortmann committed
212

213
    CmmAssign dest src -> pprAssign dflags dest src
214 215

    CmmStore  dest src
216
        | typeWidth rep == W64 && wordWidth dflags /= W64
217
        -> (if isFloatType rep then text "ASSIGN_DBL"
dterei's avatar
dterei committed
218
                               else ptext (sLit ("ASSIGN_Word64"))) <>
219
           parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
220

dterei's avatar
dterei committed
221
        | otherwise
222
        -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]
dterei's avatar
dterei committed
223
        where
224
          rep = cmmExprType dflags src
225

226
    CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->
dterei's avatar
dterei committed
227 228
        fnCall
        where
229 230 231 232 233 234 235
        (res_hints, arg_hints) = foreignTargetHints target
        hresults = zip results res_hints
        hargs    = zip args arg_hints

        ForeignConvention cconv _ _ ret = conv

        cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn)
236

237
        -- See wiki:commentary/compiler/backends/ppr-c#prototypes
238
        fnCall =
239
            case fn of
dterei's avatar
dterei committed
240
              CmmLit (CmmLabel lbl)
241
                | StdCallConv <- cconv ->
242
                    pprCall (ppr lbl) cconv hresults hargs
243 244 245 246 247
                        -- stdcall functions must be declared with
                        -- a function type, otherwise the C compiler
                        -- doesn't add the @n suffix to the label.  We
                        -- can't add the @n suffix ourselves, because
                        -- it isn't valid C.
248
                | CmmNeverReturns <- ret ->
249
                    pprCall cast_fn cconv hresults hargs <> semi
250
                | not (isMathFun lbl) ->
251
                    pprForeignCall (ppr lbl) cconv hresults hargs
dterei's avatar
dterei committed
252
              _ ->
253
                    pprCall cast_fn cconv hresults hargs <> semi
dterei's avatar
dterei committed
254
                        -- for a dynamic call, no declaration is necessary.
255

Simon Marlow's avatar
Simon Marlow committed
256
    CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty
257
    CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data _)) _results _args -> empty
Simon Marlow's avatar
Simon Marlow committed
258

259
    CmmUnsafeForeignCall target@(PrimTarget op) results args ->
260
        fn_call
261 262 263
      where
        cconv = CCallConv
        fn = pprCallishMachOp_for_C op
264 265 266 267 268

        (res_hints, arg_hints) = foreignTargetHints target
        hresults = zip results res_hints
        hargs    = zip args arg_hints

269
        fn_call
270
          -- The mem primops carry an extra alignment arg.
271 272 273
          -- We could maybe emit an alignment directive using this info.
          -- We also need to cast mem primops to prevent conflicts with GCC
          -- builtins (see bug #5967).
274
          | Just _align <- machOpMemcpyishAlign op
275
          = (text ";EFF_(" <> fn <> char ')' <> semi) $$
276
            pprForeignCall fn cconv hresults hargs
277
          | otherwise
278
          = pprCall fn cconv hresults hargs
279 280

    CmmBranch ident          -> pprBranch ident
281
    CmmCondBranch expr yes no _ -> pprCondBranch expr yes no
282
    CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi
283 284
    CmmSwitch arg ids        -> sdocWithDynFlags $ \dflags ->
                                pprSwitch dflags arg ids
285

Simon Marlow's avatar
Simon Marlow committed
286 287
    _other -> pprPanic "PprC.pprStmt" (ppr stmt)

288 289 290
type Hinted a = (a, ForeignHint)

pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]
291 292
               -> SDoc
pprForeignCall fn cconv results args = fn_call
293 294 295 296
  where
    fn_call = braces (
                 pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi
              $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi
297
              $$ pprCall (text "ghcFunPtr") cconv results args <> semi
298 299 300
             )
    cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)

301
pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
302
pprCFunType ppr_fn cconv ress args
303
  = sdocWithDynFlags $ \dflags ->
304
    let res_type [] = text "void"
305
        res_type [(one, hint)] = machRepHintCType (localRegType one) hint
dterei's avatar
dterei committed
306
        res_type _ = panic "pprCFunType: only void or 1 return value supported"
307

308
        arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint
309 310 311
    in res_type ress <+>
       parens (ccallConvAttribute cconv <> ppr_fn) <>
       parens (commafy (map arg_type args))
312 313 314 315

-- ---------------------------------------------------------------------
-- unconditional branches
pprBranch :: BlockId -> SDoc
316
pprBranch ident = text "goto" <+> pprBlockId ident <> semi
317 318 319 320


-- ---------------------------------------------------------------------
-- conditional branches to local labels
321 322
pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc
pprCondBranch expr yes no
323 324 325
        = hsep [ text "if" , parens(pprExpr expr) ,
                        text "goto", pprBlockId yes <> semi,
                        text "else goto", pprBlockId no <> semi ]
326 327 328 329 330 331

-- ---------------------------------------------------------------------
-- a local table branch
--
-- we find the fall-through cases
--
332 333
pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc
pprSwitch dflags e ids
334
  = (hang (text "switch" <+> parens ( pprExpr e ) <+> lbrace)
335
                4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace
336
  where
337
    (pairs, mbdef) = switchTargetsFallThrough ids
338

339 340
    -- fall through case
    caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
dterei's avatar
dterei committed
341 342
        where
        do_fallthrough ix =
343 344
                 hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,
                        text "/* fall through */" ]
345

dterei's avatar
dterei committed
346
        final_branch ix =
347 348
                hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,
                       text "goto" , (pprBlockId ident) <> semi ]
349

350 351
    caseify (_     , _    ) = panic "pprSwitch: switch with no cases!"

352
    def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi
353
        | otherwise       = empty
dterei's avatar
dterei committed
354

355 356 357 358 359 360
-- ---------------------------------------------------------------------
-- Expressions.
--

-- C Types: the invariant is that the C expression generated by
--
dterei's avatar
dterei committed
361
--      pprExpr e
362 363 364
--
-- has a type in C which is also given by
--
dterei's avatar
dterei committed
365
--      machRepCType (cmmExprType e)
366 367 368
--
-- (similar invariants apply to the rest of the pretty printer).

369 370 371
pprExpr :: CmmExpr -> SDoc
pprExpr e = case e of
    CmmLit lit -> pprLit lit
372 373


374
    CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty
375 376 377
    CmmReg reg      -> pprCastReg reg
    CmmRegOff reg 0 -> pprCastReg reg

378 379 380 381
    -- CmmRegOff is an alias of MO_Add
    CmmRegOff reg i -> sdocWithDynFlags $ \dflags ->
                       pprCastReg reg <> char '+' <>
                       pprHexVal (fromIntegral i) (wordWidth dflags)
382

383
    CmmMachOp mop args -> pprMachOpApp mop args
384

dterei's avatar
dterei committed
385 386
    CmmStackSlot _ _   -> panic "pprExpr: CmmStackSlot not supported!"

387

388 389 390
pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc
pprLoad dflags e ty
  | width == W64, wordWidth dflags /= W64
391 392
  = (if isFloatType ty then text "PK_DBL"
                       else text "PK_Word64")
393
    <> parens (mkP_ <> pprExpr1 e)
394

dterei's avatar
dterei committed
395
  | otherwise
396
  = case e of
397
        CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)
dterei's avatar
dterei committed
398
                 -> char '*' <> pprAsPtrReg r
399

400
        CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)
dterei's avatar
dterei committed
401
                      -> char '*' <> pprAsPtrReg r
402

403
        CmmRegOff r off | isPtrReg r && width == wordWidth dflags
404
                        , off `rem` wORD_SIZE dflags == 0 && not (isFloatType ty)
dterei's avatar
dterei committed
405
        -- ToDo: check that the offset is a word multiple?
406
        --       (For tagging to work, I had to avoid unaligned loads. --ARY)
407
                        -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift dflags))
408

409
        _other -> cLoad e ty
410 411 412
  where
    width = typeWidth ty

413 414 415 416
pprExpr1 :: CmmExpr -> SDoc
pprExpr1 (CmmLit lit)     = pprLit1 lit
pprExpr1 e@(CmmReg _reg)  = pprExpr e
pprExpr1 other            = parens (pprExpr other)
417 418 419 420

-- --------------------------------------------------------------------------
-- MachOp applications

421
pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc
422

423
pprMachOpApp op args
424
  | isMulMayOfloOp op
425
  = text "mulIntMayOflo" <> parens (commafy (map pprExpr args))
426
  where isMulMayOfloOp (MO_U_MulMayOflo _) = True
dterei's avatar
dterei committed
427 428
        isMulMayOfloOp (MO_S_MulMayOflo _) = True
        isMulMayOfloOp _ = False
429

430
pprMachOpApp mop args
dterei's avatar
dterei committed
431
  | Just ty <- machOpNeedsCast mop
432
  = ty <> parens (pprMachOpApp' mop args)
433
  | otherwise
434
  = pprMachOpApp' mop args
435 436 437 438 439 440 441 442 443

-- Comparisons in C have type 'int', but we want type W_ (this is what
-- resultRepOfMachOp says).  The other C operations inherit their type
-- from their operands, so no casting is required.
machOpNeedsCast :: MachOp -> Maybe SDoc
machOpNeedsCast mop
  | isComparisonMachOp mop = Just mkW_
  | otherwise              = Nothing

444 445
pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc
pprMachOpApp' mop args
446 447 448 449 450 451 452 453 454 455
 = case args of
    -- dyadic
    [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y

    -- unary
    [x]   -> pprMachOp_for_C mop <> parens (pprArg x)

    _     -> panic "PprC.pprMachOp : machop with wrong number of args"

  where
dterei's avatar
dterei committed
456
        -- Cast needed for signed integer ops
457 458 459 460
    pprArg e | signedOp    mop = sdocWithDynFlags $ \dflags ->
                                 cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e
             | needsFCasts mop = sdocWithDynFlags $ \dflags ->
                                 cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e
461
             | otherwise    = pprExpr1 e
462 463 464 465 466
    needsFCasts (MO_F_Eq _)   = False
    needsFCasts (MO_F_Ne _)   = False
    needsFCasts (MO_F_Neg _)  = True
    needsFCasts (MO_F_Quot _) = True
    needsFCasts mop  = floatComparison mop
467 468 469 470

-- --------------------------------------------------------------------------
-- Literals

471 472
pprLit :: CmmLit -> SDoc
pprLit lit = case lit of
473
    CmmInt i rep      -> pprHexVal i rep
474

475
    CmmFloat f w       -> parens (machRep_F_CType w) <> str
476
        where d = fromRational f :: Double
477 478 479
              str | isInfinite d && d < 0 = text "-INFINITY"
                  | isInfinite d          = text "INFINITY"
                  | isNaN d               = text "NAN"
480 481 482 483
                  | otherwise             = text (show d)
                -- these constants come from <math.h>
                -- see #1861

484 485
    CmmVec {} -> panic "PprC printing vector literal"

486 487
    CmmBlock bid       -> mkW_ <> pprCLabelAddr (infoTblLbl bid)
    CmmHighStackMark   -> panic "PprC printing high stack mark"
488 489
    CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl
    CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
490
    CmmLabelDiffOff clbl1 _ i _   -- non-word widths not supported via C
491
        -- WARNING:
492 493
        --  * the lit must occur in the info table clbl2
        --  * clbl1 must be an SRT, a slow entry point or a large bitmap
494 495
        -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i

dterei's avatar
dterei committed
496
    where
497
        pprCLabelAddr lbl = char '&' <> ppr lbl
498

499 500
pprLit1 :: CmmLit -> SDoc
pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
501
pprLit1 lit@(CmmLabelDiffOff _ _ _ _) = parens (pprLit lit)
502 503
pprLit1 lit@(CmmFloat _ _)    = parens (pprLit lit)
pprLit1 other = pprLit other
504 505 506 507

-- ---------------------------------------------------------------------------
-- Static data

508 509 510
pprStatics :: DynFlags -> [CmmStatic] -> [SDoc]
pprStatics _ [] = []
pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest)
511
  -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding
512
  | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest
513
  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest'
514 515 516
  -- adjacent floats aren't padded but combined into a single word
  | wORD_SIZE dflags == 8, CmmStaticLit (CmmFloat g W32) : rest' <- rest
  = pprLit1 (floatPairToWord dflags f g) : pprStatics dflags rest'
517
  | wORD_SIZE dflags == 4
518
  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest
519
  | otherwise
dterei's avatar
dterei committed
520
  = pprPanic "pprStatics: float" (vcat (map ppr' rest))
521 522
    where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags ->
                                  ppr (cmmLitType dflags l)
523
          ppr' _other           = text "bad static!"
524 525
pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest)
  = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest
526

527 528
pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest)
  | wordWidth dflags == W32
529 530 531 532 533
  = if wORDS_BIGENDIAN dflags
    then pprStatics dflags (CmmStaticLit (CmmInt q W32) :
                            CmmStaticLit (CmmInt r W32) : rest)
    else pprStatics dflags (CmmStaticLit (CmmInt r W32) :
                            CmmStaticLit (CmmInt q W32) : rest)
534
  where r = i .&. 0xffffffff
dterei's avatar
dterei committed
535
        q = i `shiftR` 32
536 537 538 539 540 541 542 543
pprStatics dflags (CmmStaticLit (CmmInt a W32) :
                   CmmStaticLit (CmmInt b W32) : rest)
  | wordWidth dflags == W64
  = if wORDS_BIGENDIAN dflags
    then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) :
                            rest)
    else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) :
                            rest)
544 545 546 547 548 549 550 551
pprStatics dflags (CmmStaticLit (CmmInt a W16) :
                   CmmStaticLit (CmmInt b W16) : rest)
  | wordWidth dflags == W32
  = if wORDS_BIGENDIAN dflags
    then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) :
                            rest)
    else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) :
                            rest)
552 553
pprStatics dflags (CmmStaticLit (CmmInt _ w) : _)
  | w /= wordWidth dflags
554
  = pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w)
555 556 557
pprStatics dflags (CmmStaticLit lit : rest)
  = pprLit1 lit : pprStatics dflags rest
pprStatics _ (other : _)
558
  = pprPanic "pprStatics: other" (pprStatic other)
559

560 561
pprStatic :: CmmStatic -> SDoc
pprStatic s = case s of
562

563
    CmmStaticLit lit   -> nest 4 (pprLit lit)
564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581
    CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))

    -- these should be inlined, like the old .hc
    CmmString s'       -> nest 4 (mkW_ <> parens(pprStringInCStyle s'))


-- ---------------------------------------------------------------------------
-- Block Ids

pprBlockId :: BlockId -> SDoc
pprBlockId b = char '_' <> ppr (getUnique b)

-- --------------------------------------------------------------------------
-- Print a MachOp in a way suitable for emitting via C.
--

pprMachOp_for_C :: MachOp -> SDoc

dterei's avatar
dterei committed
582
pprMachOp_for_C mop = case mop of
583 584 585 586

        -- Integer operations
        MO_Add          _ -> char '+'
        MO_Sub          _ -> char '-'
587 588
        MO_Eq           _ -> text "=="
        MO_Ne           _ -> text "!="
589 590 591 592 593 594 595 596 597
        MO_Mul          _ -> char '*'

        MO_S_Quot       _ -> char '/'
        MO_S_Rem        _ -> char '%'
        MO_S_Neg        _ -> char '-'

        MO_U_Quot       _ -> char '/'
        MO_U_Rem        _ -> char '%'

598 599 600 601 602 603 604 605
        -- & Floating-point operations
        MO_F_Add        _ -> char '+'
        MO_F_Sub        _ -> char '-'
        MO_F_Neg        _ -> char '-'
        MO_F_Mul        _ -> char '*'
        MO_F_Quot       _ -> char '/'

        -- Signed comparisons
606 607
        MO_S_Ge         _ -> text ">="
        MO_S_Le         _ -> text "<="
608 609 610
        MO_S_Gt         _ -> char '>'
        MO_S_Lt         _ -> char '<'

611
        -- & Unsigned comparisons
612 613
        MO_U_Ge         _ -> text ">="
        MO_U_Le         _ -> text "<="
614 615 616
        MO_U_Gt         _ -> char '>'
        MO_U_Lt         _ -> char '<'

617
        -- & Floating-point comparisons
618 619 620 621
        MO_F_Eq         _ -> text "=="
        MO_F_Ne         _ -> text "!="
        MO_F_Ge         _ -> text ">="
        MO_F_Le         _ -> text "<="
622 623 624
        MO_F_Gt         _ -> char '>'
        MO_F_Lt         _ -> char '<'

625 626 627 628 629 630
        -- Bitwise operations.  Not all of these may be supported at all
        -- sizes, and only integral MachReps are valid.
        MO_And          _ -> char '&'
        MO_Or           _ -> char '|'
        MO_Xor          _ -> char '^'
        MO_Not          _ -> char '~'
631 632 633
        MO_Shl          _ -> text "<<"
        MO_U_Shr        _ -> text ">>" -- unsigned shift right
        MO_S_Shr        _ -> text ">>" -- signed shift right
634

635 636
-- Conversions.  Some of these will be NOPs, but never those that convert
-- between ints and floats.
637 638 639 640 641
-- Floating-point conversions use the signed variant.
-- We won't know to generate (void*) casts here, but maybe from
-- context elsewhere

-- noop casts
642
        MO_UU_Conv from to | from == to -> empty
643
        MO_UU_Conv _from to -> parens (machRep_U_CType to)
644 645

        MO_SS_Conv from to | from == to -> empty
646 647
        MO_SS_Conv _from to -> parens (machRep_S_CType to)

Michal Terepeta's avatar
Michal Terepeta committed
648 649 650
        MO_XX_Conv from to | from == to -> empty
        MO_XX_Conv _from to -> parens (machRep_U_CType to)

651 652 653 654 655
        MO_FF_Conv from to | from == to -> empty
        MO_FF_Conv _from to -> parens (machRep_F_CType to)

        MO_SF_Conv _from to -> parens (machRep_F_CType to)
        MO_FS_Conv _from to -> parens (machRep_S_CType to)
656

657
        MO_S_MulMayOflo _ -> pprTrace "offending mop:"
658
                                (text "MO_S_MulMayOflo")
659 660 661
                                (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo"
                                      ++ " should have been handled earlier!")
        MO_U_MulMayOflo _ -> pprTrace "offending mop:"
662
                                (text "MO_U_MulMayOflo")
663 664
                                (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo"
                                      ++ " should have been handled earlier!")
665

666
        MO_V_Insert {}    -> pprTrace "offending mop:"
667
                                (text "MO_V_Insert")
668 669 670
                                (panic $ "PprC.pprMachOp_for_C: MO_V_Insert"
                                      ++ " should have been handled earlier!")
        MO_V_Extract {}   -> pprTrace "offending mop:"
671
                                (text "MO_V_Extract")
672 673
                                (panic $ "PprC.pprMachOp_for_C: MO_V_Extract"
                                      ++ " should have been handled earlier!")
674 675

        MO_V_Add {}       -> pprTrace "offending mop:"
676
                                (text "MO_V_Add")
677 678 679
                                (panic $ "PprC.pprMachOp_for_C: MO_V_Add"
                                      ++ " should have been handled earlier!")
        MO_V_Sub {}       -> pprTrace "offending mop:"
680
                                (text "MO_V_Sub")
681 682 683
                                (panic $ "PprC.pprMachOp_for_C: MO_V_Sub"
                                      ++ " should have been handled earlier!")
        MO_V_Mul {}       -> pprTrace "offending mop:"
684
                                (text "MO_V_Mul")
685 686 687 688
                                (panic $ "PprC.pprMachOp_for_C: MO_V_Mul"
                                      ++ " should have been handled earlier!")

        MO_VS_Quot {}     -> pprTrace "offending mop:"
689
                                (text "MO_VS_Quot")
690 691 692
                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot"
                                      ++ " should have been handled earlier!")
        MO_VS_Rem {}      -> pprTrace "offending mop:"
693
                                (text "MO_VS_Rem")
694 695 696
                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem"
                                      ++ " should have been handled earlier!")
        MO_VS_Neg {}      -> pprTrace "offending mop:"
697
                                (text "MO_VS_Neg")
698 699
                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg"
                                      ++ " should have been handled earlier!")
700

701
        MO_VU_Quot {}     -> pprTrace "offending mop:"
702
                                (text "MO_VU_Quot")
703 704 705
                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot"
                                      ++ " should have been handled earlier!")
        MO_VU_Rem {}      -> pprTrace "offending mop:"
706
                                (text "MO_VU_Rem")
707 708 709
                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem"
                                      ++ " should have been handled earlier!")

710
        MO_VF_Insert {}   -> pprTrace "offending mop:"
711
                                (text "MO_VF_Insert")
712 713 714
                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert"
                                      ++ " should have been handled earlier!")
        MO_VF_Extract {}  -> pprTrace "offending mop:"
715
                                (text "MO_VF_Extract")
716 717
                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract"
                                      ++ " should have been handled earlier!")
718 719

        MO_VF_Add {}      -> pprTrace "offending mop:"
720
                                (text "MO_VF_Add")
721 722 723
                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Add"
                                      ++ " should have been handled earlier!")
        MO_VF_Sub {}      -> pprTrace "offending mop:"
724
                                (text "MO_VF_Sub")
725 726 727
                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub"
                                      ++ " should have been handled earlier!")
        MO_VF_Neg {}      -> pprTrace "offending mop:"
728
                                (text "MO_VF_Neg")
729 730 731
                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg"
                                      ++ " should have been handled earlier!")
        MO_VF_Mul {}      -> pprTrace "offending mop:"
732
                                (text "MO_VF_Mul")
733 734 735
                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul"
                                      ++ " should have been handled earlier!")
        MO_VF_Quot {}     -> pprTrace "offending mop:"
736
                                (text "MO_VF_Quot")
737 738 739
                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot"
                                      ++ " should have been handled earlier!")

Ben Gamari's avatar
Ben Gamari committed
740 741
        MO_AlignmentCheck {} -> panic "-falignment-santisation not supported by unregisterised backend"

dterei's avatar
dterei committed
742
signedOp :: MachOp -> Bool      -- Argument type(s) are signed ints
dterei's avatar
dterei committed
743 744 745 746 747 748 749 750
signedOp (MO_S_Quot _)    = True
signedOp (MO_S_Rem  _)    = True
signedOp (MO_S_Neg  _)    = True
signedOp (MO_S_Ge   _)    = True
signedOp (MO_S_Le   _)    = True
signedOp (MO_S_Gt   _)    = True
signedOp (MO_S_Lt   _)    = True
signedOp (MO_S_Shr  _)    = True
751 752
signedOp (MO_SS_Conv _ _) = True
signedOp (MO_SF_Conv _ _) = True
dterei's avatar
dterei committed
753
signedOp _                = False
754

755
floatComparison :: MachOp -> Bool  -- comparison between float args
dterei's avatar
dterei committed
756 757 758 759 760 761 762
floatComparison (MO_F_Eq   _) = True
floatComparison (MO_F_Ne   _) = True
floatComparison (MO_F_Ge   _) = True
floatComparison (MO_F_Le   _) = True
floatComparison (MO_F_Gt   _) = True
floatComparison (MO_F_Lt   _) = True
floatComparison _             = False
763

764 765 766 767 768
-- ---------------------------------------------------------------------
-- tend to be implemented by foreign calls

pprCallishMachOp_for_C :: CallishMachOp -> SDoc

dterei's avatar
dterei committed
769
pprCallishMachOp_for_C mop
770
    = case mop of
771 772 773 774 775 776 777 778 779
        MO_F64_Pwr      -> text "pow"
        MO_F64_Sin      -> text "sin"
        MO_F64_Cos      -> text "cos"
        MO_F64_Tan      -> text "tan"
        MO_F64_Sinh     -> text "sinh"
        MO_F64_Cosh     -> text "cosh"
        MO_F64_Tanh     -> text "tanh"
        MO_F64_Asin     -> text "asin"
        MO_F64_Acos     -> text "acos"
780 781 782
        MO_F64_Atanh    -> text "atanh"
        MO_F64_Asinh    -> text "asinh"
        MO_F64_Acosh    -> text "acosh"
783 784
        MO_F64_Atan     -> text "atan"
        MO_F64_Log      -> text "log"
chessai's avatar
chessai committed
785
        MO_F64_Log1P    -> text "log1p"
786
        MO_F64_Exp      -> text "exp"
chessai's avatar
chessai committed
787
        MO_F64_ExpM1    -> text "expm1"
788
        MO_F64_Sqrt     -> text "sqrt"
789
        MO_F64_Fabs     -> text "fabs"
790 791 792 793 794 795 796 797 798 799
        MO_F32_Pwr      -> text "powf"
        MO_F32_Sin      -> text "sinf"
        MO_F32_Cos      -> text "cosf"
        MO_F32_Tan      -> text "tanf"
        MO_F32_Sinh     -> text "sinhf"
        MO_F32_Cosh     -> text "coshf"
        MO_F32_Tanh     -> text "tanhf"
        MO_F32_Asin     -> text "asinf"
        MO_F32_Acos     -> text "acosf"
        MO_F32_Atan     -> text "atanf"
800 801 802
        MO_F32_Asinh    -> text "asinhf"
        MO_F32_Acosh    -> text "acoshf"
        MO_F32_Atanh    -> text "atanhf"
803
        MO_F32_Log      -> text "logf"
chessai's avatar
chessai committed
804
        MO_F32_Log1P    -> text "log1pf"
805
        MO_F32_Exp      -> text "expf"
chessai's avatar
chessai committed
806
        MO_F32_ExpM1    -> text "expm1f"
807
        MO_F32_Sqrt     -> text "sqrtf"
808
        MO_F32_Fabs     -> text "fabsf"
809
        MO_ReadBarrier  -> text "load_load_barrier"
810 811 812 813
        MO_WriteBarrier -> text "write_barrier"
        MO_Memcpy _     -> text "memcpy"
        MO_Memset _     -> text "memset"
        MO_Memmove _    -> text "memmove"
814
        MO_Memcmp _     -> text "memcmp"
815
        (MO_BSwap w)    -> ptext (sLit $ bSwapLabel w)
816
        (MO_BRev w)     -> ptext (sLit $ bRevLabel w)
dterei's avatar
dterei committed
817
        (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)
818 819
        (MO_Pext w)     -> ptext (sLit $ pextLabel w)
        (MO_Pdep w)     -> ptext (sLit $ pdepLabel w)
820 821
        (MO_Clz w)      -> ptext (sLit $ clzLabel w)
        (MO_Ctz w)      -> ptext (sLit $ ctzLabel w)
822 823 824 825
        (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)
        (MO_Cmpxchg w)  -> ptext (sLit $ cmpxchgLabel w)
        (MO_AtomicRead w)  -> ptext (sLit $ atomicReadLabel w)
        (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)
tibbe's avatar
tibbe committed
826
        (MO_UF_Conv w)  -> ptext (sLit $ word2FloatLabel w)
dterei's avatar
dterei committed
827

Sylvain Henry's avatar
Sylvain Henry committed
828
        MO_S_Mul2     {} -> unsupported
Ian Lynagh's avatar
Ian Lynagh committed
829 830 831 832
        MO_S_QuotRem  {} -> unsupported
        MO_U_QuotRem  {} -> unsupported
        MO_U_QuotRem2 {} -> unsupported
        MO_Add2       {} -> unsupported
Sebastian Graf's avatar
Sebastian Graf committed
833
        MO_AddWordC   {} -> unsupported
nkaretnikov's avatar
nkaretnikov committed
834
        MO_SubWordC   {} -> unsupported
835 836
        MO_AddIntC    {} -> unsupported
        MO_SubIntC    {} -> unsupported
Ian Lynagh's avatar
Ian Lynagh committed
837 838
        MO_U_Mul2     {} -> unsupported
        MO_Touch         -> unsupported
839 840 841
        (MO_Prefetch_Data _ ) -> unsupported
        --- we could support prefetch via "__builtin_prefetch"
        --- Not adding it for now
842 843
    where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop
                            ++ " not supported!")
844 845 846 847 848 849 850

-- ---------------------------------------------------------------------
-- Useful #defines
--

mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc

851 852 853
mkJMP_ i = text "JMP_" <> parens i
mkFN_  i = text "FN_"  <> parens i -- externally visible function
mkIF_  i = text "IF_"  <> parens i -- locally visible
854 855 856

-- from includes/Stg.h
--
Simon Marlow's avatar
Simon Marlow committed
857
mkC_,mkW_,mkP_ :: SDoc
858

859 860 861
mkC_  = text "(C_)"        -- StgChar
mkW_  = text "(W_)"        -- StgWord
mkP_  = text "(P_)"        -- StgWord*