ppLlvmModule,
ppLlvmComments,
ppLlvmComment,
- ppLlvmConstants,
- ppLlvmConstant,
ppLlvmGlobals,
ppLlvmGlobal,
- ppLlvmType,
- ppLlvmTypes,
+ ppLlvmAlias,
+ ppLlvmAliases,
ppLlvmFunctionDecls,
ppLlvmFunctionDecl,
ppLlvmFunctions,
ppLlvmFunction,
+
+ -- * Utility functions
llvmSDoc
) where
import Data.List ( intersperse )
import Pretty
-import qualified Outputable as Outp
+import qualified Outputable as Out
import Unique
--------------------------------------------------------------------------------
-- | Print out a whole LLVM module.
ppLlvmModule :: LlvmModule -> Doc
-ppLlvmModule (LlvmModule comments constants globals decls funcs)
+ppLlvmModule (LlvmModule comments aliases globals decls funcs)
= ppLlvmComments comments
$+$ empty
- $+$ ppLlvmConstants constants
+ $+$ ppLlvmAliases aliases
+ $+$ empty
$+$ ppLlvmGlobals globals
$+$ empty
$+$ ppLlvmFunctionDecls decls
-- | Print out a comment, can be inside a function or on its own
ppLlvmComment :: LMString -> Doc
-ppLlvmComment com = semi <+> (ftext com)
+ppLlvmComment com = semi <+> ftext com
-- | Print out a list of global mutable variable definitions
-- | Print out a global mutable variable definition
ppLlvmGlobal :: LMGlobal -> Doc
-ppLlvmGlobal (var@(LMGlobalVar _ _ link), Nothing) =
- ppAssignment var $ text (show link) <+> text "global" <+>
- (text $ show (pLower $ getVarType var))
+ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) =
+ let sect = case x of
+ Just x' -> text ", section" <+> doubleQuotes (ftext x')
+ Nothing -> empty
-ppLlvmGlobal (var@(LMGlobalVar _ _ link), (Just stat)) =
- ppAssignment var $ text (show link) <+> text "global" <+> text (show stat)
-
-ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth
+ 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)
--- | Print out a list global constant variable
-ppLlvmConstants :: [LMConstant] -> Doc
-ppLlvmConstants cons = vcat $ map ppLlvmConstant cons
+ const' = if c then text "constant" else text "global"
--- | Print out a global constant variable
-ppLlvmConstant :: LMConstant -> Doc
-ppLlvmConstant (dst@(LMGlobalVar _ _ link), src) =
- ppAssignment dst $ text (show link) <+> text "constant" <+> text (show src)
+ in ppAssignment var $ texts link <+> const' <+> rhs <> sect <> align
-ppLlvmConstant c = error $ "Non global var as constant! " ++ show c
+ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth
-- | Print out a list of LLVM type aliases.
-ppLlvmTypes :: [LlvmType] -> Doc
-ppLlvmTypes tys = vcat $ map ppLlvmType tys
+ppLlvmAliases :: [LlvmAlias] -> Doc
+ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
-- | Print out an LLVM type alias.
-ppLlvmType :: LlvmType -> Doc
-
-ppLlvmType al@(LMAlias _ t)
- = (text $ show al) <+> equals <+> (text "type") <+> (text $ show t)
-
-ppLlvmType (LMFunction t)
- = ppLlvmFunctionDecl t
-
-ppLlvmType _ = empty
+ppLlvmAlias :: LlvmAlias -> Doc
+ppLlvmAlias (name, ty) = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty
-- | Print out a list of function definitions.
-- | Print out a function definition.
ppLlvmFunction :: LlvmFunction -> Doc
-ppLlvmFunction (LlvmFunction dec attrs body) =
+ppLlvmFunction (LlvmFunction dec args attrs sec body) =
let attrDoc = ppSpaceJoin attrs
- in (text "define") <+> (ppLlvmFuncDecSig dec)
- <+> attrDoc
+ 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
+-- | Print out a function defenition header.
+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
+
-- | Print out a list of function declaration.
ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc
-- Declarations define the function type but don't define the actual body of
-- the function.
ppLlvmFunctionDecl :: LlvmFunctionDecl -> Doc
-ppLlvmFunctionDecl dec = (text "declare") <+> ppLlvmFuncDecSig dec
-
--- | Print out a functions type signature.
--- This differs from [ppLlvmFunctionDecl] in that it is used for both function
--- declarations and defined functions to print out the type.
-ppLlvmFuncDecSig :: LlvmFunctionDecl -> Doc
-ppLlvmFuncDecSig (LlvmFunctionDecl name link cc retTy argTy params)
- = let linkTxt = show link
- linkDoc | linkTxt == "" = empty
- | otherwise = (text linkTxt) <> space
- ppParams = either ppCommaJoin ppCommaJoin params <>
- (case argTy of
- VarArgs -> (text ", ...")
- FixedArgs -> empty)
- in linkDoc <> (text $ show cc) <+> (text $ show retTy)
- <+> atsym <> (ftext name) <> lparen <+> ppParams <+> rparen
+ppLlvmFunctionDecl dec = text "declare" <+> texts dec
-- | Print out a list of LLVM blocks.
ppLlvmBlock :: LlvmBlock -> Doc
ppLlvmBlock (LlvmBlock blockId stmts)
= ppLlvmStatement (MkLabel blockId)
- $+$ nest 4 (vcat $ map ppLlvmStatement stmts)
+ $+$ nest 4 (vcat $ map ppLlvmStatement stmts)
-- | Print out an LLVM statement.
Return result -> ppReturn result
Expr expr -> ppLlvmExpression expr
Unreachable -> text "unreachable"
+ Nop -> empty
-- | Print out an LLVM expression.
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 ptr indexes -> ppGetElementPtr ptr indexes
+ 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
--------------------------------------------------------------------------------
LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d
-- should be function type otherwise
- LMGlobalVar _ (LMFunction d) _ -> ppCall' d
+ LMGlobalVar _ (LMFunction d) _ _ _ _ -> ppCall' d
-- not pointer or function, so error
_other -> error $ "ppCall called with non LMFunction type!\nMust be "
++ "local var of pointer function type."
where
- ppCall' (LlvmFunctionDecl _ _ cc ret argTy params) =
+ ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
let tc = if ct == TailCall then text "tail " else empty
ppValues = ppCommaJoin vals
- ppArgTy = either ppCommaJoin (\x -> ppCommaJoin $ map getVarType x) params <>
+ ppParams = map (\(ty,p) -> texts ty <+> ppSpaceJoin p) params
+ ppArgTy = (hcat $ intersperse comma ppParams) <>
(case argTy of
- VarArgs -> (text ", ...")
+ VarArgs -> text ", ..."
FixedArgs -> empty)
- fnty = space <> lparen <> ppArgTy <> rparen <> (text "*")
+ fnty = space <> lparen <> ppArgTy <> rparen <> text "*"
attrDoc = ppSpaceJoin attrs
- in tc <> (text "call") <+> (text $ show cc) <+> (text $ show ret)
+ 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 =
- (text $ show op) <+> (text $ show (getVarType left)) <+> (text $ getName left)
+ (texts op) <+> (texts (getVarType left)) <+> (text $ getName left)
<> comma <+> (text $ getName right)
let cmpOp
| isInt (getVarType left) && isInt (getVarType right) = text "icmp"
| isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"
+ | otherwise = 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 cmpOp <+> (text $ show op) <+> (text $ show (getVarType left))
+ -}
+ in cmpOp <+> texts op <+> texts (getVarType left)
<+> (text $ getName left) <> comma <+> (text $ getName right)
ppLoad :: LlvmVar -> Doc
-ppLoad var = (text "load") <+> (text $ show var)
+ppLoad var = text "load" <+> texts var
ppStore :: LlvmVar -> LlvmVar -> Doc
-ppStore val dst =
- (text "store") <+> (text $ show val) <> comma <+> (text $ show dst)
+ppStore val dst = text "store" <+> texts val <> comma <+> texts dst
ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> Doc
-ppCast op from to =
- let castOp = text $ show op
- in castOp <+> (text $ show from) <+> (text "to") <+> (text $ show to)
+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") <+> (text $ show tp) <> comma <+> (text $ show amount')
+ 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") <+> (text $ show tp) <> comma <+> (text $ show amount')
+ in text "alloca" <+> texts tp <> comma <+> texts amount'
-ppGetElementPtr :: LlvmVar -> [Int] -> Doc
-ppGetElementPtr ptr idx =
- let indexes = hcat $ map ((comma <+> (text $ show i32) <+>) . text . show) idx
- in (text "getelementptr") <+> (text $ show ptr) <> indexes
+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") <+> (text $ show var)
-ppReturn Nothing = (text "ret") <+> (text $ show LMVoid)
+ppReturn (Just var) = text "ret" <+> texts var
+ppReturn Nothing = text "ret" <+> texts LMVoid
ppBranch :: LlvmVar -> Doc
-ppBranch var = (text "br") <+> (text $ show var)
+ppBranch var = text "br" <+> texts var
ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> Doc
ppBranchIf cond trueT falseT
- = (text "br") <+> (text $ show cond) <> comma <+> (text $ show trueT) <> comma
- <+> (text $ show 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") <+> (text $ show tp)
- <+> (hcat $ intersperse comma (map ppPreds preds))
+ 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) = (text $ show val) <> comma <+> (text $ show lab)
+ let ppTarget (val, lab) = texts val <> comma <+> texts lab
ppTargets xs = brackets $ vcat (map ppTarget xs)
- in (text "switch") <+> (text $ show scrut) <> comma <+> (text $ show dflt)
- <+> (ppTargets targets)
+ 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'
--------------------------------------------------------------------------------
-- * Misc functions
--------------------------------------------------------------------------------
-atsym :: Doc
-atsym = text "@"
-
ppCommaJoin :: (Show a) => [a] -> Doc
-ppCommaJoin strs = hcat $ intersperse comma (map (text . show) strs)
+ppCommaJoin strs = hcat $ intersperse comma (map texts strs)
ppSpaceJoin :: (Show a) => [a] -> Doc
-ppSpaceJoin strs = hcat $ intersperse space (map (text . show) strs)
+ppSpaceJoin strs = hcat $ intersperse space (map texts strs)
-- | Convert SDoc to Doc
-llvmSDoc :: Outp.SDoc -> Doc
+llvmSDoc :: Out.SDoc -> Doc
llvmSDoc d
- = Outp.withPprStyleDoc (Outp.mkCodeStyle Outp.CStyle) d
+ = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d
+
+-- | Showable to Doc
+texts :: (Show a) => a -> Doc
+texts = (text . show)
projects / ghc-hetmet.git / blobdiff