{-# LANGUAGE CPP, GADTs #-}

-----------------------------------------------------------------------------
--
-- Pretty-printing of Cmm as C, suitable for feeding gcc
--
-- (c) The University of Glasgow 2004-2006
--
-- Print Cmm as real C, for -fvia-C
--
-- See wiki:Commentary/Compiler/Backends/PprC
--
-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"
-- relative to the old AbstractC, and many oddities/decorations have
-- disappeared from the data type.
--
-- This code generator is only supported in unregisterised mode.
--
-----------------------------------------------------------------------------

module PprC (
        writeCs,
        pprStringInCStyle
  ) where

#include "HsVersions.h"

-- Cmm stuff
import GhcPrelude

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

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

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

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

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

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

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

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

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

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


-- Chunks of static data.

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

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

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

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

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

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

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

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

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

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

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

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

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

pprStmt :: CmmNode e x -> SDoc

pprStmt :: CmmNode e x -> SDoc
pprStmt stmt :: CmmNode e x
stmt =
    (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
    case CmmNode e x
stmt of
    CmmEntry{}   -> SDoc
empty
    CmmComment _ -> SDoc
empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/")
                          -- XXX if the string contains "*/", we need to fix it
                          -- XXX we probably want to emit these comments when
                          -- some debugging option is on.  They can get quite
                          -- large.

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

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

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

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

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

        ForeignConvention cconv :: CCallConv
cconv _ _ ret :: CmmReturnInfo
ret = ForeignConvention
conv

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

        -- See wiki:Commentary/Compiler/Backends/PprC#Prototypes
        fnCall :: SDoc
fnCall =
            case CmmExpr
fn of
              CmmLit (CmmLabel lbl :: CLabel
lbl)
                | CCallConv
StdCallConv <- CCallConv
cconv ->
                    SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCall (CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl) CCallConv
cconv [(CmmFormal, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs
                        -- stdcall functions must be declared with
                        -- a function type, otherwise the C compiler
                        -- doesn't add the @n suffix to the label.  We
                        -- can't add the @n suffix ourselves, because
                        -- it isn't valid C.
                | CmmReturnInfo
CmmNeverReturns <- CmmReturnInfo
ret ->
                    SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCall SDoc
cast_fn CCallConv
cconv [(CmmFormal, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs SDoc -> SDoc -> SDoc
<> SDoc
semi
                | Bool -> Bool
not (CLabel -> Bool
isMathFun CLabel
lbl) ->
                    SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprForeignCall (CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl) CCallConv
cconv [(CmmFormal, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs
              _ ->
                    SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCall SDoc
cast_fn CCallConv
cconv [(CmmFormal, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs SDoc -> SDoc -> SDoc
<> SDoc
semi
                        -- for a dynamic call, no declaration is necessary.

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

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

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

        fn_call :: SDoc
fn_call
          -- The mem primops carry an extra alignment arg.
          -- We could maybe emit an alignment directive using this info.
          -- We also need to cast mem primops to prevent conflicts with GCC
          -- builtins (see bug #5967).
          | Just _align :: Int
_align <- CallishMachOp -> Maybe Int
machOpMemcpyishAlign CallishMachOp
op
          = (String -> SDoc
text ";EFF_(" SDoc -> SDoc -> SDoc
<> SDoc
fn SDoc -> SDoc -> SDoc
<> Char -> SDoc
char ')' SDoc -> SDoc -> SDoc
<> SDoc
semi) SDoc -> SDoc -> SDoc
$$
            SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprForeignCall SDoc
fn CCallConv
cconv [(CmmFormal, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs
          | Bool
otherwise
          = SDoc
-> CCallConv
-> [(CmmFormal, ForeignHint)]
-> [(CmmExpr, ForeignHint)]
-> SDoc
pprCall SDoc
fn CCallConv
cconv [(CmmFormal, ForeignHint)]
hresults [(CmmExpr, ForeignHint)]
hargs

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

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

type Hinted a = (a, ForeignHint)

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

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

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

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


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

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

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

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

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

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

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

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

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


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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

pprMachOp_for_C :: MachOp -> SDoc

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

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

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

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

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

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

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

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

        -- Bitwise operations.  Not all of these may be supported at all
        -- sizes, and only integral MachReps are valid.
        MO_And          _ -> Char -> SDoc
char '&'
        MO_Or           _ -> Char -> SDoc
char '|'
        MO_Xor          _ -> Char -> SDoc
char '^'
        MO_Not          _ -> Char -> SDoc
char '~'
        MO_Shl          _ -> String -> SDoc
text "<<"
        MO_U_Shr        _ -> String -> SDoc
text ">>" -- unsigned shift right
        MO_S_Shr        _ -> String -> SDoc
text ">>" -- 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 from :: Width
from to :: Width
to | Width
from Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
to -> SDoc
empty
        MO_UU_Conv _from :: Width
_from to :: Width
to -> SDoc -> SDoc
parens (Width -> SDoc
machRep_U_CType Width
to)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

pprCallishMachOp_for_C :: CallishMachOp -> SDoc

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

        MO_S_QuotRem  {} -> SDoc
unsupported
        MO_U_QuotRem  {} -> SDoc
unsupported
        MO_U_QuotRem2 {} -> SDoc
unsupported
        MO_Add2       {} -> SDoc
unsupported
        MO_AddWordC   {} -> SDoc
unsupported
        MO_SubWordC   {} -> SDoc
unsupported
        MO_AddIntC    {} -> SDoc
unsupported
        MO_SubIntC    {} -> SDoc
unsupported
        MO_U_Mul2     {} -> SDoc
unsupported
        MO_Touch         -> SDoc
unsupported
        (MO_Prefetch_Data _ ) -> SDoc
unsupported
        --- we could support prefetch via "__builtin_prefetch"
        --- Not adding it for now
    where unsupported :: SDoc
unsupported = String -> SDoc
forall a. String -> a
panic ("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]
++ " not supported!")

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

mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc

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

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

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

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

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

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

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

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

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

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

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

-- True if this global reg has type StgPtr
isFixedPtrGlobalReg :: GlobalReg -> Bool
isFixedPtrGlobalReg :: GlobalReg -> Bool
isFixedPtrGlobalReg Sp    = Bool
True
isFixedPtrGlobalReg Hp    = Bool
True
isFixedPtrGlobalReg HpLim = Bool
True
isFixedPtrGlobalReg SpLim = Bool
True
isFixedPtrGlobalReg _     = 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 _)   = Bool
False
isStrangeTypeReg (CmmGlobal g :: GlobalReg
g)  = GlobalReg -> Bool
isStrangeTypeGlobal GlobalReg
g

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  visibility :: SDoc
visibility
     | CLabel -> Bool
externallyVisibleCLabel CLabel
lbl = Char -> SDoc
char 'E'
     | Bool
otherwise                   = Char -> SDoc
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 sz :: Int
sz = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
        String -> SDoc
text "extern __attribute__((stdcall)) void " SDoc -> SDoc -> SDoc
<> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
lbl
        SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens ([SDoc] -> SDoc
commafy (Int -> SDoc -> [SDoc]
forall a. Int -> a -> [a]
replicate (Int
sz Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` DynFlags -> Int
wORD_SIZE DynFlags
dflags) (Width -> SDoc
machRep_U_CType (DynFlags -> Width
wordWidth DynFlags
dflags))))
        SDoc -> SDoc -> SDoc
<> SDoc
semi

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

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

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

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

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

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

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

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

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

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

te_Stmt :: CmmNode e x -> TE ()
te_Stmt :: CmmNode e x -> TE ()
te_Stmt (CmmAssign r :: CmmReg
r e :: CmmExpr
e)         = CmmReg -> TE ()
te_Reg CmmReg
r TE () -> TE () -> TE ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CmmExpr -> TE ()
te_Expr CmmExpr
e
te_Stmt (CmmStore l :: CmmExpr
l r :: CmmExpr
r)          = CmmExpr -> TE ()
te_Expr CmmExpr
l TE () -> TE () -> TE ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CmmExpr -> TE ()
te_Expr CmmExpr
r
te_Stmt (CmmUnsafeForeignCall target :: ForeignTarget
target rs :: [CmmFormal]
rs es :: [CmmExpr]
es)
  = do  ForeignTarget -> TE ()
te_Target ForeignTarget
target
        (CmmFormal -> TE ()) -> [CmmFormal] -> TE ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmFormal -> TE ()
te_temp [CmmFormal]
rs
        (CmmExpr -> TE ()) -> [CmmExpr] -> TE ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CmmExpr -> TE ()
te_Expr [CmmExpr]
es
te_Stmt (CmmCondBranch e :: CmmExpr
e _ _ _) = CmmExpr -> TE ()
te_Expr CmmExpr
e
te_Stmt (CmmSwitch e :: CmmExpr
e _)         = 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 _                       = () -> TE ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

te_Expr :: CmmExpr -> TE ()
te_Expr :: CmmExpr -> TE ()
te_Expr (CmmLit lit :: CmmLit
lit)            = CmmLit -> TE ()
te_Lit CmmLit
lit
te_Expr (CmmLoad e :: CmmExpr
e _)           = CmmExpr -> TE ()
te_Expr CmmExpr
e
te_Expr (CmmReg r :: CmmReg
r)              = CmmReg -> TE ()
te_Reg CmmReg
r
te_Expr (CmmMachOp _ es :: [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 r :: CmmReg
r _)         = CmmReg -> TE ()
te_Reg CmmReg
r
te_Expr (CmmStackSlot _ _)      = String -> TE ()
forall a. String -> a
panic "te_Expr: CmmStackSlot not supported!"

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


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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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