{-# LANGUAGE CPP #-}

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

module Llvm.PpLlvm (

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

    ) where

#include "HsVersions.h"

import GhcPrelude

import Llvm.AbsSyn
import Llvm.MetaData
import Llvm.Types

import Data.List ( intersperse )
import Outputable
import Unique
import FastString ( sLit )

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

-- | Print out a whole LLVM module.
ppLlvmModule :: LlvmModule -> SDoc
ppLlvmModule :: LlvmModule -> SDoc
ppLlvmModule (LlvmModule comments :: [LMString]
comments aliases :: [LlvmAlias]
aliases meta :: [MetaDecl]
meta globals :: [LMGlobal]
globals decls :: LlvmFunctionDecls
decls funcs :: 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
$+$ [MetaDecl] -> SDoc
ppLlvmMetas [MetaDecl]
meta SDoc -> SDoc -> SDoc
$+$ SDoc
newLine
    SDoc -> SDoc -> SDoc
$+$ [LMGlobal] -> SDoc
ppLlvmGlobals [LMGlobal]
globals SDoc -> SDoc -> SDoc
$+$ SDoc
newLine
    SDoc -> SDoc -> SDoc
$+$ LlvmFunctionDecls -> SDoc
ppLlvmFunctionDecls LlvmFunctionDecls
decls SDoc -> SDoc -> SDoc
$+$ SDoc
newLine
    SDoc -> SDoc -> SDoc
$+$ LlvmFunctions -> SDoc
ppLlvmFunctions LlvmFunctions
funcs

-- | Print out a multi-line comment, can be inside a function or on its own
ppLlvmComments :: [LMString] -> SDoc
ppLlvmComments :: [LMString] -> SDoc
ppLlvmComments comments :: [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 com :: LMString
com = SDoc
semi SDoc -> SDoc -> SDoc
<+> LMString -> SDoc
ftext LMString
com


-- | Print out a list of global mutable variable definitions
ppLlvmGlobals :: [LMGlobal] -> SDoc
ppLlvmGlobals :: [LMGlobal] -> SDoc
ppLlvmGlobals ls :: [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 LMGlobal -> SDoc
ppLlvmGlobal [LMGlobal]
ls

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

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

        rhs :: SDoc
rhs = case Maybe LlvmStatic
dat of
            Just stat :: LlvmStatic
stat -> LlvmStatic -> SDoc
pprSpecialStatic LlvmStatic
stat
            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
          Global   -> "global"
          Constant -> "constant"
          Alias    -> "alias"

    in LlvmVar -> SDoc -> SDoc
ppAssignment 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 (LMGlobal var :: LlvmVar
var val :: Maybe LlvmStatic
val) = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
  String -> SDoc
forall a. HasCallStack => String -> a
error (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ "Non Global var ppr as global! "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
var) String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (Maybe LlvmStatic -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe LlvmStatic
val)


-- | Print out a list of LLVM type aliases.
ppLlvmAliases :: [LlvmAlias] -> SDoc
ppLlvmAliases :: [LlvmAlias] -> SDoc
ppLlvmAliases tys :: [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 (name :: LMString
name, ty :: LlvmType
ty)
  = Char -> SDoc
char '%' SDoc -> SDoc -> SDoc
<> LMString -> SDoc
ftext LMString
name SDoc -> SDoc -> SDoc
<+> SDoc
equals SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "type" SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
ty


-- | Print out a list of LLVM metadata.
ppLlvmMetas :: [MetaDecl] -> SDoc
ppLlvmMetas :: [MetaDecl] -> SDoc
ppLlvmMetas metas :: [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 MetaDecl -> SDoc
ppLlvmMeta [MetaDecl]
metas

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

ppLlvmMeta (MetaNamed n :: LMString
n m :: [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 :: LlvmFunctions -> SDoc
ppLlvmFunctions :: LlvmFunctions -> SDoc
ppLlvmFunctions funcs :: 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 LlvmFunction -> SDoc
ppLlvmFunction LlvmFunctions
funcs

-- | Print out a function definition.
ppLlvmFunction :: LlvmFunction -> SDoc
ppLlvmFunction :: LlvmFunction -> SDoc
ppLlvmFunction fun :: 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 s' :: LMString
s' -> String -> SDoc
text "section" SDoc -> SDoc -> SDoc
<+> (SDoc -> SDoc
doubleQuotes (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ LMString -> SDoc
ftext LMString
s')
                      Nothing -> SDoc
empty
        prefixDoc :: SDoc
prefixDoc = case LlvmFunction -> Maybe LlvmStatic
funcPrefix LlvmFunction
fun of
                        Just v :: LlvmStatic
v  -> String -> SDoc
text "prefix" SDoc -> SDoc -> SDoc
<+> LlvmStatic -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmStatic
v
                        Nothing -> SDoc
empty
    in String -> SDoc
text "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
$+$ LlvmBlocks -> SDoc
ppLlvmBlocks (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 n :: LMString
n l :: LlvmLinkageType
l c :: LlvmCallConvention
c r :: LlvmType
r varg :: LlvmParameterListType
varg p :: [LlvmParameter]
p a :: LMAlign
a) args :: [LMString]
args
  = let varg' :: PtrString
varg' = case LlvmParameterListType
varg of
                      VarArgs | [LlvmParameter] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LlvmParameter]
p    -> String -> PtrString
sLit "..."
                              | Bool
otherwise -> String -> PtrString
sLit ", ..."
                      _otherwise :: LlvmParameterListType
_otherwise          -> String -> PtrString
sLit ""
        align :: SDoc
align = case LMAlign
a of
                     Just a' :: Int
a' -> String -> SDoc
text " align " SDoc -> SDoc -> SDoc
<> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
a'
                     Nothing -> SDoc
empty
        args' :: [SDoc]
args' = ((LlvmParameter, LMString) -> SDoc)
-> [(LlvmParameter, LMString)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\((ty :: LlvmType
ty,p :: [LlvmParamAttr]
p),n :: 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 '%'
                                    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 '@' 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 decs :: 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 n :: LMString
n l :: LlvmLinkageType
l c :: LlvmCallConvention
c r :: LlvmType
r varg :: LlvmParameterListType
varg p :: [LlvmParameter]
p a :: LMAlign
a)
  = let varg' :: PtrString
varg' = case LlvmParameterListType
varg of
                      VarArgs | [LlvmParameter] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LlvmParameter]
p    -> String -> PtrString
sLit "..."
                              | Bool
otherwise -> String -> PtrString
sLit ", ..."
                      _otherwise :: LlvmParameterListType
_otherwise          -> String -> PtrString
sLit ""
        align :: SDoc
align = case LMAlign
a of
                     Just a' :: Int
a' -> String -> SDoc
text " align" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
a'
                     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 (\(t :: LlvmType
t,a :: [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 "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 '@' 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 :: LlvmBlocks -> SDoc
ppLlvmBlocks :: LlvmBlocks -> SDoc
ppLlvmBlocks blocks :: 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 LlvmBlock -> SDoc
ppLlvmBlock LlvmBlocks
blocks

-- | Print out an LLVM block.
-- It must be part of a function definition.
ppLlvmBlock :: LlvmBlock -> SDoc
ppLlvmBlock :: LlvmBlock -> SDoc
ppLlvmBlock (LlvmBlock blockId :: LlvmBlockId
blockId stmts :: [LlvmStatement]
stmts) =
  let isLabel :: LlvmStatement -> Bool
isLabel (MkLabel _) = Bool
True
      isLabel _           = Bool
False
      (block :: [LlvmStatement]
block, rest :: [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 id :: LlvmBlockId
id:xs :: [LlvmStatement]
xs -> LlvmBlock -> SDoc
ppLlvmBlock (LlvmBlockId -> [LlvmStatement] -> LlvmBlock
LlvmBlock LlvmBlockId
id [LlvmStatement]
xs)
        _             -> SDoc
empty
  in LlvmBlockId -> SDoc
ppLlvmBlockLabel LlvmBlockId
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 LlvmStatement -> SDoc
ppLlvmStatement [LlvmStatement]
block)
           SDoc -> SDoc -> SDoc
$+$ SDoc
newLine
           SDoc -> SDoc -> SDoc
$+$ SDoc
ppRest

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


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


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


--------------------------------------------------------------------------------
-- * 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 :: LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
ppCall :: LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
ppCall ct :: LlvmCallType
ct fptr :: LlvmVar
fptr args :: [MetaExpr]
args attrs :: [LlvmFuncAttr]
attrs = case LlvmVar
fptr of
                           --
    -- if local var function pointer, unwrap
    LMLocalVar _ (LMPointer (LMFunction d :: LlvmFunctionDecl
d)) -> LlvmFunctionDecl -> SDoc
ppCall' LlvmFunctionDecl
d

    -- should be function type otherwise
    LMGlobalVar _ (LMFunction d :: LlvmFunctionDecl
d) _ _ _ _    -> LlvmFunctionDecl -> SDoc
ppCall' LlvmFunctionDecl
d

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

    where
        ppCall' :: LlvmFunctionDecl -> SDoc
ppCall' (LlvmFunctionDecl _ _ cc :: LlvmCallConvention
cc ret :: LlvmType
ret argTy :: LlvmParameterListType
argTy params :: [LlvmParameter]
params _) =
            let tc :: SDoc
tc = if LlvmCallType
ct LlvmCallType -> LlvmCallType -> Bool
forall a. Eq a => a -> a -> Bool
== LlvmCallType
TailCall then String -> SDoc
text "tail " else SDoc
empty
                ppValues :: SDoc
ppValues = [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
$ (MetaExpr -> SDoc) -> [MetaExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map MetaExpr -> SDoc
ppCallMetaExpr [MetaExpr]
args
                ppArgTy :: SDoc
ppArgTy  = ([LlvmType] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin ([LlvmType] -> SDoc) -> [LlvmType] -> SDoc
forall a b. (a -> b) -> a -> b
$ (LlvmParameter -> LlvmType) -> [LlvmParameter] -> [LlvmType]
forall a b. (a -> b) -> [a] -> [b]
map LlvmParameter -> LlvmType
forall a b. (a, b) -> a
fst [LlvmParameter]
params) SDoc -> SDoc -> SDoc
<>
                           (case LlvmParameterListType
argTy of
                               VarArgs   -> String -> SDoc
text ", ..."
                               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 "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
<+> LlvmVar -> SDoc
ppName LlvmVar
fptr SDoc -> SDoc -> SDoc
<> SDoc
lparen SDoc -> SDoc -> SDoc
<+> SDoc
ppValues
                    SDoc -> SDoc -> SDoc
<+> SDoc
rparen SDoc -> SDoc -> SDoc
<+> SDoc
attrDoc

        -- Metadata needs to be marked as having the `metadata` type when used
        -- in a call argument
        ppCallMetaExpr :: MetaExpr -> SDoc
ppCallMetaExpr (MetaVar v :: LlvmVar
v) = LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
v
        ppCallMetaExpr v :: MetaExpr
v           = String -> SDoc
text "metadata" SDoc -> SDoc -> SDoc
<+> MetaExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr MetaExpr
v

ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
ppMachOp op :: LlvmMachOp
op left :: LlvmVar
left right :: 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
<+> LlvmVar -> SDoc
ppName LlvmVar
left
        SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
ppName LlvmVar
right


ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
ppCmpOp op :: LlvmCmpOp
op left :: LlvmVar
left right :: 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 "icmp"
        | LlvmType -> Bool
isFloat (LlvmVar -> LlvmType
getVarType LlvmVar
left) Bool -> Bool -> Bool
&& LlvmType -> Bool
isFloat (LlvmVar -> LlvmType
getVarType LlvmVar
right) = String -> SDoc
text "fcmp"
        | Bool
otherwise = String -> SDoc
text "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
<+> LlvmVar -> SDoc
ppName LlvmVar
left SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
ppName LlvmVar
right


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

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

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

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

ppAtomicRMW :: LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
ppAtomicRMW :: LlvmAtomicOp -> LlvmVar -> LlvmVar -> LlvmSyncOrdering -> SDoc
ppAtomicRMW aop :: LlvmAtomicOp
aop tgt :: LlvmVar
tgt src :: LlvmVar
src ordering :: LlvmSyncOrdering
ordering =
  String -> SDoc
text "atomicrmw" SDoc -> SDoc -> SDoc
<+> LlvmAtomicOp -> SDoc
ppAtomicOp LlvmAtomicOp
aop SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
tgt SDoc -> SDoc -> SDoc
<> SDoc
comma
  SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
src SDoc -> SDoc -> SDoc
<+> LlvmSyncOrdering -> SDoc
ppSyncOrdering LlvmSyncOrdering
ordering

ppCmpXChg :: LlvmVar -> LlvmVar -> LlvmVar
          -> LlvmSyncOrdering -> LlvmSyncOrdering -> SDoc
ppCmpXChg :: LlvmVar
-> LlvmVar
-> LlvmVar
-> LlvmSyncOrdering
-> LlvmSyncOrdering
-> SDoc
ppCmpXChg addr :: LlvmVar
addr old :: LlvmVar
old new :: LlvmVar
new s_ord :: LlvmSyncOrdering
s_ord f_ord :: LlvmSyncOrdering
f_ord =
  String -> SDoc
text "cmpxchg" SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
addr SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
old SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr 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 :: LlvmVar -> SDoc
ppLoad :: LlvmVar -> SDoc
ppLoad var :: LlvmVar
var = String -> SDoc
text "load" SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
derefType SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr 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 ", align 1"
          | Bool
otherwise = SDoc
empty

ppALoad :: LlvmSyncOrdering -> SingleThreaded -> LlvmVar -> SDoc
ppALoad :: LlvmSyncOrdering -> Bool -> LlvmVar -> SDoc
ppALoad ord :: LlvmSyncOrdering
ord st :: Bool
st var :: LlvmVar
var = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \dflags :: DynFlags
dflags ->
  let alignment :: Int
alignment = (DynFlags -> LlvmType -> Int
llvmWidthInBits DynFlags
dflags (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` 8
      align :: SDoc
align     = String -> SDoc
text ", align" SDoc -> SDoc -> SDoc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
alignment
      sThreaded :: SDoc
sThreaded | Bool
st        = String -> SDoc
text " 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 "load atomic" SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
derefType SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
var SDoc -> SDoc -> SDoc
<> SDoc
sThreaded
            SDoc -> SDoc -> SDoc
<+> LlvmSyncOrdering -> SDoc
ppSyncOrdering LlvmSyncOrdering
ord SDoc -> SDoc -> SDoc
<> SDoc
align

ppStore :: LlvmVar -> LlvmVar -> SDoc
ppStore :: LlvmVar -> LlvmVar -> SDoc
ppStore val :: LlvmVar
val dst :: LlvmVar
dst
    | LlvmVar -> Bool
isVecPtrVar LlvmVar
dst = String -> SDoc
text "store" SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
val SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
dst SDoc -> SDoc -> SDoc
<>
                        SDoc
comma SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "align 1"
    | Bool
otherwise       = String -> SDoc
text "store" SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
val SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr 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 :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
ppCast op :: LlvmCastOp
op from :: LlvmVar
from to :: 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
<+> LlvmVar -> SDoc
ppName LlvmVar
from
    SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "to"
    SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
to


ppMalloc :: LlvmType -> Int -> SDoc
ppMalloc :: LlvmType -> Int -> SDoc
ppMalloc tp :: LlvmType
tp amount :: 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 "malloc" SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
tp SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
amount'


ppAlloca :: LlvmType -> Int -> SDoc
ppAlloca :: LlvmType -> Int -> SDoc
ppAlloca tp :: LlvmType
tp amount :: 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 "alloca" SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmType
tp SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
amount'


ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc
ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc
ppGetElementPtr inb :: Bool
inb ptr :: LlvmVar
ptr idx :: [LlvmVar]
idx =
  let indexes :: SDoc
indexes = SDoc
comma SDoc -> SDoc -> SDoc
<+> [LlvmVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin [LlvmVar]
idx
      inbound :: SDoc
inbound = if Bool
inb then String -> SDoc
text "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 "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
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
ptr
                            SDoc -> SDoc -> SDoc
<> SDoc
indexes


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


ppBranch :: LlvmVar -> SDoc
ppBranch :: LlvmVar -> SDoc
ppBranch var :: LlvmVar
var = String -> SDoc
text "br" SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
var


ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppBranchIf cond :: LlvmVar
cond trueT :: LlvmVar
trueT falseT :: LlvmVar
falseT
  = String -> SDoc
text "br" SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
cond SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
trueT SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
falseT


ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
ppPhi :: LlvmType -> [(LlvmVar, LlvmVar)] -> SDoc
ppPhi tp :: LlvmType
tp preds :: [(LlvmVar, LlvmVar)]
preds =
  let ppPreds :: (LlvmVar, LlvmVar) -> SDoc
ppPreds (val :: LlvmVar
val, label :: LlvmVar
label) = SDoc -> SDoc
brackets (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ LlvmVar -> SDoc
ppName LlvmVar
val SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
ppName LlvmVar
label
  in String -> SDoc
text "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 :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar, LlvmVar)] -> SDoc
ppSwitch scrut :: LlvmVar
scrut dflt :: LlvmVar
dflt targets :: [(LlvmVar, LlvmVar)]
targets =
  let ppTarget :: (a, a) -> SDoc
ppTarget  (val :: a
val, lab :: a
lab) = a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
val SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
lab
      ppTargets :: [(a, a)] -> SDoc
ppTargets  xs :: [(a, a)]
xs        = SDoc -> SDoc
brackets (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat (((a, a) -> SDoc) -> [(a, a)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (a, a) -> SDoc
forall a a. (Outputable a, Outputable a) => (a, a) -> SDoc
ppTarget [(a, a)]
xs)
  in String -> SDoc
text "switch" SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
scrut SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
dflt
        SDoc -> SDoc -> SDoc
<+> [(LlvmVar, LlvmVar)] -> SDoc
forall a a. (Outputable a, Outputable a) => [(a, a)] -> SDoc
ppTargets [(LlvmVar, LlvmVar)]
targets


ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
ppAsm :: LMString
-> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
ppAsm asm :: LMString
asm constraints :: LMString
constraints rty :: LlvmType
rty vars :: [LlvmVar]
vars sideeffect :: Bool
sideeffect alignstack :: 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
<+> [LlvmVar] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin [LlvmVar]
vars SDoc -> SDoc -> SDoc
<+> SDoc
rparen
      side :: SDoc
side  = if Bool
sideeffect then String -> SDoc
text "sideeffect" else SDoc
empty
      align :: SDoc
align = if Bool
alignstack then String -> SDoc
text "alignstack" else SDoc
empty
  in String -> SDoc
text "call" SDoc -> SDoc -> SDoc
<+> SDoc
rty' SDoc -> SDoc -> SDoc
<+> String -> SDoc
text "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 :: LlvmVar -> LlvmVar -> SDoc
ppExtract :: LlvmVar -> LlvmVar -> SDoc
ppExtract vec :: LlvmVar
vec idx :: LlvmVar
idx =
    String -> SDoc
text "extractelement"
    SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmVar -> LlvmType
getVarType LlvmVar
vec) SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
ppName LlvmVar
vec SDoc -> SDoc -> SDoc
<> SDoc
comma
    SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
idx

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

ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppInsert vec :: LlvmVar
vec elt :: LlvmVar
elt idx :: LlvmVar
idx =
    String -> SDoc
text "insertelement"
    SDoc -> SDoc -> SDoc
<+> LlvmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (LlvmVar -> LlvmType
getVarType LlvmVar
vec) SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
ppName 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
<+> LlvmVar -> SDoc
ppName LlvmVar
elt SDoc -> SDoc -> SDoc
<> SDoc
comma
    SDoc -> SDoc -> SDoc
<+> LlvmVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr LlvmVar
idx


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

ppMetaExpr :: [MetaAnnot] -> LlvmExpression -> SDoc
ppMetaExpr :: [MetaAnnot] -> LlvmExpression -> SDoc
ppMetaExpr meta :: [MetaAnnot]
meta expr :: LlvmExpression
expr = LlvmExpression -> SDoc
ppLlvmExpression LlvmExpression
expr SDoc -> SDoc -> SDoc
<> [MetaAnnot] -> SDoc
ppMetaAnnots [MetaAnnot]
meta

ppMetaAnnots :: [MetaAnnot] -> SDoc
ppMetaAnnots :: [MetaAnnot] -> SDoc
ppMetaAnnots meta :: [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 name :: LMString
name e :: 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 n :: MetaId
n    -> MetaId -> SDoc
forall a. Outputable a => a -> SDoc
ppr MetaId
n
            MetaStruct ms :: [MetaExpr]
ms -> SDoc
exclamation SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces ([MetaExpr] -> SDoc
forall a. Outputable a => [a] -> SDoc
ppCommaJoin [MetaExpr]
ms)
            other :: MetaExpr
other         -> SDoc
exclamation SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
braces (MetaExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr MetaExpr
other) -- possible?


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

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

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