module Llvm.PpLlvm (
ppLlvmModule,
ppLlvmComments,
ppLlvmComment,
ppLlvmGlobals,
ppLlvmGlobal,
ppLlvmAlias,
ppLlvmAliases,
ppLlvmFunctionDecls,
ppLlvmFunctionDecl,
ppLlvmFunctions,
ppLlvmFunction,
llvmSDoc
) where
#include "HsVersions.h"
import Llvm.AbsSyn
import Llvm.Types
import Data.List ( intersperse )
import Pretty
import qualified Outputable as Out
import Unique
ppLlvmModule :: LlvmModule -> Doc
ppLlvmModule (LlvmModule comments aliases globals decls funcs)
= ppLlvmComments comments
$+$ empty
$+$ ppLlvmAliases aliases
$+$ empty
$+$ ppLlvmGlobals globals
$+$ empty
$+$ ppLlvmFunctionDecls decls
$+$ empty
$+$ ppLlvmFunctions funcs
ppLlvmComments :: [LMString] -> Doc
ppLlvmComments comments = vcat $ map ppLlvmComment comments
ppLlvmComment :: LMString -> Doc
ppLlvmComment com = semi <+> ftext com
ppLlvmGlobals :: [LMGlobal] -> Doc
ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls
ppLlvmGlobal :: LMGlobal -> Doc
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
ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth
ppLlvmAliases :: [LlvmAlias] -> Doc
ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
ppLlvmAlias :: LlvmAlias -> Doc
ppLlvmAlias (name, ty) = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty
ppLlvmFunctions :: LlvmFunctions -> Doc
ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
ppLlvmFunction :: LlvmFunction -> Doc
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
ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc
ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
= let varg' = if varg == VarArgs then text ", ..." else empty
align = case a of
Just a' -> space <> 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 args') <> varg' <> rparen <> align
ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc
ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
ppLlvmFunctionDecl :: LlvmFunctionDecl -> Doc
ppLlvmFunctionDecl dec = text "declare" <+> texts dec
ppLlvmBlocks :: LlvmBlocks -> Doc
ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks
ppLlvmBlock :: LlvmBlock -> Doc
ppLlvmBlock (LlvmBlock blockId stmts)
= ppLlvmStatement (MkLabel blockId)
$+$ nest 4 (vcat $ map ppLlvmStatement stmts)
ppLlvmStatement :: LlvmStatement -> Doc
ppLlvmStatement stmt
= case stmt of
Assignment dst expr -> ppAssignment dst (ppLlvmExpression expr)
Branch target -> ppBranch target
BranchIf cond ifT ifF -> ppBranchIf cond ifT ifF
Comment comments -> ppLlvmComments comments
MkLabel label -> (llvmSDoc $ pprUnique label) <> colon
Store value ptr -> ppStore value ptr
Switch scrut def tgs -> ppSwitch scrut def tgs
Return result -> ppReturn result
Expr expr -> ppLlvmExpression expr
Unreachable -> text "unreachable"
ppLlvmExpression :: LlvmExpression -> Doc
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
ppCall :: LlvmCallType -> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> Doc
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 (\(ty,p) -> texts ty <+> ppSpaceJoin p) 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 -> Doc
ppMachOp op left right =
(texts op) <+> (texts (getVarType left)) <+> (text $ getName left)
<> comma <+> (text $ getName right)
ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> Doc
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 -> Doc -> Doc
ppAssignment var expr = (text $ getName var) <+> equals <+> expr
ppLoad :: LlvmVar -> Doc
ppLoad var = text "load" <+> texts var
ppStore :: LlvmVar -> LlvmVar -> Doc
ppStore val dst = text "store" <+> texts val <> comma <+> texts dst
ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> Doc
ppCast op from to = texts op <+> texts from <+> text "to" <+> texts to
ppMalloc :: LlvmType -> Int -> Doc
ppMalloc tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
in text "malloc" <+> texts tp <> comma <+> texts amount'
ppAlloca :: LlvmType -> Int -> Doc
ppAlloca tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
in text "alloca" <+> texts tp <> comma <+> texts amount'
ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> Doc
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 -> Doc
ppReturn (Just var) = text "ret" <+> texts var
ppReturn Nothing = text "ret" <+> texts LMVoid
ppBranch :: LlvmVar -> Doc
ppBranch var = text "br" <+> texts var
ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> Doc
ppBranchIf cond trueT falseT
= text "br" <+> texts cond <> comma <+> texts trueT <> comma <+> texts falseT
ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> Doc
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)] -> Doc
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 -> Doc
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'
ppCommaJoin :: (Show a) => [a] -> Doc
ppCommaJoin strs = hcat $ intersperse comma (map texts strs)
ppSpaceJoin :: (Show a) => [a] -> Doc
ppSpaceJoin strs = hcat $ intersperse space (map texts strs)
llvmSDoc :: Out.SDoc -> Doc
llvmSDoc d
= Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d
texts :: (Show a) => a -> Doc
texts = (text . show)