module Llvm.PpLlvm (
ppLlvmModule,
ppLlvmComments,
ppLlvmComment,
ppLlvmGlobals,
ppLlvmGlobal,
ppLlvmAliases,
ppLlvmAlias,
ppLlvmMetas,
ppLlvmMeta,
ppLlvmFunctionDecls,
ppLlvmFunctionDecl,
ppLlvmFunctions,
ppLlvmFunction,
) where
#include "HsVersions.h"
import Llvm.AbsSyn
import Llvm.Types
import Data.List ( intersperse )
import Outputable
import Unique
ppLlvmModule :: LlvmModule -> SDoc
ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)
= ppLlvmComments comments $+$ newLine
$+$ ppLlvmAliases aliases $+$ newLine
$+$ ppLlvmMetas meta $+$ newLine
$+$ ppLlvmGlobals globals $+$ newLine
$+$ ppLlvmFunctionDecls decls $+$ newLine
$+$ ppLlvmFunctions funcs
ppLlvmComments :: [LMString] -> SDoc
ppLlvmComments comments = vcat $ map ppLlvmComment comments
ppLlvmComment :: LMString -> SDoc
ppLlvmComment com = semi <+> ftext com
ppLlvmGlobals :: [LMGlobal] -> SDoc
ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls
ppLlvmGlobal :: LMGlobal -> SDoc
ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) =
let sect = case x of
Just x' -> text ", section" <+> doubleQuotes (ftext x')
Nothing -> empty
align = case a of
Just a' -> text ", align" <+> int a'
Nothing -> empty
rhs = case dat of
Just stat -> texts stat
Nothing -> texts (pLower $ getVarType var)
const' = if c then text "constant" else text "global"
in ppAssignment var $ texts link <+> const' <+> rhs <> sect <> align
$+$ newLine
ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth
ppLlvmAliases :: [LlvmAlias] -> SDoc
ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
ppLlvmAlias :: LlvmAlias -> SDoc
ppLlvmAlias (name, ty)
= text "%" <> ftext name <+> equals <+> text "type" <+> texts ty
ppLlvmMetas :: [LlvmMeta] -> SDoc
ppLlvmMetas metas = vcat $ map ppLlvmMeta metas
ppLlvmMeta :: LlvmMeta -> SDoc
ppLlvmMeta (MetaUnamed (LMMetaUnamed u) metas)
= exclamation <> int u <> text " = metadata !{" <>
hcat (intersperse comma $ map ppLlvmMetaVal metas) <> text "}"
ppLlvmMeta (MetaNamed n metas)
= exclamation <> ftext n <> text " = !{" <>
hcat (intersperse comma $ map pprNode munq) <> text "}"
where
munq = map (\(LMMetaUnamed u) -> u) metas
pprNode n = exclamation <> int n
ppLlvmMetaVal :: LlvmMetaVal -> SDoc
ppLlvmMetaVal (MetaStr s) = text "metadata !" <> doubleQuotes (ftext s)
ppLlvmMetaVal (MetaVar v) = texts v
ppLlvmMetaVal (MetaNode (LMMetaUnamed u))
= text "metadata !" <> int u
ppLlvmFunctions :: LlvmFunctions -> SDoc
ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
ppLlvmFunction :: LlvmFunction -> SDoc
ppLlvmFunction (LlvmFunction dec args attrs sec body) =
let attrDoc = ppSpaceJoin attrs
secDoc = case sec of
Just s' -> text "section" <+> (doubleQuotes $ ftext s')
Nothing -> empty
in text "define" <+> ppLlvmFunctionHeader dec args
<+> attrDoc <+> secDoc
$+$ lbrace
$+$ ppLlvmBlocks body
$+$ rbrace
$+$ newLine
$+$ newLine
ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc
ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
= let varg' = case varg of
VarArgs | null p -> text "..."
| otherwise -> text ", ..."
_otherwise -> empty
align = case a of
Just a' -> text " align" <+> texts a'
Nothing -> empty
args' = map (\((ty,p),n) -> texts ty <+> ppSpaceJoin p <+> text "%"
<> ftext n)
(zip p args)
in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <>
(hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align
ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc
ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc
ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
= let varg' = case varg of
VarArgs | null p -> text "..."
| otherwise -> text ", ..."
_otherwise -> empty
align = case a of
Just a' -> text " align" <+> texts a'
Nothing -> empty
args = hcat $ intersperse (comma <> space) $
map (\(t,a) -> texts t <+> ppSpaceJoin a) p
in text "declare" <+> texts l <+> texts c <+> texts r <+> text "@" <>
ftext n <> lparen <> args <> varg' <> rparen <> align $+$ newLine
ppLlvmBlocks :: LlvmBlocks -> SDoc
ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks
ppLlvmBlock :: LlvmBlock -> SDoc
ppLlvmBlock (LlvmBlock blockId stmts)
= go blockId stmts
where
lbreak acc [] = (Nothing, reverse acc, [])
lbreak acc (MkLabel id:xs) = (Just id, reverse acc, xs)
lbreak acc (x:xs) = lbreak (x:acc) xs
go id code =
let (id2, block, rest) = lbreak [] code
ppRest = case id2 of
Just id2' -> go id2' rest
Nothing -> empty
in ppLlvmBlockLabel id
$+$ (vcat $ map ppLlvmStatement block)
$+$ newLine
$+$ ppRest
ppLlvmBlockLabel :: LlvmBlockId -> SDoc
ppLlvmBlockLabel id = pprUnique id <> colon
ppLlvmStatement :: LlvmStatement -> SDoc
ppLlvmStatement stmt =
let ind = (text " " <>)
in case stmt of
Assignment dst expr -> ind $ ppAssignment dst (ppLlvmExpression expr)
Fence st ord -> ind $ ppFence st ord
Branch target -> ind $ ppBranch target
BranchIf cond ifT ifF -> ind $ ppBranchIf cond ifT ifF
Comment comments -> ind $ ppLlvmComments comments
MkLabel label -> ppLlvmBlockLabel label
Store value ptr -> ind $ ppStore value ptr
Switch scrut def tgs -> ind $ ppSwitch scrut def tgs
Return result -> ind $ ppReturn result
Expr expr -> ind $ ppLlvmExpression expr
Unreachable -> ind $ text "unreachable"
Nop -> empty
MetaStmt meta s -> ppMetaStatement meta s
ppLlvmExpression :: LlvmExpression -> SDoc
ppLlvmExpression expr
= case expr of
Alloca tp amount -> ppAlloca tp amount
LlvmOp op left right -> ppMachOp op left right
Call tp fp args attrs -> ppCall tp fp args attrs
Cast op from to -> ppCast op from to
Compare op left right -> ppCmpOp op left right
GetElemPtr inb ptr indexes -> ppGetElementPtr inb ptr indexes
Load ptr -> ppLoad ptr
Malloc tp amount -> ppMalloc tp amount
Phi tp precessors -> ppPhi tp precessors
Asm asm c ty v se sk -> ppAsm asm c ty v se sk
MetaExpr meta expr -> ppMetaExpr meta expr
ppCall :: LlvmCallType -> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> SDoc
ppCall ct fptr vals attrs = case fptr of
LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d
LMGlobalVar _ (LMFunction d) _ _ _ _ -> ppCall' d
_other -> error $ "ppCall called with non LMFunction type!\nMust be "
++ " called with either global var of function type or "
++ "local var of pointer function type."
where
ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
let tc = if ct == TailCall then text "tail " else empty
ppValues = ppCommaJoin vals
ppParams = map (texts . fst) params
ppArgTy = (hcat $ intersperse comma ppParams) <>
(case argTy of
VarArgs -> text ", ..."
FixedArgs -> empty)
fnty = space <> lparen <> ppArgTy <> rparen <> text "*"
attrDoc = ppSpaceJoin attrs
in tc <> text "call" <+> texts cc <+> texts ret
<> fnty <+> (text $ getName fptr) <> lparen <+> ppValues
<+> rparen <+> attrDoc
ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
ppMachOp op left right =
(texts op) <+> (texts (getVarType left)) <+> (text $ getName left)
<> comma <+> (text $ getName right)
ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
ppCmpOp op left right =
let cmpOp
| isInt (getVarType left) && isInt (getVarType right) = text "icmp"
| isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"
| otherwise = text "icmp"
in cmpOp <+> texts op <+> texts (getVarType left)
<+> (text $ getName left) <> comma <+> (text $ getName right)
ppAssignment :: LlvmVar -> SDoc -> SDoc
ppAssignment var expr = (text $ getName var) <+> equals <+> expr
ppFence :: Bool -> LlvmSyncOrdering -> SDoc
ppFence st ord =
let singleThread = case st of True -> text "singlethread"
False -> empty
in text "fence" <+> singleThread <+> ppSyncOrdering ord
ppSyncOrdering :: LlvmSyncOrdering -> SDoc
ppSyncOrdering SyncUnord = text "unordered"
ppSyncOrdering SyncMonotonic = text "monotonic"
ppSyncOrdering SyncAcquire = text "acquire"
ppSyncOrdering SyncRelease = text "release"
ppSyncOrdering SyncAcqRel = text "acq_rel"
ppSyncOrdering SyncSeqCst = text "seq_cst"
ppLoad :: LlvmVar -> SDoc
ppLoad var = text "load" <+> texts var
ppStore :: LlvmVar -> LlvmVar -> SDoc
ppStore val dst = text "store" <+> texts val <> comma <+> texts dst
ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
ppCast op from to = texts op <+> texts from <+> text "to" <+> texts to
ppMalloc :: LlvmType -> Int -> SDoc
ppMalloc tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
in text "malloc" <+> texts tp <> comma <+> texts amount'
ppAlloca :: LlvmType -> Int -> SDoc
ppAlloca tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
in text "alloca" <+> texts tp <> comma <+> texts amount'
ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc
ppGetElementPtr inb ptr idx =
let indexes = comma <+> ppCommaJoin idx
inbound = if inb then text "inbounds" else empty
in text "getelementptr" <+> inbound <+> texts ptr <> indexes
ppReturn :: Maybe LlvmVar -> SDoc
ppReturn (Just var) = text "ret" <+> texts var
ppReturn Nothing = text "ret" <+> texts LMVoid
ppBranch :: LlvmVar -> SDoc
ppBranch var = text "br" <+> texts var
ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppBranchIf cond trueT falseT
= text "br" <+> texts cond <> comma <+> texts trueT <> comma <+> texts falseT
ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
ppPhi tp preds =
let ppPreds (val, label) = brackets $ (text $ getName val) <> comma
<+> (text $ getName label)
in text "phi" <+> texts tp <+> hcat (intersperse comma $ map ppPreds preds)
ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
ppSwitch scrut dflt targets =
let ppTarget (val, lab) = texts val <> comma <+> texts lab
ppTargets xs = brackets $ vcat (map ppTarget xs)
in text "switch" <+> texts scrut <> comma <+> texts dflt
<+> ppTargets targets
ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
ppAsm asm constraints rty vars sideeffect alignstack =
let asm' = doubleQuotes $ ftext asm
cons = doubleQuotes $ ftext constraints
rty' = texts rty
vars' = lparen <+> ppCommaJoin vars <+> rparen
side = if sideeffect then text "sideeffect" else empty
align = if alignstack then text "alignstack" else empty
in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma
<+> cons <> vars'
ppMetaStatement :: [MetaData] -> LlvmStatement -> SDoc
ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetas meta
ppMetaExpr :: [MetaData] -> LlvmExpression -> SDoc
ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetas meta
ppMetas :: [MetaData] -> SDoc
ppMetas meta = hcat $ map ppMeta meta
where
ppMeta (name, (LMMetaUnamed n))
= comma <+> exclamation <> ftext name <+> exclamation <> int n
ppCommaJoin :: (Show a) => [a] -> SDoc
ppCommaJoin strs = hcat $ intersperse (comma <> space) (map texts strs)
ppSpaceJoin :: (Show a) => [a] -> SDoc
ppSpaceJoin strs = hcat $ intersperse space (map texts strs)
texts :: (Show a) => a -> SDoc
texts = (text . show)
newLine :: SDoc
newLine = text ""
exclamation :: SDoc
exclamation = text "!"