{-# LANGUAGE CPP, GADTs #-}

-----------------------------------------------------------------------------
--
-- Pretty-printing of Cmm as C, suitable for feeding gcc
--
-- (c) The University of Glasgow 2004-2006
--
-- Print Cmm as real C, for -fvia-C
--
-- See wiki:Commentary/Compiler/Backends/PprC
--
-- 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.
--
-- This code generator is only supported in unregisterised mode.
--
-----------------------------------------------------------------------------

module PprC (
        writeCs,
        pprStringInCStyle
  ) where

#include "GhclibHsVersions.h"

-- Cmm stuff
import GhcPrelude

import BlockId
import CLabel
import ForeignCall
import Cmm hiding (pprBBlock)
import PprCmm ()
import Hoopl.Block
import Hoopl.Collections
import Hoopl.Graph
import CmmUtils
import CmmSwitch

-- Utils
import CPrim
import DynFlags
import FastString
import Outputable
import Platform
import UniqSet
import UniqFM
import Unique
import Util

-- The rest
import Control.Monad.ST
import Data.Bits
import Data.Char
import Data.List
import Data.Map (Map)
import Data.Word
import System.IO
import qualified Data.Map as Map
import Control.Monad (liftM, ap)
import qualified Data.Array.Unsafe as U ( castSTUArray )
import Data.Array.ST

-- --------------------------------------------------------------------------
-- Top level

pprCs :: [RawCmmGroup] -> SDoc
pprCs :: [RawCmmGroup] -> SDoc
pprCs [RawCmmGroup]
cmms
 = CodeStyle -> SDoc -> SDoc
pprCode CodeStyle
CStyle ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (RawCmmGroup -> SDoc) -> [RawCmmGroup] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map RawCmmGroup -> SDoc
pprC [RawCmmGroup]
cmms)

writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO ()
writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO ()
writeCs DynFlags
dflags Handle
handle [RawCmmGroup]
cmms
  = DynFlags -> Handle -> SDoc -> IO ()
printForC DynFlags
dflags Handle
handle ([RawCmmGroup] -> SDoc
pprCs [RawCmmGroup]
cmms)

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

pprC :: RawCmmGroup -> SDoc
pprC :: RawCmmGroup -> SDoc
pprC RawCmmGroup
tops = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse SDoc
blankLine ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (RawCmmDecl -> SDoc) -> RawCmmGroup -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map RawCmmDecl -> SDoc
pprTop RawCmmGroup
tops

--
-- top level procs
--
pprTop :: RawCmmDecl -> SDoc
pprTop :: RawCmmDecl -> SDoc
pprTop (CmmProc LabelMap CmmStatics
infos CLabel
clbl [GlobalReg]
_in_live_regs CmmGraph
graph) =

    (case KeyOf LabelMap -> LabelMap CmmStatics -> Maybe CmmStatics
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (CmmGraph -> BlockId
forall (n :: * -> * -> *). GenCmmGraph n -> BlockId
g_entry CmmGraph
graph) LabelMap CmmStatics
infos of
       Maybe CmmStatics
Nothing -> SDoc
empty
       Just (Statics CLabel
info_clbl [CmmStatic]
info_dat) ->
           [CmmStatic] -> SDoc
pprDataExterns [CmmStatic]
info_dat SDoc -> SDoc -> SDoc
$$
           Bool -> CLabel -> [CmmStatic] -> SDoc
pprWordArray Bool
info_is_in_rodata CLabel
info_clbl [CmmStatic]
info_dat) SDoc -> SDoc -> SDoc
$$
    ([SDoc] -> SDoc
vcat [
           SDoc
blankLine,
           SDoc
extern_decls,
           (if (CLabel -> Bool
externallyVisibleCLabel CLabel
clbl)
                    then SDoc -> SDoc
mkFN_ else SDoc -> SDoc
mkIF_) (CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
clbl) SDoc -> SDoc -> SDoc
<+> SDoc
lbrace,
           Int -> SDoc -> SDoc
nest Int
8 SDoc
temp_decls,
           [SDoc] -> SDoc
vcat ((CmmBlock -> SDoc) -> [CmmBlock] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CmmBlock -> SDoc
pprBBlock [CmmBlock]
blocks),
           SDoc
rbrace ]
    )
  where
        -- info tables are always in .rodata
        info_is_in_rodata :: Bool
info_is_in_rodata = Bool
True
        blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
toBlockListEntryFirst CmmGraph
graph
        (SDoc
temp_decls, SDoc
extern_decls) = [CmmBlock] -> (SDoc, SDoc)
pprTempAndExternDecls [CmmBlock]
blocks


-- Chunks of static data.

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

pprTop (CmmData Section
section (Statics CLabel
lbl [CmmString [Word8]
str])) =
  CLabel -> SDoc
pprExternDecl CLabel
lbl SDoc -> SDoc -> SDoc
$$
  [SDoc] -> SDoc
hcat [
    CLabel -> SDoc
pprLocalness CLabel
lbl, Bool -> SDoc
pprConstness (Section -> Bool
isSecConstant Section
section), String -> SDoc
text String
"char ", CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl,
    String -> SDoc
text String
"[] = ", [Word8] -> SDoc
pprStringInCStyle [Word8]
str, SDoc
semi
  ]

pprTop (CmmData Section
section (Statics CLabel
lbl [CmmUninitialised Int
size])) =
  CLabel -> SDoc
pprExternDecl CLabel
lbl SDoc -> SDoc -> SDoc
$$
  [SDoc] -> SDoc
hcat [
    CLabel -> SDoc
pprLocalness CLabel
lbl, Bool -> SDoc
pprConstness (Section -> Bool
isSecConstant Section
section), String -> SDoc
text String
"char ", CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl,
    SDoc -> SDoc
brackets (Int -> SDoc
int Int
size), SDoc
semi
  ]

pprTop (CmmData Section
section (Statics CLabel
lbl [CmmStatic]
lits)) =
  [CmmStatic] -> SDoc
pprDataExterns [CmmStatic]
lits SDoc -> SDoc -> SDoc
$$
  Bool -> CLabel -> [CmmStatic] -> SDoc
pprWordArray (Section -> Bool
isSecConstant Section
section) CLabel
lbl [CmmStatic]
lits

-- --------------------------------------------------------------------------
-- 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.
--

pprBBlock :: CmmBlock -> SDoc
pprBBlock :: CmmBlock -> SDoc
pprBBlock CmmBlock
block =
  Int -> SDoc -> SDoc
nest Int
4 (BlockId -> SDoc
pprBlockId (CmmBlock -> BlockId
forall (thing :: * -> * -> *) x.
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
block) SDoc -> SDoc -> SDoc
<> SDoc
colon) SDoc -> SDoc -> SDoc
$$
  Int -> SDoc -> SDoc
nest Int
8 ([SDoc] -> SDoc
vcat ((CmmNode O O -> SDoc) -> [CmmNode O O] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CmmNode O O -> SDoc
forall e x. CmmNode e x -> SDoc
pprStmt (Block CmmNode O O -> [CmmNode O O]
forall (n :: * -> * -> *). Block n O O -> [n O O]
blockToList Block CmmNode O O
nodes)) SDoc -> SDoc -> SDoc
$$ CmmNode O C -> SDoc
forall e x. CmmNode e x -> SDoc
pprStmt CmmNode O C
last)
 where
  (CmmNode C O
_, Block CmmNode O O
nodes, CmmNode O C
last)  = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: * -> * -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block

-- --------------------------------------------------------------------------
-- Info tables. Just arrays of words.
-- See codeGen/ClosureInfo, and nativeGen/PprMach

pprWordArray :: Bool -> CLabel -> [CmmStatic] -> SDoc
pprWordArray :: Bool -> CLabel -> [CmmStatic] -> SDoc
pprWordArray Bool
is_ro CLabel
lbl [CmmStatic]
ds
  = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
    -- TODO: align closures only
    CLabel -> SDoc
pprExternDecl CLabel
lbl SDoc -> SDoc -> SDoc
$$
    [SDoc] -> SDoc
hcat [ CLabel -> SDoc
pprLocalness CLabel
lbl, Bool -> SDoc
pprConstness Bool
is_ro, String -> SDoc
text String
"StgWord"
         , SDoc
space, CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl, String -> SDoc
text String
"[]"
         -- See Note [StgWord alignment]
         , Width -> SDoc
pprAlignment (DynFlags -> Width
wordWidth DynFlags
dflags)
         , String -> SDoc
text String
"= {" ]
    SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
8 ([SDoc] -> SDoc
commafy (DynFlags -> [CmmStatic] -> [SDoc]
pprStatics DynFlags
dflags [CmmStatic]
ds))
    SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"};"

pprAlignment :: Width -> SDoc
pprAlignment :: Width -> SDoc
pprAlignment Width
words =
     String -> SDoc
text String
"__attribute__((aligned(" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int (Width -> Int
widthInBytes Width
words) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
")))"

-- 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.
-- One of known exceptions is m68k (Trac #11395, comment:16) where:
--   __alignof__(StgWord) == 2, sizeof(StgWord) == 4
--
-- Thus we explicitly increase alignment by using
--    __attribute__((aligned(4)))
-- declaration.

--
-- has to be static, if it isn't globally visible
--
pprLocalness :: CLabel -> SDoc
pprLocalness :: CLabel -> SDoc
pprLocalness CLabel
lbl | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CLabel -> Bool
externallyVisibleCLabel CLabel
lbl = String -> SDoc
text String
"static "
                 | Bool
otherwise = SDoc
empty

pprConstness :: Bool -> SDoc
pprConstness :: Bool -> SDoc
pprConstness Bool
is_ro | Bool
is_ro = String -> SDoc
text String
"const "
                   | Bool
otherwise = SDoc
empty

-- --------------------------------------------------------------------------
-- Statements.
--

pprStmt :: CmmNode e x -> SDoc

pprStmt :: CmmNode e x -> SDoc
pprStmt CmmNode e x
stmt =
    (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
    case CmmNode e x
stmt of
    CmmEntry{}   -> SDoc
empty
    CmmComment FastString
_ -> SDoc
empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/")
                          -- 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.

    CmmTick CmmTickish
_ -> SDoc
empty
    CmmUnwind{} -> SDoc
empty

    CmmAssign CmmReg
dest CmmExpr
src -> DynFlags -> CmmReg -> CmmExpr -> SDoc
pprAssign DynFlags
dflags CmmReg
dest CmmExpr
src

    CmmStore  CmmExpr
dest CmmExpr
src
        | CmmType -> Width
typeWidth CmmType
rep Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 Bool -> Bool -> Bool
&& DynFlags -> Width
wordWidth DynFlags
dflags Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
/= Width
W64
        -> (if CmmType -> Bool
isFloatType CmmType
rep then String -> SDoc
text String
"ASSIGN_DBL"
                               else PtrString -> SDoc
ptext (String -> PtrString
sLit (String
"ASSIGN_Word64"))) SDoc -> SDoc -> SDoc
<>
           SDoc -> SDoc
parens (SDoc
mkP_ SDoc -> SDoc -> SDoc
<> CmmExpr -> SDoc
pprExpr1 CmmExpr
dest SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<> CmmExpr -> SDoc
pprExpr CmmExpr
src) SDoc -> SDoc -> SDoc
<> SDoc
semi

        | Bool
otherwise
        -> [SDoc] -> SDoc
hsep [ CmmExpr -> SDoc
pprExpr (CmmExpr -> CmmType -> CmmExpr
CmmLoad CmmExpr
dest CmmType
rep), SDoc
equals, CmmExpr -> SDoc
pprExpr CmmExpr
src SDoc -> SDoc -> SDoc
<> SDoc
semi ]
        where
          rep :: CmmType
rep = DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
src

    CmmUnsafeForeignCall target :: ForeignTarget
target@(ForeignTarget CmmExpr
fn ForeignConvention
conv) [CmmFormal]
results [CmmExpr]
args ->
        SDoc
fnCall
        where
        ([ForeignHint]
res_hints, [ForeignHint]
arg_hints) = ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints ForeignTarget
target
        hresults :: [(CmmFormal, ForeignHint)]
hresults = [CmmFormal] -> [ForeignHint] -> [(CmmFormal, ForeignHint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CmmFormal]
results [ForeignHint]
res_hints
        hargs :: [(CmmExpr, ForeignHint)]
hargs    = [CmmExpr] -> [ForeignHint] -> [(CmmExpr, ForeignHint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CmmExpr]
args [ForeignHint]
arg_hints

        ForeignConvention CCallConv
cconv [ForeignHint]
_ [ForeignHint]
_ CmmReturnInfo
ret = ForeignConvention
conv

        cast_fn :: SDoc
cast_fn = SDoc -> SDoc
parens (SDoc -> CmmExpr -> SDoc
cCast (SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCFunType (Char -> SDoc
char Char
'*') CCallConv
cconv [(CmmFormal, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs) CmmExpr
fn)

        -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
        fnCall :: SDoc
fnCall =
            case CmmExpr
fn of
              CmmLit (CmmLabel CLabel
lbl)
                | CCallConv
StdCallConv <- CCallConv
cconv ->
                    SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCall (CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl) CCallConv
cconv [(CmmFormal, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs
                        -- 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.
                | CmmReturnInfo
CmmNeverReturns <- CmmReturnInfo
ret ->
                    SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCall SDoc
cast_fn CCallConv
cconv [(CmmFormal, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs SDoc -> SDoc -> SDoc
<> SDoc
semi
                | Bool -> Bool
not (CLabel -> Bool
isMathFun CLabel
lbl) ->
                    SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprForeignCall (CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl) CCallConv
cconv [(CmmFormal, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs
              CmmExpr
_ ->
                    SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCall SDoc
cast_fn CCallConv
cconv [(CmmFormal, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs SDoc -> SDoc -> SDoc
<> SDoc
semi
                        -- for a dynamic call, no declaration is necessary.

    CmmUnsafeForeignCall (PrimTarget CallishMachOp
MO_Touch) [CmmFormal]
_results [CmmExpr]
_args -> SDoc
empty
    CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data Int
_)) [CmmFormal]
_results [CmmExpr]
_args -> SDoc
empty

    CmmUnsafeForeignCall target :: ForeignTarget
target@(PrimTarget CallishMachOp
op) [CmmFormal]
results [CmmExpr]
args ->
        SDoc
fn_call
      where
        cconv :: CCallConv
cconv = CCallConv
CCallConv
        fn :: SDoc
fn = CallishMachOp -> SDoc
pprCallishMachOp_for_C CallishMachOp
op

        ([ForeignHint]
res_hints, [ForeignHint]
arg_hints) = ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints ForeignTarget
target
        hresults :: [(CmmFormal, ForeignHint)]
hresults = [CmmFormal] -> [ForeignHint] -> [(CmmFormal, ForeignHint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CmmFormal]
results [ForeignHint]
res_hints
        hargs :: [(CmmExpr, ForeignHint)]
hargs    = [CmmExpr] -> [ForeignHint] -> [(CmmExpr, ForeignHint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [CmmExpr]
args [ForeignHint]
arg_hints

        fn_call :: SDoc
fn_call
          -- The mem primops carry an extra alignment arg.
          -- 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).
          | Just Int
_align <- CallishMachOp -> Maybe Int
machOpMemcpyishAlign CallishMachOp
op
          = (String -> SDoc
text String
";EFF_(" SDoc -> SDoc -> SDoc
<> SDoc
fn SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
')' SDoc -> SDoc -> SDoc
<> SDoc
semi) SDoc -> SDoc -> SDoc
$$
            SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprForeignCall SDoc
fn CCallConv
cconv [(CmmFormal, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs
          | Bool
otherwise
          = SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCall SDoc
fn CCallConv
cconv [(CmmFormal, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs

    CmmBranch BlockId
ident          -> BlockId -> SDoc
pprBranch BlockId
ident
    CmmCondBranch CmmExpr
expr BlockId
yes BlockId
no Maybe Bool
_ -> CmmExpr -> BlockId -> BlockId -> SDoc
pprCondBranch CmmExpr
expr BlockId
yes BlockId
no
    CmmCall { cml_target :: CmmNode O C -> CmmExpr
cml_target = CmmExpr
expr } -> SDoc -> SDoc
mkJMP_ (CmmExpr -> SDoc
pprExpr CmmExpr
expr) SDoc -> SDoc -> SDoc
<> SDoc
semi
    CmmSwitch CmmExpr
arg SwitchTargets
ids        -> (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
                                DynFlags -> CmmExpr -> SwitchTargets -> SDoc
pprSwitch DynFlags
dflags CmmExpr
arg SwitchTargets
ids

    CmmNode e x
_other -> String -> SDoc -> SDoc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"PprC.pprStmt" (CmmNode e x -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmNode e x
stmt)

type Hinted a = (a, ForeignHint)

pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]
               -> SDoc
pprForeignCall :: SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprForeignCall SDoc
fn CCallConv
cconv [(CmmFormal, ForeignHint)]
results [(CmmExpr, ForeignHint)]
args = SDoc
fn_call
  where
    fn_call :: SDoc
fn_call = SDoc -> SDoc
braces (
                 SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCFunType (Char -> SDoc
char Char
'*' SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"ghcFunPtr") CCallConv
cconv [(CmmFormal, ForeignHint)]
results [(CmmExpr, ForeignHint)]
args SDoc -> SDoc -> SDoc
<> SDoc
semi
              SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"ghcFunPtr" SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> SDoc
cast_fn SDoc -> SDoc -> SDoc
<> SDoc
semi
              SDoc -> SDoc -> SDoc
$$ SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCall (String -> SDoc
text String
"ghcFunPtr") CCallConv
cconv [(CmmFormal, ForeignHint)]
results [(CmmExpr, ForeignHint)]
args SDoc -> SDoc -> SDoc
<> SDoc
semi
             )
    cast_fn :: SDoc
cast_fn = SDoc -> SDoc
parens (SDoc -> SDoc
parens (SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCFunType (Char -> SDoc
char Char
'*') CCallConv
cconv [(CmmFormal, ForeignHint)]
results [(CmmExpr, ForeignHint)]
args) SDoc -> SDoc -> SDoc
<> SDoc
fn)

pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
pprCFunType :: SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCFunType SDoc
ppr_fn CCallConv
cconv [(CmmFormal, ForeignHint)]
ress [(CmmExpr, ForeignHint)]
args
  = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
    let res_type :: [(CmmFormal, ForeignHint)] -> SDoc
res_type [] = String -> SDoc
text String
"void"
        res_type [(CmmFormal
one, ForeignHint
hint)] = CmmType -> ForeignHint -> SDoc
machRepHintCType (CmmFormal -> CmmType
localRegType CmmFormal
one) ForeignHint
hint
        res_type [(CmmFormal, ForeignHint)]
_ = String -> SDoc
forall a. String -> a
panic String
"pprCFunType: only void or 1 return value supported"

        arg_type :: (CmmExpr, ForeignHint) -> SDoc
arg_type (CmmExpr
expr, ForeignHint
hint) = CmmType -> ForeignHint -> SDoc
machRepHintCType (DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
expr) ForeignHint
hint
    in [(CmmFormal, ForeignHint)] -> SDoc
res_type [(CmmFormal, ForeignHint)]
ress SDoc -> SDoc -> SDoc
<+>
       SDoc -> SDoc
parens (CCallConv -> SDoc
ccallConvAttribute CCallConv
cconv SDoc -> SDoc -> SDoc
<> SDoc
ppr_fn) SDoc -> SDoc -> SDoc
<>
       SDoc -> SDoc
parens ([SDoc] -> SDoc
commafy (((CmmExpr, ForeignHint) -> SDoc)
-> [(CmmExpr, ForeignHint)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (CmmExpr, ForeignHint) -> SDoc
arg_type [(CmmExpr, ForeignHint)]
args))

-- ---------------------------------------------------------------------
-- unconditional branches
pprBranch :: BlockId -> SDoc
pprBranch :: BlockId -> SDoc
pprBranch BlockId
ident = String -> SDoc
text String
"goto" SDoc -> SDoc -> SDoc
<+> BlockId -> SDoc
pprBlockId BlockId
ident SDoc -> SDoc -> SDoc
<> SDoc
semi


-- ---------------------------------------------------------------------
-- conditional branches to local labels
pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc
pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc
pprCondBranch CmmExpr
expr BlockId
yes BlockId
no
        = [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"if" , SDoc -> SDoc
parens(CmmExpr -> SDoc
pprExpr CmmExpr
expr) ,
                        String -> SDoc
text String
"goto", BlockId -> SDoc
pprBlockId BlockId
yes SDoc -> SDoc -> SDoc
<> SDoc
semi,
                        String -> SDoc
text String
"else goto", BlockId -> SDoc
pprBlockId BlockId
no SDoc -> SDoc -> SDoc
<> SDoc
semi ]

-- ---------------------------------------------------------------------
-- a local table branch
--
-- we find the fall-through cases
--
pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc
pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc
pprSwitch DynFlags
dflags CmmExpr
e SwitchTargets
ids
  = (SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"switch" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens ( CmmExpr -> SDoc
pprExpr CmmExpr
e ) SDoc -> SDoc -> SDoc
<+> SDoc
lbrace)
                Int
4 ([SDoc] -> SDoc
vcat ( (([Integer], BlockId) -> SDoc) -> [([Integer], BlockId)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ([Integer], BlockId) -> SDoc
caseify [([Integer], BlockId)]
pairs ) SDoc -> SDoc -> SDoc
$$ SDoc
def)) SDoc -> SDoc -> SDoc
$$ SDoc
rbrace
  where
    ([([Integer], BlockId)]
pairs, Maybe BlockId
mbdef) = SwitchTargets -> ([([Integer], BlockId)], Maybe BlockId)
switchTargetsFallThrough SwitchTargets
ids

    -- fall through case
    caseify :: ([Integer], BlockId) -> SDoc
caseify (Integer
ix:[Integer]
ixs, BlockId
ident) = [SDoc] -> SDoc
vcat ((Integer -> SDoc) -> [Integer] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> SDoc
do_fallthrough [Integer]
ixs) SDoc -> SDoc -> SDoc
$$ Integer -> SDoc
final_branch Integer
ix
        where
        do_fallthrough :: Integer -> SDoc
do_fallthrough Integer
ix =
                 [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"case" , Integer -> Width -> SDoc
pprHexVal Integer
ix (DynFlags -> Width
wordWidth DynFlags
dflags) SDoc -> SDoc -> SDoc
<> SDoc
colon ,
                        String -> SDoc
text String
"/* fall through */" ]

        final_branch :: Integer -> SDoc
final_branch Integer
ix =
                [SDoc] -> SDoc
hsep [ String -> SDoc
text String
"case" , Integer -> Width -> SDoc
pprHexVal Integer
ix (DynFlags -> Width
wordWidth DynFlags
dflags) SDoc -> SDoc -> SDoc
<> SDoc
colon ,
                       String -> SDoc
text String
"goto" , (BlockId -> SDoc
pprBlockId BlockId
ident) SDoc -> SDoc -> SDoc
<> SDoc
semi ]

    caseify ([Integer]
_     , BlockId
_    ) = String -> SDoc
forall a. String -> a
panic String
"pprSwitch: switch with no cases!"

    def :: SDoc
def | Just BlockId
l <- Maybe BlockId
mbdef = String -> SDoc
text String
"default: goto" SDoc -> SDoc -> SDoc
<+> BlockId -> SDoc
pprBlockId BlockId
l SDoc -> SDoc -> SDoc
<> SDoc
semi
        | Bool
otherwise       = SDoc
empty

-- ---------------------------------------------------------------------
-- Expressions.
--

-- C Types: the invariant is that the C expression generated by
--
--      pprExpr e
--
-- has a type in C which is also given by
--
--      machRepCType (cmmExprType e)
--
-- (similar invariants apply to the rest of the pretty printer).

pprExpr :: CmmExpr -> SDoc
pprExpr :: CmmExpr -> SDoc
pprExpr CmmExpr
e = case CmmExpr
e of
    CmmLit CmmLit
lit -> CmmLit -> SDoc
pprLit CmmLit
lit


    CmmLoad CmmExpr
e CmmType
ty -> (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags -> DynFlags -> CmmExpr -> CmmType -> SDoc
pprLoad DynFlags
dflags CmmExpr
e CmmType
ty
    CmmReg CmmReg
reg      -> CmmReg -> SDoc
pprCastReg CmmReg
reg
    CmmRegOff CmmReg
reg Int
0 -> CmmReg -> SDoc
pprCastReg CmmReg
reg

    -- CmmRegOff is an alias of MO_Add
    CmmRegOff CmmReg
reg Int
i -> (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
                       CmmReg -> SDoc
pprCastReg CmmReg
reg SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'+' SDoc -> SDoc -> SDoc
<>
                       Integer -> Width -> SDoc
pprHexVal (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i) (DynFlags -> Width
wordWidth DynFlags
dflags)

    CmmMachOp MachOp
mop [CmmExpr]
args -> MachOp -> [CmmExpr] -> SDoc
pprMachOpApp MachOp
mop [CmmExpr]
args

    CmmStackSlot Area
_ Int
_   -> String -> SDoc
forall a. String -> a
panic String
"pprExpr: CmmStackSlot not supported!"


pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc
pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc
pprLoad DynFlags
dflags CmmExpr
e CmmType
ty
  | Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64, DynFlags -> Width
wordWidth DynFlags
dflags Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
/= Width
W64
  = (if CmmType -> Bool
isFloatType CmmType
ty then String -> SDoc
text String
"PK_DBL"
                       else String -> SDoc
text String
"PK_Word64")
    SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (SDoc
mkP_ SDoc -> SDoc -> SDoc
<> CmmExpr -> SDoc
pprExpr1 CmmExpr
e)

  | Bool
otherwise
  = case CmmExpr
e of
        CmmReg CmmReg
r | CmmReg -> Bool
isPtrReg CmmReg
r Bool -> Bool -> Bool
&& Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Width
wordWidth DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmType -> Bool
isFloatType CmmType
ty)
                 -> Char -> SDoc
char Char
'*' SDoc -> SDoc -> SDoc
<> CmmReg -> SDoc
pprAsPtrReg CmmReg
r

        CmmRegOff CmmReg
r Int
0 | CmmReg -> Bool
isPtrReg CmmReg
r Bool -> Bool -> Bool
&& Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Width
wordWidth DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmType -> Bool
isFloatType CmmType
ty)
                      -> Char -> SDoc
char Char
'*' SDoc -> SDoc -> SDoc
<> CmmReg -> SDoc
pprAsPtrReg CmmReg
r

        CmmRegOff CmmReg
r Int
off | CmmReg -> Bool
isPtrReg CmmReg
r Bool -> Bool -> Bool
&& Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Width
wordWidth DynFlags
dflags
                        , Int
off Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmType -> Bool
isFloatType CmmType
ty)
        -- ToDo: check that the offset is a word multiple?
        --       (For tagging to work, I had to avoid unaligned loads. --ARY)
                        -> CmmReg -> SDoc
pprAsPtrReg CmmReg
r SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
brackets (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int
off Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` DynFlags -> Int
wordShift DynFlags
dflags))

        CmmExpr
_other -> CmmExpr -> CmmType -> SDoc
cLoad CmmExpr
e CmmType
ty
  where
    width :: Width
width = CmmType -> Width
typeWidth CmmType
ty

pprExpr1 :: CmmExpr -> SDoc
pprExpr1 :: CmmExpr -> SDoc
pprExpr1 (CmmLit CmmLit
lit)     = CmmLit -> SDoc
pprLit1 CmmLit
lit
pprExpr1 e :: CmmExpr
e@(CmmReg CmmReg
_reg)  = CmmExpr -> SDoc
pprExpr CmmExpr
e
pprExpr1 CmmExpr
other            = SDoc -> SDoc
parens (CmmExpr -> SDoc
pprExpr CmmExpr
other)

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

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

pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc
pprMachOpApp MachOp
op [CmmExpr]
args
  | MachOp -> Bool
isMulMayOfloOp MachOp
op
  = String -> SDoc
text String
"mulIntMayOflo" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens ([SDoc] -> SDoc
commafy ((CmmExpr -> SDoc) -> [CmmExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CmmExpr -> SDoc
pprExpr [CmmExpr]
args))
  where isMulMayOfloOp :: MachOp -> Bool
isMulMayOfloOp (MO_U_MulMayOflo Width
_) = Bool
True
        isMulMayOfloOp (MO_S_MulMayOflo Width
_) = Bool
True
        isMulMayOfloOp MachOp
_ = Bool
False

pprMachOpApp MachOp
mop [CmmExpr]
args
  | Just SDoc
ty <- MachOp -> Maybe SDoc
machOpNeedsCast MachOp
mop
  = SDoc
ty SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (MachOp -> [CmmExpr] -> SDoc
pprMachOpApp' MachOp
mop [CmmExpr]
args)
  | Bool
otherwise
  = MachOp -> [CmmExpr] -> SDoc
pprMachOpApp' MachOp
mop [CmmExpr]
args

-- 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 :: MachOp -> Maybe SDoc
machOpNeedsCast MachOp
mop
  | MachOp -> Bool
isComparisonMachOp MachOp
mop = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
mkW_
  | Bool
otherwise              = Maybe SDoc
forall a. Maybe a
Nothing

pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc
pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc
pprMachOpApp' MachOp
mop [CmmExpr]
args
 = case [CmmExpr]
args of
    -- dyadic
    [CmmExpr
x,CmmExpr
y] -> CmmExpr -> SDoc
pprArg CmmExpr
x SDoc -> SDoc -> SDoc
<+> MachOp -> SDoc
pprMachOp_for_C MachOp
mop SDoc -> SDoc -> SDoc
<+> CmmExpr -> SDoc
pprArg CmmExpr
y

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

    [CmmExpr]
_     -> String -> SDoc
forall a. String -> a
panic String
"PprC.pprMachOp : machop with wrong number of args"

  where
        -- Cast needed for signed integer ops
    pprArg :: CmmExpr -> SDoc
pprArg CmmExpr
e | MachOp -> Bool
signedOp    MachOp
mop = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
                                 SDoc -> CmmExpr -> SDoc
cCast (Width -> SDoc
machRep_S_CType (CmmType -> Width
typeWidth (DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
e))) CmmExpr
e
             | MachOp -> Bool
needsFCasts MachOp
mop = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
                                 SDoc -> CmmExpr -> SDoc
cCast (Width -> SDoc
machRep_F_CType (CmmType -> Width
typeWidth (DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
e))) CmmExpr
e
             | Bool
otherwise    = CmmExpr -> SDoc
pprExpr1 CmmExpr
e
    needsFCasts :: MachOp -> Bool
needsFCasts (MO_F_Eq Width
_)   = Bool
False
    needsFCasts (MO_F_Ne Width
_)   = Bool
False
    needsFCasts (MO_F_Neg Width
_)  = Bool
True
    needsFCasts (MO_F_Quot Width
_) = Bool
True
    needsFCasts MachOp
mop  = MachOp -> Bool
floatComparison MachOp
mop

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

pprLit :: CmmLit -> SDoc
pprLit :: CmmLit -> SDoc
pprLit CmmLit
lit = case CmmLit
lit of
    CmmInt Integer
i Width
rep      -> Integer -> Width -> SDoc
pprHexVal Integer
i Width
rep

    CmmFloat Rational
f Width
w       -> SDoc -> SDoc
parens (Width -> SDoc
machRep_F_CType Width
w) SDoc -> SDoc -> SDoc
<> SDoc
str
        where d :: Double
d = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
f :: Double
              str :: SDoc
str | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
d Bool -> Bool -> Bool
&& Double
d Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 = String -> SDoc
text String
"-INFINITY"
                  | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
d          = String -> SDoc
text String
"INFINITY"
                  | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
d               = String -> SDoc
text String
"NAN"
                  | Bool
otherwise             = String -> SDoc
text (Double -> String
forall a. Show a => a -> String
show Double
d)
                -- these constants come from <math.h>
                -- see #1861

    CmmVec {} -> String -> SDoc
forall a. String -> a
panic String
"PprC printing vector literal"

    CmmBlock BlockId
bid       -> SDoc
mkW_ SDoc -> SDoc -> SDoc
<> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
pprCLabelAddr (BlockId -> CLabel
infoTblLbl BlockId
bid)
    CmmLit
CmmHighStackMark   -> String -> SDoc
forall a. String -> a
panic String
"PprC printing high stack mark"
    CmmLabel CLabel
clbl      -> SDoc
mkW_ SDoc -> SDoc -> SDoc
<> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
pprCLabelAddr CLabel
clbl
    CmmLabelOff CLabel
clbl Int
i -> SDoc
mkW_ SDoc -> SDoc -> SDoc
<> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
pprCLabelAddr CLabel
clbl SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'+' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i
    CmmLabelDiffOff CLabel
clbl1 CLabel
_ Int
i Width
_   -- non-word widths not supported via C
        -- WARNING:
        --  * the lit must occur in the info table clbl2
        --  * clbl1 must be an SRT, a slow entry point or a large bitmap
        -> SDoc
mkW_ SDoc -> SDoc -> SDoc
<> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
pprCLabelAddr CLabel
clbl1 SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'+' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i

    where
        pprCLabelAddr :: a -> SDoc
pprCLabelAddr a
lbl = Char -> SDoc
char Char
'&' SDoc -> SDoc -> SDoc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
lbl

pprLit1 :: CmmLit -> SDoc
pprLit1 :: CmmLit -> SDoc
pprLit1 lit :: CmmLit
lit@(CmmLabelOff CLabel
_ Int
_) = SDoc -> SDoc
parens (CmmLit -> SDoc
pprLit CmmLit
lit)
pprLit1 lit :: CmmLit
lit@(CmmLabelDiffOff CLabel
_ CLabel
_ Int
_ Width
_) = SDoc -> SDoc
parens (CmmLit -> SDoc
pprLit CmmLit
lit)
pprLit1 lit :: CmmLit
lit@(CmmFloat Rational
_ Width
_)    = SDoc -> SDoc
parens (CmmLit -> SDoc
pprLit CmmLit
lit)
pprLit1 CmmLit
other = CmmLit -> SDoc
pprLit CmmLit
other

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

pprStatics :: DynFlags -> [CmmStatic] -> [SDoc]
pprStatics :: DynFlags -> [CmmStatic] -> [SDoc]
pprStatics DynFlags
_ [] = []
pprStatics DynFlags
dflags (CmmStaticLit (CmmFloat Rational
f Width
W32) : [CmmStatic]
rest)
  -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding
  | DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8, CmmStaticLit (CmmInt Integer
0 Width
W32) : [CmmStatic]
rest' <- [CmmStatic]
rest
  = CmmLit -> SDoc
pprLit1 (DynFlags -> Rational -> CmmLit
floatToWord DynFlags
dflags Rational
f) SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: DynFlags -> [CmmStatic] -> [SDoc]
pprStatics DynFlags
dflags [CmmStatic]
rest'
  -- adjacent floats aren't padded but combined into a single word
  | DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8, CmmStaticLit (CmmFloat Rational
g Width
W32) : [CmmStatic]
rest' <- [CmmStatic]
rest
  = CmmLit -> SDoc
pprLit1 (DynFlags -> Rational -> Rational -> CmmLit
floatPairToWord DynFlags
dflags Rational
f Rational
g) SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: DynFlags -> [CmmStatic] -> [SDoc]
pprStatics DynFlags
dflags [CmmStatic]
rest'
  | DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4
  = CmmLit -> SDoc
pprLit1 (DynFlags -> Rational -> CmmLit
floatToWord DynFlags
dflags Rational
f) SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: DynFlags -> [CmmStatic] -> [SDoc]
pprStatics DynFlags
dflags [CmmStatic]
rest
  | Bool
otherwise
  = String -> SDoc -> [SDoc]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"pprStatics: float" ([SDoc] -> SDoc
vcat ((CmmStatic -> SDoc) -> [CmmStatic] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CmmStatic -> SDoc
ppr' [CmmStatic]
rest))
    where ppr' :: CmmStatic -> SDoc
ppr' (CmmStaticLit CmmLit
l) = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
                                  CmmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DynFlags -> CmmLit -> CmmType
cmmLitType DynFlags
dflags CmmLit
l)
          ppr' CmmStatic
_other           = String -> SDoc
text String
"bad static!"
pprStatics DynFlags
dflags (CmmStaticLit (CmmFloat Rational
f Width
W64) : [CmmStatic]
rest)
  = (CmmLit -> SDoc) -> [CmmLit] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CmmLit -> SDoc
pprLit1 (DynFlags -> Rational -> [CmmLit]
doubleToWords DynFlags
dflags Rational
f) [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ DynFlags -> [CmmStatic] -> [SDoc]
pprStatics DynFlags
dflags [CmmStatic]
rest

pprStatics DynFlags
dflags (CmmStaticLit (CmmInt Integer
i Width
W64) : [CmmStatic]
rest)
  | DynFlags -> Width
wordWidth DynFlags
dflags Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32
  = if DynFlags -> Bool
wORDS_BIGENDIAN DynFlags
dflags
    then DynFlags -> [CmmStatic] -> [SDoc]
pprStatics DynFlags
dflags (CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
q Width
W32) CmmStatic -> [CmmStatic] -> [CmmStatic]
forall a. a -> [a] -> [a]
:
                            CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
r Width
W32) CmmStatic -> [CmmStatic] -> [CmmStatic]
forall a. a -> [a] -> [a]
: [CmmStatic]
rest)
    else DynFlags -> [CmmStatic] -> [SDoc]
pprStatics DynFlags
dflags (CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
r Width
W32) CmmStatic -> [CmmStatic] -> [CmmStatic]
forall a. a -> [a] -> [a]
:
                            CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
q Width
W32) CmmStatic -> [CmmStatic] -> [CmmStatic]
forall a. a -> [a] -> [a]
: [CmmStatic]
rest)
  where r :: Integer
r = Integer
i Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
0xffffffff
        q :: Integer
q = Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
32
pprStatics DynFlags
dflags (CmmStaticLit (CmmInt Integer
a Width
W32) :
                   CmmStaticLit (CmmInt Integer
b Width
W32) : [CmmStatic]
rest)
  | DynFlags -> Width
wordWidth DynFlags
dflags Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64
  = if DynFlags -> Bool
wORDS_BIGENDIAN DynFlags
dflags
    then DynFlags -> [CmmStatic] -> [SDoc]
pprStatics DynFlags
dflags (CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt ((Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL Integer
a Int
32) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
b) Width
W64) CmmStatic -> [CmmStatic] -> [CmmStatic]
forall a. a -> [a] -> [a]
:
                            [CmmStatic]
rest)
    else DynFlags -> [CmmStatic] -> [SDoc]
pprStatics DynFlags
dflags (CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt ((Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL Integer
b Int
32) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
a) Width
W64) CmmStatic -> [CmmStatic] -> [CmmStatic]
forall a. a -> [a] -> [a]
:
                            [CmmStatic]
rest)
pprStatics DynFlags
dflags (CmmStaticLit (CmmInt Integer
a Width
W16) :
                   CmmStaticLit (CmmInt Integer
b Width
W16) : [CmmStatic]
rest)
  | DynFlags -> Width
wordWidth DynFlags
dflags Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32
  = if DynFlags -> Bool
wORDS_BIGENDIAN DynFlags
dflags
    then DynFlags -> [CmmStatic] -> [SDoc]
pprStatics DynFlags
dflags (CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt ((Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL Integer
a Int
16) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
b) Width
W32) CmmStatic -> [CmmStatic] -> [CmmStatic]
forall a. a -> [a] -> [a]
:
                            [CmmStatic]
rest)
    else DynFlags -> [CmmStatic] -> [SDoc]
pprStatics DynFlags
dflags (CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt ((Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL Integer
b Int
16) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
a) Width
W32) CmmStatic -> [CmmStatic] -> [CmmStatic]
forall a. a -> [a] -> [a]
:
                            [CmmStatic]
rest)
pprStatics DynFlags
dflags (CmmStaticLit (CmmInt Integer
_ Width
w) : [CmmStatic]
_)
  | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
/= DynFlags -> Width
wordWidth DynFlags
dflags
  = String -> SDoc -> [SDoc]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"pprStatics: cannot emit a non-word-sized static literal" (Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w)
pprStatics DynFlags
dflags (CmmStaticLit CmmLit
lit : [CmmStatic]
rest)
  = CmmLit -> SDoc
pprLit1 CmmLit
lit SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: DynFlags -> [CmmStatic] -> [SDoc]
pprStatics DynFlags
dflags [CmmStatic]
rest
pprStatics DynFlags
_ (CmmStatic
other : [CmmStatic]
_)
  = String -> SDoc -> [SDoc]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"pprStatics: other" (CmmStatic -> SDoc
pprStatic CmmStatic
other)

pprStatic :: CmmStatic -> SDoc
pprStatic :: CmmStatic -> SDoc
pprStatic CmmStatic
s = case CmmStatic
s of

    CmmStaticLit CmmLit
lit   -> Int -> SDoc -> SDoc
nest Int
4 (CmmLit -> SDoc
pprLit CmmLit
lit)
    CmmUninitialised Int
i -> Int -> SDoc -> SDoc
nest Int
4 (SDoc
mkC_ SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
brackets (Int -> SDoc
int Int
i))

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


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

pprBlockId :: BlockId -> SDoc
pprBlockId :: BlockId -> SDoc
pprBlockId BlockId
b = Char -> SDoc
char Char
'_' SDoc -> SDoc -> SDoc
<> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr (BlockId -> Unique
forall a. Uniquable a => a -> Unique
getUnique BlockId
b)

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

pprMachOp_for_C :: MachOp -> SDoc

pprMachOp_for_C :: MachOp -> SDoc
pprMachOp_for_C MachOp
mop = case MachOp
mop of

        -- Integer operations
        MO_Add          Width
_ -> Char -> SDoc
char Char
'+'
        MO_Sub          Width
_ -> Char -> SDoc
char Char
'-'
        MO_Eq           Width
_ -> String -> SDoc
text String
"=="
        MO_Ne           Width
_ -> String -> SDoc
text String
"!="
        MO_Mul          Width
_ -> Char -> SDoc
char Char
'*'

        MO_S_Quot       Width
_ -> Char -> SDoc
char Char
'/'
        MO_S_Rem        Width
_ -> Char -> SDoc
char Char
'%'
        MO_S_Neg        Width
_ -> Char -> SDoc
char Char
'-'

        MO_U_Quot       Width
_ -> Char -> SDoc
char Char
'/'
        MO_U_Rem        Width
_ -> Char -> SDoc
char Char
'%'

        -- & Floating-point operations
        MO_F_Add        Width
_ -> Char -> SDoc
char Char
'+'
        MO_F_Sub        Width
_ -> Char -> SDoc
char Char
'-'
        MO_F_Neg        Width
_ -> Char -> SDoc
char Char
'-'
        MO_F_Mul        Width
_ -> Char -> SDoc
char Char
'*'
        MO_F_Quot       Width
_ -> Char -> SDoc
char Char
'/'

        -- Signed comparisons
        MO_S_Ge         Width
_ -> String -> SDoc
text String
">="
        MO_S_Le         Width
_ -> String -> SDoc
text String
"<="
        MO_S_Gt         Width
_ -> Char -> SDoc
char Char
'>'
        MO_S_Lt         Width
_ -> Char -> SDoc
char Char
'<'

        -- & Unsigned comparisons
        MO_U_Ge         Width
_ -> String -> SDoc
text String
">="
        MO_U_Le         Width
_ -> String -> SDoc
text String
"<="
        MO_U_Gt         Width
_ -> Char -> SDoc
char Char
'>'
        MO_U_Lt         Width
_ -> Char -> SDoc
char Char
'<'

        -- & Floating-point comparisons
        MO_F_Eq         Width
_ -> String -> SDoc
text String
"=="
        MO_F_Ne         Width
_ -> String -> SDoc
text String
"!="
        MO_F_Ge         Width
_ -> String -> SDoc
text String
">="
        MO_F_Le         Width
_ -> String -> SDoc
text String
"<="
        MO_F_Gt         Width
_ -> Char -> SDoc
char Char
'>'
        MO_F_Lt         Width
_ -> Char -> SDoc
char Char
'<'

        -- Bitwise operations.  Not all of these may be supported at all
        -- sizes, and only integral MachReps are valid.
        MO_And          Width
_ -> Char -> SDoc
char Char
'&'
        MO_Or           Width
_ -> Char -> SDoc
char Char
'|'
        MO_Xor          Width
_ -> Char -> SDoc
char Char
'^'
        MO_Not          Width
_ -> Char -> SDoc
char Char
'~'
        MO_Shl          Width
_ -> String -> SDoc
text String
"<<"
        MO_U_Shr        Width
_ -> String -> SDoc
text String
">>" -- unsigned shift right
        MO_S_Shr        Width
_ -> String -> SDoc
text String
">>" -- signed shift right

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

-- noop casts
        MO_UU_Conv Width
from Width
to | Width
from Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
to -> SDoc
empty
        MO_UU_Conv Width
_from Width
to -> SDoc -> SDoc
parens (Width -> SDoc
machRep_U_CType Width
to)

        MO_SS_Conv Width
from Width
to | Width
from Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
to -> SDoc
empty
        MO_SS_Conv Width
_from Width
to -> SDoc -> SDoc
parens (Width -> SDoc
machRep_S_CType Width
to)

        MO_XX_Conv Width
from Width
to | Width
from Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
to -> SDoc
empty
        MO_XX_Conv Width
_from Width
to -> SDoc -> SDoc
parens (Width -> SDoc
machRep_U_CType Width
to)

        MO_FF_Conv Width
from Width
to | Width
from Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
to -> SDoc
empty
        MO_FF_Conv Width
_from Width
to -> SDoc -> SDoc
parens (Width -> SDoc
machRep_F_CType Width
to)

        MO_SF_Conv Width
_from Width
to -> SDoc -> SDoc
parens (Width -> SDoc
machRep_F_CType Width
to)
        MO_FS_Conv Width
_from Width
to -> SDoc -> SDoc
parens (Width -> SDoc
machRep_S_CType Width
to)

        MO_S_MulMayOflo Width
_ -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_S_MulMayOflo")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_S_MulMayOflo"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")
        MO_U_MulMayOflo Width
_ -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_U_MulMayOflo")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_U_MulMayOflo"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")

        MO_V_Insert {}    -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_V_Insert")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_V_Insert"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")
        MO_V_Extract {}   -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_V_Extract")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_V_Extract"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")

        MO_V_Add {}       -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_V_Add")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_V_Add"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")
        MO_V_Sub {}       -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_V_Sub")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_V_Sub"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")
        MO_V_Mul {}       -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_V_Mul")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_V_Mul"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")

        MO_VS_Quot {}     -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_VS_Quot")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_VS_Quot"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")
        MO_VS_Rem {}      -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_VS_Rem")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_VS_Rem"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")
        MO_VS_Neg {}      -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_VS_Neg")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_VS_Neg"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")

        MO_VU_Quot {}     -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_VU_Quot")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_VU_Quot"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")
        MO_VU_Rem {}      -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_VU_Rem")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_VU_Rem"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")

        MO_VF_Insert {}   -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_VF_Insert")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_VF_Insert"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")
        MO_VF_Extract {}  -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_VF_Extract")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_VF_Extract"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")

        MO_VF_Add {}      -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_VF_Add")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_VF_Add"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")
        MO_VF_Sub {}      -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_VF_Sub")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_VF_Sub"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")
        MO_VF_Neg {}      -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_VF_Neg")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_VF_Neg"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")
        MO_VF_Mul {}      -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_VF_Mul")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_VF_Mul"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")
        MO_VF_Quot {}     -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
text String
"MO_VF_Quot")
                                (String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: MO_VF_Quot"
                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" should have been handled earlier!")

        MO_AlignmentCheck {} -> String -> SDoc
forall a. String -> a
panic String
"-falignment-santisation not supported by unregisterised backend"

signedOp :: MachOp -> Bool      -- Argument type(s) are signed ints
signedOp :: MachOp -> Bool
signedOp (MO_S_Quot Width
_)    = Bool
True
signedOp (MO_S_Rem  Width
_)    = Bool
True
signedOp (MO_S_Neg  Width
_)    = Bool
True
signedOp (MO_S_Ge   Width
_)    = Bool
True
signedOp (MO_S_Le   Width
_)    = Bool
True
signedOp (MO_S_Gt   Width
_)    = Bool
True
signedOp (MO_S_Lt   Width
_)    = Bool
True
signedOp (MO_S_Shr  Width
_)    = Bool
True
signedOp (MO_SS_Conv Width
_ Width
_) = Bool
True
signedOp (MO_SF_Conv Width
_ Width
_) = Bool
True
signedOp MachOp
_                = Bool
False

floatComparison :: MachOp -> Bool  -- comparison between float args
floatComparison :: MachOp -> Bool
floatComparison (MO_F_Eq   Width
_) = Bool
True
floatComparison (MO_F_Ne   Width
_) = Bool
True
floatComparison (MO_F_Ge   Width
_) = Bool
True
floatComparison (MO_F_Le   Width
_) = Bool
True
floatComparison (MO_F_Gt   Width
_) = Bool
True
floatComparison (MO_F_Lt   Width
_) = Bool
True
floatComparison MachOp
_             = Bool
False

-- ---------------------------------------------------------------------
-- tend to be implemented by foreign calls

pprCallishMachOp_for_C :: CallishMachOp -> SDoc

pprCallishMachOp_for_C :: CallishMachOp -> SDoc
pprCallishMachOp_for_C CallishMachOp
mop
    = case CallishMachOp
mop of
        CallishMachOp
MO_F64_Pwr      -> String -> SDoc
text String
"pow"
        CallishMachOp
MO_F64_Sin      -> String -> SDoc
text String
"sin"
        CallishMachOp
MO_F64_Cos      -> String -> SDoc
text String
"cos"
        CallishMachOp
MO_F64_Tan      -> String -> SDoc
text String
"tan"
        CallishMachOp
MO_F64_Sinh     -> String -> SDoc
text String
"sinh"
        CallishMachOp
MO_F64_Cosh     -> String -> SDoc
text String
"cosh"
        CallishMachOp
MO_F64_Tanh     -> String -> SDoc
text String
"tanh"
        CallishMachOp
MO_F64_Asin     -> String -> SDoc
text String
"asin"
        CallishMachOp
MO_F64_Acos     -> String -> SDoc
text String
"acos"
        CallishMachOp
MO_F64_Atanh    -> String -> SDoc
text String
"atanh"
        CallishMachOp
MO_F64_Asinh    -> String -> SDoc
text String
"asinh"
        CallishMachOp
MO_F64_Acosh    -> String -> SDoc
text String
"acosh"
        CallishMachOp
MO_F64_Atan     -> String -> SDoc
text String
"atan"
        CallishMachOp
MO_F64_Log      -> String -> SDoc
text String
"log"
        CallishMachOp
MO_F64_Exp      -> String -> SDoc
text String
"exp"
        CallishMachOp
MO_F64_Sqrt     -> String -> SDoc
text String
"sqrt"
        CallishMachOp
MO_F64_Fabs     -> String -> SDoc
text String
"fabs"
        CallishMachOp
MO_F32_Pwr      -> String -> SDoc
text String
"powf"
        CallishMachOp
MO_F32_Sin      -> String -> SDoc
text String
"sinf"
        CallishMachOp
MO_F32_Cos      -> String -> SDoc
text String
"cosf"
        CallishMachOp
MO_F32_Tan      -> String -> SDoc
text String
"tanf"
        CallishMachOp
MO_F32_Sinh     -> String -> SDoc
text String
"sinhf"
        CallishMachOp
MO_F32_Cosh     -> String -> SDoc
text String
"coshf"
        CallishMachOp
MO_F32_Tanh     -> String -> SDoc
text String
"tanhf"
        CallishMachOp
MO_F32_Asin     -> String -> SDoc
text String
"asinf"
        CallishMachOp
MO_F32_Acos     -> String -> SDoc
text String
"acosf"
        CallishMachOp
MO_F32_Atan     -> String -> SDoc
text String
"atanf"
        CallishMachOp
MO_F32_Asinh    -> String -> SDoc
text String
"asinhf"
        CallishMachOp
MO_F32_Acosh    -> String -> SDoc
text String
"acoshf"
        CallishMachOp
MO_F32_Atanh    -> String -> SDoc
text String
"atanhf"
        CallishMachOp
MO_F32_Log      -> String -> SDoc
text String
"logf"
        CallishMachOp
MO_F32_Exp      -> String -> SDoc
text String
"expf"
        CallishMachOp
MO_F32_Sqrt     -> String -> SDoc
text String
"sqrtf"
        CallishMachOp
MO_F32_Fabs     -> String -> SDoc
text String
"fabsf"
        CallishMachOp
MO_ReadBarrier  -> String -> SDoc
text String
"load_load_barrier"
        CallishMachOp
MO_WriteBarrier -> String -> SDoc
text String
"write_barrier"
        MO_Memcpy Int
_     -> String -> SDoc
text String
"memcpy"
        MO_Memset Int
_     -> String -> SDoc
text String
"memset"
        MO_Memmove Int
_    -> String -> SDoc
text String
"memmove"
        MO_Memcmp Int
_     -> String -> SDoc
text String
"memcmp"
        (MO_BSwap Width
w)    -> PtrString -> SDoc
ptext (String -> PtrString
sLit (String -> PtrString) -> String -> PtrString
forall a b. (a -> b) -> a -> b
$ Width -> String
bSwapLabel Width
w)
        (MO_PopCnt Width
w)   -> PtrString -> SDoc
ptext (String -> PtrString
sLit (String -> PtrString) -> String -> PtrString
forall a b. (a -> b) -> a -> b
$ Width -> String
popCntLabel Width
w)
        (MO_Pext Width
w)     -> PtrString -> SDoc
ptext (String -> PtrString
sLit (String -> PtrString) -> String -> PtrString
forall a b. (a -> b) -> a -> b
$ Width -> String
pextLabel Width
w)
        (MO_Pdep Width
w)     -> PtrString -> SDoc
ptext (String -> PtrString
sLit (String -> PtrString) -> String -> PtrString
forall a b. (a -> b) -> a -> b
$ Width -> String
pdepLabel Width
w)
        (MO_Clz Width
w)      -> PtrString -> SDoc
ptext (String -> PtrString
sLit (String -> PtrString) -> String -> PtrString
forall a b. (a -> b) -> a -> b
$ Width -> String
clzLabel Width
w)
        (MO_Ctz Width
w)      -> PtrString -> SDoc
ptext (String -> PtrString
sLit (String -> PtrString) -> String -> PtrString
forall a b. (a -> b) -> a -> b
$ Width -> String
ctzLabel Width
w)
        (MO_AtomicRMW Width
w AtomicMachOp
amop) -> PtrString -> SDoc
ptext (String -> PtrString
sLit (String -> PtrString) -> String -> PtrString
forall a b. (a -> b) -> a -> b
$ Width -> AtomicMachOp -> String
atomicRMWLabel Width
w AtomicMachOp
amop)
        (MO_Cmpxchg Width
w)  -> PtrString -> SDoc
ptext (String -> PtrString
sLit (String -> PtrString) -> String -> PtrString
forall a b. (a -> b) -> a -> b
$ Width -> String
cmpxchgLabel Width
w)
        (MO_AtomicRead Width
w)  -> PtrString -> SDoc
ptext (String -> PtrString
sLit (String -> PtrString) -> String -> PtrString
forall a b. (a -> b) -> a -> b
$ Width -> String
atomicReadLabel Width
w)
        (MO_AtomicWrite Width
w) -> PtrString -> SDoc
ptext (String -> PtrString
sLit (String -> PtrString) -> String -> PtrString
forall a b. (a -> b) -> a -> b
$ Width -> String
atomicWriteLabel Width
w)
        (MO_UF_Conv Width
w)  -> PtrString -> SDoc
ptext (String -> PtrString
sLit (String -> PtrString) -> String -> PtrString
forall a b. (a -> b) -> a -> b
$ Width -> String
word2FloatLabel Width
w)

        MO_S_QuotRem  {} -> SDoc
unsupported
        MO_U_QuotRem  {} -> SDoc
unsupported
        MO_U_QuotRem2 {} -> SDoc
unsupported
        MO_Add2       {} -> SDoc
unsupported
        MO_AddWordC   {} -> SDoc
unsupported
        MO_SubWordC   {} -> SDoc
unsupported
        MO_AddIntC    {} -> SDoc
unsupported
        MO_SubIntC    {} -> SDoc
unsupported
        MO_U_Mul2     {} -> SDoc
unsupported
        CallishMachOp
MO_Touch         -> SDoc
unsupported
        (MO_Prefetch_Data Int
_ ) -> SDoc
unsupported
        --- we could support prefetch via "__builtin_prefetch"
        --- Not adding it for now
    where unsupported :: SDoc
unsupported = String -> SDoc
forall a. String -> a
panic (String
"pprCallishMachOp_for_C: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallishMachOp -> String
forall a. Show a => a -> String
show CallishMachOp
mop
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not supported!")

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

mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc

mkJMP_ :: SDoc -> SDoc
mkJMP_ SDoc
i = String -> SDoc
text String
"JMP_" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens SDoc
i
mkFN_ :: SDoc -> SDoc
mkFN_  SDoc
i = String -> SDoc
text String
"FN_"  SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens SDoc
i -- externally visible function
mkIF_ :: SDoc -> SDoc
mkIF_  SDoc
i = String -> SDoc
text String
"IF_"  SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens SDoc
i -- locally visible

-- from includes/Stg.h
--
mkC_,mkW_,mkP_ :: SDoc

mkC_ :: SDoc
mkC_  = String -> SDoc
text String
"(C_)"        -- StgChar
mkW_ :: SDoc
mkW_  = String -> SDoc
text String
"(W_)"        -- StgWord
mkP_ :: SDoc
mkP_  = String -> SDoc
text String
"(P_)"        -- StgWord*

-- ---------------------------------------------------------------------
--
-- Assignments
--
-- Generating assignments is what we're all about, here
--
pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc

-- dest is a reg, rhs is a reg
pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc
pprAssign DynFlags
_ CmmReg
r1 (CmmReg CmmReg
r2)
   | CmmReg -> Bool
isPtrReg CmmReg
r1 Bool -> Bool -> Bool
&& CmmReg -> Bool
isPtrReg CmmReg
r2
   = [SDoc] -> SDoc
hcat [ CmmReg -> SDoc
pprAsPtrReg CmmReg
r1, SDoc
equals, CmmReg -> SDoc
pprAsPtrReg CmmReg
r2, SDoc
semi ]

-- dest is a reg, rhs is a CmmRegOff
pprAssign DynFlags
dflags CmmReg
r1 (CmmRegOff CmmReg
r2 Int
off)
   | CmmReg -> Bool
isPtrReg CmmReg
r1 Bool -> Bool -> Bool
&& CmmReg -> Bool
isPtrReg CmmReg
r2 Bool -> Bool -> Bool
&& (Int
off Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` DynFlags -> Int
wORD_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
   = [SDoc] -> SDoc
hcat [ CmmReg -> SDoc
pprAsPtrReg CmmReg
r1, SDoc
equals, CmmReg -> SDoc
pprAsPtrReg CmmReg
r2, SDoc
op, Int -> SDoc
int Int
off', SDoc
semi ]
  where
        off1 :: Int
off1 = Int
off Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` DynFlags -> Int
wordShift DynFlags
dflags

        (SDoc
op,Int
off') | Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0  = (Char -> SDoc
char Char
'+', Int
off1)
                  | Bool
otherwise = (Char -> SDoc
char Char
'-', -Int
off1)

-- dest is a reg, rhs is anything.
-- We can't cast the lvalue, so we have to cast the rhs if necessary.  Casting
-- the lvalue elicits a warning from new GCC versions (3.4+).
pprAssign DynFlags
_ CmmReg
r1 CmmExpr
r2
  | CmmReg -> Bool
isFixedPtrReg CmmReg
r1             = SDoc -> SDoc
mkAssign (SDoc
mkP_ SDoc -> SDoc -> SDoc
<> CmmExpr -> SDoc
pprExpr1 CmmExpr
r2)
  | Just SDoc
ty <- CmmReg -> Maybe SDoc
strangeRegType CmmReg
r1 = SDoc -> SDoc
mkAssign (SDoc -> SDoc
parens SDoc
ty SDoc -> SDoc -> SDoc
<> CmmExpr -> SDoc
pprExpr1 CmmExpr
r2)
  | Bool
otherwise                    = SDoc -> SDoc
mkAssign (CmmExpr -> SDoc
pprExpr CmmExpr
r2)
    where mkAssign :: SDoc -> SDoc
mkAssign SDoc
x = if CmmReg
r1 CmmReg -> CmmReg -> Bool
forall a. Eq a => a -> a -> Bool
== GlobalReg -> CmmReg
CmmGlobal GlobalReg
BaseReg
                       then String -> SDoc
text String
"ASSIGN_BaseReg" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens SDoc
x SDoc -> SDoc -> SDoc
<> SDoc
semi
                       else CmmReg -> SDoc
pprReg CmmReg
r1 SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" = " SDoc -> SDoc -> SDoc
<> SDoc
x SDoc -> SDoc -> SDoc
<> SDoc
semi

-- ---------------------------------------------------------------------
-- Registers

pprCastReg :: CmmReg -> SDoc
pprCastReg :: CmmReg -> SDoc
pprCastReg CmmReg
reg
   | CmmReg -> Bool
isStrangeTypeReg CmmReg
reg = SDoc
mkW_ SDoc -> SDoc -> SDoc
<> CmmReg -> SDoc
pprReg CmmReg
reg
   | Bool
otherwise            = CmmReg -> SDoc
pprReg CmmReg
reg

-- True if (pprReg reg) will give an expression with type StgPtr.  We
-- need to take care with pointer arithmetic on registers with type
-- StgPtr.
isFixedPtrReg :: CmmReg -> Bool
isFixedPtrReg :: CmmReg -> Bool
isFixedPtrReg (CmmLocal CmmFormal
_) = Bool
False
isFixedPtrReg (CmmGlobal GlobalReg
r) = GlobalReg -> Bool
isFixedPtrGlobalReg GlobalReg
r

-- True if (pprAsPtrReg reg) will give an expression with type StgPtr
-- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST.
-- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT;
-- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY.
isPtrReg :: CmmReg -> Bool
isPtrReg :: CmmReg -> Bool
isPtrReg (CmmLocal CmmFormal
_)                         = Bool
False
isPtrReg (CmmGlobal (VanillaReg Int
_ VGcPtr
VGcPtr))    = Bool
True  -- if we print via pprAsPtrReg
isPtrReg (CmmGlobal (VanillaReg Int
_ VGcPtr
VNonGcPtr)) = Bool
False -- if we print via pprAsPtrReg
isPtrReg (CmmGlobal GlobalReg
reg)                      = GlobalReg -> Bool
isFixedPtrGlobalReg GlobalReg
reg

-- True if this global reg has type StgPtr
isFixedPtrGlobalReg :: GlobalReg -> Bool
isFixedPtrGlobalReg :: GlobalReg -> Bool
isFixedPtrGlobalReg GlobalReg
Sp    = Bool
True
isFixedPtrGlobalReg GlobalReg
Hp    = Bool
True
isFixedPtrGlobalReg GlobalReg
HpLim = Bool
True
isFixedPtrGlobalReg GlobalReg
SpLim = Bool
True
isFixedPtrGlobalReg GlobalReg
_     = Bool
False

-- True if in C this register doesn't have the type given by
-- (machRepCType (cmmRegType reg)), so it has to be cast.
isStrangeTypeReg :: CmmReg -> Bool
isStrangeTypeReg :: CmmReg -> Bool
isStrangeTypeReg (CmmLocal CmmFormal
_)   = Bool
False
isStrangeTypeReg (CmmGlobal GlobalReg
g)  = GlobalReg -> Bool
isStrangeTypeGlobal GlobalReg
g

isStrangeTypeGlobal :: GlobalReg -> Bool
isStrangeTypeGlobal :: GlobalReg -> Bool
isStrangeTypeGlobal GlobalReg
CCCS                = Bool
True
isStrangeTypeGlobal GlobalReg
CurrentTSO          = Bool
True
isStrangeTypeGlobal GlobalReg
CurrentNursery      = Bool
True
isStrangeTypeGlobal GlobalReg
BaseReg             = Bool
True
isStrangeTypeGlobal GlobalReg
r                   = GlobalReg -> Bool
isFixedPtrGlobalReg GlobalReg
r

strangeRegType :: CmmReg -> Maybe SDoc
strangeRegType :: CmmReg -> Maybe SDoc
strangeRegType (CmmGlobal GlobalReg
CCCS) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
text String
"struct CostCentreStack_ *")
strangeRegType (CmmGlobal GlobalReg
CurrentTSO) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
text String
"struct StgTSO_ *")
strangeRegType (CmmGlobal GlobalReg
CurrentNursery) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
text String
"struct bdescr_ *")
strangeRegType (CmmGlobal GlobalReg
BaseReg) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
text String
"struct StgRegTable_ *")
strangeRegType CmmReg
_ = Maybe SDoc
forall a. Maybe a
Nothing

-- pprReg just prints the register name.
--
pprReg :: CmmReg -> SDoc
pprReg :: CmmReg -> SDoc
pprReg CmmReg
r = case CmmReg
r of
        CmmLocal  CmmFormal
local  -> CmmFormal -> SDoc
pprLocalReg CmmFormal
local
        CmmGlobal GlobalReg
global -> GlobalReg -> SDoc
pprGlobalReg GlobalReg
global

pprAsPtrReg :: CmmReg -> SDoc
pprAsPtrReg :: CmmReg -> SDoc
pprAsPtrReg (CmmGlobal (VanillaReg Int
n VGcPtr
gcp))
  = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> text ".p"
pprAsPtrReg CmmReg
other_reg = CmmReg -> SDoc
pprReg CmmReg
other_reg

pprGlobalReg :: GlobalReg -> SDoc
pprGlobalReg :: GlobalReg -> SDoc
pprGlobalReg GlobalReg
gr = case GlobalReg
gr of
    VanillaReg Int
n VGcPtr
_ -> Char -> SDoc
char Char
'R' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n  SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
".w"
        -- pprGlobalReg prints a VanillaReg as a .w regardless
        -- Example:     R1.w = R1.w & (-0x8UL);
        --              JMP_(*R1.p);
    FloatReg   Int
n   -> Char -> SDoc
char Char
'F' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n
    DoubleReg  Int
n   -> Char -> SDoc
char Char
'D' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n
    LongReg    Int
n   -> Char -> SDoc
char Char
'L' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n
    GlobalReg
Sp             -> String -> SDoc
text String
"Sp"
    GlobalReg
SpLim          -> String -> SDoc
text String
"SpLim"
    GlobalReg
Hp             -> String -> SDoc
text String
"Hp"
    GlobalReg
HpLim          -> String -> SDoc
text String
"HpLim"
    GlobalReg
CCCS           -> String -> SDoc
text String
"CCCS"
    GlobalReg
CurrentTSO     -> String -> SDoc
text String
"CurrentTSO"
    GlobalReg
CurrentNursery -> String -> SDoc
text String
"CurrentNursery"
    GlobalReg
HpAlloc        -> String -> SDoc
text String
"HpAlloc"
    GlobalReg
BaseReg        -> String -> SDoc
text String
"BaseReg"
    GlobalReg
EagerBlackholeInfo -> String -> SDoc
text String
"stg_EAGER_BLACKHOLE_info"
    GlobalReg
GCEnter1       -> String -> SDoc
text String
"stg_gc_enter_1"
    GlobalReg
GCFun          -> String -> SDoc
text String
"stg_gc_fun"
    GlobalReg
other          -> String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"pprGlobalReg: Unsupported register: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ GlobalReg -> String
forall a. Show a => a -> String
show GlobalReg
other

pprLocalReg :: LocalReg -> SDoc
pprLocalReg :: CmmFormal -> SDoc
pprLocalReg (LocalReg Unique
uniq CmmType
_) = Char -> SDoc
char Char
'_' SDoc -> SDoc -> SDoc
<> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
uniq

-- -----------------------------------------------------------------------------
-- Foreign Calls

pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
pprCall :: SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCall SDoc
ppr_fn CCallConv
cconv [(CmmFormal, ForeignHint)]
results [(CmmExpr, ForeignHint)]
args
  | Bool -> Bool
not (CCallConv -> Bool
is_cishCC CCallConv
cconv)
  = String -> SDoc
forall a. String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"pprCall: unknown calling convention"

  | Bool
otherwise
  =
    [(CmmFormal, ForeignHint)] -> SDoc -> SDoc
ppr_assign [(CmmFormal, ForeignHint)]
results (SDoc
ppr_fn SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens ([SDoc] -> SDoc
commafy (((CmmExpr, ForeignHint) -> SDoc)
-> [(CmmExpr, ForeignHint)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (CmmExpr, ForeignHint) -> SDoc
pprArg [(CmmExpr, ForeignHint)]
args))) SDoc -> SDoc -> SDoc
<> SDoc
semi
  where
     ppr_assign :: [(CmmFormal, ForeignHint)] -> SDoc -> SDoc
ppr_assign []           SDoc
rhs = SDoc
rhs
     ppr_assign [(CmmFormal
one,ForeignHint
hint)] SDoc
rhs
         = CmmFormal -> SDoc
pprLocalReg CmmFormal
one SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" = "
                 SDoc -> SDoc -> SDoc
<> ForeignHint -> CmmType -> SDoc
pprUnHint ForeignHint
hint (CmmFormal -> CmmType
localRegType CmmFormal
one) SDoc -> SDoc -> SDoc
<> SDoc
rhs
     ppr_assign [(CmmFormal, ForeignHint)]
_other SDoc
_rhs = String -> SDoc
forall a. String -> a
panic String
"pprCall: multiple results"

     pprArg :: (CmmExpr, ForeignHint) -> SDoc
pprArg (CmmExpr
expr, ForeignHint
AddrHint)
        = SDoc -> CmmExpr -> SDoc
cCast (String -> SDoc
text String
"void *") CmmExpr
expr
        -- see comment by machRepHintCType below
     pprArg (CmmExpr
expr, ForeignHint
SignedHint)
        = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
          SDoc -> CmmExpr -> SDoc
cCast (Width -> SDoc
machRep_S_CType (Width -> SDoc) -> Width -> SDoc
forall a b. (a -> b) -> a -> b
$ CmmType -> Width
typeWidth (CmmType -> Width) -> CmmType -> Width
forall a b. (a -> b) -> a -> b
$ DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
expr) CmmExpr
expr
     pprArg (CmmExpr
expr, ForeignHint
_other)
        = CmmExpr -> SDoc
pprExpr CmmExpr
expr

     pprUnHint :: ForeignHint -> CmmType -> SDoc
pprUnHint ForeignHint
AddrHint   CmmType
rep = SDoc -> SDoc
parens (CmmType -> SDoc
machRepCType CmmType
rep)
     pprUnHint ForeignHint
SignedHint CmmType
rep = SDoc -> SDoc
parens (CmmType -> SDoc
machRepCType CmmType
rep)
     pprUnHint ForeignHint
_          CmmType
_   = SDoc
empty

-- Currently we only have these two calling conventions, but this might
-- change in the future...
is_cishCC :: CCallConv -> Bool
is_cishCC :: CCallConv -> Bool
is_cishCC CCallConv
CCallConv    = Bool
True
is_cishCC CCallConv
CApiConv     = Bool
True
is_cishCC CCallConv
StdCallConv  = Bool
True
is_cishCC CCallConv
PrimCallConv = Bool
False
is_cishCC CCallConv
JavaScriptCallConv = Bool
False

-- ---------------------------------------------------------------------
-- Find and print local and external declarations for a list of
-- Cmm statements.
--
pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})
pprTempAndExternDecls :: [CmmBlock] -> (SDoc, SDoc)
pprTempAndExternDecls [CmmBlock]
stmts
  = (UniqFM CmmFormal -> ([CmmFormal] -> SDoc) -> SDoc
forall a. UniqFM a -> ([a] -> SDoc) -> SDoc
pprUFM (UniqSet CmmFormal -> UniqFM CmmFormal
forall a. UniqSet a -> UniqFM a
getUniqSet UniqSet CmmFormal
temps) ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> ([CmmFormal] -> [SDoc]) -> [CmmFormal] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CmmFormal -> SDoc) -> [CmmFormal] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CmmFormal -> SDoc
pprTempDecl),
     [SDoc] -> SDoc
vcat ((CLabel -> SDoc) -> [CLabel] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CLabel -> SDoc
pprExternDecl (Map CLabel () -> [CLabel]
forall k a. Map k a -> [k]
Map.keys Map CLabel ()
lbls)))
  where (UniqSet CmmFormal
temps, Map CLabel ()
lbls) = TE () -> (UniqSet CmmFormal, Map CLabel ())
runTE ((CmmBlock -> TE ()) -> [CmmBlock] -> TE ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmBlock -> TE ()
te_BB [CmmBlock]
stmts)

pprDataExterns :: [CmmStatic] -> SDoc
pprDataExterns :: [CmmStatic] -> SDoc
pprDataExterns [CmmStatic]
statics
  = [SDoc] -> SDoc
vcat ((CLabel -> SDoc) -> [CLabel] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CLabel -> SDoc
pprExternDecl (Map CLabel () -> [CLabel]
forall k a. Map k a -> [k]
Map.keys Map CLabel ()
lbls))
  where (UniqSet CmmFormal
_, Map CLabel ()
lbls) = TE () -> (UniqSet CmmFormal, Map CLabel ())
runTE ((CmmStatic -> TE ()) -> [CmmStatic] -> TE ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmStatic -> TE ()
te_Static [CmmStatic]
statics)

pprTempDecl :: LocalReg -> SDoc
pprTempDecl :: CmmFormal -> SDoc
pprTempDecl l :: CmmFormal
l@(LocalReg Unique
_ CmmType
rep)
  = [SDoc] -> SDoc
hcat [ CmmType -> SDoc
machRepCType CmmType
rep, SDoc
space, CmmFormal -> SDoc
pprLocalReg CmmFormal
l, SDoc
semi ]

pprExternDecl :: CLabel -> SDoc
pprExternDecl :: CLabel -> SDoc
pprExternDecl CLabel
lbl
  -- do not print anything for "known external" things
  | Bool -> Bool
not (CLabel -> Bool
needsCDecl CLabel
lbl) = SDoc
empty
  | Just Int
sz <- CLabel -> Maybe Int
foreignLabelStdcallInfo CLabel
lbl = Int -> SDoc
stdcall_decl Int
sz
  | Bool
otherwise =
        [SDoc] -> SDoc
hcat [ SDoc
visibility, CLabel -> SDoc
label_type CLabel
lbl , SDoc
lparen, CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl, String -> SDoc
text String
");"
             -- occasionally useful to see label type
             -- , text "/* ", pprDebugCLabel lbl, text " */"
             ]
 where
  label_type :: CLabel -> SDoc
label_type CLabel
lbl | CLabel -> Bool
isBytesLabel CLabel
lbl         = String -> SDoc
text String
"B_"
                 | CLabel -> Bool
isForeignLabel CLabel
lbl Bool -> Bool -> Bool
&& CLabel -> Bool
isCFunctionLabel CLabel
lbl
                                            = String -> SDoc
text String
"FF_"
                 | CLabel -> Bool
isCFunctionLabel CLabel
lbl     = String -> SDoc
text String
"F_"
                 | CLabel -> Bool
isStaticClosureLabel CLabel
lbl = String -> SDoc
text String
"C_"
                 -- generic .rodata labels
                 | CLabel -> Bool
isSomeRODataLabel CLabel
lbl    = String -> SDoc
text String
"RO_"
                 -- generic .data labels (common case)
                 | Bool
otherwise                = String -> SDoc
text String
"RW_"

  visibility :: SDoc
visibility
     | CLabel -> Bool
externallyVisibleCLabel CLabel
lbl = Char -> SDoc
char Char
'E'
     | Bool
otherwise                   = Char -> SDoc
char Char
'I'

  -- If the label we want to refer to is a stdcall function (on Windows) then
  -- we must generate an appropriate prototype for it, so that the C compiler will
  -- add the @n suffix to the label (#2276)
  stdcall_decl :: Int -> SDoc
stdcall_decl Int
sz = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
        String -> SDoc
text String
"extern __attribute__((stdcall)) void " SDoc -> SDoc -> SDoc
<> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl
        SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens ([SDoc] -> SDoc
commafy (Int -> SDoc -> [SDoc]
forall a. Int -> a -> [a]
replicate (Int
sz Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` DynFlags -> Int
wORD_SIZE DynFlags
dflags) (Width -> SDoc
machRep_U_CType (DynFlags -> Width
wordWidth DynFlags
dflags))))
        SDoc -> SDoc -> SDoc
<> SDoc
semi

type TEState = (UniqSet LocalReg, Map CLabel ())
newtype TE a = TE { TE a
-> (UniqSet CmmFormal, Map CLabel ())
-> (a, (UniqSet CmmFormal, Map CLabel ()))
unTE :: TEState -> (a, TEState) }

instance Functor TE where
      fmap :: (a -> b) -> TE a -> TE b
fmap = (a -> b) -> TE a -> TE b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative TE where
      pure :: a -> TE a
pure a
a = ((UniqSet CmmFormal, Map CLabel ())
 -> (a, (UniqSet CmmFormal, Map CLabel ())))
-> TE a
forall a.
((UniqSet CmmFormal, Map CLabel ())
 -> (a, (UniqSet CmmFormal, Map CLabel ())))
-> TE a
TE (((UniqSet CmmFormal, Map CLabel ())
  -> (a, (UniqSet CmmFormal, Map CLabel ())))
 -> TE a)
-> ((UniqSet CmmFormal, Map CLabel ())
    -> (a, (UniqSet CmmFormal, Map CLabel ())))
-> TE a
forall a b. (a -> b) -> a -> b
$ \(UniqSet CmmFormal, Map CLabel ())
s -> (a
a, (UniqSet CmmFormal, Map CLabel ())
s)
      <*> :: TE (a -> b) -> TE a -> TE b
(<*>) = TE (a -> b) -> TE a -> TE b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad TE where
   TE (UniqSet CmmFormal, Map CLabel ())
-> (a, (UniqSet CmmFormal, Map CLabel ()))
m >>= :: TE a -> (a -> TE b) -> TE b
>>= a -> TE b
k  = ((UniqSet CmmFormal, Map CLabel ())
 -> (b, (UniqSet CmmFormal, Map CLabel ())))
-> TE b
forall a.
((UniqSet CmmFormal, Map CLabel ())
 -> (a, (UniqSet CmmFormal, Map CLabel ())))
-> TE a
TE (((UniqSet CmmFormal, Map CLabel ())
  -> (b, (UniqSet CmmFormal, Map CLabel ())))
 -> TE b)
-> ((UniqSet CmmFormal, Map CLabel ())
    -> (b, (UniqSet CmmFormal, Map CLabel ())))
-> TE b
forall a b. (a -> b) -> a -> b
$ \(UniqSet CmmFormal, Map CLabel ())
s -> case (UniqSet CmmFormal, Map CLabel ())
-> (a, (UniqSet CmmFormal, Map CLabel ()))
m (UniqSet CmmFormal, Map CLabel ())
s of (a
a, (UniqSet CmmFormal, Map CLabel ())
s') -> TE b
-> (UniqSet CmmFormal, Map CLabel ())
-> (b, (UniqSet CmmFormal, Map CLabel ()))
forall a.
TE a
-> (UniqSet CmmFormal, Map CLabel ())
-> (a, (UniqSet CmmFormal, Map CLabel ()))
unTE (a -> TE b
k a
a) (UniqSet CmmFormal, Map CLabel ())
s'

te_lbl :: CLabel -> TE ()
te_lbl :: CLabel -> TE ()
te_lbl CLabel
lbl = ((UniqSet CmmFormal, Map CLabel ())
 -> ((), (UniqSet CmmFormal, Map CLabel ())))
-> TE ()
forall a.
((UniqSet CmmFormal, Map CLabel ())
 -> (a, (UniqSet CmmFormal, Map CLabel ())))
-> TE a
TE (((UniqSet CmmFormal, Map CLabel ())
  -> ((), (UniqSet CmmFormal, Map CLabel ())))
 -> TE ())
-> ((UniqSet CmmFormal, Map CLabel ())
    -> ((), (UniqSet CmmFormal, Map CLabel ())))
-> TE ()
forall a b. (a -> b) -> a -> b
$ \(UniqSet CmmFormal
temps,Map CLabel ()
lbls) -> ((), (UniqSet CmmFormal
temps, CLabel -> () -> Map CLabel () -> Map CLabel ()
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CLabel
lbl () Map CLabel ()
lbls))

te_temp :: LocalReg -> TE ()
te_temp :: CmmFormal -> TE ()
te_temp CmmFormal
r = ((UniqSet CmmFormal, Map CLabel ())
 -> ((), (UniqSet CmmFormal, Map CLabel ())))
-> TE ()
forall a.
((UniqSet CmmFormal, Map CLabel ())
 -> (a, (UniqSet CmmFormal, Map CLabel ())))
-> TE a
TE (((UniqSet CmmFormal, Map CLabel ())
  -> ((), (UniqSet CmmFormal, Map CLabel ())))
 -> TE ())
-> ((UniqSet CmmFormal, Map CLabel ())
    -> ((), (UniqSet CmmFormal, Map CLabel ())))
-> TE ()
forall a b. (a -> b) -> a -> b
$ \(UniqSet CmmFormal
temps,Map CLabel ()
lbls) -> ((), (UniqSet CmmFormal -> CmmFormal -> UniqSet CmmFormal
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet CmmFormal
temps CmmFormal
r, Map CLabel ()
lbls))

runTE :: TE () -> TEState
runTE :: TE () -> (UniqSet CmmFormal, Map CLabel ())
runTE (TE (UniqSet CmmFormal, Map CLabel ())
-> ((), (UniqSet CmmFormal, Map CLabel ()))
m) = ((), (UniqSet CmmFormal, Map CLabel ()))
-> (UniqSet CmmFormal, Map CLabel ())
forall a b. (a, b) -> b
snd ((UniqSet CmmFormal, Map CLabel ())
-> ((), (UniqSet CmmFormal, Map CLabel ()))
m (UniqSet CmmFormal
forall a. UniqSet a
emptyUniqSet, Map CLabel ()
forall k a. Map k a
Map.empty))

te_Static :: CmmStatic -> TE ()
te_Static :: CmmStatic -> TE ()
te_Static (CmmStaticLit CmmLit
lit) = CmmLit -> TE ()
te_Lit CmmLit
lit
te_Static CmmStatic
_ = () -> TE ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

te_BB :: CmmBlock -> TE ()
te_BB :: CmmBlock -> TE ()
te_BB CmmBlock
block = (CmmNode O O -> TE ()) -> [CmmNode O O] -> TE ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmNode O O -> TE ()
forall e x. CmmNode e x -> TE ()
te_Stmt (Block CmmNode O O -> [CmmNode O O]
forall (n :: * -> * -> *). Block n O O -> [n O O]
blockToList Block CmmNode O O
mid) TE () -> TE () -> TE ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CmmNode O C -> TE ()
forall e x. CmmNode e x -> TE ()
te_Stmt CmmNode O C
last
  where (CmmNode C O
_, Block CmmNode O O
mid, CmmNode O C
last) = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: * -> * -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block

te_Lit :: CmmLit -> TE ()
te_Lit :: CmmLit -> TE ()
te_Lit (CmmLabel CLabel
l) = CLabel -> TE ()
te_lbl CLabel
l
te_Lit (CmmLabelOff CLabel
l Int
_) = CLabel -> TE ()
te_lbl CLabel
l
te_Lit (CmmLabelDiffOff CLabel
l1 CLabel
_ Int
_ Width
_) = CLabel -> TE ()
te_lbl CLabel
l1
te_Lit CmmLit
_ = () -> TE ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

te_Stmt :: CmmNode e x -> TE ()
te_Stmt :: CmmNode e x -> TE ()
te_Stmt (CmmAssign CmmReg
r CmmExpr
e)         = CmmReg -> TE ()
te_Reg CmmReg
r TE () -> TE () -> TE ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CmmExpr -> TE ()
te_Expr CmmExpr
e
te_Stmt (CmmStore CmmExpr
l CmmExpr
r)          = CmmExpr -> TE ()
te_Expr CmmExpr
l TE () -> TE () -> TE ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CmmExpr -> TE ()
te_Expr CmmExpr
r
te_Stmt (CmmUnsafeForeignCall ForeignTarget
target [CmmFormal]
rs [CmmExpr]
es)
  = do  ForeignTarget -> TE ()
te_Target ForeignTarget
target
        (CmmFormal -> TE ()) -> [CmmFormal] -> TE ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmFormal -> TE ()
te_temp [CmmFormal]
rs
        (CmmExpr -> TE ()) -> [CmmExpr] -> TE ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmExpr -> TE ()
te_Expr [CmmExpr]
es
te_Stmt (CmmCondBranch CmmExpr
e BlockId
_ BlockId
_ Maybe Bool
_) = CmmExpr -> TE ()
te_Expr CmmExpr
e
te_Stmt (CmmSwitch CmmExpr
e SwitchTargets
_)         = CmmExpr -> TE ()
te_Expr CmmExpr
e
te_Stmt (CmmCall { cml_target :: CmmNode O C -> CmmExpr
cml_target = CmmExpr
e }) = CmmExpr -> TE ()
te_Expr CmmExpr
e
te_Stmt CmmNode e x
_                       = () -> TE ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

te_Target :: ForeignTarget -> TE ()
te_Target :: ForeignTarget -> TE ()
te_Target (ForeignTarget CmmExpr
e ForeignConvention
_)      = CmmExpr -> TE ()
te_Expr CmmExpr
e
te_Target (PrimTarget{})           = () -> TE ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

te_Expr :: CmmExpr -> TE ()
te_Expr :: CmmExpr -> TE ()
te_Expr (CmmLit CmmLit
lit)            = CmmLit -> TE ()
te_Lit CmmLit
lit
te_Expr (CmmLoad CmmExpr
e CmmType
_)           = CmmExpr -> TE ()
te_Expr CmmExpr
e
te_Expr (CmmReg CmmReg
r)              = CmmReg -> TE ()
te_Reg CmmReg
r
te_Expr (CmmMachOp MachOp
_ [CmmExpr]
es)        = (CmmExpr -> TE ()) -> [CmmExpr] -> TE ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmExpr -> TE ()
te_Expr [CmmExpr]
es
te_Expr (CmmRegOff CmmReg
r Int
_)         = CmmReg -> TE ()
te_Reg CmmReg
r
te_Expr (CmmStackSlot Area
_ Int
_)      = String -> TE ()
forall a. String -> a
panic String
"te_Expr: CmmStackSlot not supported!"

te_Reg :: CmmReg -> TE ()
te_Reg :: CmmReg -> TE ()
te_Reg (CmmLocal CmmFormal
l) = CmmFormal -> TE ()
te_temp CmmFormal
l
te_Reg CmmReg
_            = () -> TE ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- ---------------------------------------------------------------------
-- C types for MachReps

cCast :: SDoc -> CmmExpr -> SDoc
cCast :: SDoc -> CmmExpr -> SDoc
cCast SDoc
ty CmmExpr
expr = SDoc -> SDoc
parens SDoc
ty SDoc -> SDoc -> SDoc
<> CmmExpr -> SDoc
pprExpr1 CmmExpr
expr

cLoad :: CmmExpr -> CmmType -> SDoc
cLoad :: CmmExpr -> CmmType -> SDoc
cLoad CmmExpr
expr CmmType
rep
    = (Platform -> SDoc) -> SDoc
sdocWithPlatform ((Platform -> SDoc) -> SDoc) -> (Platform -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \Platform
platform ->
      if Arch -> Bool
bewareLoadStoreAlignment (Platform -> Arch
platformArch Platform
platform)
      then let decl :: SDoc
decl = CmmType -> SDoc
machRepCType CmmType
rep SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"x" SDoc -> SDoc -> SDoc
<> SDoc
semi
               struct :: SDoc
struct = String -> SDoc
text String
"struct" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces (SDoc
decl)
               packed_attr :: SDoc
packed_attr = String -> SDoc
text String
"__attribute__((packed))"
               cast :: SDoc
cast = SDoc -> SDoc
parens (SDoc
struct SDoc -> SDoc -> SDoc
<+> SDoc
packed_attr SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'*')
           in SDoc -> SDoc
parens (SDoc
cast SDoc -> SDoc -> SDoc
<+> CmmExpr -> SDoc
pprExpr1 CmmExpr
expr) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"->x"
      else Char -> SDoc
char Char
'*' SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (SDoc -> CmmExpr -> SDoc
cCast (CmmType -> SDoc
machRepPtrCType CmmType
rep) CmmExpr
expr)
    where -- On these platforms, unaligned loads are known to cause problems
          bewareLoadStoreAlignment :: Arch -> Bool
bewareLoadStoreAlignment Arch
ArchAlpha    = Bool
True
          bewareLoadStoreAlignment Arch
ArchMipseb   = Bool
True
          bewareLoadStoreAlignment Arch
ArchMipsel   = Bool
True
          bewareLoadStoreAlignment (ArchARM {}) = Bool
True
          bewareLoadStoreAlignment Arch
ArchARM64    = Bool
True
          bewareLoadStoreAlignment Arch
ArchSPARC    = Bool
True
          bewareLoadStoreAlignment Arch
ArchSPARC64  = Bool
True
          -- Pessimistically assume that they will also cause problems
          -- on unknown arches
          bewareLoadStoreAlignment Arch
ArchUnknown  = Bool
True
          bewareLoadStoreAlignment Arch
_            = Bool
False

isCmmWordType :: DynFlags -> CmmType -> Bool
-- True of GcPtrReg/NonGcReg of native word size
isCmmWordType :: DynFlags -> CmmType -> Bool
isCmmWordType DynFlags
dflags CmmType
ty = Bool -> Bool
not (CmmType -> Bool
isFloatType CmmType
ty)
                       Bool -> Bool -> Bool
&& CmmType -> Width
typeWidth CmmType
ty Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Width
wordWidth DynFlags
dflags

-- This is for finding the types of foreign call arguments.  For a pointer
-- argument, we always cast the argument to (void *), to avoid warnings from
-- the C compiler.
machRepHintCType :: CmmType -> ForeignHint -> SDoc
machRepHintCType :: CmmType -> ForeignHint -> SDoc
machRepHintCType CmmType
_   ForeignHint
AddrHint   = String -> SDoc
text String
"void *"
machRepHintCType CmmType
rep ForeignHint
SignedHint = Width -> SDoc
machRep_S_CType (CmmType -> Width
typeWidth CmmType
rep)
machRepHintCType CmmType
rep ForeignHint
_other     = CmmType -> SDoc
machRepCType CmmType
rep

machRepPtrCType :: CmmType -> SDoc
machRepPtrCType :: CmmType -> SDoc
machRepPtrCType CmmType
r
 = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
   if DynFlags -> CmmType -> Bool
isCmmWordType DynFlags
dflags CmmType
r then String -> SDoc
text String
"P_"
                             else CmmType -> SDoc
machRepCType CmmType
r SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'*'

machRepCType :: CmmType -> SDoc
machRepCType :: CmmType -> SDoc
machRepCType CmmType
ty | CmmType -> Bool
isFloatType CmmType
ty = Width -> SDoc
machRep_F_CType Width
w
                | Bool
otherwise      = Width -> SDoc
machRep_U_CType Width
w
                where
                  w :: Width
w = CmmType -> Width
typeWidth CmmType
ty

machRep_F_CType :: Width -> SDoc
machRep_F_CType :: Width -> SDoc
machRep_F_CType Width
W32 = String -> SDoc
text String
"StgFloat" -- ToDo: correct?
machRep_F_CType Width
W64 = String -> SDoc
text String
"StgDouble"
machRep_F_CType Width
_   = String -> SDoc
forall a. String -> a
panic String
"machRep_F_CType"

machRep_U_CType :: Width -> SDoc
machRep_U_CType :: Width -> SDoc
machRep_U_CType Width
w
 = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
   case Width
w of
   Width
_ | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Width
wordWidth DynFlags
dflags -> String -> SDoc
text String
"W_"
   Width
W8  -> String -> SDoc
text String
"StgWord8"
   Width
W16 -> String -> SDoc
text String
"StgWord16"
   Width
W32 -> String -> SDoc
text String
"StgWord32"
   Width
W64 -> String -> SDoc
text String
"StgWord64"
   Width
_   -> String -> SDoc
forall a. String -> a
panic String
"machRep_U_CType"

machRep_S_CType :: Width -> SDoc
machRep_S_CType :: Width -> SDoc
machRep_S_CType Width
w
 = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
   case Width
w of
   Width
_ | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Width
wordWidth DynFlags
dflags -> String -> SDoc
text String
"I_"
   Width
W8  -> String -> SDoc
text String
"StgInt8"
   Width
W16 -> String -> SDoc
text String
"StgInt16"
   Width
W32 -> String -> SDoc
text String
"StgInt32"
   Width
W64 -> String -> SDoc
text String
"StgInt64"
   Width
_   -> String -> SDoc
forall a. String -> a
panic String
"machRep_S_CType"


-- ---------------------------------------------------------------------
-- print strings as valid C strings

pprStringInCStyle :: [Word8] -> SDoc
pprStringInCStyle :: [Word8] -> SDoc
pprStringInCStyle [Word8]
s = SDoc -> SDoc
doubleQuotes (String -> SDoc
text ((Word8 -> String) -> [Word8] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Word8 -> String
charToC [Word8]
s))

-- ---------------------------------------------------------------------------
-- Initialising static objects with floating-point numbers.  We can't
-- just emit the floating point number, because C will cast it to an int
-- by rounding it.  We want the actual bit-representation of the float.
--
-- Consider a concrete C example:
--    double d = 2.5e-10;
--    float f  = 2.5e-10f;
--
--    int * i2 = &d;      printf ("i2: %08X %08X\n", i2[0], i2[1]);
--    long long * l = &d; printf (" l: %016llX\n",   l[0]);
--    int * i = &f;       printf (" i: %08X\n",      i[0]);
-- Result on 64-bit LE (x86_64):
--     i2: E826D695 3DF12E0B
--      l: 3DF12E0BE826D695
--      i: 2F89705F
-- Result on 32-bit BE (m68k):
--     i2: 3DF12E0B E826D695
--      l: 3DF12E0BE826D695
--      i: 2F89705F
--
-- The trick here is to notice that binary representation does not
-- change much: only Word32 values get swapped on LE hosts / targets.

-- This is a hack to turn the floating point numbers into ints that we
-- can safely initialise to static locations.

castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)
castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)
castFloatToWord32Array = STUArray s Int Float -> ST s (STUArray s Int Word32)
forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
U.castSTUArray

castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)
castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)
castDoubleToWord64Array = STUArray s Int Double -> ST s (STUArray s Int Word64)
forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
U.castSTUArray

floatToWord :: DynFlags -> Rational -> CmmLit
floatToWord :: DynFlags -> Rational -> CmmLit
floatToWord DynFlags
dflags Rational
r
  = (forall s. ST s CmmLit) -> CmmLit
forall a. (forall s. ST s a) -> a
runST (do
        STUArray s Int Float
arr <- (Int, Int) -> ST s (STUArray s Int Float)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
0)
        STUArray s Int Float -> Int -> Float -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Float
arr Int
0 (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r)
        STUArray s Int Word32
arr' <- STUArray s Int Float -> ST s (STUArray s Int Word32)
forall s. STUArray s Int Float -> ST s (STUArray s Int Word32)
castFloatToWord32Array STUArray s Int Float
arr
        Word32
w32 <- STUArray s Int Word32 -> Int -> ST s Word32
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word32
arr' Int
0
        CmmLit -> ST s CmmLit
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Width -> CmmLit
CmmInt (Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger Word32
w32 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
wo) (DynFlags -> Width
wordWidth DynFlags
dflags))
    )
    where wo :: Int
wo | DynFlags -> Width
wordWidth DynFlags
dflags Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64
             , DynFlags -> Bool
wORDS_BIGENDIAN DynFlags
dflags    = Int
32
             | Bool
otherwise                 = Int
0

floatPairToWord :: DynFlags -> Rational -> Rational -> CmmLit
floatPairToWord :: DynFlags -> Rational -> Rational -> CmmLit
floatPairToWord DynFlags
dflags Rational
r1 Rational
r2
  = (forall s. ST s CmmLit) -> CmmLit
forall a. (forall s. ST s a) -> a
runST (do
        STUArray s Int Float
arr <- (Int, Int) -> ST s (STUArray s Int Float)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
1)
        STUArray s Int Float -> Int -> Float -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Float
arr Int
0 (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r1)
        STUArray s Int Float -> Int -> Float -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Float
arr Int
1 (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r2)
        STUArray s Int Word32
arr' <- STUArray s Int Float -> ST s (STUArray s Int Word32)
forall s. STUArray s Int Float -> ST s (STUArray s Int Word32)
castFloatToWord32Array STUArray s Int Float
arr
        Word32
w32_1 <- STUArray s Int Word32 -> Int -> ST s Word32
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word32
arr' Int
0
        Word32
w32_2 <- STUArray s Int Word32 -> Int -> ST s Word32
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word32
arr' Int
1
        CmmLit -> ST s CmmLit
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Word32 -> CmmLit
pprWord32Pair Word32
w32_1 Word32
w32_2)
    )
    where pprWord32Pair :: Word32 -> Word32 -> CmmLit
pprWord32Pair Word32
w32_1 Word32
w32_2
              | DynFlags -> Bool
wORDS_BIGENDIAN DynFlags
dflags =
                  Integer -> Width -> CmmLit
CmmInt ((Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL Integer
i1 Int
32) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
i2) Width
W64
              | Bool
otherwise =
                  Integer -> Width -> CmmLit
CmmInt ((Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
shiftL Integer
i2 Int
32) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Integer
i1) Width
W64
              where i1 :: Integer
i1 = Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger Word32
w32_1
                    i2 :: Integer
i2 = Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger Word32
w32_2

doubleToWords :: DynFlags -> Rational -> [CmmLit]
doubleToWords :: DynFlags -> Rational -> [CmmLit]
doubleToWords DynFlags
dflags Rational
r
  = (forall s. ST s [CmmLit]) -> [CmmLit]
forall a. (forall s. ST s a) -> a
runST (do
        STUArray s Int Double
arr <- (Int, Int) -> ST s (STUArray s Int Double)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ ((Int
0::Int),Int
1)
        STUArray s Int Double -> Int -> Double -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Double
arr Int
0 (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r)
        STUArray s Int Word64
arr' <- STUArray s Int Double -> ST s (STUArray s Int Word64)
forall s. STUArray s Int Double -> ST s (STUArray s Int Word64)
castDoubleToWord64Array STUArray s Int Double
arr
        Word64
w64 <- STUArray s Int Word64 -> Int -> ST s Word64
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Word64
arr' Int
0
        [CmmLit] -> ST s [CmmLit]
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> [CmmLit]
pprWord64 Word64
w64)
    )
    where targetWidth :: Width
targetWidth = DynFlags -> Width
wordWidth DynFlags
dflags
          targetBE :: Bool
targetBE    = DynFlags -> Bool
wORDS_BIGENDIAN DynFlags
dflags
          pprWord64 :: Word64 -> [CmmLit]
pprWord64 Word64
w64
              | Width
targetWidth Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 =
                  [ Integer -> Width -> CmmLit
CmmInt (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
w64) Width
targetWidth ]
              | Width
targetWidth Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32 =
                  [ Integer -> Width -> CmmLit
CmmInt (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
targetW1) Width
targetWidth
                  , Integer -> Width -> CmmLit
CmmInt (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
targetW2) Width
targetWidth
                  ]
              | Bool
otherwise = String -> [CmmLit]
forall a. String -> a
panic String
"doubleToWords.pprWord64"
              where (Word64
targetW1, Word64
targetW2)
                        | Bool
targetBE  = (Word64
wHi, Word64
wLo)
                        | Bool
otherwise = (Word64
wLo, Word64
wHi)
                    wHi :: Word64
wHi = Word64
w64 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32
                    wLo :: Word64
wLo = Word64
w64 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0xFFFFffff

-- ---------------------------------------------------------------------------
-- Utils

wordShift :: DynFlags -> Int
wordShift :: DynFlags -> Int
wordShift DynFlags
dflags = Width -> Int
widthInLog (DynFlags -> Width
wordWidth DynFlags
dflags)

commafy :: [SDoc] -> SDoc
commafy :: [SDoc] -> SDoc
commafy [SDoc]
xs = [SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma [SDoc]
xs

-- Print in C hex format: 0x13fa
pprHexVal :: Integer -> Width -> SDoc
pprHexVal :: Integer -> Width -> SDoc
pprHexVal Integer
w Width
rep
  | Integer
w Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0     = SDoc -> SDoc
parens (Char -> SDoc
char Char
'-' SDoc -> SDoc -> SDoc
<>
                    String -> SDoc
text String
"0x" SDoc -> SDoc -> SDoc
<> Integer -> SDoc
intToDoc (-Integer
w) SDoc -> SDoc -> SDoc
<> Width -> SDoc
repsuffix Width
rep)
  | Bool
otherwise =     String -> SDoc
text String
"0x" SDoc -> SDoc -> SDoc
<> Integer -> SDoc
intToDoc   Integer
w  SDoc -> SDoc -> SDoc
<> Width -> SDoc
repsuffix Width
rep
  where
        -- type suffix for literals:
        -- Integer literals are unsigned in Cmm/C.  We explicitly cast to
        -- signed values for doing signed operations, but at all other
        -- times values are unsigned.  This also helps eliminate occasional
        -- warnings about integer overflow from gcc.

      repsuffix :: Width -> SDoc
repsuffix Width
W64 = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
               if DynFlags -> Int
cINT_SIZE       DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 then Char -> SDoc
char Char
'U'
          else if DynFlags -> Int
cLONG_SIZE      DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 then String -> SDoc
text String
"UL"
          else if DynFlags -> Int
cLONG_LONG_SIZE DynFlags
dflags Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 then String -> SDoc
text String
"ULL"
          else String -> SDoc
forall a. String -> a
panic String
"pprHexVal: Can't find a 64-bit type"
      repsuffix Width
_ = Char -> SDoc
char Char
'U'

      intToDoc :: Integer -> SDoc
      intToDoc :: Integer -> SDoc
intToDoc Integer
i = case Integer -> Integer
truncInt Integer
i of
                       Integer
0 -> Char -> SDoc
char Char
'0'
                       Integer
v -> Integer -> SDoc
go Integer
v

      -- We need to truncate value as Cmm backend does not drop
      -- redundant bits to ease handling of negative values.
      -- Thus the following Cmm code on 64-bit arch, like amd64:
      --     CInt v;
      --     v = {something};
      --     if (v == %lobits32(-1)) { ...
      -- leads to the following C code:
      --     StgWord64 v = (StgWord32)({something});
      --     if (v == 0xFFFFffffFFFFffffU) { ...
      -- Such code is incorrect as it promotes both operands to StgWord64
      -- and the whole condition is always false.
      truncInt :: Integer -> Integer
      truncInt :: Integer -> Integer
truncInt Integer
i =
          case Width
rep of
              Width
W8  -> Integer
i Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`rem` (Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
8 :: Int))
              Width
W16 -> Integer
i Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`rem` (Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
16 :: Int))
              Width
W32 -> Integer
i Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`rem` (Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
32 :: Int))
              Width
W64 -> Integer
i Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`rem` (Integer
2Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
64 :: Int))
              Width
_   -> String -> Integer
forall a. String -> a
panic (String
"pprHexVal/truncInt: C backend can't encode "
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Width -> String
forall a. Show a => a -> String
show Width
rep String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" literals")

      go :: Integer -> SDoc
go Integer
0 = SDoc
empty
      go Integer
w' = Integer -> SDoc
go Integer
q SDoc -> SDoc -> SDoc
<> SDoc
dig
           where
             (Integer
q,Integer
r) = Integer
w' Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Integer
16
             dig :: SDoc
dig | Integer
r Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
10    = Char -> SDoc
char (Int -> Char
chr (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
r Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
'0'))
                 | Bool
otherwise = Char -> SDoc
char (Int -> Char
chr (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
'a'))