Commit 01234ecf authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Merge branch 'master' of ssh://darcs.haskell.org/srv/darcs/ghc

parents 6a25e927 fe44d053
......@@ -139,6 +139,7 @@ Library
Literal
Llvm
Llvm.AbsSyn
Llvm.MetaData
Llvm.PpLlvm
Llvm.Types
LlvmCodeGen
......
......@@ -32,20 +32,22 @@ module Llvm (
-- * Variables and Type System
LlvmVar(..), LlvmStatic(..), LlvmLit(..), LlvmType(..),
LlvmAlias, LMGlobal, LMString, LMSection, LMAlign,
LlvmAlias, LMGlobal(..), LMString, LMSection, LMAlign,
LMConst(..),
-- ** Some basic types
i64, i32, i16, i8, i1, i8Ptr, llvmWord, llvmWordPtr,
-- ** Metadata types
LlvmMetaVal(..), LlvmMetaUnamed(..), LlvmMeta(..), MetaData,
MetaExpr(..), MetaAnnot(..), MetaDecl(..),
-- ** Operations on the type system.
isGlobal, getLitType, getLit, getName, getPlainName, getVarType,
getLink, getStatType, getGlobalVar, getGlobalType, pVarLift, pVarLower,
isGlobal, getLitType, getVarType,
getLink, getStatType, pVarLift, pVarLower,
pLift, pLower, isInt, isFloat, isPointer, isVector, llvmWidthInBits,
-- * Pretty Printing
ppLit, ppName, ppPlainName,
ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,
ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions,
ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta,
......@@ -53,6 +55,7 @@ module Llvm (
) where
import Llvm.AbsSyn
import Llvm.MetaData
import Llvm.PpLlvm
import Llvm.Types
......@@ -4,6 +4,7 @@
module Llvm.AbsSyn where
import Llvm.MetaData
import Llvm.Types
import Unique
......@@ -32,7 +33,7 @@ data LlvmModule = LlvmModule {
modAliases :: [LlvmAlias],
-- | LLVM meta data.
modMeta :: [LlvmMeta],
modMeta :: [MetaDecl],
-- | Global variables to include in the module.
modGlobals :: [LMGlobal],
......@@ -165,11 +166,9 @@ data LlvmStatement
{- |
A LLVM statement with metadata attached to it.
-}
| MetaStmt [MetaData] LlvmStatement
| MetaStmt [MetaAnnot] LlvmStatement
deriving (Show, Eq)
type MetaData = (LMString, LlvmMetaUnamed)
deriving (Eq)
-- | Llvm Expressions
......@@ -252,6 +251,17 @@ data LlvmExpression
-}
| Call LlvmCallType LlvmVar [LlvmVar] [LlvmFuncAttr]
{- |
Call a function as above but potentially taking metadata as arguments.
* tailJumps: CallType to signal if the function should be tail called
* fnptrval: An LLVM value containing a pointer to a function to be
invoked. Can be indirect. Should be LMFunction type.
* args: Arguments that may include metadata.
* attrs: A list of function attributes for the call. Only NoReturn,
NoUnwind, ReadOnly and ReadNone are valid here.
-}
| CallM LlvmCallType LlvmVar [MetaExpr] [LlvmFuncAttr]
{- |
Merge variables from different basic blocks which are predecessors of this
basic block in a new variable of type tp.
......@@ -278,7 +288,7 @@ data LlvmExpression
{- |
A LLVM expression with metadata attached to it.
-}
| MetaExpr [MetaData] LlvmExpression
| MExpr [MetaAnnot] LlvmExpression
deriving (Show, Eq)
deriving (Eq)
--------------------------------------------------------------------------------
-- | The LLVM Metadata System.
--
-- The LLVM metadata feature is poorly documented but roughly follows the
-- following design:
-- * Metadata can be constructed in a few different ways (See below).
-- * After which it can either be attached to LLVM statements to pass along
-- extra information to the optimizer and code generator OR specificially named
-- metadata has an affect on the whole module (i.e., linking behaviour).
--
--
-- # Constructing metadata
-- Metadata comes largely in three forms:
--
-- * Metadata expressions -- these are the raw metadata values that encode
-- information. They consist of metadata strings, metadata nodes, regular
-- LLVM values (both literals and references to global variables) and
-- metadata expressions (i.e., recursive data type). Some examples:
-- !{ metadata !"hello", metadata !0, i32 0 }
-- !{ metadata !1, metadata !{ i32 0 } }
--
-- * Metadata nodes -- global metadata variables that attach a metadata
-- expression to a number. For example:
-- !0 = metadata !{ [<metadata expressions>] !}
--
-- * Named metadata -- global metadata variables that attach a metadata nodes
-- to a name. Used ONLY to communicated module level information to LLVM
-- through a meaningful name. For example:
-- !llvm.module.linkage = !{ !0, !1 }
--
--
-- # Using Metadata
-- Using metadata depends on the form it is in:
--
-- * Attach to instructions -- metadata can be attached to LLVM instructions
-- using a specific reference as follows:
-- %l = load i32* @glob, !nontemporal !10
-- %m = load i32* @glob, !nontemporal !{ i32 0, metadata !{ i32 0 } }
-- Only metadata nodes or expressions can be attached, named metadata cannot.
-- Refer to LLVM documentation for which instructions take metadata and its
-- meaning.
--
-- * As arguments -- llvm functions can take metadata as arguments, for
-- example:
-- call void @llvm.dbg.value(metadata !{ i32 0 }, i64 0, metadata !1)
-- As with instructions, only metadata nodes or expressions can be attached.
--
-- * As a named metadata -- Here the metadata is simply declared in global
-- scope using a specific name to communicate module level information to LLVM.
-- For example:
-- !llvm.module.linkage = !{ !0, !1 }
--
module Llvm.MetaData where
import Llvm.Types
import Outputable
-- | LLVM metadata expressions
data MetaExpr = MetaStr LMString
| MetaNode Int
| MetaVar LlvmVar
| MetaStruct [MetaExpr]
deriving (Eq)
instance Outputable MetaExpr where
ppr (MetaStr s ) = text "metadata !\"" <> ftext s <> char '"'
ppr (MetaNode n ) = text "metadata !" <> int n
ppr (MetaVar v ) = ppr v
ppr (MetaStruct es) = text "metadata !{ " <> ppCommaJoin es <> char '}'
-- | Associates some metadata with a specific label for attaching to an
-- instruction.
data MetaAnnot = MetaAnnot LMString MetaExpr
deriving (Eq)
-- | Metadata declarations. Metadata can only be declared in global scope.
data MetaDecl
-- | Named metadata. Only used for communicating module information to
-- LLVM. ('!name = !{ [!<n>] }' form).
= MetaNamed LMString [Int]
-- | Metadata node declaration.
-- ('!0 = metadata !{ <metadata expression> }' form).
| MetaUnamed Int MetaExpr
......@@ -24,11 +24,13 @@ module Llvm.PpLlvm (
#include "HsVersions.h"
import Llvm.AbsSyn
import Llvm.MetaData
import Llvm.Types
import Data.List ( intersperse )
import Outputable
import Unique
import FastString ( sLit )
--------------------------------------------------------------------------------
-- * Top Level Print functions
......@@ -59,7 +61,7 @@ ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls
-- | Print out a global mutable variable definition
ppLlvmGlobal :: LMGlobal -> SDoc
ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) =
ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
let sect = case x of
Just x' -> text ", section" <+> doubleQuotes (ftext x')
Nothing -> empty
......@@ -69,15 +71,21 @@ ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) =
Nothing -> empty
rhs = case dat of
Just stat -> texts stat
Nothing -> texts (pLower $ getVarType var)
Just stat -> ppr stat
Nothing -> ppr (pLower $ getVarType var)
const' = if c then text "constant" else text "global"
-- Position of linkage is different for aliases.
const_link = case c of
Global -> ppr link <+> text "global"
Constant -> ppr link <+> text "constant"
Alias -> text "alias" <+> ppr link
in ppAssignment var $ texts link <+> const' <+> rhs <> sect <> align
in ppAssignment var $ const_link <+> rhs <> sect <> align
$+$ newLine
ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth
ppLlvmGlobal (LMGlobal var val) = sdocWithDynFlags $ \dflags ->
error $ "Non Global var ppr as global! "
++ showSDoc dflags (ppr var) ++ " " ++ showSDoc dflags (ppr val)
-- | Print out a list of LLVM type aliases.
......@@ -87,32 +95,31 @@ ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
-- | Print out an LLVM type alias.
ppLlvmAlias :: LlvmAlias -> SDoc
ppLlvmAlias (name, ty)
= text "%" <> ftext name <+> equals <+> text "type" <+> texts ty
= char '%' <> ftext name <+> equals <+> text "type" <+> ppr ty
-- | Print out a list of LLVM metadata.
ppLlvmMetas :: [LlvmMeta] -> SDoc
ppLlvmMetas :: [MetaDecl] -> SDoc
ppLlvmMetas metas = vcat $ map ppLlvmMeta metas
-- | Print out an LLVM metadata definition.
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 "}"
ppLlvmMeta :: MetaDecl -> SDoc
ppLlvmMeta (MetaUnamed n m)
= exclamation <> int n <> text " = metadata !" <> braces (ppLlvmMetaExpr m)
ppLlvmMeta (MetaNamed n m)
= exclamation <> ftext n <> text " = !" <> braces nodes
where
munq = map (\(LMMetaUnamed u) -> u) metas
nodes = hcat $ intersperse comma $ map pprNode m
pprNode n = exclamation <> int n
-- | Print out an LLVM metadata value.
ppLlvmMetaVal :: LlvmMetaVal -> SDoc
ppLlvmMetaVal (MetaStr s) = text "metadata !" <> doubleQuotes (ftext s)
ppLlvmMetaVal (MetaVar v) = texts v
ppLlvmMetaVal (MetaNode (LMMetaUnamed u))
= text "metadata !" <> int u
ppLlvmMetaExpr :: MetaExpr -> SDoc
ppLlvmMetaExpr (MetaStr s ) = text "metadata !" <> doubleQuotes (ftext s)
ppLlvmMetaExpr (MetaNode n ) = text "metadata !" <> int n
ppLlvmMetaExpr (MetaVar v ) = ppr v
ppLlvmMetaExpr (MetaStruct es) =
text "metadata !{" <> hsep (punctuate comma (map ppLlvmMetaExpr es)) <> char '}'
-- | Print out a list of function definitions.
......@@ -138,17 +145,17 @@ ppLlvmFunction (LlvmFunction dec args attrs sec body) =
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
VarArgs | null p -> sLit "..."
| otherwise -> sLit ", ..."
_otherwise -> sLit ""
align = case a of
Just a' -> text " align" <+> texts a'
Just a' -> text " align " <> ppr a'
Nothing -> empty
args' = map (\((ty,p),n) -> texts ty <+> ppSpaceJoin p <+> text "%"
args' = map (\((ty,p),n) -> ppr ty <+> ppSpaceJoin p <+> char '%'
<> ftext n)
(zip p args)
in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <>
(hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align
in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <>
(hsep $ punctuate comma args') <> ptext varg' <> rparen <> align
-- | Print out a list of function declaration.
ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc
......@@ -160,16 +167,16 @@ 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
VarArgs | null p -> sLit "..."
| otherwise -> sLit ", ..."
_otherwise -> sLit ""
align = case a of
Just a' -> text " align" <+> texts a'
Just a' -> text " align" <+> ppr 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
map (\(t,a) -> ppr t <+> ppSpaceJoin a) p
in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <>
ftext n <> lparen <> args <> ptext varg' <> rparen <> align $+$ newLine
-- | Print out a list of LLVM blocks.
......@@ -179,19 +186,14 @@ ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks
-- | Print out an LLVM block.
-- It must be part of a function definition.
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
ppLlvmBlock (LlvmBlock blockId stmts) =
let isLabel (MkLabel _) = True
isLabel _ = False
(block, rest) = break isLabel stmts
ppRest = case rest of
MkLabel id:xs -> ppLlvmBlock (LlvmBlock id xs)
_ -> empty
in ppLlvmBlockLabel blockId
$+$ (vcat $ map ppLlvmStatement block)
$+$ newLine
$+$ ppRest
......@@ -227,7 +229,8 @@ 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
Call tp fp args attrs -> ppCall tp fp (map MetaVar args) attrs
CallM 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
Extract vec idx -> ppExtract vec idx
......@@ -237,7 +240,7 @@ ppLlvmExpression expr
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
MExpr meta expr -> ppMetaExpr meta expr
--------------------------------------------------------------------------------
......@@ -246,8 +249,8 @@ ppLlvmExpression expr
-- | 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 -> [LlvmVar] -> [LlvmFuncAttr] -> SDoc
ppCall ct fptr vals attrs = case fptr of
ppCall :: LlvmCallType -> LlvmVar -> [MetaExpr] -> [LlvmFuncAttr] -> SDoc
ppCall ct fptr args attrs = case fptr of
--
-- if local var function pointer, unwrap
LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d
......@@ -263,23 +266,22 @@ ppCall ct fptr vals attrs = case fptr of
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) <>
ppValues = ppCommaJoin args
ppArgTy = (ppCommaJoin $ map fst params) <>
(case argTy of
VarArgs -> text ", ..."
FixedArgs -> empty)
fnty = space <> lparen <> ppArgTy <> rparen <> text "*"
fnty = space <> lparen <> ppArgTy <> rparen <> char '*'
attrDoc = ppSpaceJoin attrs
in tc <> text "call" <+> texts cc <+> texts ret
<> fnty <+> (text $ getName fptr) <> lparen <+> ppValues
in tc <> text "call" <+> ppr cc <+> ppr ret
<> fnty <+> ppName 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)
(ppr op) <+> (ppr (getVarType left)) <+> ppName left
<> comma <+> ppName right
ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
......@@ -293,12 +295,12 @@ ppCmpOp op left right =
++ (show $ getVarType left) ++ ", right = "
++ (show $ getVarType right))
-}
in cmpOp <+> texts op <+> texts (getVarType left)
<+> (text $ getName left) <> comma <+> (text $ getName right)
in cmpOp <+> ppr op <+> ppr (getVarType left)
<+> ppName left <> comma <+> ppName right
ppAssignment :: LlvmVar -> SDoc -> SDoc
ppAssignment var expr = (text $ getName var) <+> equals <+> expr
ppAssignment var expr = ppName var <+> equals <+> expr
ppFence :: Bool -> LlvmSyncOrdering -> SDoc
ppFence st ord =
......@@ -324,72 +326,71 @@ ppSyncOrdering SyncSeqCst = text "seq_cst"
ppLoad :: LlvmVar -> SDoc
ppLoad var
| isVecPtrVar var = text "load" <+> texts var <>
| isVecPtrVar var = text "load" <+> ppr var <>
comma <+> text "align 1"
| otherwise = text "load" <+> texts var
| otherwise = text "load" <+> ppr var
where
isVecPtrVar :: LlvmVar -> Bool
isVecPtrVar = isVector . pLower . getVarType
ppStore :: LlvmVar -> LlvmVar -> SDoc
ppStore val dst
| isVecPtrVar dst = text "store" <+> texts val <> comma <+> texts dst <>
| isVecPtrVar dst = text "store" <+> ppr val <> comma <+> ppr dst <>
comma <+> text "align 1"
| otherwise = text "store" <+> texts val <> comma <+> texts dst
| otherwise = text "store" <+> ppr val <> comma <+> ppr dst
where
isVecPtrVar :: LlvmVar -> Bool
isVecPtrVar = isVector . pLower . getVarType
ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
ppCast op from to = texts op <+> texts from <+> text "to" <+> texts to
ppCast op from to = ppr op <+> ppr from <+> text "to" <+> ppr to
ppMalloc :: LlvmType -> Int -> SDoc
ppMalloc tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
in text "malloc" <+> texts tp <> comma <+> texts amount'
in text "malloc" <+> ppr tp <> comma <+> ppr amount'
ppAlloca :: LlvmType -> Int -> SDoc
ppAlloca tp amount =
let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
in text "alloca" <+> texts tp <> comma <+> texts amount'
in text "alloca" <+> ppr tp <> comma <+> ppr 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
in text "getelementptr" <+> inbound <+> ppr ptr <> indexes
ppReturn :: Maybe LlvmVar -> SDoc
ppReturn (Just var) = text "ret" <+> texts var
ppReturn Nothing = text "ret" <+> texts LMVoid
ppReturn (Just var) = text "ret" <+> ppr var
ppReturn Nothing = text "ret" <+> ppr LMVoid
ppBranch :: LlvmVar -> SDoc
ppBranch var = text "br" <+> texts var
ppBranch var = text "br" <+> ppr var
ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppBranchIf cond trueT falseT
= text "br" <+> texts cond <> comma <+> texts trueT <> comma <+> texts falseT
= text "br" <+> ppr cond <> comma <+> ppr trueT <> comma <+> ppr 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)
let ppPreds (val, label) = brackets $ ppName val <> comma <+> ppName label
in text "phi" <+> ppr tp <+> hsep (punctuate comma $ map ppPreds preds)
ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
ppSwitch scrut dflt targets =
let ppTarget (val, lab) = texts val <> comma <+> texts lab
let ppTarget (val, lab) = ppr val <> comma <+> ppr lab
ppTargets xs = brackets $ vcat (map ppTarget xs)
in text "switch" <+> texts scrut <> comma <+> texts dflt
in text "switch" <+> ppr scrut <> comma <+> ppr dflt
<+> ppTargets targets
......@@ -397,7 +398,7 @@ 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
rty' = ppr rty
vars' = lparen <+> ppCommaJoin vars <+> rparen
side = if sideeffect then text "sideeffect" else empty
align = if alignstack then text "alignstack" else empty
......@@ -407,49 +408,42 @@ ppAsm asm constraints rty vars sideeffect alignstack =
ppExtract :: LlvmVar -> LlvmVar -> SDoc
ppExtract vec idx =
text "extractelement"
<+> texts (getVarType vec) <+> text (getName vec) <> comma
<+> texts idx
<+> ppr (getVarType vec) <+> ppName vec <> comma
<+> ppr idx
ppInsert :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
ppInsert vec elt idx =
text "insertelement"
<+> texts (getVarType vec) <+> text (getName vec) <> comma
<+> texts (getVarType elt) <+> text (getName elt) <> comma
<+> texts idx
ppMetaStatement :: [MetaData] -> LlvmStatement -> SDoc
ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetas meta
<+> ppr (getVarType vec) <+> ppName vec <> comma
<+> ppr (getVarType elt) <+> ppName elt <> comma
<+> ppr idx
ppMetaExpr :: [MetaData] -> LlvmExpression -> SDoc
ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetas meta
ppMetaStatement :: [MetaAnnot] -> LlvmStatement -> SDoc
ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetaAnnots meta
ppMetaExpr :: [MetaAnnot] -> LlvmExpression -> SDoc
ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetaAnnots meta
ppMetas :: [MetaData] -> SDoc
ppMetas meta = hcat $ map ppMeta meta
ppMetaAnnots :: [MetaAnnot] -> SDoc
ppMetaAnnots meta = hcat $ map ppMeta meta
where
ppMeta (name, (LMMetaUnamed n))
= comma <+> exclamation <> ftext name <+> exclamation <> int n
ppMeta (MetaAnnot name e)
= comma <+> exclamation <> ftext name <+>
case e of
MetaNode n -> exclamation <> int n
MetaStruct ms -> exclamation <> braces (ppCommaJoin ms)
other -> exclamation <> braces (ppr other) -- possible?
--------------------------------------------------------------------------------
-- * Misc functions
--------------------------------------------------------------------------------
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)
-- | Showable to SDoc
texts :: (Show a) => a -> SDoc
texts = (text . show)
-- | Blank line.
newLine :: SDoc
newLine = text ""
newLine = empty
-- | Exclamation point.
exclamation :: SDoc
exclamation = text "!"
exclamation = char '!'
This diff is collapsed.
......@@ -11,6 +11,7 @@ import LlvmCodeGen.Base
import LlvmCodeGen.CodeGen
import LlvmCodeGen.Data
import LlvmCodeGen.Ppr
import LlvmCodeGen.Regs
import LlvmMangler
import CgUtils ( fixStgRegisters )
......@@ -23,142 +24,173 @@ import DynFlags
import ErrUtils
import FastString
import Outputable