{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}

--------------------------------------------------------------------------------
-- | Pretty print LLVM IR Code.
--

module GHC.Llvm.Ppr (

    -- * Top level LLVM objects.
    ppLlvmModule,
    ppLlvmComments,
    ppLlvmComment,
    ppLlvmGlobals,
    ppLlvmGlobal,
    ppLlvmAliases,
    ppLlvmAlias,
    ppLlvmMetas,
    ppLlvmMeta,
    ppLlvmFunctionDecls,
    ppLlvmFunctionDecl,
    ppLlvmFunctions,
    ppLlvmFunction,

    ppVar,
    ppLit,
    ppTypeLit,
    ppName,
    ppPlainName

    ) where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Llvm.Syntax
import GHC.Llvm.MetaData
import GHC.Llvm.Types

import Data.Int
import Data.List ( intersperse )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.Unique
import GHC.Data.FastString

--------------------------------------------------------------------------------
-- * Top Level Print functions
--------------------------------------------------------------------------------

-- | Print out a whole LLVM module.
ppLlvmModule :: LlvmOpts -> LlvmModule -> SDoc
ppLlvmModule :: LlvmOpts -> LlvmModule -> SDoc
ppLlvmModule LlvmOpts
opts (LlvmModule [LMString]
comments [LlvmAlias]
aliases [MetaDecl]
meta [LMGlobal]
globals LlvmFunctionDecls
decls LlvmFunctions
funcs)
  = [LMString] -> SDoc
ppLlvmComments [LMString]
comments SDoc -> SDoc -> SDoc
$+$ SDoc
newLine
    SDoc -> SDoc -> SDoc
$+$ [LlvmAlias] -> SDoc
ppLlvmAliases [LlvmAlias]
aliases SDoc -> SDoc -> SDoc
$+$ SDoc
newLine
    SDoc -> SDoc -> SDoc
$+$ LlvmOpts -> [MetaDecl] -> SDoc
ppLlvmMetas LlvmOpts
opts [MetaDecl]
meta SDoc -> SDoc -> SDoc
$+$ SDoc
newLine
    SDoc -> SDoc -> SDoc
$+$ LlvmOpts -> [LMGlobal] -> SDoc
ppLlvmGlobals LlvmOpts
opts [LMGlobal]
globals SDoc -> SDoc -> SDoc
$+$ SDoc
newLine
    SDoc -> SDoc -> SDoc
$+$ LlvmFunctionDecls -> SDoc
ppLlvmFunctionDecls LlvmFunctionDecls
decls SDoc -> SDoc -> SDoc
$+$ SDoc
newLine
    SDoc -> SDoc -> SDoc
$+$ LlvmOpts -> LlvmFunctions -> SDoc
ppLlvmFunctions LlvmOpts
opts LlvmFunctions
funcs

-- | Print out a multi-line comment, can be inside a function or on its own
ppLlvmComments :: [LMString] -> SDoc
ppLlvmComments :: [LMString] -> SDoc
ppLlvmComments [LMString]
comments = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (LMString -> SDoc) -> [LMString] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LMString -> SDoc
ppLlvmComment [LMString]
comments

-- | Print out a comment, can be inside a function or on its own
ppLlvmComment :: LMString -> SDoc
ppLlvmComment :: LMString -> SDoc
ppLlvmComment LMString
com = SDoc
semi SDoc -> SDoc -> SDoc
<+> LMString -> SDoc
ftext LMString
com


-- | Print out a list of global mutable variable definitions
ppLlvmGlobals :: LlvmOpts -> [LMGlobal] -> SDoc
ppLlvmGlobals :: LlvmOpts -> [LMGlobal] -> SDoc
ppLlvmGlobals LlvmOpts
opts [LMGlobal]
ls = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (LMGlobal -> SDoc) -> [LMGlobal] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (LlvmOpts -> LMGlobal -> SDoc
ppLlvmGlobal LlvmOpts
opts) [LMGlobal]
ls

-- | Print out a global mutable variable definition
ppLlvmGlobal :: LlvmOpts -> LMGlobal -> SDoc
ppLlvmGlobal :: LlvmOpts -> LMGlobal -> SDoc
ppLlvmGlobal LlvmOpts
opts (LMGlobal var :: LlvmVar
var@(LMGlobalVar LMString
_ LlvmType
_ LlvmLinkageType
link LMSection
x LMAlign
a LMConst
c) Maybe LlvmStatic
dat) =
    let sect :: SDoc
sect = case LMSection
x of
            Just LMString
x' -> String -> SDoc
text String
", section" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
doubleQuotes (LMString -> SDoc
ftext LMString
x')
            LMSection
Nothing -> SDoc
empty

        align :: SDoc
align = case LMAlign
a of
            Just Int
a' -> String -> SDoc
text String
", align" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
a'
            LMAlign
Nothing -> SDoc
empty

        rhs :: SDoc
rhs = case Maybe LlvmStatic
dat of
            Just LlvmStatic
stat -> LlvmOpts -> LlvmStatic -> SDoc
pprSpecialStatic LlvmOpts
opts LlvmStatic
stat
            Maybe LlvmStatic
Nothing   -> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> LlvmType
pLower (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
var)

        -- Position of linkage is different for aliases.
        const :: String
const = case LMConst
c of
          LMConst
Global   -> String
"global"
          LMConst
Constant -> String
"constant"
          LMConst
Alias    -> String
"alias"

    in LlvmOpts -> LlvmVar -> SDoc -> SDoc
ppAssignment LlvmOpts
opts LlvmVar
var (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ LlvmLinkageType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmLinkageType
link SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
const SDoc -> SDoc -> SDoc
<+> SDoc
rhs SDoc -> SDoc -> SDoc
<> SDoc
sect SDoc -> SDoc -> SDoc
<> SDoc
align
       SDoc -> SDoc -> SDoc
$+$ SDoc
newLine

ppLlvmGlobal LlvmOpts
opts (LMGlobal LlvmVar
var Maybe LlvmStatic
val) = String -> SDoc -> SDoc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"ppLlvmGlobal" (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
  String -> SDoc
text String
"Non Global var ppr as global! " SDoc -> SDoc -> SDoc
<> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
var SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"=" SDoc -> SDoc -> SDoc
<> Maybe SDoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((LlvmStatic -> SDoc) -> Maybe LlvmStatic -> Maybe SDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LlvmOpts -> LlvmStatic -> SDoc
ppStatic LlvmOpts
opts) Maybe LlvmStatic
val)


-- | Print out a list of LLVM type aliases.
ppLlvmAliases :: [LlvmAlias] -> SDoc
ppLlvmAliases :: [LlvmAlias] -> SDoc
ppLlvmAliases [LlvmAlias]
tys = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (LlvmAlias -> SDoc) -> [LlvmAlias] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LlvmAlias -> SDoc
ppLlvmAlias [LlvmAlias]
tys

-- | Print out an LLVM type alias.
ppLlvmAlias :: LlvmAlias -> SDoc
ppLlvmAlias :: LlvmAlias -> SDoc
ppLlvmAlias (LMString
name, LlvmType
ty)
  = Char -> SDoc
char Char
'%' SDoc -> SDoc -> SDoc
<> LMString -> SDoc
ftext LMString
name SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"type" SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
ty


-- | Print out a list of LLVM metadata.
ppLlvmMetas :: LlvmOpts -> [MetaDecl] -> SDoc
ppLlvmMetas :: LlvmOpts -> [MetaDecl] -> SDoc
ppLlvmMetas LlvmOpts
opts [MetaDecl]
metas = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (MetaDecl -> SDoc) -> [MetaDecl] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (LlvmOpts -> MetaDecl -> SDoc
ppLlvmMeta LlvmOpts
opts) [MetaDecl]
metas

-- | Print out an LLVM metadata definition.
ppLlvmMeta :: LlvmOpts -> MetaDecl -> SDoc
ppLlvmMeta :: LlvmOpts -> MetaDecl -> SDoc
ppLlvmMeta LlvmOpts
opts (MetaUnnamed MetaId
n MetaExpr
m)
  = MetaId -> SDoc
forall a. Outputable a => a -> SDoc
ppr MetaId
n SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> LlvmOpts -> MetaExpr -> SDoc
ppMetaExpr LlvmOpts
opts MetaExpr
m

ppLlvmMeta LlvmOpts
_opts (MetaNamed LMString
n [MetaId]
m)
  = SDoc
exclamation SDoc -> SDoc -> SDoc
<> LMString -> SDoc
ftext LMString
n SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> SDoc
exclamation SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces SDoc
nodes
  where
    nodes :: SDoc
nodes = [SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse SDoc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ (MetaId -> SDoc) -> [MetaId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map MetaId -> SDoc
forall a. Outputable a => a -> SDoc
ppr [MetaId]
m


-- | Print out a list of function definitions.
ppLlvmFunctions :: LlvmOpts -> LlvmFunctions -> SDoc
ppLlvmFunctions :: LlvmOpts -> LlvmFunctions -> SDoc
ppLlvmFunctions LlvmOpts
opts LlvmFunctions
funcs = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (LlvmFunction -> SDoc) -> LlvmFunctions -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (LlvmOpts -> LlvmFunction -> SDoc
ppLlvmFunction LlvmOpts
opts) LlvmFunctions
funcs

-- | Print out a function definition.
ppLlvmFunction :: LlvmOpts -> LlvmFunction -> SDoc
ppLlvmFunction :: LlvmOpts -> LlvmFunction -> SDoc
ppLlvmFunction LlvmOpts
opts LlvmFunction
fun =
    let attrDoc :: SDoc
attrDoc = [LlvmFuncAttr] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppSpaceJoin (LlvmFunction -> [LlvmFuncAttr]
funcAttrs LlvmFunction
fun)
        secDoc :: SDoc
secDoc = case LlvmFunction -> LMSection
funcSect LlvmFunction
fun of
                      Just LMString
s' -> String -> SDoc
text String
"section" SDoc -> SDoc -> SDoc
<+> (SDoc -> SDoc
doubleQuotes (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ LMString -> SDoc
ftext LMString
s')
                      LMSection
Nothing -> SDoc
empty
        prefixDoc :: SDoc
prefixDoc = case LlvmFunction -> Maybe LlvmStatic
funcPrefix LlvmFunction
fun of
                        Just LlvmStatic
v  -> String -> SDoc
text String
"prefix" SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmStatic -> SDoc
ppStatic LlvmOpts
opts LlvmStatic
v
                        Maybe LlvmStatic
Nothing -> SDoc
empty
    in String -> SDoc
text String
"define" SDoc -> SDoc -> SDoc
<+> LlvmFunctionDecl -> [LMString] -> SDoc
ppLlvmFunctionHeader (LlvmFunction -> LlvmFunctionDecl
funcDecl LlvmFunction
fun) (LlvmFunction -> [LMString]
funcArgs LlvmFunction
fun)
        SDoc -> SDoc -> SDoc
<+> SDoc
attrDoc SDoc -> SDoc -> SDoc
<+> SDoc
secDoc SDoc -> SDoc -> SDoc
<+> SDoc
prefixDoc
        SDoc -> SDoc -> SDoc
$+$ SDoc
lbrace
        SDoc -> SDoc -> SDoc
$+$ LlvmOpts -> LlvmBlocks -> SDoc
ppLlvmBlocks LlvmOpts
opts (LlvmFunction -> LlvmBlocks
funcBody LlvmFunction
fun)
        SDoc -> SDoc -> SDoc
$+$ SDoc
rbrace
        SDoc -> SDoc -> SDoc
$+$ SDoc
newLine
        SDoc -> SDoc -> SDoc
$+$ SDoc
newLine

-- | Print out a function definition header.
ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc
ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc
ppLlvmFunctionHeader (LlvmFunctionDecl LMString
n LlvmLinkageType
l LlvmCallConvention
c LlvmType
r LlvmParameterListType
varg [LlvmParameter]
p LMAlign
a) [LMString]
args
  = let varg' :: PtrString
varg' = case LlvmParameterListType
varg of
                      LlvmParameterListType
VarArgs | [LlvmParameter] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LlvmParameter]
p    -> String -> PtrString
sLit String
"..."
                              | Bool
otherwise -> String -> PtrString
sLit String
", ..."
                      LlvmParameterListType
_otherwise          -> String -> PtrString
sLit String
""
        align :: SDoc
align = case LMAlign
a of
                     Just Int
a' -> String -> SDoc
text String
" align " SDoc -> SDoc -> SDoc
<> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
a'
                     LMAlign
Nothing -> SDoc
empty
        args' :: [SDoc]
args' = ((LlvmParameter, LMString) -> SDoc)
-> [(LlvmParameter, LMString)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\((LlvmType
ty,[LlvmParamAttr]
p),LMString
n) -> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
ty SDoc -> SDoc -> SDoc
<+> [LlvmParamAttr] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppSpaceJoin [LlvmParamAttr]
p SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'%'
                                    SDoc -> SDoc -> SDoc
<> LMString -> SDoc
ftext LMString
n)
                    ([LlvmParameter] -> [LMString] -> [(LlvmParameter, LMString)]
forall a b. [a] -> [b] -> [(a, b)]
zip [LlvmParameter]
p [LMString]
args)
    in LlvmLinkageType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmLinkageType
l SDoc -> SDoc -> SDoc
<+> LlvmCallConvention -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmCallConvention
c SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
r SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'@' SDoc -> SDoc -> SDoc
<> LMString -> SDoc
ftext LMString
n SDoc -> SDoc -> SDoc
<> SDoc
lparen SDoc -> SDoc -> SDoc
<>
        ([SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma [SDoc]
args') SDoc -> SDoc -> SDoc
<> PtrString -> SDoc
ptext PtrString
varg' SDoc -> SDoc -> SDoc
<> SDoc
rparen SDoc -> SDoc -> SDoc
<> SDoc
align

-- | Print out a list of function declaration.
ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc
ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc
ppLlvmFunctionDecls LlvmFunctionDecls
decs = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (LlvmFunctionDecl -> SDoc) -> LlvmFunctionDecls -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map LlvmFunctionDecl -> SDoc
ppLlvmFunctionDecl LlvmFunctionDecls
decs

-- | Print out a function declaration.
-- Declarations define the function type but don't define the actual body of
-- the function.
ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc
ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc
ppLlvmFunctionDecl (LlvmFunctionDecl LMString
n LlvmLinkageType
l LlvmCallConvention
c LlvmType
r LlvmParameterListType
varg [LlvmParameter]
p LMAlign
a)
  = let varg' :: PtrString
varg' = case LlvmParameterListType
varg of
                      LlvmParameterListType
VarArgs | [LlvmParameter] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LlvmParameter]
p    -> String -> PtrString
sLit String
"..."
                              | Bool
otherwise -> String -> PtrString
sLit String
", ..."
                      LlvmParameterListType
_otherwise          -> String -> PtrString
sLit String
""
        align :: SDoc
align = case LMAlign
a of
                     Just Int
a' -> String -> SDoc
text String
" align" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
a'
                     LMAlign
Nothing -> SDoc
empty
        args :: SDoc
args = [SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse (SDoc
comma SDoc -> SDoc -> SDoc
<> SDoc
space) ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$
                  (LlvmParameter -> SDoc) -> [LlvmParameter] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\(LlvmType
t,[LlvmParamAttr]
a) -> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<+> [LlvmParamAttr] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppSpaceJoin [LlvmParamAttr]
a) [LlvmParameter]
p
    in String -> SDoc
text String
"declare" SDoc -> SDoc -> SDoc
<+> LlvmLinkageType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmLinkageType
l SDoc -> SDoc -> SDoc
<+> LlvmCallConvention -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmCallConvention
c SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
r SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'@' SDoc -> SDoc -> SDoc
<>
        LMString -> SDoc
ftext LMString
n SDoc -> SDoc -> SDoc
<> SDoc
lparen SDoc -> SDoc -> SDoc
<> SDoc
args SDoc -> SDoc -> SDoc
<> PtrString -> SDoc
ptext PtrString
varg' SDoc -> SDoc -> SDoc
<> SDoc
rparen SDoc -> SDoc -> SDoc
<> SDoc
align SDoc -> SDoc -> SDoc
$+$ SDoc
newLine


-- | Print out a list of LLVM blocks.
ppLlvmBlocks :: LlvmOpts -> LlvmBlocks -> SDoc
ppLlvmBlocks :: LlvmOpts -> LlvmBlocks -> SDoc
ppLlvmBlocks LlvmOpts
opts LlvmBlocks
blocks = [SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (LlvmBlock -> SDoc) -> LlvmBlocks -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (LlvmOpts -> LlvmBlock -> SDoc
ppLlvmBlock LlvmOpts
opts) LlvmBlocks
blocks

-- | Print out an LLVM block.
-- It must be part of a function definition.
ppLlvmBlock :: LlvmOpts -> LlvmBlock -> SDoc
ppLlvmBlock :: LlvmOpts -> LlvmBlock -> SDoc
ppLlvmBlock LlvmOpts
opts (LlvmBlock Unique
blockId [LlvmStatement]
stmts) =
  let isLabel :: LlvmStatement -> Bool
isLabel (MkLabel Unique
_) = Bool
True
      isLabel LlvmStatement
_           = Bool
False
      ([LlvmStatement]
block, [LlvmStatement]
rest)       = (LlvmStatement -> Bool)
-> [LlvmStatement] -> ([LlvmStatement], [LlvmStatement])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break LlvmStatement -> Bool
isLabel [LlvmStatement]
stmts
      ppRest :: SDoc
ppRest = case [LlvmStatement]
rest of
        MkLabel Unique
id:[LlvmStatement]
xs -> LlvmOpts -> LlvmBlock -> SDoc
ppLlvmBlock LlvmOpts
opts (Unique -> [LlvmStatement] -> LlvmBlock
LlvmBlock Unique
id [LlvmStatement]
xs)
        [LlvmStatement]
_             -> SDoc
empty
  in Unique -> SDoc
ppLlvmBlockLabel Unique
blockId
           SDoc -> SDoc -> SDoc
$+$ ([SDoc] -> SDoc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (LlvmStatement -> SDoc) -> [LlvmStatement] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (LlvmOpts -> LlvmStatement -> SDoc
ppLlvmStatement LlvmOpts
opts) [LlvmStatement]
block)
           SDoc -> SDoc -> SDoc
$+$ SDoc
newLine
           SDoc -> SDoc -> SDoc
$+$ SDoc
ppRest

-- | Print out an LLVM block label.
ppLlvmBlockLabel :: LlvmBlockId -> SDoc
ppLlvmBlockLabel :: Unique -> SDoc
ppLlvmBlockLabel Unique
id = Unique -> SDoc
pprUniqueAlways Unique
id SDoc -> SDoc -> SDoc
<> SDoc
colon


-- | Print out an LLVM statement.
ppLlvmStatement :: LlvmOpts -> LlvmStatement -> SDoc
ppLlvmStatement :: LlvmOpts -> LlvmStatement -> SDoc
ppLlvmStatement LlvmOpts
opts LlvmStatement
stmt =
  let ind :: SDoc -> SDoc
ind = (String -> SDoc
text String
"  " SDoc -> SDoc -> SDoc
<>)
  in case LlvmStatement
stmt of
        Assignment  LlvmVar
dst LlvmExpression
expr      -> SDoc -> SDoc
ind (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ LlvmOpts -> LlvmVar -> SDoc -> SDoc
ppAssignment LlvmOpts
opts LlvmVar
dst (LlvmOpts -> LlvmExpression -> SDoc
ppLlvmExpression LlvmOpts
opts LlvmExpression
expr)
        Fence       Bool
st LlvmSyncOrdering
ord        -> SDoc -> SDoc
ind (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Bool -> LlvmSyncOrdering -> SDoc
ppFence Bool
st LlvmSyncOrdering
ord
        Branch      LlvmVar
target        -> SDoc -> SDoc
ind (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ LlvmOpts -> LlvmVar -> SDoc
ppBranch LlvmOpts
opts LlvmVar
target
        BranchIf    LlvmVar
cond LlvmVar
ifT LlvmVar
ifF  -> SDoc -> SDoc
ind (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppBranchIf LlvmOpts
opts LlvmVar
cond LlvmVar
ifT LlvmVar
ifF
        Comment     [LMString]
comments      -> SDoc -> SDoc
ind (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [LMString] -> SDoc
ppLlvmComments [LMString]
comments
        MkLabel     Unique
label         -> Unique -> SDoc
ppLlvmBlockLabel Unique
label
        Store       LlvmVar
value LlvmVar
ptr     -> SDoc -> SDoc
ind (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ LlvmOpts -> LlvmVar -> LlvmVar -> SDoc
ppStore LlvmOpts
opts LlvmVar
value LlvmVar
ptr
        Switch      LlvmVar
scrut LlvmVar
def [(LlvmVar, LlvmVar)]
tgs -> SDoc -> SDoc
ind (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ LlvmOpts -> LlvmVar -> LlvmVar -> [(LlvmVar, LlvmVar)] -> SDoc
ppSwitch LlvmOpts
opts LlvmVar
scrut LlvmVar
def [(LlvmVar, LlvmVar)]
tgs
        Return      Maybe LlvmVar
result        -> SDoc -> SDoc
ind (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ LlvmOpts -> Maybe LlvmVar -> SDoc
ppReturn LlvmOpts
opts Maybe LlvmVar
result
        Expr        LlvmExpression
expr          -> SDoc -> SDoc
ind (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ LlvmOpts -> LlvmExpression -> SDoc
ppLlvmExpression LlvmOpts
opts LlvmExpression
expr
        LlvmStatement
Unreachable               -> SDoc -> SDoc
ind (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"unreachable"
        LlvmStatement
Nop                       -> SDoc
empty
        MetaStmt    [MetaAnnot]
meta LlvmStatement
s        -> LlvmOpts -> [MetaAnnot] -> LlvmStatement -> SDoc
ppMetaStatement LlvmOpts
opts [MetaAnnot]
meta LlvmStatement
s


-- | Print out an LLVM expression.
ppLlvmExpression :: LlvmOpts -> LlvmExpression -> SDoc
ppLlvmExpression :: LlvmOpts -> LlvmExpression -> SDoc
ppLlvmExpression LlvmOpts
opts LlvmExpression
expr
  = case LlvmExpression
expr of
        Alloca     LlvmType
tp Int
amount        -> LlvmOpts -> LlvmType -> Int -> SDoc
ppAlloca LlvmOpts
opts LlvmType
tp Int
amount
        LlvmOp     LlvmMachOp
op LlvmVar
left LlvmVar
right    -> LlvmOpts -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
ppMachOp LlvmOpts
opts LlvmMachOp
op LlvmVar
left LlvmVar
right
        Call       LlvmCallType
tp LlvmVar
fp [LlvmVar]
args [LlvmFuncAttr]
attrs -> LlvmOpts
-> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
ppCall LlvmOpts
opts LlvmCallType
tp LlvmVar
fp ((LlvmVar -> MetaExpr) -> [LlvmVar] -> [MetaExpr]
forall a b. (a -> b) -> [a] -> [b]
map LlvmVar -> MetaExpr
MetaVar [LlvmVar]
args) [LlvmFuncAttr]
attrs
        CallM      LlvmCallType
tp LlvmVar
fp [MetaExpr]
args [LlvmFuncAttr]
attrs -> LlvmOpts
-> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
ppCall LlvmOpts
opts LlvmCallType
tp LlvmVar
fp [MetaExpr]
args [LlvmFuncAttr]
attrs
        Cast       LlvmCastOp
op LlvmVar
from LlvmType
to       -> LlvmOpts -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
ppCast LlvmOpts
opts LlvmCastOp
op LlvmVar
from LlvmType
to
        Compare    LlvmCmpOp
op LlvmVar
left LlvmVar
right    -> LlvmOpts -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
ppCmpOp LlvmOpts
opts LlvmCmpOp
op LlvmVar
left LlvmVar
right
        Extract    LlvmVar
vec LlvmVar
idx          -> LlvmOpts -> LlvmVar -> LlvmVar -> SDoc
ppExtract LlvmOpts
opts LlvmVar
vec LlvmVar
idx
        ExtractV   LlvmVar
struct Int
idx       -> LlvmOpts -> LlvmVar -> Int -> SDoc
ppExtractV LlvmOpts
opts LlvmVar
struct Int
idx
        Insert     LlvmVar
vec LlvmVar
elt LlvmVar
idx      -> LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppInsert LlvmOpts
opts LlvmVar
vec LlvmVar
elt LlvmVar
idx
        GetElemPtr Bool
inb LlvmVar
ptr [LlvmVar]
indexes  -> LlvmOpts -> Bool -> LlvmVar -> [LlvmVar] -> SDoc
ppGetElementPtr LlvmOpts
opts Bool
inb LlvmVar
ptr [LlvmVar]
indexes
        Load       LlvmVar
ptr              -> LlvmOpts -> LlvmVar -> SDoc
ppLoad LlvmOpts
opts LlvmVar
ptr
        ALoad      LlvmSyncOrdering
ord Bool
st LlvmVar
ptr       -> LlvmOpts -> LlvmSyncOrdering -> Bool -> LlvmVar -> SDoc
ppALoad LlvmOpts
opts LlvmSyncOrdering
ord Bool
st LlvmVar
ptr
        Malloc     LlvmType
tp Int
amount        -> LlvmOpts -> LlvmType -> Int -> SDoc
ppMalloc LlvmOpts
opts LlvmType
tp Int
amount
        AtomicRMW  LlvmAtomicOp
aop LlvmVar
tgt LlvmVar
src LlvmSyncOrdering
ordering -> LlvmOpts
-> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
ppAtomicRMW LlvmOpts
opts LlvmAtomicOp
aop LlvmVar
tgt LlvmVar
src LlvmSyncOrdering
ordering
        CmpXChg    LlvmVar
addr LlvmVar
old LlvmVar
new LlvmSyncOrdering
s_ord LlvmSyncOrdering
f_ord -> LlvmOpts
-> LlvmVar
-> LlvmVar
-> LlvmVar
-> LlvmSyncOrdering
-> LlvmSyncOrdering
-> SDoc
ppCmpXChg LlvmOpts
opts LlvmVar
addr LlvmVar
old LlvmVar
new LlvmSyncOrdering
s_ord LlvmSyncOrdering
f_ord
        Phi        LlvmType
tp [(LlvmVar, LlvmVar)]
predecessors  -> LlvmOpts -> LlvmType -> [(LlvmVar, LlvmVar)] -> SDoc
ppPhi LlvmOpts
opts LlvmType
tp [(LlvmVar, LlvmVar)]
predecessors
        Asm        LMString
asm LMString
c LlvmType
ty [LlvmVar]
v Bool
se Bool
sk -> LlvmOpts
-> LMString
-> LMString
-> LlvmType
-> [LlvmVar]
-> Bool
-> Bool
-> SDoc
ppAsm LlvmOpts
opts LMString
asm LMString
c LlvmType
ty [LlvmVar]
v Bool
se Bool
sk
        MExpr      [MetaAnnot]
meta LlvmExpression
expr        -> LlvmOpts -> [MetaAnnot] -> LlvmExpression -> SDoc
ppMetaAnnotExpr LlvmOpts
opts [MetaAnnot]
meta LlvmExpression
expr

ppMetaExpr :: LlvmOpts -> MetaExpr -> SDoc
ppMetaExpr :: LlvmOpts -> MetaExpr -> SDoc
ppMetaExpr LlvmOpts
opts = \case
  MetaVar (LMLitVar (LMNullLit LlvmType
_)) -> String -> SDoc
text String
"null"
  MetaStr    LMString
s                     -> Char -> SDoc
char Char
'!' SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
doubleQuotes (LMString -> SDoc
ftext LMString
s)
  MetaNode   MetaId
n                     -> MetaId -> SDoc
forall a. Outputable a => a -> SDoc
ppr MetaId
n
  MetaVar    LlvmVar
v                     -> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
v
  MetaStruct [MetaExpr]
es                    -> Char -> SDoc
char Char
'!' SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces ([SDoc] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin ((MetaExpr -> SDoc) -> [MetaExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (LlvmOpts -> MetaExpr -> SDoc
ppMetaExpr LlvmOpts
opts) [MetaExpr]
es))


--------------------------------------------------------------------------------
-- * Individual print functions
--------------------------------------------------------------------------------

-- | Should always be a function pointer. So a global var of function type
-- (since globals are always pointers) or a local var of pointer function type.
ppCall :: LlvmOpts -> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
ppCall :: LlvmOpts
-> LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
ppCall LlvmOpts
opts LlvmCallType
ct LlvmVar
fptr [MetaExpr]
args [LlvmFuncAttr]
attrs = case LlvmVar
fptr of
                           --
    -- if local var function pointer, unwrap
    LMLocalVar Unique
_ (LMPointer (LMFunction LlvmFunctionDecl
d)) -> LlvmFunctionDecl -> SDoc
ppCall' LlvmFunctionDecl
d

    -- should be function type otherwise
    LMGlobalVar LMString
_ (LMFunction LlvmFunctionDecl
d) LlvmLinkageType
_ LMSection
_ LMAlign
_ LMConst
_    -> LlvmFunctionDecl -> SDoc
ppCall' LlvmFunctionDecl
d

    -- not pointer or function, so error
    LlvmVar
_other -> String -> SDoc
forall a. HasCallStack => String -> a
error (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ String
"ppCall called with non LMFunction type!\nMust be "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" called with either global var of function type or "
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"local var of pointer function type."

    where
        ppCall' :: LlvmFunctionDecl -> SDoc
ppCall' (LlvmFunctionDecl LMString
_ LlvmLinkageType
_ LlvmCallConvention
cc LlvmType
ret LlvmParameterListType
argTy [LlvmParameter]
params LMAlign
_) =
            let tc :: SDoc
tc = if LlvmCallType
ct LlvmCallType -> LlvmCallType -> Bool
forall a. Eq a => a -> a -> Bool
== LlvmCallType
TailCall then String -> SDoc
text String
"tail " else SDoc
empty
                ppValues :: SDoc
ppValues = LlvmOpts -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc
ppCallParams LlvmOpts
opts ((LlvmParameter -> [LlvmParamAttr])
-> [LlvmParameter] -> [[LlvmParamAttr]]
forall a b. (a -> b) -> [a] -> [b]
map LlvmParameter -> [LlvmParamAttr]
forall a b. (a, b) -> b
snd [LlvmParameter]
params) [MetaExpr]
args
                ppArgTy :: SDoc
ppArgTy  = ([SDoc] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (LlvmParameter -> SDoc) -> [LlvmParameter] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> SDoc)
-> (LlvmParameter -> LlvmType) -> LlvmParameter -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmParameter -> LlvmType
forall a b. (a, b) -> a
fst) [LlvmParameter]
params) SDoc -> SDoc -> SDoc
<>
                           (case LlvmParameterListType
argTy of
                               LlvmParameterListType
VarArgs   -> String -> SDoc
text String
", ..."
                               LlvmParameterListType
FixedArgs -> SDoc
empty)
                fnty :: SDoc
fnty = SDoc
space SDoc -> SDoc -> SDoc
<> SDoc
lparen SDoc -> SDoc -> SDoc
<> SDoc
ppArgTy SDoc -> SDoc -> SDoc
<> SDoc
rparen
                attrDoc :: SDoc
attrDoc = [LlvmFuncAttr] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppSpaceJoin [LlvmFuncAttr]
attrs
            in  SDoc
tc SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"call" SDoc -> SDoc -> SDoc
<+> LlvmCallConvention -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmCallConvention
cc SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
ret
                    SDoc -> SDoc -> SDoc
<> SDoc
fnty SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppName LlvmOpts
opts LlvmVar
fptr SDoc -> SDoc -> SDoc
<> SDoc
lparen SDoc -> SDoc -> SDoc
<+> SDoc
ppValues
                    SDoc -> SDoc -> SDoc
<+> SDoc
rparen SDoc -> SDoc -> SDoc
<+> SDoc
attrDoc

        ppCallParams :: LlvmOpts -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc
        ppCallParams :: LlvmOpts -> [[LlvmParamAttr]] -> [MetaExpr] -> SDoc
ppCallParams LlvmOpts
opts [[LlvmParamAttr]]
attrs [MetaExpr]
args = [SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ([LlvmParamAttr] -> MetaExpr -> SDoc)
-> [[LlvmParamAttr]] -> [MetaExpr] -> [SDoc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [LlvmParamAttr] -> MetaExpr -> SDoc
ppCallMetaExpr [[LlvmParamAttr]]
attrs [MetaExpr]
args
         where
          -- Metadata needs to be marked as having the `metadata` type when used
          -- in a call argument
          ppCallMetaExpr :: [LlvmParamAttr] -> MetaExpr -> SDoc
ppCallMetaExpr [LlvmParamAttr]
attrs (MetaVar LlvmVar
v) = [LlvmParamAttr] -> LlvmOpts -> LlvmVar -> SDoc
ppVar' [LlvmParamAttr]
attrs LlvmOpts
opts LlvmVar
v
          ppCallMetaExpr [LlvmParamAttr]
_ MetaExpr
v             = String -> SDoc
text String
"metadata" SDoc -> SDoc -> SDoc
<+> LlvmOpts -> MetaExpr -> SDoc
ppMetaExpr LlvmOpts
opts MetaExpr
v


ppMachOp :: LlvmOpts -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
ppMachOp :: LlvmOpts -> LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
ppMachOp LlvmOpts
opts LlvmMachOp
op LlvmVar
left LlvmVar
right =
  (LlvmMachOp -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmMachOp
op) SDoc -> SDoc -> SDoc
<+> (LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmVar -> LlvmType
getVarType LlvmVar
left)) SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppName LlvmOpts
opts LlvmVar
left
        SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppName LlvmOpts
opts LlvmVar
right


ppCmpOp :: LlvmOpts -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
ppCmpOp :: LlvmOpts -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
ppCmpOp LlvmOpts
opts LlvmCmpOp
op LlvmVar
left LlvmVar
right =
  let cmpOp :: SDoc
cmpOp
        | LlvmType -> Bool
isInt (LlvmVar -> LlvmType
getVarType LlvmVar
left) Bool -> Bool -> Bool
&& LlvmType -> Bool
isInt (LlvmVar -> LlvmType
getVarType LlvmVar
right) = String -> SDoc
text String
"icmp"
        | LlvmType -> Bool
isFloat (LlvmVar -> LlvmType
getVarType LlvmVar
left) Bool -> Bool -> Bool
&& LlvmType -> Bool
isFloat (LlvmVar -> LlvmType
getVarType LlvmVar
right) = String -> SDoc
text String
"fcmp"
        | Bool
otherwise = String -> SDoc
text String
"icmp" -- Just continue as its much easier to debug
        {-
        | otherwise = error ("can't compare different types, left = "
                ++ (show $ getVarType left) ++ ", right = "
                ++ (show $ getVarType right))
        -}
  in SDoc
cmpOp SDoc -> SDoc -> SDoc
<+> LlvmCmpOp -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmCmpOp
op SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmVar -> LlvmType
getVarType LlvmVar
left)
        SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppName LlvmOpts
opts LlvmVar
left SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppName LlvmOpts
opts LlvmVar
right


ppAssignment :: LlvmOpts -> LlvmVar -> SDoc -> SDoc
ppAssignment :: LlvmOpts -> LlvmVar -> SDoc -> SDoc
ppAssignment LlvmOpts
opts LlvmVar
var SDoc
expr = LlvmOpts -> LlvmVar -> SDoc
ppName LlvmOpts
opts LlvmVar
var SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> SDoc
expr

ppFence :: Bool -> LlvmSyncOrdering -> SDoc
ppFence :: Bool -> LlvmSyncOrdering -> SDoc
ppFence Bool
st LlvmSyncOrdering
ord =
  let singleThread :: SDoc
singleThread = case Bool
st of Bool
True  -> String -> SDoc
text String
"singlethread"
                                Bool
False -> SDoc
empty
  in String -> SDoc
text String
"fence" SDoc -> SDoc -> SDoc
<+> SDoc
singleThread SDoc -> SDoc -> SDoc
<+> LlvmSyncOrdering -> SDoc
ppSyncOrdering LlvmSyncOrdering
ord

ppSyncOrdering :: LlvmSyncOrdering -> SDoc
ppSyncOrdering :: LlvmSyncOrdering -> SDoc
ppSyncOrdering LlvmSyncOrdering
SyncUnord     = String -> SDoc
text String
"unordered"
ppSyncOrdering LlvmSyncOrdering
SyncMonotonic = String -> SDoc
text String
"monotonic"
ppSyncOrdering LlvmSyncOrdering
SyncAcquire   = String -> SDoc
text String
"acquire"
ppSyncOrdering LlvmSyncOrdering
SyncRelease   = String -> SDoc
text String
"release"
ppSyncOrdering LlvmSyncOrdering
SyncAcqRel    = String -> SDoc
text String
"acq_rel"
ppSyncOrdering LlvmSyncOrdering
SyncSeqCst    = String -> SDoc
text String
"seq_cst"

ppAtomicOp :: LlvmAtomicOp -> SDoc
ppAtomicOp :: LlvmAtomicOp -> SDoc
ppAtomicOp LlvmAtomicOp
LAO_Xchg = String -> SDoc
text String
"xchg"
ppAtomicOp LlvmAtomicOp
LAO_Add  = String -> SDoc
text String
"add"
ppAtomicOp LlvmAtomicOp
LAO_Sub  = String -> SDoc
text String
"sub"
ppAtomicOp LlvmAtomicOp
LAO_And  = String -> SDoc
text String
"and"
ppAtomicOp LlvmAtomicOp
LAO_Nand = String -> SDoc
text String
"nand"
ppAtomicOp LlvmAtomicOp
LAO_Or   = String -> SDoc
text String
"or"
ppAtomicOp LlvmAtomicOp
LAO_Xor  = String -> SDoc
text String
"xor"
ppAtomicOp LlvmAtomicOp
LAO_Max  = String -> SDoc
text String
"max"
ppAtomicOp LlvmAtomicOp
LAO_Min  = String -> SDoc
text String
"min"
ppAtomicOp LlvmAtomicOp
LAO_Umax = String -> SDoc
text String
"umax"
ppAtomicOp LlvmAtomicOp
LAO_Umin = String -> SDoc
text String
"umin"

ppAtomicRMW :: LlvmOpts -> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
ppAtomicRMW :: LlvmOpts
-> LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
ppAtomicRMW LlvmOpts
opts LlvmAtomicOp
aop LlvmVar
tgt LlvmVar
src LlvmSyncOrdering
ordering =
  String -> SDoc
text String
"atomicrmw" SDoc -> SDoc -> SDoc
<+> LlvmAtomicOp -> SDoc
ppAtomicOp LlvmAtomicOp
aop SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
tgt SDoc -> SDoc -> SDoc
<> SDoc
comma
  SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
src SDoc -> SDoc -> SDoc
<+> LlvmSyncOrdering -> SDoc
ppSyncOrdering LlvmSyncOrdering
ordering

ppCmpXChg :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar
          -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc
ppCmpXChg :: LlvmOpts
-> LlvmVar
-> LlvmVar
-> LlvmVar
-> LlvmSyncOrdering
-> LlvmSyncOrdering
-> SDoc
ppCmpXChg LlvmOpts
opts LlvmVar
addr LlvmVar
old LlvmVar
new LlvmSyncOrdering
s_ord LlvmSyncOrdering
f_ord =
  String -> SDoc
text String
"cmpxchg" SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
addr SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
old SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
new
  SDoc -> SDoc -> SDoc
<+> LlvmSyncOrdering -> SDoc
ppSyncOrdering LlvmSyncOrdering
s_ord SDoc -> SDoc -> SDoc
<+> LlvmSyncOrdering -> SDoc
ppSyncOrdering LlvmSyncOrdering
f_ord

-- XXX: On x86, vector types need to be 16-byte aligned for aligned access, but
-- we have no way of guaranteeing that this is true with GHC (we would need to
-- modify the layout of the stack and closures, change the storage manager,
-- etc.). So, we blindly tell LLVM that *any* vector store or load could be
-- unaligned. In the future we may be able to guarantee that certain vector
-- access patterns are aligned, in which case we will need a more granular way
-- of specifying alignment.

ppLoad :: LlvmOpts -> LlvmVar -> SDoc
ppLoad :: LlvmOpts -> LlvmVar -> SDoc
ppLoad LlvmOpts
opts LlvmVar
var = String -> SDoc
text String
"load" SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
derefType SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
var SDoc -> SDoc -> SDoc
<> SDoc
align
  where
    derefType :: LlvmType
derefType = LlvmType -> LlvmType
pLower (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
var
    align :: SDoc
align | LlvmType -> Bool
isVector (LlvmType -> Bool) -> (LlvmVar -> LlvmType) -> LlvmVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmType -> LlvmType
pLower (LlvmType -> LlvmType)
-> (LlvmVar -> LlvmType) -> LlvmVar -> LlvmType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmVar -> LlvmType
getVarType (LlvmVar -> Bool) -> LlvmVar -> Bool
forall a b. (a -> b) -> a -> b
$ LlvmVar
var = String -> SDoc
text String
", align 1"
          | Bool
otherwise = SDoc
empty

ppALoad :: LlvmOpts -> LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc
ppALoad :: LlvmOpts -> LlvmSyncOrdering -> Bool -> LlvmVar -> SDoc
ppALoad LlvmOpts
opts LlvmSyncOrdering
ord Bool
st LlvmVar
var =
  let alignment :: Int
alignment = (Platform -> LlvmType -> Int
llvmWidthInBits (LlvmOpts -> Platform
llvmOptsPlatform LlvmOpts
opts) (LlvmType -> Int) -> LlvmType -> Int
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
var) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
8
      align :: SDoc
align     = String -> SDoc
text String
", align" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
alignment
      sThreaded :: SDoc
sThreaded | Bool
st        = String -> SDoc
text String
" singlethread"
                | Bool
otherwise = SDoc
empty
      derefType :: LlvmType
derefType = LlvmType -> LlvmType
pLower (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
var
  in String -> SDoc
text String
"load atomic" SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
derefType SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
var SDoc -> SDoc -> SDoc
<> SDoc
sThreaded
            SDoc -> SDoc -> SDoc
<+> LlvmSyncOrdering -> SDoc
ppSyncOrdering LlvmSyncOrdering
ord SDoc -> SDoc -> SDoc
<> SDoc
align

ppStore :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc
ppStore :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc
ppStore LlvmOpts
opts LlvmVar
val LlvmVar
dst
    | LlvmVar -> Bool
isVecPtrVar LlvmVar
dst = String -> SDoc
text String
"store" SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
val SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
dst SDoc -> SDoc -> SDoc
<>
                        SDoc
comma SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"align 1"
    | Bool
otherwise       = String -> SDoc
text String
"store" SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
val SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
dst
  where
    isVecPtrVar :: LlvmVar -> Bool
    isVecPtrVar :: LlvmVar -> Bool
isVecPtrVar = LlvmType -> Bool
isVector (LlvmType -> Bool) -> (LlvmVar -> LlvmType) -> LlvmVar -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmType -> LlvmType
pLower (LlvmType -> LlvmType)
-> (LlvmVar -> LlvmType) -> LlvmVar -> LlvmType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LlvmVar -> LlvmType
getVarType


ppCast :: LlvmOpts -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
ppCast :: LlvmOpts -> LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
ppCast LlvmOpts
opts LlvmCastOp
op LlvmVar
from LlvmType
to
    =   LlvmCastOp -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmCastOp
op
    SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmVar -> LlvmType
getVarType LlvmVar
from) SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppName LlvmOpts
opts LlvmVar
from
    SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"to"
    SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
to


ppMalloc :: LlvmOpts -> LlvmType -> Int -> SDoc
ppMalloc :: LlvmOpts -> LlvmType -> Int -> SDoc
ppMalloc LlvmOpts
opts LlvmType
tp Int
amount =
  let amount' :: LlvmVar
amount' = LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ Integer -> LlvmType -> LlvmLit
LMIntLit (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
amount) LlvmType
i32
  in String -> SDoc
text String
"malloc" SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
tp SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
amount'


ppAlloca :: LlvmOpts -> LlvmType -> Int -> SDoc
ppAlloca :: LlvmOpts -> LlvmType -> Int -> SDoc
ppAlloca LlvmOpts
opts LlvmType
tp Int
amount =
  let amount' :: LlvmVar
amount' = LlvmLit -> LlvmVar
LMLitVar (LlvmLit -> LlvmVar) -> LlvmLit -> LlvmVar
forall a b. (a -> b) -> a -> b
$ Integer -> LlvmType -> LlvmLit
LMIntLit (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
amount) LlvmType
i32
  in String -> SDoc
text String
"alloca" SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
tp SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
amount'


ppGetElementPtr :: LlvmOpts -> Bool -> LlvmVar -> [LlvmVar] -> SDoc
ppGetElementPtr :: LlvmOpts -> Bool -> LlvmVar -> [LlvmVar] -> SDoc
ppGetElementPtr LlvmOpts
opts Bool
inb LlvmVar
ptr [LlvmVar]
idx =
  let indexes :: SDoc
indexes = SDoc
comma SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin ((LlvmVar -> SDoc) -> [LlvmVar] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts) [LlvmVar]
idx)
      inbound :: SDoc
inbound = if Bool
inb then String -> SDoc
text String
"inbounds" else SDoc
empty
      derefType :: LlvmType
derefType = LlvmType -> LlvmType
pLower (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
ptr
  in String -> SDoc
text String
"getelementptr" SDoc -> SDoc -> SDoc
<+> SDoc
inbound SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
derefType SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
ptr
                            SDoc -> SDoc -> SDoc
<> SDoc
indexes


ppReturn :: LlvmOpts -> Maybe LlvmVar -> SDoc
ppReturn :: LlvmOpts -> Maybe LlvmVar -> SDoc
ppReturn LlvmOpts
opts (Just LlvmVar
var) = String -> SDoc
text String
"ret" SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
var
ppReturn LlvmOpts
_    Maybe LlvmVar
Nothing    = String -> SDoc
text String
"ret" SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
LMVoid


ppBranch :: LlvmOpts -> LlvmVar -> SDoc
ppBranch :: LlvmOpts -> LlvmVar -> SDoc
ppBranch LlvmOpts
opts LlvmVar
var = String -> SDoc
text String
"br" SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
var


ppBranchIf :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppBranchIf :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppBranchIf LlvmOpts
opts LlvmVar
cond LlvmVar
trueT LlvmVar
falseT
  = String -> SDoc
text String
"br" SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
cond SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
trueT SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
falseT


ppPhi :: LlvmOpts -> LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
ppPhi :: LlvmOpts -> LlvmType -> [(LlvmVar, LlvmVar)] -> SDoc
ppPhi LlvmOpts
opts LlvmType
tp [(LlvmVar, LlvmVar)]
preds =
  let ppPreds :: (LlvmVar, LlvmVar) -> SDoc
ppPreds (LlvmVar
val, LlvmVar
label) = SDoc -> SDoc
brackets (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ LlvmOpts -> LlvmVar -> SDoc
ppName LlvmOpts
opts LlvmVar
val SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppName LlvmOpts
opts LlvmVar
label
  in String -> SDoc
text String
"phi" SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
tp SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
hsep (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ((LlvmVar, LlvmVar) -> SDoc) -> [(LlvmVar, LlvmVar)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (LlvmVar, LlvmVar) -> SDoc
ppPreds [(LlvmVar, LlvmVar)]
preds)


ppSwitch :: LlvmOpts -> LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
ppSwitch :: LlvmOpts -> LlvmVar -> LlvmVar -> [(LlvmVar, LlvmVar)] -> SDoc
ppSwitch LlvmOpts
opts LlvmVar
scrut LlvmVar
dflt [(LlvmVar, LlvmVar)]
targets =
  let ppTarget :: (LlvmVar, LlvmVar) -> SDoc
ppTarget  (LlvmVar
val, LlvmVar
lab) = LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
val SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
lab
      ppTargets :: [(LlvmVar, LlvmVar)] -> SDoc
ppTargets  [(LlvmVar, LlvmVar)]
xs        = SDoc -> SDoc
brackets (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat (((LlvmVar, LlvmVar) -> SDoc) -> [(LlvmVar, LlvmVar)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (LlvmVar, LlvmVar) -> SDoc
ppTarget [(LlvmVar, LlvmVar)]
xs)
  in String -> SDoc
text String
"switch" SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
scrut SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
dflt
        SDoc -> SDoc -> SDoc
<+> [(LlvmVar, LlvmVar)] -> SDoc
ppTargets [(LlvmVar, LlvmVar)]
targets


ppAsm :: LlvmOpts -> LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
ppAsm :: LlvmOpts
-> LMString
-> LMString
-> LlvmType
-> [LlvmVar]
-> Bool
-> Bool
-> SDoc
ppAsm LlvmOpts
opts LMString
asm LMString
constraints LlvmType
rty [LlvmVar]
vars Bool
sideeffect Bool
alignstack =
  let asm' :: SDoc
asm'  = SDoc -> SDoc
doubleQuotes (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ LMString -> SDoc
ftext LMString
asm
      cons :: SDoc
cons  = SDoc -> SDoc
doubleQuotes (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ LMString -> SDoc
ftext LMString
constraints
      rty' :: SDoc
rty'  = LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
rty
      vars' :: SDoc
vars' = SDoc
lparen SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin ((LlvmVar -> SDoc) -> [LlvmVar] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts) [LlvmVar]
vars) SDoc -> SDoc -> SDoc
<+> SDoc
rparen
      side :: SDoc
side  = if Bool
sideeffect then String -> SDoc
text String
"sideeffect" else SDoc
empty
      align :: SDoc
align = if Bool
alignstack then String -> SDoc
text String
"alignstack" else SDoc
empty
  in String -> SDoc
text String
"call" SDoc -> SDoc -> SDoc
<+> SDoc
rty' SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"asm" SDoc -> SDoc -> SDoc
<+> SDoc
side SDoc -> SDoc -> SDoc
<+> SDoc
align SDoc -> SDoc -> SDoc
<+> SDoc
asm' SDoc -> SDoc -> SDoc
<> SDoc
comma
        SDoc -> SDoc -> SDoc
<+> SDoc
cons SDoc -> SDoc -> SDoc
<> SDoc
vars'

ppExtract :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc
ppExtract :: LlvmOpts -> LlvmVar -> LlvmVar -> SDoc
ppExtract LlvmOpts
opts LlvmVar
vec LlvmVar
idx =
    String -> SDoc
text String
"extractelement"
    SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmVar -> LlvmType
getVarType LlvmVar
vec) SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppName LlvmOpts
opts LlvmVar
vec SDoc -> SDoc -> SDoc
<> SDoc
comma
    SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
idx

ppExtractV :: LlvmOpts -> LlvmVar -> Int -> SDoc
ppExtractV :: LlvmOpts -> LlvmVar -> Int -> SDoc
ppExtractV LlvmOpts
opts LlvmVar
struct Int
idx =
    String -> SDoc
text String
"extractvalue"
    SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmVar -> LlvmType
getVarType LlvmVar
struct) SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppName LlvmOpts
opts LlvmVar
struct SDoc -> SDoc -> SDoc
<> SDoc
comma
    SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
idx

ppInsert :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppInsert :: LlvmOpts -> LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppInsert LlvmOpts
opts LlvmVar
vec LlvmVar
elt LlvmVar
idx =
    String -> SDoc
text String
"insertelement"
    SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmVar -> LlvmType
getVarType LlvmVar
vec) SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppName LlvmOpts
opts LlvmVar
vec SDoc -> SDoc -> SDoc
<> SDoc
comma
    SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmVar -> LlvmType
getVarType LlvmVar
elt) SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppName LlvmOpts
opts LlvmVar
elt SDoc -> SDoc -> SDoc
<> SDoc
comma
    SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
idx


ppMetaStatement :: LlvmOpts -> [MetaAnnot] -> LlvmStatement -> SDoc
ppMetaStatement :: LlvmOpts -> [MetaAnnot] -> LlvmStatement -> SDoc
ppMetaStatement LlvmOpts
opts [MetaAnnot]
meta LlvmStatement
stmt =
   LlvmOpts -> LlvmStatement -> SDoc
ppLlvmStatement LlvmOpts
opts LlvmStatement
stmt SDoc -> SDoc -> SDoc
<> LlvmOpts -> [MetaAnnot] -> SDoc
ppMetaAnnots LlvmOpts
opts [MetaAnnot]
meta

ppMetaAnnotExpr :: LlvmOpts -> [MetaAnnot] -> LlvmExpression -> SDoc
ppMetaAnnotExpr :: LlvmOpts -> [MetaAnnot] -> LlvmExpression -> SDoc
ppMetaAnnotExpr LlvmOpts
opts [MetaAnnot]
meta LlvmExpression
expr =
   LlvmOpts -> LlvmExpression -> SDoc
ppLlvmExpression LlvmOpts
opts LlvmExpression
expr SDoc -> SDoc -> SDoc
<> LlvmOpts -> [MetaAnnot] -> SDoc
ppMetaAnnots LlvmOpts
opts [MetaAnnot]
meta

ppMetaAnnots :: LlvmOpts -> [MetaAnnot] -> SDoc
ppMetaAnnots :: LlvmOpts -> [MetaAnnot] -> SDoc
ppMetaAnnots LlvmOpts
opts [MetaAnnot]
meta = [SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (MetaAnnot -> SDoc) -> [MetaAnnot] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map MetaAnnot -> SDoc
ppMeta [MetaAnnot]
meta
  where
    ppMeta :: MetaAnnot -> SDoc
ppMeta (MetaAnnot LMString
name MetaExpr
e)
        = SDoc
comma SDoc -> SDoc -> SDoc
<+> SDoc
exclamation SDoc -> SDoc -> SDoc
<> LMString -> SDoc
ftext LMString
name SDoc -> SDoc -> SDoc
<+>
          case MetaExpr
e of
            MetaNode MetaId
n    -> MetaId -> SDoc
forall a. Outputable a => a -> SDoc
ppr MetaId
n
            MetaStruct [MetaExpr]
ms -> SDoc
exclamation SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces ([SDoc] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin ((MetaExpr -> SDoc) -> [MetaExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (LlvmOpts -> MetaExpr -> SDoc
ppMetaExpr LlvmOpts
opts) [MetaExpr]
ms))
            MetaExpr
other         -> SDoc
exclamation SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces (LlvmOpts -> MetaExpr -> SDoc
ppMetaExpr LlvmOpts
opts MetaExpr
other) -- possible?

-- | Return the variable name or value of the 'LlvmVar'
-- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).
ppName :: LlvmOpts -> LlvmVar -> SDoc
ppName :: LlvmOpts -> LlvmVar -> SDoc
ppName LlvmOpts
opts LlvmVar
v = case LlvmVar
v of
   LMGlobalVar {} -> Char -> SDoc
char Char
'@' SDoc -> SDoc -> SDoc
<> LlvmOpts -> LlvmVar -> SDoc
ppPlainName LlvmOpts
opts LlvmVar
v
   LMLocalVar  {} -> Char -> SDoc
char Char
'%' SDoc -> SDoc -> SDoc
<> LlvmOpts -> LlvmVar -> SDoc
ppPlainName LlvmOpts
opts LlvmVar
v
   LMNLocalVar {} -> Char -> SDoc
char Char
'%' SDoc -> SDoc -> SDoc
<> LlvmOpts -> LlvmVar -> SDoc
ppPlainName LlvmOpts
opts LlvmVar
v
   LMLitVar    {} ->             LlvmOpts -> LlvmVar -> SDoc
ppPlainName LlvmOpts
opts LlvmVar
v

-- | Return the variable name or value of the 'LlvmVar'
-- in a plain textual representation (e.g. @x@, @y@ or @42@).
ppPlainName :: LlvmOpts -> LlvmVar -> SDoc
ppPlainName :: LlvmOpts -> LlvmVar -> SDoc
ppPlainName LlvmOpts
opts LlvmVar
v = case LlvmVar
v of
   (LMGlobalVar LMString
x LlvmType
_ LlvmLinkageType
_ LMSection
_ LMAlign
_ LMConst
_) -> LMString -> SDoc
ftext LMString
x
   (LMLocalVar  Unique
x LlvmType
LMLabel  ) -> String -> SDoc
text (Unique -> String
forall a. Show a => a -> String
show Unique
x)
   (LMLocalVar  Unique
x LlvmType
_        ) -> String -> SDoc
text (Char
'l' Char -> String -> String
forall a. a -> [a] -> [a]
: Unique -> String
forall a. Show a => a -> String
show Unique
x)
   (LMNLocalVar LMString
x LlvmType
_        ) -> LMString -> SDoc
ftext LMString
x
   (LMLitVar    LlvmLit
x          ) -> LlvmOpts -> LlvmLit -> SDoc
ppLit LlvmOpts
opts LlvmLit
x

-- | Print a literal value. No type.
ppLit :: LlvmOpts -> LlvmLit -> SDoc
ppLit :: LlvmOpts -> LlvmLit -> SDoc
ppLit LlvmOpts
opts LlvmLit
l = case LlvmLit
l of
   (LMIntLit Integer
i (LMInt Int
32))  -> Int32 -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Integer -> Int32
forall a. Num a => Integer -> a
fromInteger Integer
i :: Int32)
   (LMIntLit Integer
i (LMInt Int
64))  -> Int64 -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Integer -> Int64
forall a. Num a => Integer -> a
fromInteger Integer
i :: Int64)
   (LMIntLit   Integer
i LlvmType
_       )  -> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i)::Int)
   (LMFloatLit Double
r LlvmType
LMFloat )  -> Platform -> Float -> SDoc
ppFloat (LlvmOpts -> Platform
llvmOptsPlatform LlvmOpts
opts) (Float -> SDoc) -> Float -> SDoc
forall a b. (a -> b) -> a -> b
$ Double -> Float
narrowFp Double
r
   (LMFloatLit Double
r LlvmType
LMDouble)  -> Platform -> Double -> SDoc
ppDouble (LlvmOpts -> Platform
llvmOptsPlatform LlvmOpts
opts) Double
r
   f :: LlvmLit
f@(LMFloatLit Double
_ LlvmType
_)       -> String -> SDoc -> SDoc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"ppLit" (String -> SDoc
text String
"Can't print this float literal: " SDoc -> SDoc -> SDoc
<> LlvmOpts -> LlvmLit -> SDoc
ppTypeLit LlvmOpts
opts LlvmLit
f)
   (LMVectorLit [LlvmLit]
ls  )       -> Char -> SDoc
char Char
'<' SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin ((LlvmLit -> SDoc) -> [LlvmLit] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (LlvmOpts -> LlvmLit -> SDoc
ppTypeLit LlvmOpts
opts) [LlvmLit]
ls) SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'>'
   (LMNullLit LlvmType
_     )       -> String -> SDoc
text String
"null"
   -- #11487 was an issue where we passed undef for some arguments
   -- that were actually live. By chance the registers holding those
   -- arguments usually happened to have the right values anyways, but
   -- that was not guaranteed. To find such bugs reliably, we set the
   -- flag below when validating, which replaces undef literals (at
   -- common types) with values that are likely to cause a crash or test
   -- failure.
   (LMUndefLit LlvmType
t    )
      | LlvmOpts -> Bool
llvmOptsFillUndefWithGarbage LlvmOpts
opts
      , Just LlvmLit
lit <- LlvmType -> Maybe LlvmLit
garbageLit LlvmType
t   -> LlvmOpts -> LlvmLit -> SDoc
ppLit LlvmOpts
opts LlvmLit
lit
      | Bool
otherwise                  -> String -> SDoc
text String
"undef"

ppVar :: LlvmOpts -> LlvmVar -> SDoc
ppVar :: LlvmOpts -> LlvmVar -> SDoc
ppVar = [LlvmParamAttr] -> LlvmOpts -> LlvmVar -> SDoc
ppVar' []

ppVar' :: [LlvmParamAttr] -> LlvmOpts -> LlvmVar -> SDoc
ppVar' :: [LlvmParamAttr] -> LlvmOpts -> LlvmVar -> SDoc
ppVar' [LlvmParamAttr]
attrs LlvmOpts
opts LlvmVar
v = case LlvmVar
v of
  LMLitVar LlvmLit
x -> [LlvmParamAttr] -> LlvmOpts -> LlvmLit -> SDoc
ppTypeLit' [LlvmParamAttr]
attrs LlvmOpts
opts LlvmLit
x
  LlvmVar
x          -> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmVar -> LlvmType
getVarType LlvmVar
x) SDoc -> SDoc -> SDoc
<+> [LlvmParamAttr] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppSpaceJoin [LlvmParamAttr]
attrs SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmVar -> SDoc
ppName LlvmOpts
opts LlvmVar
x

ppTypeLit :: LlvmOpts -> LlvmLit -> SDoc
ppTypeLit :: LlvmOpts -> LlvmLit -> SDoc
ppTypeLit = [LlvmParamAttr] -> LlvmOpts -> LlvmLit -> SDoc
ppTypeLit' []

ppTypeLit' :: [LlvmParamAttr] -> LlvmOpts -> LlvmLit -> SDoc
ppTypeLit' :: [LlvmParamAttr] -> LlvmOpts -> LlvmLit -> SDoc
ppTypeLit' [LlvmParamAttr]
attrs LlvmOpts
opts LlvmLit
l = case LlvmLit
l of
  LMVectorLit {} -> LlvmOpts -> LlvmLit -> SDoc
ppLit LlvmOpts
opts LlvmLit
l
  LlvmLit
_              -> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmLit -> LlvmType
getLitType LlvmLit
l) SDoc -> SDoc -> SDoc
<+> [LlvmParamAttr] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppSpaceJoin [LlvmParamAttr]
attrs SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmLit -> SDoc
ppLit LlvmOpts
opts LlvmLit
l

ppStatic :: LlvmOpts -> LlvmStatic -> SDoc
ppStatic :: LlvmOpts -> LlvmStatic -> SDoc
ppStatic LlvmOpts
opts LlvmStatic
st = case LlvmStatic
st of
  LMComment       LMString
s -> String -> SDoc
text String
"; " SDoc -> SDoc -> SDoc
<> LMString -> SDoc
ftext LMString
s
  LMStaticLit   LlvmLit
l   -> LlvmOpts -> LlvmLit -> SDoc
ppTypeLit LlvmOpts
opts LlvmLit
l
  LMUninitType    LlvmType
t -> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" undef"
  LMStaticStr   LMString
s LlvmType
t -> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" c\"" SDoc -> SDoc -> SDoc
<> LMString -> SDoc
ftext LMString
s SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"\\00\""
  LMStaticArray [LlvmStatic]
d LlvmType
t -> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" [" SDoc -> SDoc -> SDoc
<> [SDoc] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin ((LlvmStatic -> SDoc) -> [LlvmStatic] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (LlvmOpts -> LlvmStatic -> SDoc
ppStatic LlvmOpts
opts) [LlvmStatic]
d) SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
']'
  LMStaticStruc [LlvmStatic]
d LlvmType
t -> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"<{" SDoc -> SDoc -> SDoc
<> [SDoc] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin ((LlvmStatic -> SDoc) -> [LlvmStatic] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (LlvmOpts -> LlvmStatic -> SDoc
ppStatic LlvmOpts
opts) [LlvmStatic]
d) SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"}>"
  LMStaticPointer LlvmVar
v -> LlvmOpts -> LlvmVar -> SDoc
ppVar LlvmOpts
opts LlvmVar
v
  LMTrunc LlvmStatic
v LlvmType
t       -> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" trunc (" SDoc -> SDoc -> SDoc
<> LlvmOpts -> LlvmStatic -> SDoc
ppStatic LlvmOpts
opts LlvmStatic
v SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" to " SDoc -> SDoc -> SDoc
<> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
')'
  LMBitc LlvmStatic
v LlvmType
t        -> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" bitcast (" SDoc -> SDoc -> SDoc
<> LlvmOpts -> LlvmStatic -> SDoc
ppStatic LlvmOpts
opts LlvmStatic
v SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" to " SDoc -> SDoc -> SDoc
<> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
')'
  LMPtoI LlvmStatic
v LlvmType
t        -> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" ptrtoint (" SDoc -> SDoc -> SDoc
<> LlvmOpts -> LlvmStatic -> SDoc
ppStatic LlvmOpts
opts LlvmStatic
v SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" to " SDoc -> SDoc -> SDoc
<> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
')'
  LMAdd LlvmStatic
s1 LlvmStatic
s2       -> LlvmOpts
-> LlvmStatic
-> LlvmStatic
-> PtrString
-> PtrString
-> String
-> SDoc
pprStaticArith LlvmOpts
opts LlvmStatic
s1 LlvmStatic
s2 (String -> PtrString
sLit String
"add") (String -> PtrString
sLit String
"fadd") String
"LMAdd"
  LMSub LlvmStatic
s1 LlvmStatic
s2       -> LlvmOpts
-> LlvmStatic
-> LlvmStatic
-> PtrString
-> PtrString
-> String
-> SDoc
pprStaticArith LlvmOpts
opts LlvmStatic
s1 LlvmStatic
s2 (String -> PtrString
sLit String
"sub") (String -> PtrString
sLit String
"fsub") String
"LMSub"


pprSpecialStatic :: LlvmOpts -> LlvmStatic -> SDoc
pprSpecialStatic :: LlvmOpts -> LlvmStatic -> SDoc
pprSpecialStatic LlvmOpts
opts LlvmStatic
stat = case LlvmStatic
stat of
   LMBitc LlvmStatic
v LlvmType
t        -> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> LlvmType
pLower LlvmType
t)
                        SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
", bitcast ("
                        SDoc -> SDoc -> SDoc
<> LlvmOpts -> LlvmStatic -> SDoc
ppStatic LlvmOpts
opts LlvmStatic
v SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" to " SDoc -> SDoc -> SDoc
<> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
t
                        SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
')'
   LMStaticPointer LlvmVar
x -> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmType -> LlvmType
pLower (LlvmType -> LlvmType) -> LlvmType -> LlvmType
forall a b. (a -> b) -> a -> b
$ LlvmVar -> LlvmType
getVarType LlvmVar
x)
                        SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmOpts -> LlvmStatic -> SDoc
ppStatic LlvmOpts
opts LlvmStatic
stat
   LlvmStatic
_                 -> LlvmOpts -> LlvmStatic -> SDoc
ppStatic LlvmOpts
opts LlvmStatic
stat


pprStaticArith :: LlvmOpts -> LlvmStatic -> LlvmStatic -> PtrString -> PtrString
                  -> String -> SDoc
pprStaticArith :: LlvmOpts
-> LlvmStatic
-> LlvmStatic
-> PtrString
-> PtrString
-> String
-> SDoc
pprStaticArith LlvmOpts
opts LlvmStatic
s1 LlvmStatic
s2 PtrString
int_op PtrString
float_op String
op_name =
  let ty1 :: LlvmType
ty1 = LlvmStatic -> LlvmType
getStatType LlvmStatic
s1
      op :: PtrString
op  = if LlvmType -> Bool
isFloat LlvmType
ty1 then PtrString
float_op else PtrString
int_op
  in if LlvmType
ty1 LlvmType -> LlvmType -> Bool
forall a. Eq a => a -> a -> Bool
== LlvmStatic -> LlvmType
getStatType LlvmStatic
s2
     then LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
ty1 SDoc -> SDoc -> SDoc
<+> PtrString -> SDoc
ptext PtrString
op SDoc -> SDoc -> SDoc
<+> SDoc
lparen SDoc -> SDoc -> SDoc
<> LlvmOpts -> LlvmStatic -> SDoc
ppStatic LlvmOpts
opts LlvmStatic
s1 SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<> LlvmOpts -> LlvmStatic -> SDoc
ppStatic LlvmOpts
opts LlvmStatic
s2 SDoc -> SDoc -> SDoc
<> SDoc
rparen
     else String -> SDoc -> SDoc
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"pprStaticArith" (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
            String -> SDoc
text String
op_name SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" with different types! s1: " SDoc -> SDoc -> SDoc
<> LlvmOpts -> LlvmStatic -> SDoc
ppStatic LlvmOpts
opts LlvmStatic
s1
                         SDoc -> SDoc -> SDoc
<> String -> SDoc
textString
", s2: " SDoc -> SDoc -> SDoc
<> LlvmOpts -> LlvmStatic -> SDoc
ppStatic LlvmOpts
opts LlvmStatic
s2


--------------------------------------------------------------------------------
-- * Misc functions
--------------------------------------------------------------------------------

-- | Blank line.
newLine :: SDoc
newLine :: SDoc
newLine = SDoc
empty

-- | Exclamation point.
exclamation :: SDoc
exclamation :: SDoc
exclamation = Char -> SDoc
char Char
'!'