{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingVia   #-}
{-# LANGUAGE GADTs         #-}
{-# LANGUAGE LambdaCase    #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

-----------------------------------------------------------------------------
--
-- 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/ppr-c
--
-- 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 GHC.CmmToC
   ( cmmToC
   )
where

import GHC.Prelude

import GHC.Platform

import GHC.CmmToAsm.CPrim

import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm hiding (pprBBlock, pprStatic)
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Utils
import GHC.Cmm.Switch
import GHC.Cmm.InitFini

import GHC.Types.ForeignCall
import GHC.Types.Unique.Set
import GHC.Types.Unique.FM
import GHC.Types.Unique

import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Monad.State.Strict (State (..), runState, state)
import GHC.Utils.Misc

import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Char
import Data.List (intersperse)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map (Map)
import qualified Data.Map as Map
import GHC.Float

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

cmmToC :: Platform -> RawCmmGroup -> SDoc
cmmToC :: Platform -> RawCmmGroup -> SDoc
cmmToC Platform
platform RawCmmGroup
tops = ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
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 (Platform -> RawCmmDecl -> SDoc
pprTop Platform
platform) RawCmmGroup
tops) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
blankLine

--
-- top level procs
--
pprTop :: Platform -> RawCmmDecl -> SDoc
pprTop :: Platform -> RawCmmDecl -> SDoc
pprTop Platform
platform = \case
  (CmmProc LabelMap RawCmmStatics
infos CLabel
clbl [GlobalReg]
_in_live_regs CmmGraph
graph) ->
    (case BlockId -> LabelMap RawCmmStatics -> Maybe RawCmmStatics
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup (CmmGraph -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
graph) LabelMap RawCmmStatics
infos of
       Maybe RawCmmStatics
Nothing -> SDoc
forall doc. IsOutput doc => doc
empty
       Just (CmmStaticsRaw CLabel
info_clbl [CmmStatic]
info_dat) ->
           Platform -> [CmmStatic] -> SDoc
pprDataExterns Platform
platform [CmmStatic]
info_dat SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
           Platform -> Bool -> CLabel -> [CmmStatic] -> SDoc
pprWordArray Platform
platform Bool
info_is_in_rodata CLabel
info_clbl [CmmStatic]
info_dat) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
    ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [
           SDoc
blankLine,
           SDoc
extern_decls,
           (if (CLabel -> Bool
externallyVisibleCLabel CLabel
clbl)
                    then SDoc -> SDoc
mkFN_ else SDoc -> SDoc
mkIF_) (Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform CLabel
clbl) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
forall doc. IsLine doc => doc
lbrace,
           Int -> SDoc -> SDoc
nest Int
8 SDoc
temp_decls,
           [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((CmmBlock -> SDoc) -> [CmmBlock] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmBlock -> SDoc
pprBBlock Platform
platform) [CmmBlock]
blocks),
           SDoc
forall doc. IsLine doc => doc
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) = Platform -> [CmmBlock] -> (SDoc, SDoc)
pprTempAndExternDecls Platform
platform [CmmBlock]
blocks


  -- Chunks of static data.

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

  RawCmmDecl
cmm_data | Just (InitOrFini
initOrFini, [CLabel]
clbls) <- RawCmmDecl -> Maybe (InitOrFini, [CLabel])
isInitOrFiniArray RawCmmDecl
cmm_data ->
    Platform -> InitOrFini -> [CLabel] -> SDoc
pprCtorArray Platform
platform InitOrFini
initOrFini [CLabel]
clbls

  (CmmData Section
section (CmmStaticsRaw CLabel
lbl [CmmString ByteString
str])) ->
    Platform -> CLabel -> SDoc
pprExternDecl Platform
platform CLabel
lbl SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
    [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [
      CLabel -> SDoc
pprLocalness CLabel
lbl, Bool -> SDoc
pprConstness (Section -> Bool
isSecConstant Section
section), String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"char ", Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform CLabel
lbl,
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"[] = ", ByteString -> SDoc
pprStringInCStyle ByteString
str, SDoc
forall doc. IsLine doc => doc
semi
    ]

  (CmmData Section
section (CmmStaticsRaw CLabel
lbl [CmmUninitialised Int
size])) ->
    Platform -> CLabel -> SDoc
pprExternDecl Platform
platform CLabel
lbl SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
    [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [
      CLabel -> SDoc
pprLocalness CLabel
lbl, Bool -> SDoc
pprConstness (Section -> Bool
isSecConstant Section
section), String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"char ", Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform CLabel
lbl,
      SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
size), SDoc
forall doc. IsLine doc => doc
semi
    ]

  (CmmData Section
section (CmmStaticsRaw CLabel
lbl [CmmStatic]
lits)) ->
    Platform -> [CmmStatic] -> SDoc
pprDataExterns Platform
platform [CmmStatic]
lits SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
    Platform -> Bool -> CLabel -> [CmmStatic] -> SDoc
pprWordArray Platform
platform (Section -> Bool
isSecConstant Section
section) CLabel
lbl [CmmStatic]
lits
  where
    isSecConstant :: Section -> Bool
isSecConstant Section
section = case Section -> SectionProtection
sectionProtection Section
section of
      SectionProtection
ReadOnlySection -> Bool
True
      SectionProtection
WriteProtectedSection -> Bool
True
      SectionProtection
_ -> Bool
False

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

pprBBlock :: Platform -> CmmBlock -> SDoc
pprBBlock :: Platform -> CmmBlock -> SDoc
pprBBlock Platform
platform CmmBlock
block =
  Int -> SDoc -> SDoc
nest Int
4 (BlockId -> SDoc
pprBlockId (CmmBlock -> BlockId
forall (x :: Extensibility). Block CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
block) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
  Int -> SDoc -> SDoc
nest Int
8 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((CmmNode O O -> SDoc) -> [CmmNode O O] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmNode O O -> SDoc
forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> SDoc
pprStmt Platform
platform) (Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
nodes)) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Platform -> CmmNode O C -> SDoc
forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> SDoc
pprStmt Platform
platform 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 :: Extensibility -> Extensibility -> *).
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 :: Platform -> Bool -> CLabel -> [CmmStatic] -> SDoc
pprWordArray :: Platform -> Bool -> CLabel -> [CmmStatic] -> SDoc
pprWordArray Platform
platform Bool
is_ro CLabel
lbl [CmmStatic]
ds
  = -- TODO: align closures only
    Platform -> CLabel -> SDoc
pprExternDecl Platform
platform CLabel
lbl SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
    [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [ CLabel -> SDoc
pprLocalness CLabel
lbl, Bool -> SDoc
pprConstness Bool
is_ro, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StgWord"
         , SDoc
forall doc. IsLine doc => doc
space, Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform CLabel
lbl, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"[]"
         -- See Note [StgWord alignment]
         , Width -> SDoc
pprAlignment (Platform -> Width
wordWidth Platform
platform)
         , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"= {" ]
    SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
8 ([SDoc] -> SDoc
commafy (Platform -> [CmmLit] -> [SDoc]
staticLitsToWords Platform
platform ([CmmLit] -> [SDoc]) -> [CmmLit] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ [CmmStatic] -> [CmmLit]
toLits [CmmStatic]
ds))
    SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"};"
  where
    toLits :: [CmmStatic] -> [CmmLit]
    toLits :: [CmmStatic] -> [CmmLit]
toLits = (CmmStatic -> CmmLit) -> [CmmStatic] -> [CmmLit]
forall a b. (a -> b) -> [a] -> [b]
map CmmStatic -> CmmLit
f
      where
        f :: CmmStatic -> CmmLit
f (CmmStaticLit CmmLit
lit) = CmmLit
lit
        f CmmStatic
static             = String -> SDoc -> CmmLit
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"pprWordArray: Unexpected literal"  (Platform -> CmmStatic -> SDoc
pprStatic Platform
platform CmmStatic
static)

pprAlignment :: Width -> SDoc
pprAlignment :: Width -> SDoc
pprAlignment Width
words =
     String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"__attribute__((aligned(" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int (Width -> Int
widthInBytes Width
words) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
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 (#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
forall doc. IsLine doc => String -> doc
text String
"static "
                 | Bool
otherwise = SDoc
forall doc. IsOutput doc => doc
empty

pprConstness :: Bool -> SDoc
pprConstness :: Bool -> SDoc
pprConstness Bool
is_ro | Bool
is_ro = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"const "
                   | Bool
otherwise = SDoc
forall doc. IsOutput doc => doc
empty

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

pprStmt :: Platform -> CmmNode e x -> SDoc
pprStmt :: forall (e :: Extensibility) (x :: Extensibility).
Platform -> CmmNode e x -> SDoc
pprStmt Platform
platform CmmNode e x
stmt =
    case CmmNode e x
stmt of
    CmmEntry{}   -> SDoc
forall doc. IsOutput doc => doc
empty
    CmmComment FastString
_ -> SDoc
forall doc. IsOutput doc => doc
empty -- (hang (text "/*") 3 (ftext s)) $$ text "*/"
                          -- 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
forall doc. IsOutput doc => doc
empty
    CmmUnwind{} -> SDoc
forall doc. IsOutput doc => doc
empty

    CmmAssign CmmReg
dest CmmExpr
src -> Platform -> CmmReg -> CmmExpr -> SDoc
pprAssign Platform
platform CmmReg
dest CmmExpr
src

    CmmStore  CmmExpr
dest CmmExpr
src AlignmentSpec
align
        | CmmType -> Width
typeWidth CmmType
rep Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 Bool -> Bool -> Bool
&& Platform -> Width
wordWidth Platform
platform Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
/= Width
W64
        -> (if CmmType -> Bool
isFloatType CmmType
rep then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ASSIGN_DBL"
                               else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ASSIGN_Word64") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
           SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc
mkP_ SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Platform -> CmmExpr -> SDoc
pprExpr1 Platform
platform CmmExpr
dest SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Platform -> CmmExpr -> SDoc
pprExpr Platform
platform CmmExpr
src) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi

        | Bool
otherwise
        -> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ Platform -> CmmExpr -> SDoc
pprExpr Platform
platform (CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad CmmExpr
dest CmmType
rep AlignmentSpec
align), SDoc
forall doc. IsLine doc => doc
equals, Platform -> CmmExpr -> SDoc
pprExpr Platform
platform CmmExpr
src SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi ]
        where
          rep :: CmmType
rep = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
src

    CmmUnsafeForeignCall target :: ForeignTarget
target@(ForeignTarget CmmExpr
fn ForeignConvention
conv) [LocalReg]
results [CmmExpr]
args ->
        SDoc
fnCall
        where
        ([ForeignHint]
res_hints, [ForeignHint]
arg_hints) = ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints ForeignTarget
target
        hresults :: [(LocalReg, ForeignHint)]
hresults = [LocalReg] -> [ForeignHint] -> [(LocalReg, ForeignHint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LocalReg]
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
forall doc. IsLine doc => doc -> doc
parens (Platform -> SDoc -> CmmExpr -> SDoc
cCast Platform
platform (Platform
-> SDoc
-> CCallConv
-> [(LocalReg, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCFunType Platform
platform (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'*') CCallConv
cconv [(LocalReg, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs) CmmExpr
fn)

        -- See wiki:commentary/compiler/backends/ppr-c#prototypes
        fnCall :: SDoc
fnCall =
            case CmmExpr
fn of
              CmmLit (CmmLabel CLabel
lbl)
                | CCallConv
StdCallConv <- CCallConv
cconv ->
                    Platform
-> SDoc
-> CCallConv
-> [(LocalReg, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCall Platform
platform (Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform CLabel
lbl) CCallConv
cconv [(LocalReg, 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 ->
                    Platform
-> SDoc
-> CCallConv
-> [(LocalReg, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCall Platform
platform SDoc
cast_fn CCallConv
cconv [(LocalReg, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"__builtin_unreachable();"
                | Bool -> Bool
not (CLabel -> Bool
isMathFun CLabel
lbl) ->
                    Platform
-> SDoc
-> CCallConv
-> [(LocalReg, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprForeignCall Platform
platform (Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform CLabel
lbl) CCallConv
cconv [(LocalReg, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs
              CmmExpr
_ ->
                    Platform
-> SDoc
-> CCallConv
-> [(LocalReg, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCall Platform
platform SDoc
cast_fn CCallConv
cconv [(LocalReg, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
                        -- for a dynamic call, no declaration is necessary.

    CmmUnsafeForeignCall (PrimTarget CallishMachOp
MO_Touch) [LocalReg]
_results [CmmExpr]
_args -> SDoc
forall doc. IsOutput doc => doc
empty
    CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data Int
_)) [LocalReg]
_results [CmmExpr]
_args -> SDoc
forall doc. IsOutput doc => doc
empty

    CmmUnsafeForeignCall (PrimTarget CallishMachOp
MO_ReleaseFence) [] [] ->
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"__atomic_thread_fence(__ATOMIC_RELEASE);"
    CmmUnsafeForeignCall (PrimTarget CallishMachOp
MO_AcquireFence) [] [] ->
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"__atomic_thread_fence(__ATOMIC_ACQUIRE);"
    CmmUnsafeForeignCall (PrimTarget CallishMachOp
MO_SeqCstFence) [] [] ->
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"__atomic_thread_fence(__ATOMIC_SEQ_CST);"

    CmmUnsafeForeignCall target :: ForeignTarget
target@(PrimTarget CallishMachOp
op) [LocalReg]
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 :: [(LocalReg, ForeignHint)]
hresults = [LocalReg] -> [ForeignHint] -> [(LocalReg, ForeignHint)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LocalReg]
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

        need_cdecl :: Bool
need_cdecl
          | CallishMachOp
MO_ResumeThread  <- CallishMachOp
op                 = Bool
True
          | CallishMachOp
MO_SuspendThread <- CallishMachOp
op                 = Bool
True
          | Bool
otherwise                              = Bool
False

        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).
          | Bool
need_cdecl
          = (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
";EFF_(" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
fn SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
')' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
            Platform
-> SDoc
-> CCallConv
-> [(LocalReg, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprForeignCall Platform
platform SDoc
fn CCallConv
cconv [(LocalReg, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs
          | Bool
otherwise
          = Platform
-> SDoc
-> CCallConv
-> [(LocalReg, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCall Platform
platform SDoc
fn CCallConv
cconv [(LocalReg, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs

    CmmBranch BlockId
ident               -> BlockId -> SDoc
pprBranch BlockId
ident
    CmmCondBranch CmmExpr
expr BlockId
yes BlockId
no Maybe Bool
_   -> Platform -> CmmExpr -> BlockId -> BlockId -> SDoc
pprCondBranch Platform
platform CmmExpr
expr BlockId
yes BlockId
no
    CmmCall { cml_target :: CmmNode O C -> CmmExpr
cml_target = CmmExpr
expr } -> SDoc -> SDoc
mkJMP_ (Platform -> CmmExpr -> SDoc
pprExpr Platform
platform CmmExpr
expr) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
    CmmSwitch CmmExpr
arg SwitchTargets
ids             -> Platform -> CmmExpr -> SwitchTargets -> SDoc
pprSwitch Platform
platform CmmExpr
arg SwitchTargets
ids

    CmmNode e x
_other -> String -> SDoc -> SDoc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"PprC.pprStmt" (Platform -> CmmNode e x -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmNode e x
stmt)

type Hinted a = (a, ForeignHint)

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

pprCFunType :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
pprCFunType :: Platform
-> SDoc
-> CCallConv
-> [(LocalReg, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCFunType Platform
platform SDoc
ppr_fn CCallConv
cconv [(LocalReg, ForeignHint)]
ress [(CmmExpr, ForeignHint)]
args
  = let res_type :: [(LocalReg, ForeignHint)] -> SDoc
res_type [] = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"void"
        res_type [(LocalReg
one, ForeignHint
hint)] = Platform -> CmmType -> ForeignHint -> SDoc
machRepHintCType Platform
platform (LocalReg -> CmmType
localRegType LocalReg
one) ForeignHint
hint
        res_type [(LocalReg, ForeignHint)]
_ = String -> SDoc
forall a. HasCallStack => String -> a
panic String
"pprCFunType: only void or 1 return value supported"

        arg_type :: (CmmExpr, ForeignHint) -> SDoc
arg_type (CmmExpr
expr, ForeignHint
hint) = Platform -> CmmType -> ForeignHint -> SDoc
machRepHintCType Platform
platform (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
expr) ForeignHint
hint
    in [(LocalReg, ForeignHint)] -> SDoc
res_type [(LocalReg, ForeignHint)]
ress SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
       SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (CCallConv -> SDoc
ccallConvAttribute CCallConv
cconv SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
ppr_fn) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
       SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
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
forall doc. IsLine doc => String -> doc
text String
"goto" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> BlockId -> SDoc
pprBlockId BlockId
ident SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi


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

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

    rep :: Width
rep = CmmType -> Width
typeWidth (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
e)

    -- fall through case
    caseify :: (NonEmpty Integer, BlockId) -> SDoc
caseify (Integer
ix:|[Integer]
ixs, BlockId
ident) = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((Integer -> SDoc) -> [Integer] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> SDoc
do_fallthrough [Integer]
ixs) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Integer -> SDoc
final_branch Integer
ix
        where
        do_fallthrough :: Integer -> SDoc
do_fallthrough Integer
ix =
                 [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"case" , Platform -> Integer -> Width -> SDoc
pprHexVal Platform
platform Integer
ix Width
rep SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon ,
                        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"/* fall through */" ]

        final_branch :: Integer -> SDoc
final_branch Integer
ix =
                [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"case" , Platform -> Integer -> Width -> SDoc
pprHexVal Platform
platform Integer
ix Width
rep SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon ,
                       String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"goto" , (BlockId -> SDoc
pprBlockId BlockId
ident) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi ]

    def :: SDoc
def | Just BlockId
l <- Maybe BlockId
mbdef = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"default: goto" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> BlockId -> SDoc
pprBlockId BlockId
l SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
        | Bool
otherwise       = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"default: __builtin_unreachable();"

-- ---------------------------------------------------------------------
-- 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 :: Platform -> CmmExpr -> SDoc
pprExpr :: Platform -> CmmExpr -> SDoc
pprExpr Platform
platform CmmExpr
e = case CmmExpr
e of
    CmmLit CmmLit
lit         -> Platform -> CmmLit -> SDoc
pprLit Platform
platform CmmLit
lit
    CmmLoad CmmExpr
e CmmType
ty AlignmentSpec
align -> Platform -> CmmExpr -> CmmType -> AlignmentSpec -> SDoc
pprLoad Platform
platform CmmExpr
e CmmType
ty AlignmentSpec
align
    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    -> Platform -> CmmExpr -> SDoc
pprExpr Platform
platform (CmmExpr -> SDoc) -> CmmExpr -> SDoc
forall a b. (a -> b) -> a -> b
$ MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
w) [CmmReg -> CmmExpr
CmmReg CmmReg
reg, CmmLit -> CmmExpr
CmmLit (CmmLit -> CmmExpr) -> CmmLit -> CmmExpr
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
i) Width
w]
      where w :: Width
w = CmmReg -> Width
cmmRegWidth CmmReg
reg

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

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


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

  -- TODO: exploit natural-alignment where possible
  | 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
== Platform -> Width
wordWidth Platform
platform Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmType -> Bool
isFloatType CmmType
ty)
                 -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'*' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
== Platform -> Width
wordWidth Platform
platform Bool -> Bool -> Bool
&& Bool -> Bool
not (CmmType -> Bool
isFloatType CmmType
ty)
                      -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'*' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
== Platform -> Width
wordWidth Platform
platform
                        , Int
off Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Platform -> Int
platformWordSizeInBytes Platform
platform 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
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Int
off Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Platform -> Int
wordShift Platform
platform))

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

pprExpr1 :: Platform -> CmmExpr -> SDoc
pprExpr1 :: Platform -> CmmExpr -> SDoc
pprExpr1 Platform
platform CmmExpr
e = case CmmExpr
e of
   CmmLit CmmLit
lit  -> Platform -> CmmLit -> SDoc
pprLit1 Platform
platform CmmLit
lit
   CmmReg CmmReg
_reg -> Platform -> CmmExpr -> SDoc
pprExpr Platform
platform CmmExpr
e
   CmmExpr
_           -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> CmmExpr -> SDoc
pprExpr Platform
platform CmmExpr
e)

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

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

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

pprMachOpApp Platform
platform (MO_RelaxedRead Width
w) [CmmExpr
x]
  = Platform -> CmmExpr -> SDoc
pprExpr Platform
platform (CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad CmmExpr
x (Width -> CmmType
cmmBits Width
w) AlignmentSpec
NaturallyAligned)

pprMachOpApp Platform
platform MachOp
mop [CmmExpr]
args
  | Just SDoc
ty <- Platform -> MachOp -> [CmmType] -> Maybe SDoc
machOpNeedsCast Platform
platform MachOp
mop ((CmmExpr -> CmmType) -> [CmmExpr] -> [CmmType]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform) [CmmExpr]
args)
  = SDoc
ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> MachOp -> [CmmExpr] -> SDoc
pprMachOpApp' Platform
platform MachOp
mop [CmmExpr]
args)
  | Bool
otherwise
  = Platform -> MachOp -> [CmmExpr] -> SDoc
pprMachOpApp' Platform
platform MachOp
mop [CmmExpr]
args

{-
Note [Zero-extending sub-word signed results]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a program like (from #20634):

    test() {
        bits64 ret;
        bits8 a,b;
        a = 0xe1 :: bits8;       // == -31 signed
        b = %quot(a, 3::bits8);  // == -10 signed
        ret = %zx64(a);          // == 0xf6 unsigned
        return (ret);
    }

This program should return 0xf6 == 246. However, we need to be very careful
with when dealing with the result of the %quot. For instance, one might be
tempted produce code like:

    StgWord8 a = 0xe1U;
    StgInt8  b = (StgInt8) a / (StgInt8) 0x3U;
    StgWord ret = (W_) b;

However, this would be wrong; by widening `b` directly from `StgInt8` to
`StgWord` we will get sign-extension semantics: rather than 0xf6 we will get
0xfffffffffffffff6. To avoid this we must first cast `b` back to `StgWord8`,
ensuring that we get zero-extension semantics when we widen up to `StgWord`.

Note [When in doubt, cast arguments as unsigned]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In general C's signed-ness behavior can lead to surprising results and
consequently we are very explicit about ensuring that arguments have the
correct signedness. For instance, consider a program like

    test() {
        bits64 ret, a, b;
        a = %neg(43 :: bits64);
        b = %neg(0x443c70fa3e465120 :: bits64);
        ret = %modu(a, b);
        return (ret);
    }

In this case both `a` and `b` will be StgInts in the generated C (since
`MO_Neg` is a signed operation). However, we want to ensure that we perform an
*unsigned* modulus operation, therefore we must be careful to cast both arguments
to StgWord. We do this for any operation where the signedness of the argument
may affect the operation's semantics.
-}

-- | The result type of most operations is determined by the operands. However,
-- there are a few exceptions: particularly operations which might get promoted
-- to a signed result. For these we explicitly cast the result.
machOpNeedsCast :: Platform -> MachOp -> [CmmType] -> Maybe SDoc
machOpNeedsCast :: Platform -> MachOp -> [CmmType] -> Maybe SDoc
machOpNeedsCast Platform
platform MachOp
mop [CmmType]
args
    -- Comparisons in C have type 'int', but we want type W_ (this is what
    -- resultRepOfMachOp says).
  | MachOp -> Bool
isComparisonMachOp MachOp
mop = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just SDoc
mkW_

    -- See Note [Zero-extending sub-word signed results]
  | MachOp -> Bool
signedOp MachOp
mop
  , CmmType
res_ty <- Platform -> MachOp -> [CmmType] -> CmmType
machOpResultType Platform
platform MachOp
mop [CmmType]
args
  , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CmmType -> Bool
isFloatType CmmType
res_ty -- only integer operations, not MO_SF_Conv
  , let w :: Width
w = CmmType -> Width
typeWidth CmmType
res_ty
  , Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Platform -> Width
wordWidth Platform
platform
  = Width -> Maybe SDoc
cast_it Width
w

    -- A shift operation like (a >> b) where a::Word8 and b::Word has type Word
    -- in C yet we want a Word8
  | Just Width
w <- MachOp -> Maybe Width
shiftOp MachOp
mop  = Width -> Maybe SDoc
cast_it Width
w

    -- The results of these operations may be promoted to signed values
    -- due to C11 section 6.3.1.1.
  | MO_Add Width
w <- MachOp
mop        = Width -> Maybe SDoc
cast_it Width
w
  | MO_Sub Width
w <- MachOp
mop        = Width -> Maybe SDoc
cast_it Width
w
  | MO_Mul Width
w <- MachOp
mop        = Width -> Maybe SDoc
cast_it Width
w
  | MO_U_Quot Width
w <- MachOp
mop     = Width -> Maybe SDoc
cast_it Width
w
  | MO_U_Rem  Width
w <- MachOp
mop     = Width -> Maybe SDoc
cast_it Width
w
  | MO_And Width
w <- MachOp
mop        = Width -> Maybe SDoc
cast_it Width
w
  | MO_Or  Width
w <- MachOp
mop        = Width -> Maybe SDoc
cast_it Width
w
  | MO_Xor Width
w <- MachOp
mop        = Width -> Maybe SDoc
cast_it Width
w
  | MO_Not Width
w <- MachOp
mop        = Width -> Maybe SDoc
cast_it Width
w

  | Bool
otherwise              = Maybe SDoc
forall a. Maybe a
Nothing
  where
    cast_it :: Width -> Maybe SDoc
cast_it Width
w =
      let ty :: SDoc
ty = Platform -> Width -> SDoc
machRep_U_CType Platform
platform Width
w
      in SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
ty

pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc
pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc
pprMachOpApp' Platform
platform MachOp
mop [CmmExpr]
args
 = case [CmmExpr]
args of

    -- ternary
    args :: [CmmExpr]
args@[CmmExpr
_,CmmExpr
_,CmmExpr
_] ->
      Platform -> MachOp -> SDoc
pprMachOp_for_C Platform
platform MachOp
mop SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ((CmmExpr -> SDoc) -> [CmmExpr] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas CmmExpr -> SDoc
pprArg [CmmExpr]
args)

    -- dyadic
    [CmmExpr
x,CmmExpr
y] -> CmmExpr -> SDoc
pprArg CmmExpr
x SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> MachOp -> SDoc
pprMachOp_for_C Platform
platform MachOp
mop SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CmmExpr -> SDoc
pprArg CmmExpr
y

    -- unary
    [CmmExpr
x]   -> Platform -> MachOp -> SDoc
pprMachOp_for_C Platform
platform MachOp
mop SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (CmmExpr -> SDoc
pprArg CmmExpr
x)

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

  where
    pprArg :: CmmExpr -> SDoc
pprArg CmmExpr
e
      | MachOp -> Bool
needsFCasts MachOp
mop = Platform -> SDoc -> CmmExpr -> SDoc
cCast Platform
platform (Width -> SDoc
machRep_F_CType Width
width) CmmExpr
e
        -- Cast needed for signed integer ops
      | MachOp -> Bool
signedOp    MachOp
mop = Platform -> SDoc -> CmmExpr -> SDoc
cCast Platform
platform (Platform -> Width -> SDoc
machRep_S_CType Platform
platform Width
width) CmmExpr
e
        -- See Note [When in doubt, cast arguments as unsigned]
      | MachOp -> Bool
needsUnsignedCast MachOp
mop
                        = Platform -> SDoc -> CmmExpr -> SDoc
cCast Platform
platform (Platform -> Width -> SDoc
machRep_U_CType Platform
platform Width
width) CmmExpr
e
      | Bool
otherwise       = Platform -> CmmExpr -> SDoc
pprExpr1 Platform
platform CmmExpr
e
      where
        width :: Width
width = CmmType -> Width
typeWidth (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
e)

    needsFCasts :: MachOp -> Bool
needsFCasts (MO_F_Neg Width
_)  = Bool
True
    needsFCasts (MO_F_Quot Width
_) = Bool
True
    needsFCasts MachOp
mop  = MachOp -> Bool
floatComparison MachOp
mop

    -- See Note [When in doubt, cast arguments as unsigned]
    needsUnsignedCast :: MachOp -> Bool
needsUnsignedCast (MO_Mul    Width
_) = Bool
True
    needsUnsignedCast (MO_U_Shr  Width
_) = Bool
True
    needsUnsignedCast (MO_U_Quot Width
_) = Bool
True
    needsUnsignedCast (MO_U_Rem  Width
_) = Bool
True
    needsUnsignedCast (MO_U_Ge   Width
_) = Bool
True
    needsUnsignedCast (MO_U_Le   Width
_) = Bool
True
    needsUnsignedCast (MO_U_Gt   Width
_) = Bool
True
    needsUnsignedCast (MO_U_Lt   Width
_) = Bool
True
    needsUnsignedCast MachOp
_             = Bool
False

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

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

    CmmFloat Rational
f Width
w       -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Width -> SDoc
machRep_F_CType Width
w) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
forall doc. IsLine doc => String -> doc
text String
"-INFINITY"
                  | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
d          = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"INFINITY"
                  | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
d               = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NAN"
                  | Bool
otherwise             = String -> SDoc
forall doc. IsLine doc => String -> doc
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. HasCallStack => String -> a
panic String
"PprC printing vector literal"

    CmmBlock BlockId
bid       -> SDoc
mkW_ SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> CLabel -> SDoc
pprCLabelAddr (BlockId -> CLabel
infoTblLbl BlockId
bid)
    CmmLit
CmmHighStackMark   -> String -> SDoc
forall a. HasCallStack => String -> a
panic String
"PprC printing high stack mark"
    CmmLabel CLabel
clbl      -> SDoc
mkW_ SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> CLabel -> SDoc
pprCLabelAddr CLabel
clbl
    CmmLabelOff CLabel
clbl Int
i -> SDoc
mkW_ SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> CLabel -> SDoc
pprCLabelAddr CLabel
clbl SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'+' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
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
forall doc. IsLine doc => doc -> doc -> doc
<> CLabel -> SDoc
pprCLabelAddr CLabel
clbl1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'+' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
i

    where
        pprCLabelAddr :: CLabel -> SDoc
pprCLabelAddr CLabel
lbl = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'&' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform CLabel
lbl

pprLit1 :: Platform -> CmmLit -> SDoc
pprLit1 :: Platform -> CmmLit -> SDoc
pprLit1 Platform
platform CmmLit
lit = case CmmLit
lit of
   (CmmLabelOff CLabel
_ Int
_)         -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> CmmLit -> SDoc
pprLit Platform
platform CmmLit
lit)
   (CmmLabelDiffOff CLabel
_ CLabel
_ Int
_ Width
_) -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> CmmLit -> SDoc
pprLit Platform
platform CmmLit
lit)
   (CmmFloat Rational
_ Width
_)            -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> CmmLit -> SDoc
pprLit Platform
platform CmmLit
lit)
   CmmLit
_                         -> Platform -> CmmLit -> SDoc
pprLit Platform
platform CmmLit
lit

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

-- | Produce a list of word sized literals encoding the given list of 'CmmLit's.
staticLitsToWords :: Platform -> [CmmLit] -> [SDoc]
staticLitsToWords :: Platform -> [CmmLit] -> [SDoc]
staticLitsToWords Platform
platform = [CmmLit] -> [SDoc]
go ([CmmLit] -> [SDoc])
-> ([CmmLit] -> [CmmLit]) -> [CmmLit] -> [SDoc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CmmLit -> [CmmLit]) -> [CmmLit] -> [CmmLit]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap CmmLit -> [CmmLit]
decomposeMultiWord
  where
    -- rem_bytes is how many bytes remain in the word we are currently filling.
    -- accum is the word we are filling.
    go :: [CmmLit] -> [SDoc]
    go :: [CmmLit] -> [SDoc]
go [] = []
    go lits :: [CmmLit]
lits@(CmmLit
lit : [CmmLit]
_)
      | Just (Integer, Width)
_ <- CmmLit -> Maybe (Integer, Width)
isSubWordLit CmmLit
lit
      = Int -> Integer -> [CmmLit] -> [SDoc]
goSubWord Int
wordWidthBytes Integer
0 [CmmLit]
lits
    go (CmmLit
lit : [CmmLit]
rest)
      = Platform -> CmmLit -> SDoc
pprLit1 Platform
platform CmmLit
lit SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [CmmLit] -> [SDoc]
go [CmmLit]
rest

    goSubWord :: Int -> Integer -> [CmmLit] -> [SDoc]
    goSubWord :: Int -> Integer -> [CmmLit] -> [SDoc]
goSubWord Int
rem_bytes Integer
accum (CmmLit
lit : [CmmLit]
rest)
      | Just (Integer
bytes, Width
w) <- CmmLit -> Maybe (Integer, Width)
isSubWordLit CmmLit
lit
      , Int
rem_bytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Width -> Int
widthInBytes Width
w
      = let accum' :: Integer
accum' = (Integer
accum Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Width -> Int
widthInBits Width
w) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. Width -> Integer -> Integer
fixEndian Width
w Integer
bytes
        in Int -> Integer -> [CmmLit] -> [SDoc]
goSubWord (Int
rem_bytes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Width -> Int
widthInBytes Width
w) Integer
accum' [CmmLit]
rest
    goSubWord Int
rem_bytes Integer
accum [CmmLit]
rest
      = Integer -> SDoc
pprWord (Width -> Integer -> Integer
fixEndian (Platform -> Width
wordWidth Platform
platform) (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Integer
accum Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` (Int
8Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
rem_bytes)) SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
: [CmmLit] -> [SDoc]
go [CmmLit]
rest

    fixEndian :: Width -> Integer -> Integer
    fixEndian :: Width -> Integer -> Integer
fixEndian Width
w = case Platform -> ByteOrder
platformByteOrder Platform
platform of
      ByteOrder
BigEndian    -> Integer -> Integer
forall a. a -> a
id
      ByteOrder
LittleEndian -> Width -> Integer -> Integer
byteSwap Width
w

    -- Decompose multi-word or floating-point literals into multiple
    -- single-word (or smaller) literals.
    decomposeMultiWord :: CmmLit -> [CmmLit]
    decomposeMultiWord :: CmmLit -> [CmmLit]
decomposeMultiWord (CmmFloat Rational
n Width
W64)
      | Width
W32 <- Platform -> Width
wordWidth Platform
platform = CmmLit -> [CmmLit]
decomposeMultiWord (Rational -> CmmLit
doubleToWord64 Rational
n)
      | Bool
otherwise = [Rational -> CmmLit
doubleToWord64 Rational
n]
    decomposeMultiWord (CmmFloat Rational
n Width
W32)
      = [Rational -> CmmLit
floatToWord32 Rational
n]
    decomposeMultiWord (CmmInt Integer
n Width
W64)
      | Width
W32 <- Platform -> Width
wordWidth Platform
platform
      = case Platform -> ByteOrder
platformByteOrder Platform
platform of
          ByteOrder
BigEndian -> [Integer -> Width -> CmmLit
CmmInt Integer
hi Width
W32, Integer -> Width -> CmmLit
CmmInt Integer
lo Width
W32]
          ByteOrder
LittleEndian -> [Integer -> Width -> CmmLit
CmmInt Integer
lo Width
W32, Integer -> Width -> CmmLit
CmmInt Integer
hi Width
W32]
      where
        hi :: Integer
hi = Integer
n Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
32
        lo :: Integer
lo = Integer
n Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
0xffffffff
    decomposeMultiWord CmmLit
lit = [CmmLit
lit]

    -- Decompose a sub-word-sized literal into the integer value and its
    -- (sub-word-sized) width.
    isSubWordLit :: CmmLit -> Maybe (Integer, Width)
    isSubWordLit :: CmmLit -> Maybe (Integer, Width)
isSubWordLit CmmLit
lit =
      case CmmLit
lit of
        CmmInt Integer
n Width
w
          | Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Platform -> Width
wordWidth Platform
platform   -> (Integer, Width) -> Maybe (Integer, Width)
forall a. a -> Maybe a
Just (Integer
n, Width
w)
        CmmLit
_                            -> Maybe (Integer, Width)
forall a. Maybe a
Nothing

    wordWidthBytes :: Int
wordWidthBytes = Width -> Int
widthInBytes (Width -> Int) -> Width -> Int
forall a b. (a -> b) -> a -> b
$ Platform -> Width
wordWidth Platform
platform

    pprWord :: Integer -> SDoc
    pprWord :: Integer -> SDoc
pprWord Integer
n = Platform -> Integer -> Width -> SDoc
pprHexVal Platform
platform Integer
n (Platform -> Width
wordWidth Platform
platform)

byteSwap :: Width -> Integer -> Integer
byteSwap :: Width -> Integer -> Integer
byteSwap Width
width Integer
n = (Integer -> Integer -> Integer) -> Integer -> [Integer] -> Integer
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
f Integer
0 [Integer]
bytes
  where
    f :: a -> a -> a
f a
acc a
m = (a
acc a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
m
    bytes :: [Integer]
bytes = [ Int -> Integer
byte Int
i | Int
i <- [Int
0..Width -> Int
widthInBytes Width
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]
    byte :: Int -> Integer
byte Int
i = (Integer
n Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
8)) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
0xff

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

    CmmStaticLit CmmLit
lit   -> Int -> SDoc -> SDoc
nest Int
4 (Platform -> CmmLit -> SDoc
pprLit Platform
platform CmmLit
lit)
    CmmUninitialised Int
i -> Int -> SDoc -> SDoc
nest Int
4 (SDoc
mkC_ SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
i))

    -- these should be inlined, like the old .hc
    CmmString ByteString
s'       -> Int -> SDoc -> SDoc
nest Int
4 (SDoc
mkW_ SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens(ByteString -> SDoc
pprStringInCStyle ByteString
s'))
    CmmFileEmbed {}    -> String -> SDoc
forall a. HasCallStack => String -> a
panic String
"Unexpected CmmFileEmbed literal"


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

pprBlockId :: BlockId -> SDoc
pprBlockId :: BlockId -> SDoc
pprBlockId BlockId
b = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'_' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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 :: Platform -> MachOp -> SDoc

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

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

        MO_S_Quot       Width
_ -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'/'
        MO_S_Rem        Width
_ -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'%'
        MO_S_Neg        Width
_ -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'-'

        MO_U_Quot       Width
_ -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'/'
        MO_U_Rem        Width
_ -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'%'

        -- Floating-point operations
        MO_F_Add        Width
_ -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'+'
        MO_F_Sub        Width
_ -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'-'
        MO_F_Neg        Width
_ -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'-'
        MO_F_Mul        Width
_ -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'*'
        MO_F_Quot       Width
_ -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'/'

        -- Floating-point fused multiply-add operations
        MO_FMA FMASign
FMAdd Width
w ->
          case Width
w of
            Width
W32 -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fmaf"
            Width
W64 -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fma"
            Width
_   ->
              String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"FMAdd")
                (String -> SDoc
forall a. HasCallStack => String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: FMAdd unsupported"
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"at width " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Width -> String
forall a. Show a => a -> String
show Width
w)
        MO_FMA FMASign
var Width
_width  ->
          String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
            (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"FMA " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FMASign -> String
forall a. Show a => a -> String
show FMASign
var)
            (String -> SDoc
forall a. HasCallStack => String -> a
panic (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"PprC.pprMachOp_for_C: should have been handled earlier!")

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

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

        -- & Floating-point comparisons
        MO_F_Eq         Width
_ -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"=="
        MO_F_Ne         Width
_ -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"!="
        MO_F_Ge         Width
_ -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
">="
        MO_F_Le         Width
_ -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<="
        MO_F_Gt         Width
_ -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'>'
        MO_F_Lt         Width
_ -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
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
forall doc. IsLine doc => Char -> doc
char Char
'&'
        MO_Or           Width
_ -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'|'
        MO_Xor          Width
_ -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'^'
        MO_Not          Width
_ -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'~'
        MO_Shl          Width
_ -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<<"
        MO_U_Shr        Width
_ -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
">>" -- unsigned shift right
        MO_S_Shr        Width
_ -> String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsOutput doc => doc
empty
        MO_UU_Conv Width
_from Width
to -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> Width -> SDoc
machRep_U_CType Platform
platform Width
to)

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

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

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

        MO_SF_Conv Width
_from Width
to -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Width -> SDoc
machRep_F_CType Width
to)
        MO_FS_Conv Width
_from Width
to -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> Width -> SDoc
machRep_S_CType Platform
platform Width
to)

        MO_RelaxedRead Width
_ -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"MO_RelaxedRead")
                                (String -> SDoc
forall a. HasCallStack => 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_S_MulMayOflo Width
_ -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"MO_S_MulMayOflo")
                                (String -> SDoc
forall a. HasCallStack => 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_V_Insert {}    -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"offending mop:"
                                (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"MO_V_Insert")
                                (String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"MO_V_Extract")
                                (String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"MO_V_Add")
                                (String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"MO_V_Sub")
                                (String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"MO_V_Mul")
                                (String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"MO_VS_Quot")
                                (String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"MO_VS_Rem")
                                (String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"MO_VS_Neg")
                                (String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"MO_VU_Quot")
                                (String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"MO_VU_Rem")
                                (String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"MO_VF_Insert")
                                (String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"MO_VF_Extract")
                                (String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"MO_VF_Add")
                                (String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"MO_VF_Sub")
                                (String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"MO_VF_Neg")
                                (String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"MO_VF_Mul")
                                (String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"MO_VF_Quot")
                                (String -> SDoc
forall a. HasCallStack => 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. HasCallStack => String -> a
panic String
"-falignment-sanitisation 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

shiftOp :: MachOp -> Maybe Width
shiftOp :: MachOp -> Maybe Width
shiftOp (MO_Shl Width
w)        = Width -> Maybe Width
forall a. a -> Maybe a
Just Width
w
shiftOp (MO_U_Shr Width
w)      = Width -> Maybe Width
forall a. a -> Maybe a
Just Width
w
shiftOp (MO_S_Shr Width
w)      = Width -> Maybe Width
forall a. a -> Maybe a
Just Width
w
shiftOp MachOp
_                 = Maybe Width
forall a. Maybe a
Nothing

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
forall doc. IsLine doc => String -> doc
text String
"pow"
        CallishMachOp
MO_F64_Sin      -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sin"
        CallishMachOp
MO_F64_Cos      -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cos"
        CallishMachOp
MO_F64_Tan      -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tan"
        CallishMachOp
MO_F64_Sinh     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sinh"
        CallishMachOp
MO_F64_Cosh     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cosh"
        CallishMachOp
MO_F64_Tanh     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tanh"
        CallishMachOp
MO_F64_Asin     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"asin"
        CallishMachOp
MO_F64_Acos     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"acos"
        CallishMachOp
MO_F64_Atanh    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"atanh"
        CallishMachOp
MO_F64_Asinh    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"asinh"
        CallishMachOp
MO_F64_Acosh    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"acosh"
        CallishMachOp
MO_F64_Atan     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"atan"
        CallishMachOp
MO_F64_Log      -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"log"
        CallishMachOp
MO_F64_Log1P    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"log1p"
        CallishMachOp
MO_F64_Exp      -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"exp"
        CallishMachOp
MO_F64_ExpM1    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"expm1"
        CallishMachOp
MO_F64_Sqrt     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sqrt"
        CallishMachOp
MO_F64_Fabs     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fabs"
        CallishMachOp
MO_F32_Pwr      -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"powf"
        CallishMachOp
MO_F32_Sin      -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sinf"
        CallishMachOp
MO_F32_Cos      -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cosf"
        CallishMachOp
MO_F32_Tan      -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tanf"
        CallishMachOp
MO_F32_Sinh     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sinhf"
        CallishMachOp
MO_F32_Cosh     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"coshf"
        CallishMachOp
MO_F32_Tanh     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"tanhf"
        CallishMachOp
MO_F32_Asin     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"asinf"
        CallishMachOp
MO_F32_Acos     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"acosf"
        CallishMachOp
MO_F32_Atan     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"atanf"
        CallishMachOp
MO_F32_Asinh    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"asinhf"
        CallishMachOp
MO_F32_Acosh    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"acoshf"
        CallishMachOp
MO_F32_Atanh    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"atanhf"
        CallishMachOp
MO_F32_Log      -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"logf"
        CallishMachOp
MO_F32_Log1P    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"log1pf"
        CallishMachOp
MO_F32_Exp      -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"expf"
        CallishMachOp
MO_F32_ExpM1    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"expm1f"
        CallishMachOp
MO_F32_Sqrt     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"sqrtf"
        CallishMachOp
MO_F32_Fabs     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fabsf"
        CallishMachOp
MO_AcquireFence -> SDoc
unsupported
        CallishMachOp
MO_ReleaseFence -> SDoc
unsupported
        CallishMachOp
MO_SeqCstFence  -> SDoc
unsupported
        MO_Memcpy Int
_     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"__builtin_memcpy"
        MO_Memset Int
_     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"__builtin_memset"
        MO_Memmove Int
_    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"__builtin_memmove"
        MO_Memcmp Int
_     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"__builtin_memcmp"

        CallishMachOp
MO_SuspendThread -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"suspendThread"
        CallishMachOp
MO_ResumeThread  -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"resumeThread"

        MO_BSwap Width
w          -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (Width -> FastString
bSwapLabel Width
w)
        MO_BRev Width
w           -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (Width -> FastString
bRevLabel Width
w)
        MO_PopCnt Width
w         -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (Width -> FastString
popCntLabel Width
w)
        MO_Pext Width
w           -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (Width -> FastString
pextLabel Width
w)
        MO_Pdep Width
w           -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (Width -> FastString
pdepLabel Width
w)
        MO_Clz Width
w            -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (Width -> FastString
clzLabel Width
w)
        MO_Ctz Width
w            -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (Width -> FastString
ctzLabel Width
w)
        MO_AtomicRMW Width
w AtomicMachOp
amop -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (Width -> AtomicMachOp -> FastString
atomicRMWLabel Width
w AtomicMachOp
amop)
        MO_Cmpxchg Width
w        -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (Width -> FastString
cmpxchgLabel Width
w)
        MO_Xchg Width
w           -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (Width -> FastString
xchgLabel Width
w)
        -- TODO: handle orderings
        MO_AtomicRead Width
w MemoryOrdering
_   -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (Width -> FastString
atomicReadLabel Width
w)
        MO_AtomicWrite Width
w MemoryOrdering
_  -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (Width -> FastString
atomicWriteLabel Width
w)
        MO_UF_Conv Width
w        -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (Width -> FastString
word2FloatLabel Width
w)

        MO_S_Mul2     {} -> SDoc
unsupported
        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
        -- we could support prefetch via "__builtin_prefetch"
        -- Not adding it for now
        (MO_Prefetch_Data Int
_ ) -> SDoc
unsupported

        CallishMachOp
MO_I64_ToI   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_int64ToInt"
        CallishMachOp
MO_I64_FromI -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_intToInt64"
        CallishMachOp
MO_W64_ToW   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_word64ToWord"
        CallishMachOp
MO_W64_FromW -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_wordToWord64"
        CallishMachOp
MO_x64_Neg   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_neg64"
        CallishMachOp
MO_x64_Add   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_add64"
        CallishMachOp
MO_x64_Sub   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_sub64"
        CallishMachOp
MO_x64_Mul   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_mul64"
        CallishMachOp
MO_I64_Quot  -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_quotInt64"
        CallishMachOp
MO_I64_Rem   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_remInt64"
        CallishMachOp
MO_W64_Quot  -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_quotWord64"
        CallishMachOp
MO_W64_Rem   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_remWord64"
        CallishMachOp
MO_x64_And   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_and64"
        CallishMachOp
MO_x64_Or    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_or64"
        CallishMachOp
MO_x64_Xor   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_xor64"
        CallishMachOp
MO_x64_Not   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_not64"
        CallishMachOp
MO_x64_Shl   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_uncheckedShiftL64"
        CallishMachOp
MO_I64_Shr   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_uncheckedIShiftRA64"
        CallishMachOp
MO_W64_Shr   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_uncheckedShiftRL64"
        CallishMachOp
MO_x64_Eq    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_eq64"
        CallishMachOp
MO_x64_Ne    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_ne64"
        CallishMachOp
MO_I64_Ge    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_geInt64"
        CallishMachOp
MO_I64_Gt    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_gtInt64"
        CallishMachOp
MO_I64_Le    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_leInt64"
        CallishMachOp
MO_I64_Lt    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_ltInt64"
        CallishMachOp
MO_W64_Ge    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_geWord64"
        CallishMachOp
MO_W64_Gt    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_gtWord64"
        CallishMachOp
MO_W64_Le    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_leWord64"
        CallishMachOp
MO_W64_Lt    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hs_ltWord64"
    where unsupported :: SDoc
unsupported = String -> SDoc
forall a. HasCallStack => 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
forall doc. IsLine doc => String -> doc
text String
"JMP_" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
i
mkFN_ :: SDoc -> SDoc
mkFN_  SDoc
i = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"FN_"  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
i -- externally visible function
mkIF_ :: SDoc -> SDoc
mkIF_  SDoc
i = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"IF_"  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
i -- locally visible

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

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

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

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

-- dest is a reg, rhs is a CmmRegOff
pprAssign Platform
platform 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` Platform -> Int
platformWordSizeInBytes Platform
platform Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
   = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [ CmmReg -> SDoc
pprAsPtrReg CmmReg
r1, SDoc
forall doc. IsLine doc => doc
equals, CmmReg -> SDoc
pprAsPtrReg CmmReg
r2, SDoc
op, Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
off', SDoc
forall doc. IsLine doc => doc
semi ]
  where
        off1 :: Int
off1 = Int
off Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Platform -> Int
wordShift Platform
platform

        (SDoc
op,Int
off') | Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0  = (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'+', Int
off1)
                  | Bool
otherwise = (Char -> SDoc
forall doc. IsLine doc => Char -> doc
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 Platform
platform CmmReg
r1 CmmExpr
r2
  | CmmReg -> Bool
isFixedPtrReg CmmReg
r1             = SDoc -> SDoc
mkAssign (SDoc
mkP_ SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Platform -> CmmExpr -> SDoc
pprExpr1 Platform
platform CmmExpr
r2)
  | Just SDoc
ty <- CmmReg -> Maybe SDoc
strangeRegType CmmReg
r1 = SDoc -> SDoc
mkAssign (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Platform -> CmmExpr -> SDoc
pprExpr1 Platform
platform CmmExpr
r2)
  | Bool
otherwise                    = SDoc -> SDoc
mkAssign (Platform -> CmmExpr -> SDoc
pprExpr Platform
platform CmmExpr
r2)
    where mkAssign :: SDoc -> SDoc
mkAssign SDoc
x =
            case CmmReg
r1 of
              CmmGlobal (GlobalRegUse GlobalReg
BaseReg CmmType
_) ->
                String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ASSIGN_BaseReg" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
x SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
              CmmReg
_ -> CmmReg -> SDoc
pprReg CmmReg
r1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" = " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
x SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi

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

pprCastReg :: CmmReg -> SDoc
pprCastReg :: CmmReg -> SDoc
pprCastReg CmmReg
reg
   | CmmReg -> Bool
isStrangeTypeReg CmmReg
reg = SDoc
mkW_ SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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 LocalReg
_) = Bool
False
isFixedPtrReg (CmmGlobal (GlobalRegUse GlobalReg
r CmmType
_)) = 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 LocalReg
_)                                 = Bool
False
isPtrReg (CmmGlobal (GlobalRegUse (VanillaReg Int
_) CmmType
ty)) = CmmType -> Bool
isGcPtrType CmmType
ty -- if we print via pprAsPtrReg
isPtrReg (CmmGlobal (GlobalRegUse GlobalReg
reg CmmType
_))             = 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 LocalReg
_)   = Bool
False
isStrangeTypeReg (CmmGlobal (GlobalRegUse GlobalReg
g CmmType
_)) = 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 (GlobalRegUse GlobalReg
CCCS CmmType
_)) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"struct CostCentreStack_ *")
strangeRegType (CmmGlobal (GlobalRegUse GlobalReg
CurrentTSO CmmType
_)) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"struct StgTSO_ *")
strangeRegType (CmmGlobal (GlobalRegUse GlobalReg
CurrentNursery CmmType
_)) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"struct bdescr_ *")
strangeRegType (CmmGlobal (GlobalRegUse GlobalReg
BaseReg CmmType
_)) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
forall doc. IsLine doc => String -> doc
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  LocalReg
local  -> LocalReg -> SDoc
pprLocalReg LocalReg
local
        CmmGlobal (GlobalRegUse GlobalReg
global CmmType
_ ) -> GlobalReg -> SDoc
pprGlobalReg GlobalReg
global

pprAsPtrReg :: CmmReg -> SDoc
pprAsPtrReg :: CmmReg -> SDoc
pprAsPtrReg (CmmGlobal (GlobalRegUse (VanillaReg Int
n) CmmType
ty))
  = Bool -> String -> SDoc -> SDoc -> SDoc
forall a. HasCallStack => Bool -> String -> SDoc -> a -> a
warnPprTrace (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CmmType -> Bool
isGcPtrType CmmType
ty) String
"pprAsPtrReg" (Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'R' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
".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   -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'R' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => Char -> doc
char Char
'F' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n
    DoubleReg  Int
n   -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'D' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n
    LongReg    Int
n   -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'L' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n
    GlobalReg
Sp             -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Sp"
    GlobalReg
SpLim          -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"SpLim"
    GlobalReg
Hp             -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Hp"
    GlobalReg
HpLim          -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"HpLim"
    GlobalReg
CCCS           -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CCCS"
    GlobalReg
CurrentTSO     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CurrentTSO"
    GlobalReg
CurrentNursery -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CurrentNursery"
    GlobalReg
HpAlloc        -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"HpAlloc"
    GlobalReg
BaseReg        -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"BaseReg"
    GlobalReg
EagerBlackholeInfo -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stg_EAGER_BLACKHOLE_info"
    GlobalReg
GCEnter1       -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stg_gc_enter_1"
    GlobalReg
GCFun          -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"stg_gc_fun"
    GlobalReg
other          -> String -> SDoc
forall a. HasCallStack => 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 :: LocalReg -> SDoc
pprLocalReg (LocalReg Unique
uniq CmmType
_) = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'_' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Unique -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unique
uniq

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

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

  | Bool
otherwise
  =
    [(LocalReg, ForeignHint)] -> SDoc -> SDoc
ppr_assign [(LocalReg, ForeignHint)]
results (SDoc
ppr_fn SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
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
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
  where
     ppr_assign :: [(LocalReg, ForeignHint)] -> SDoc -> SDoc
ppr_assign []           SDoc
rhs = SDoc
rhs
     ppr_assign [(LocalReg
one,ForeignHint
hint)] SDoc
rhs
         = LocalReg -> SDoc
pprLocalReg LocalReg
one SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" = "
                 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> ForeignHint -> CmmType -> SDoc
pprUnHint ForeignHint
hint (LocalReg -> CmmType
localRegType LocalReg
one) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
rhs
     ppr_assign [(LocalReg, ForeignHint)]
_other SDoc
_rhs = String -> SDoc
forall a. HasCallStack => String -> a
panic String
"pprCall: multiple results"

     pprArg :: (CmmExpr, ForeignHint) -> SDoc
pprArg (CmmExpr
expr, ForeignHint
AddrHint)
        = Platform -> SDoc -> CmmExpr -> SDoc
cCast Platform
platform (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"void *") CmmExpr
expr
        -- see comment by machRepHintCType below
     pprArg (CmmExpr
expr, ForeignHint
SignedHint)
        = Platform -> SDoc -> CmmExpr -> SDoc
cCast Platform
platform (Platform -> Width -> SDoc
machRep_S_CType Platform
platform (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
$ Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
expr) CmmExpr
expr
     pprArg (CmmExpr
expr, ForeignHint
_other)
        = Platform -> CmmExpr -> SDoc
pprExpr Platform
platform CmmExpr
expr

     pprUnHint :: ForeignHint -> CmmType -> SDoc
pprUnHint ForeignHint
AddrHint   CmmType
rep = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> CmmType -> SDoc
machRepCType Platform
platform CmmType
rep)
     pprUnHint ForeignHint
SignedHint CmmType
rep = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> CmmType -> SDoc
machRepCType Platform
platform CmmType
rep)
     pprUnHint ForeignHint
_          CmmType
_   = SDoc
forall doc. IsOutput doc => doc
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 :: Platform -> [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})
pprTempAndExternDecls :: Platform -> [CmmBlock] -> (SDoc, SDoc)
pprTempAndExternDecls Platform
platform [CmmBlock]
stmts
  = (UniqFM LocalReg LocalReg -> ([LocalReg] -> SDoc) -> SDoc
forall {k} (key :: k) a. UniqFM key a -> ([a] -> SDoc) -> SDoc
pprUFM (UniqSet LocalReg -> UniqFM LocalReg LocalReg
forall a. UniqSet a -> UniqFM a a
getUniqSet UniqSet LocalReg
temps) ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> ([LocalReg] -> [SDoc]) -> [LocalReg] -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocalReg -> SDoc) -> [LocalReg] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> LocalReg -> SDoc
pprTempDecl Platform
platform)),
     [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((CLabel -> SDoc) -> [CLabel] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CLabel -> SDoc
pprExternDecl Platform
platform) (Map CLabel () -> [CLabel]
forall k a. Map k a -> [k]
Map.keys Map CLabel ()
lbls)))
  where (UniqSet LocalReg
temps, Map CLabel ()
lbls) = TE () -> (UniqSet LocalReg, 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 :: Platform -> [CmmStatic] -> SDoc
pprDataExterns :: Platform -> [CmmStatic] -> SDoc
pprDataExterns Platform
platform [CmmStatic]
statics
  = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ((CLabel -> SDoc) -> [CLabel] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CLabel -> SDoc
pprExternDecl Platform
platform) (Map CLabel () -> [CLabel]
forall k a. Map k a -> [k]
Map.keys Map CLabel ()
lbls))
  where (UniqSet LocalReg
_, Map CLabel ()
lbls) = TE () -> (UniqSet LocalReg, 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 :: Platform -> LocalReg -> SDoc
pprTempDecl :: Platform -> LocalReg -> SDoc
pprTempDecl Platform
platform l :: LocalReg
l@(LocalReg Unique
_ CmmType
rep)
  = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [ Platform -> CmmType -> SDoc
machRepCType Platform
platform CmmType
rep, SDoc
forall doc. IsLine doc => doc
space, LocalReg -> SDoc
pprLocalReg LocalReg
l, SDoc
forall doc. IsLine doc => doc
semi ]

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

  visibility :: SDoc
visibility
     | CLabel -> Bool
externallyVisibleCLabel CLabel
lbl = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'E'
     | Bool
otherwise                   = Char -> SDoc
forall doc. IsLine doc => Char -> doc
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 =
        String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"extern __attribute__((stdcall)) void " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform CLabel
lbl
        SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
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` Platform -> Int
platformWordSizeInBytes Platform
platform) (Platform -> Width -> SDoc
machRep_U_CType Platform
platform (Platform -> Width
wordWidth Platform
platform))))
        SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi

type TEState = (UniqSet LocalReg, Map CLabel ())
newtype TE a = TE' (State TEState a)
  deriving stock ((forall a b. (a -> b) -> TE a -> TE b)
-> (forall a b. a -> TE b -> TE a) -> Functor TE
forall a b. a -> TE b -> TE a
forall a b. (a -> b) -> TE a -> TE b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> TE a -> TE b
fmap :: forall a b. (a -> b) -> TE a -> TE b
$c<$ :: forall a b. a -> TE b -> TE a
<$ :: forall a b. a -> TE b -> TE a
Functor)
  deriving (Functor TE
Functor TE =>
(forall a. a -> TE a)
-> (forall a b. TE (a -> b) -> TE a -> TE b)
-> (forall a b c. (a -> b -> c) -> TE a -> TE b -> TE c)
-> (forall a b. TE a -> TE b -> TE b)
-> (forall a b. TE a -> TE b -> TE a)
-> Applicative TE
forall a. a -> TE a
forall a b. TE a -> TE b -> TE a
forall a b. TE a -> TE b -> TE b
forall a b. TE (a -> b) -> TE a -> TE b
forall a b c. (a -> b -> c) -> TE a -> TE b -> TE c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> TE a
pure :: forall a. a -> TE a
$c<*> :: forall a b. TE (a -> b) -> TE a -> TE b
<*> :: forall a b. TE (a -> b) -> TE a -> TE b
$cliftA2 :: forall a b c. (a -> b -> c) -> TE a -> TE b -> TE c
liftA2 :: forall a b c. (a -> b -> c) -> TE a -> TE b -> TE c
$c*> :: forall a b. TE a -> TE b -> TE b
*> :: forall a b. TE a -> TE b -> TE b
$c<* :: forall a b. TE a -> TE b -> TE a
<* :: forall a b. TE a -> TE b -> TE a
Applicative, Applicative TE
Applicative TE =>
(forall a b. TE a -> (a -> TE b) -> TE b)
-> (forall a b. TE a -> TE b -> TE b)
-> (forall a. a -> TE a)
-> Monad TE
forall a. a -> TE a
forall a b. TE a -> TE b -> TE b
forall a b. TE a -> (a -> TE b) -> TE b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. TE a -> (a -> TE b) -> TE b
>>= :: forall a b. TE a -> (a -> TE b) -> TE b
$c>> :: forall a b. TE a -> TE b -> TE b
>> :: forall a b. TE a -> TE b -> TE b
$creturn :: forall a. a -> TE a
return :: forall a. a -> TE a
Monad) via State TEState

pattern TE :: (TEState -> (a, TEState)) -> TE a
pattern $mTE :: forall {r} {a}.
TE a
-> (((UniqSet LocalReg, Map CLabel ())
     -> (a, (UniqSet LocalReg, Map CLabel ())))
    -> r)
-> ((# #) -> r)
-> r
$bTE :: forall a.
((UniqSet LocalReg, Map CLabel ())
 -> (a, (UniqSet LocalReg, Map CLabel ())))
-> TE a
TE f <- TE' (runState -> f)
  where TE (UniqSet LocalReg, Map CLabel ())
-> (a, (UniqSet LocalReg, Map CLabel ()))
f  = State (UniqSet LocalReg, Map CLabel ()) a -> TE a
forall a. State (UniqSet LocalReg, Map CLabel ()) a -> TE a
TE' (((UniqSet LocalReg, Map CLabel ())
 -> (a, (UniqSet LocalReg, Map CLabel ())))
-> State (UniqSet LocalReg, Map CLabel ()) a
forall s a. (s -> (a, s)) -> State s a
state (UniqSet LocalReg, Map CLabel ())
-> (a, (UniqSet LocalReg, Map CLabel ()))
f)
{-# COMPLETE TE #-}

te_lbl :: CLabel -> TE ()
te_lbl :: CLabel -> TE ()
te_lbl CLabel
lbl = ((UniqSet LocalReg, Map CLabel ())
 -> ((), (UniqSet LocalReg, Map CLabel ())))
-> TE ()
forall a.
((UniqSet LocalReg, Map CLabel ())
 -> (a, (UniqSet LocalReg, Map CLabel ())))
-> TE a
TE (((UniqSet LocalReg, Map CLabel ())
  -> ((), (UniqSet LocalReg, Map CLabel ())))
 -> TE ())
-> ((UniqSet LocalReg, Map CLabel ())
    -> ((), (UniqSet LocalReg, Map CLabel ())))
-> TE ()
forall a b. (a -> b) -> a -> b
$ \(UniqSet LocalReg
temps,Map CLabel ()
lbls) -> ((), (UniqSet LocalReg
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 :: LocalReg -> TE ()
te_temp LocalReg
r = ((UniqSet LocalReg, Map CLabel ())
 -> ((), (UniqSet LocalReg, Map CLabel ())))
-> TE ()
forall a.
((UniqSet LocalReg, Map CLabel ())
 -> (a, (UniqSet LocalReg, Map CLabel ())))
-> TE a
TE (((UniqSet LocalReg, Map CLabel ())
  -> ((), (UniqSet LocalReg, Map CLabel ())))
 -> TE ())
-> ((UniqSet LocalReg, Map CLabel ())
    -> ((), (UniqSet LocalReg, Map CLabel ())))
-> TE ()
forall a b. (a -> b) -> a -> b
$ \(UniqSet LocalReg
temps,Map CLabel ()
lbls) -> ((), (UniqSet LocalReg -> LocalReg -> UniqSet LocalReg
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
addOneToUniqSet UniqSet LocalReg
temps LocalReg
r, Map CLabel ()
lbls))

runTE :: TE () -> TEState
runTE :: TE () -> (UniqSet LocalReg, Map CLabel ())
runTE (TE (UniqSet LocalReg, Map CLabel ())
-> ((), (UniqSet LocalReg, Map CLabel ()))
m) = ((), (UniqSet LocalReg, Map CLabel ()))
-> (UniqSet LocalReg, Map CLabel ())
forall a b. (a, b) -> b
snd ((UniqSet LocalReg, Map CLabel ())
-> ((), (UniqSet LocalReg, Map CLabel ()))
m (UniqSet LocalReg
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 a. a -> TE a
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 :: Extensibility) (x :: Extensibility).
CmmNode e x -> TE ()
te_Stmt (Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
mid) TE () -> TE () -> TE ()
forall a b. TE a -> TE b -> TE b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CmmNode O C -> TE ()
forall (e :: Extensibility) (x :: Extensibility).
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 :: Extensibility -> Extensibility -> *).
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 a. a -> TE a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

te_Stmt :: CmmNode e x -> TE ()
te_Stmt :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> TE ()
te_Stmt (CmmAssign CmmReg
r CmmExpr
e)         = CmmReg -> TE ()
te_Reg CmmReg
r TE () -> TE () -> TE ()
forall a b. TE a -> TE b -> TE b
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 AlignmentSpec
_)        = CmmExpr -> TE ()
te_Expr CmmExpr
l TE () -> TE () -> TE ()
forall a b. TE a -> TE b -> TE b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CmmExpr -> TE ()
te_Expr CmmExpr
r
te_Stmt (CmmUnsafeForeignCall ForeignTarget
target [LocalReg]
rs [CmmExpr]
es)
  = do  ForeignTarget -> TE ()
te_Target ForeignTarget
target
        (LocalReg -> TE ()) -> [LocalReg] -> TE ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LocalReg -> TE ()
te_temp [LocalReg]
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 a. a -> TE a
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 a. a -> TE a
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
_ AlignmentSpec
_)         = 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. HasCallStack => String -> a
panic String
"te_Expr: CmmStackSlot not supported!"

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


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

cCast :: Platform -> SDoc -> CmmExpr -> SDoc
cCast :: Platform -> SDoc -> CmmExpr -> SDoc
cCast Platform
platform SDoc
ty CmmExpr
expr = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Platform -> CmmExpr -> SDoc
pprExpr1 Platform
platform CmmExpr
expr

cLoad :: Platform -> CmmExpr -> CmmType -> SDoc
cLoad :: Platform -> CmmExpr -> CmmType -> SDoc
cLoad Platform
platform CmmExpr
expr CmmType
rep
    = if Arch -> Bool
bewareLoadStoreAlignment (Platform -> Arch
platformArch Platform
platform)
      then let decl :: SDoc
decl = Platform -> CmmType -> SDoc
machRepCType Platform
platform CmmType
rep SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"x" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
               struct :: SDoc
struct = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"struct" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (SDoc
decl)
               packed_attr :: SDoc
packed_attr = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"__attribute__((packed))"
               cast :: SDoc
cast = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc
struct SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
packed_attr SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'*')
           in SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc
cast SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CmmExpr -> SDoc
pprExpr1 Platform
platform CmmExpr
expr) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"->x"
      else Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'*' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> SDoc -> CmmExpr -> SDoc
cCast Platform
platform (Platform -> CmmType -> SDoc
machRepPtrCType Platform
platform 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
ArchAArch64  = Bool
True
          -- Pessimistically assume that they will also cause problems
          -- on unknown arches
          bewareLoadStoreAlignment Arch
ArchUnknown  = Bool
True
          bewareLoadStoreAlignment Arch
_            = Bool
False

isCmmWordType :: Platform -> CmmType -> Bool
-- True of GcPtrReg/NonGcReg of native word size
isCmmWordType :: Platform -> CmmType -> Bool
isCmmWordType Platform
platform 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
== Platform -> Width
wordWidth Platform
platform

-- 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 :: Platform -> CmmType -> ForeignHint -> SDoc
machRepHintCType :: Platform -> CmmType -> ForeignHint -> SDoc
machRepHintCType Platform
platform CmmType
rep = \case
   ForeignHint
AddrHint   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"void *"
   ForeignHint
SignedHint -> Platform -> Width -> SDoc
machRep_S_CType Platform
platform (CmmType -> Width
typeWidth CmmType
rep)
   ForeignHint
_other     -> Platform -> CmmType -> SDoc
machRepCType Platform
platform CmmType
rep

machRepPtrCType :: Platform -> CmmType -> SDoc
machRepPtrCType :: Platform -> CmmType -> SDoc
machRepPtrCType Platform
platform CmmType
r
 = if Platform -> CmmType -> Bool
isCmmWordType Platform
platform CmmType
r
      then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"P_"
      else Platform -> CmmType -> SDoc
machRepCType Platform
platform CmmType
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'*'

machRepCType :: Platform -> CmmType -> SDoc
machRepCType :: Platform -> CmmType -> SDoc
machRepCType Platform
platform CmmType
ty
   | CmmType -> Bool
isFloatType CmmType
ty = Width -> SDoc
machRep_F_CType Width
w
   | Bool
otherwise      = Platform -> Width -> SDoc
machRep_U_CType Platform
platform 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
forall doc. IsLine doc => String -> doc
text String
"StgFloat" -- ToDo: correct?
machRep_F_CType Width
W64 = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StgDouble"
machRep_F_CType Width
_   = String -> SDoc
forall a. HasCallStack => String -> a
panic String
"machRep_F_CType"

machRep_U_CType :: Platform -> Width -> SDoc
machRep_U_CType :: Platform -> Width -> SDoc
machRep_U_CType Platform
platform Width
w
 = case Width
w of
   Width
_ | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"W_"
   Width
W8  -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StgWord8"
   Width
W16 -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StgWord16"
   Width
W32 -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StgWord32"
   Width
W64 -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StgWord64"
   Width
_   -> String -> SDoc
forall a. HasCallStack => String -> a
panic String
"machRep_U_CType"

machRep_S_CType :: Platform -> Width -> SDoc
machRep_S_CType :: Platform -> Width -> SDoc
machRep_S_CType Platform
platform Width
w
 = case Width
w of
   Width
_ | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"I_"
   Width
W8  -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StgInt8"
   Width
W16 -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StgInt16"
   Width
W32 -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StgInt32"
   Width
W64 -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StgInt64"
   Width
_   -> String -> SDoc
forall a. HasCallStack => String -> a
panic String
"machRep_S_CType"


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

pprStringInCStyle :: ByteString -> SDoc
pprStringInCStyle :: ByteString -> SDoc
pprStringInCStyle ByteString
s = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (String -> SDoc
forall doc. IsLine doc => String -> doc
text ((Word8 -> String) -> [Word8] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Word8 -> String
charToC (ByteString -> [Word8]
BS.unpack ByteString
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.

floatToWord32 :: Rational -> CmmLit
floatToWord32 :: Rational -> CmmLit
floatToWord32 Rational
r = Integer -> Width -> CmmLit
CmmInt (Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger (Float -> Word32
castFloatToWord32 (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
r))) Width
W32

doubleToWord64 :: Rational -> CmmLit
doubleToWord64 :: Rational -> CmmLit
doubleToWord64 Rational
r = Integer -> Width -> CmmLit
CmmInt (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Double -> Word64
castDoubleToWord64 (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
r))) Width
W64


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

wordShift :: Platform -> Int
wordShift :: Platform -> Int
wordShift Platform
platform = Width -> Int
widthInLog (Platform -> Width
wordWidth Platform
platform)

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

-- | Print in C hex format
--
-- Examples:
--
--   5114    :: W32  ===>  ((StgWord32)0x13faU)
--   (-5114) :: W32  ===>  ((StgWord32)(-0x13faU))
--
-- We use casts to support types smaller than `unsigned int`; C literal
-- suffixes support longer but not shorter types.
pprHexVal :: Platform -> Integer -> Width -> SDoc
pprHexVal :: Platform -> Integer -> Width -> SDoc
pprHexVal Platform
platform Integer
w Width
rep = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
ctype SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
rawlit
  where
      rawlit :: SDoc
rawlit
        | Integer
w Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0     = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'-' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
                          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"0x" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Integer -> SDoc
intToDoc (-Integer
w) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
repsuffix Width
rep)
        | Bool
otherwise =     String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"0x" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Integer -> SDoc
intToDoc   Integer
w  SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
repsuffix Width
rep
      ctype :: SDoc
ctype = Platform -> Width -> SDoc
machRep_U_CType Platform
platform Width
rep

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

      constants :: PlatformConstants
constants = Platform -> PlatformConstants
platformConstants Platform
platform

      repsuffix :: Width -> SDoc
repsuffix Width
W64 =
               if PlatformConstants -> Int
pc_CINT_SIZE       PlatformConstants
constants Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 then Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'U'
          else if PlatformConstants -> Int
pc_CLONG_SIZE      PlatformConstants
constants Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"UL"
          else if PlatformConstants -> Int
pc_CLONG_LONG_SIZE PlatformConstants
constants Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ULL"
          else String -> SDoc
forall a. HasCallStack => String -> a
panic String
"pprHexVal: Can't find a 64-bit type"
      repsuffix Width
_ = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'U'

      intToDoc :: Integer -> SDoc
      intToDoc :: Integer -> SDoc
intToDoc Integer
i = case Integer -> Integer
truncInt Integer
i of
                       Integer
0 -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'0'
                       Integer
v -> Integer -> SDoc
forall {t}. IsLine t => Integer -> t
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. HasCallStack => 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 -> t
go Integer
0 = t
forall doc. IsOutput doc => doc
empty
      go Integer
w' = Integer -> t
go Integer
q t -> t -> t
forall doc. IsLine doc => doc -> doc -> doc
<> t
dig
           where
             (Integer
q,Integer
r) = Integer
w' Integer -> Integer -> (Integer, Integer)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Integer
16
             dig :: t
dig | Integer
r Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
10    = Char -> t
forall doc. IsLine doc => Char -> doc
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 -> t
forall doc. IsLine doc => Char -> doc
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'))

-- | Construct a constructor/finalizer function. Instead of emitting a
-- initializer/finalizer array we rather just emit a single function, annotated
-- with the appropriate C attribute, which then calls each of the initializers.
pprCtorArray :: Platform -> InitOrFini -> [CLabel] -> SDoc
pprCtorArray :: Platform -> InitOrFini -> [CLabel] -> SDoc
pprCtorArray Platform
platform InitOrFini
initOrFini [CLabel]
lbls =
       SDoc
decls
    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"static __attribute__((" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
attribute SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"))"
    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"void _hs_" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
suffix SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"()"
    SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces SDoc
body
  where
    body :: SDoc
body = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform CLabel
lbl SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" ();" | CLabel
lbl <- [CLabel]
lbls ]
    decls :: SDoc
decls = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"void" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprCLabel Platform
platform CLabel
lbl SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" (void);" | CLabel
lbl <- [CLabel]
lbls ]
    (String
attribute, String
suffix) = case InitOrFini
initOrFini of
                  InitOrFini
IsInitArray
                    -- See Note [JSFFI initialization] for details
                    | Arch
ArchWasm32 <- Platform -> Arch
platformArch Platform
platform -> (String
"constructor(101)", String
"constructor")
                    | Bool
otherwise -> (String
"constructor", String
"constructor")
                  InitOrFini
IsFiniArray -> (String
"destructor", String
"destructor")