summaryrefslogtreecommitdiff
path: root/compiler/llvmGen
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/llvmGen')
-rw-r--r--compiler/llvmGen/Llvm.hs11
-rw-r--r--compiler/llvmGen/Llvm/AbsSyn.hs40
-rw-r--r--compiler/llvmGen/Llvm/MetaData.hs84
-rw-r--r--compiler/llvmGen/Llvm/PpLlvm.hs210
-rw-r--r--compiler/llvmGen/Llvm/Types.hs469
-rw-r--r--compiler/llvmGen/LlvmCodeGen.hs252
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Base.hs404
-rw-r--r--compiler/llvmGen/LlvmCodeGen/CodeGen.hs1175
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Data.hs155
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Ppr.hs85
-rw-r--r--compiler/llvmGen/LlvmCodeGen/Regs.hs55
11 files changed, 1599 insertions, 1341 deletions
diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs
index d69b88ce23..85095997ae 100644
--- a/compiler/llvmGen/Llvm.hs
+++ b/compiler/llvmGen/Llvm.hs
@@ -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
diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs
index f5f5eacdee..f92bd89c5c 100644
--- a/compiler/llvmGen/Llvm/AbsSyn.hs
+++ b/compiler/llvmGen/Llvm/AbsSyn.hs
@@ -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
@@ -253,6 +252,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.
* tp: type of the merged variable, must match the types of the
@@ -264,21 +274,21 @@ data LlvmExpression
{- |
Inline assembly expression. Syntax is very similar to the style used by GCC.
- * assembly: Actual inline assembly code.
- * contraints: Operand constraints.
- * return ty: Return type of function.
- * vars: Any variables involved in the assembly code.
- * sideeffect: Does the expression have side effects not visible from the
- constraints list.
- * alignstack: Should the stack be conservatively aligned before this
- expression is executed.
+ * assembly: Actual inline assembly code.
+ * constraints: Operand constraints.
+ * return ty: Return type of function.
+ * vars: Any variables involved in the assembly code.
+ * sideeffect: Does the expression have side effects not visible from the
+ constraints list.
+ * alignstack: Should the stack be conservatively aligned before this
+ expression is executed.
-}
| Asm LMString LMString LlvmType [LlvmVar] Bool Bool
{- |
A LLVM expression with metadata attached to it.
-}
- | MetaExpr [MetaData] LlvmExpression
+ | MExpr [MetaAnnot] LlvmExpression
- deriving (Show, Eq)
+ deriving (Eq)
diff --git a/compiler/llvmGen/Llvm/MetaData.hs b/compiler/llvmGen/Llvm/MetaData.hs
new file mode 100644
index 0000000000..dda3ca0c4c
--- /dev/null
+++ b/compiler/llvmGen/Llvm/MetaData.hs
@@ -0,0 +1,84 @@
+--------------------------------------------------------------------------------
+-- | 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
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index a709a05b7d..fca1a7cd4d 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -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 " = " <> 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 '!'
diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs
index 8b33c0b9dd..6b9c8c181a 100644
--- a/compiler/llvmGen/Llvm/Types.hs
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
--------------------------------------------------------------------------------
-- | The LLVM Type System.
--
@@ -8,12 +10,11 @@ module Llvm.Types where
import Data.Char
import Data.Int
-import Data.List (intercalate)
import Numeric
import DynFlags
import FastString
-import Outputable (panic)
+import Outputable
import Unique
-- from NCG
@@ -26,7 +27,11 @@ import GHC.Float
--
-- | A global mutable variable. Maybe defined or external
-type LMGlobal = (LlvmVar, Maybe LlvmStatic)
+data LMGlobal = LMGlobal {
+ getGlobalVar :: LlvmVar, -- ^ Returns the variable of the 'LMGlobal'
+ getGlobalValue :: Maybe LlvmStatic -- ^ Return the value of the 'LMGlobal'
+ }
+
-- | A String in LLVM
type LMString = FastString
@@ -47,76 +52,49 @@ data LlvmType
| LMVoid -- ^ Void type
| LMStruct [LlvmType] -- ^ Structure type
| LMAlias LlvmAlias -- ^ A type alias
+ | LMMetadata -- ^ LLVM Metadata
-- | Function type, used to create pointers to functions
| LMFunction LlvmFunctionDecl
deriving (Eq)
-instance Show LlvmType where
- show (LMInt size ) = "i" ++ show size
- show (LMFloat ) = "float"
- show (LMDouble ) = "double"
- show (LMFloat80 ) = "x86_fp80"
- show (LMFloat128 ) = "fp128"
- show (LMPointer x ) = show x ++ "*"
- show (LMArray nr tp ) = "[" ++ show nr ++ " x " ++ show tp ++ "]"
- show (LMVector nr tp ) = "<" ++ show nr ++ " x " ++ show tp ++ ">"
- show (LMLabel ) = "label"
- show (LMVoid ) = "void"
- show (LMStruct tys ) = "<{" ++ (commaCat tys) ++ "}>"
-
- show (LMFunction (LlvmFunctionDecl _ _ _ r varg p _))
- = let varg' = case varg of
- VarArgs | null args -> "..."
- | otherwise -> ", ..."
- _otherwise -> ""
- -- by default we don't print param attributes
- args = intercalate ", " $ map (show . fst) p
- in show r ++ " (" ++ args ++ varg' ++ ")"
-
- show (LMAlias (s,_)) = "%" ++ unpackFS s
-
--- | LLVM metadata values. Used for representing debug and optimization
--- information.
-data LlvmMetaVal
- -- | Metadata string
- = MetaStr LMString
- -- | Metadata node
- | MetaNode LlvmMetaUnamed
- -- | Normal value type as metadata
- | MetaVar LlvmVar
- deriving (Eq)
-
--- | LLVM metadata nodes.
-data LlvmMeta
- -- | Unamed metadata
- = MetaUnamed LlvmMetaUnamed [LlvmMetaVal]
- -- | Named metadata
- | MetaNamed LMString [LlvmMetaUnamed]
- deriving (Eq)
-
--- | Unamed metadata variable.
-newtype LlvmMetaUnamed = LMMetaUnamed Int
-
-instance Eq LlvmMetaUnamed where
- (==) (LMMetaUnamed n) (LMMetaUnamed m) = n == m
-
-instance Show LlvmMetaVal where
- show (MetaStr s) = "metadata !\"" ++ unpackFS s ++ "\""
- show (MetaNode n) = "metadata " ++ show n
- show (MetaVar v) = show v
-
-instance Show LlvmMetaUnamed where
- show (LMMetaUnamed u) = "!" ++ show u
-
-instance Show LlvmMeta where
- show (MetaUnamed m _) = show m
- show (MetaNamed m _) = "!" ++ unpackFS m
+instance Outputable LlvmType where
+ ppr (LMInt size ) = char 'i' <> ppr size
+ ppr (LMFloat ) = text "float"
+ ppr (LMDouble ) = text "double"
+ ppr (LMFloat80 ) = text "x86_fp80"
+ ppr (LMFloat128 ) = text "fp128"
+ ppr (LMPointer x ) = ppr x <> char '*'
+ ppr (LMArray nr tp ) = char '[' <> ppr nr <> text " x " <> ppr tp <> char ']'
+ ppr (LMVector nr tp ) = char '<' <> ppr nr <> text " x " <> ppr tp <> char '>'
+ ppr (LMLabel ) = text "label"
+ ppr (LMVoid ) = text "void"
+ ppr (LMStruct tys ) = text "<{" <> ppCommaJoin tys <> text "}>"
+ ppr (LMMetadata ) = text "metadata"
+
+ ppr (LMFunction (LlvmFunctionDecl _ _ _ r varg p _))
+ = ppr r <+> lparen <> ppParams varg p <> rparen
+
+ ppr (LMAlias (s,_)) = char '%' <> ftext s
+
+ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc
+ppParams varg p
+ = let varg' = case varg of
+ VarArgs | null args -> sLit "..."
+ | otherwise -> sLit ", ..."
+ _otherwise -> sLit ""
+ -- by default we don't print param attributes
+ args = map fst p
+ in ppCommaJoin args <> ptext varg'
-- | An LLVM section definition. If Nothing then let LLVM decide the section
type LMSection = Maybe LMString
type LMAlign = Maybe Int
-type LMConst = Bool -- ^ is a variable constant or not
+
+data LMConst = Global -- ^ Mutable global variable
+ | Constant -- ^ Constant global variable
+ | Alias -- ^ Alias of another variable
+ deriving (Eq)
-- | LLVM Variables
data LlvmVar
@@ -131,9 +109,9 @@ data LlvmVar
| LMLitVar LlvmLit
deriving (Eq)
-instance Show LlvmVar where
- show (LMLitVar x) = show x
- show (x ) = show (getVarType x) ++ " " ++ getName x
+instance Outputable LlvmVar where
+ ppr (LMLitVar x) = ppr x
+ ppr (x ) = ppr (getVarType x) <+> ppName x
-- | Llvm Literal Data.
@@ -152,9 +130,9 @@ data LlvmLit
| LMUndefLit LlvmType
deriving (Eq)
-instance Show LlvmLit where
- show l@(LMVectorLit {}) = getLit l
- show l = show (getLitType l) ++ " " ++ getLit l
+instance Outputable LlvmLit where
+ ppr l@(LMVectorLit {}) = ppLit l
+ ppr l = ppr (getLitType l) <+> ppLit l
-- | Llvm Static Data.
@@ -177,37 +155,33 @@ data LlvmStatic
| LMAdd LlvmStatic LlvmStatic -- ^ Constant addition operation
| LMSub LlvmStatic LlvmStatic -- ^ Constant subtraction operation
-instance Show LlvmStatic where
- show (LMComment s) = "; " ++ unpackFS s
- show (LMStaticLit l ) = show l
- show (LMUninitType t) = show t ++ " undef"
- show (LMStaticStr s t) = show t ++ " c\"" ++ unpackFS s ++ "\\00\""
- show (LMStaticArray d t) = show t ++ " [" ++ commaCat d ++ "]"
- show (LMStaticStruc d t) = show t ++ "<{" ++ commaCat d ++ "}>"
- show (LMStaticPointer v) = show v
- show (LMBitc v t)
- = show t ++ " bitcast (" ++ show v ++ " to " ++ show t ++ ")"
- show (LMPtoI v t)
- = show t ++ " ptrtoint (" ++ show v ++ " to " ++ show t ++ ")"
- show (LMAdd s1 s2)
- = let ty1 = getStatType s1
- op = if isFloat ty1 then " fadd (" else " add ("
- in if ty1 == getStatType s2
- then show ty1 ++ op ++ show s1 ++ "," ++ show s2 ++ ")"
- else error $ "LMAdd with different types! s1: "
- ++ show s1 ++ ", s2: " ++ show s2
- show (LMSub s1 s2)
- = let ty1 = getStatType s1
- op = if isFloat ty1 then " fsub (" else " sub ("
- in if ty1 == getStatType s2
- then show ty1 ++ op ++ show s1 ++ "," ++ show s2 ++ ")"
- else error $ "LMSub with different types! s1: "
- ++ show s1 ++ ", s2: " ++ show s2
-
-
--- | Concatenate an array together, separated by commas
-commaCat :: Show a => [a] -> String
-commaCat xs = intercalate ", " $ map show xs
+instance Outputable LlvmStatic where
+ ppr (LMComment s) = text "; " <> ftext s
+ ppr (LMStaticLit l ) = ppr l
+ ppr (LMUninitType t) = ppr t <> text " undef"
+ ppr (LMStaticStr s t) = ppr t <> text " c\"" <> ftext s <> text "\\00\""
+ ppr (LMStaticArray d t) = ppr t <> text " [" <> ppCommaJoin d <> char ']'
+ ppr (LMStaticStruc d t) = ppr t <> text "<{" <> ppCommaJoin d <> text "}>"
+ ppr (LMStaticPointer v) = ppr v
+ ppr (LMBitc v t)
+ = ppr t <> text " bitcast (" <> ppr v <> text " to " <> ppr t <> char ')'
+ ppr (LMPtoI v t)
+ = ppr t <> text " ptrtoint (" <> ppr v <> text " to " <> ppr t <> char ')'
+
+ ppr (LMAdd s1 s2)
+ = pprStaticArith s1 s2 (sLit "add") (sLit "fadd") "LMAdd"
+ ppr (LMSub s1 s2)
+ = pprStaticArith s1 s2 (sLit "sub") (sLit "fsub") "LMSub"
+
+pprStaticArith :: LlvmStatic -> LlvmStatic -> LitString -> LitString -> String -> SDoc
+pprStaticArith s1 s2 int_op float_op op_name =
+ let ty1 = getStatType s1
+ op = if isFloat ty1 then float_op else int_op
+ in if ty1 == getStatType s2
+ then ppr ty1 <+> ptext op <+> lparen <> ppr s1 <> comma <> ppr s2 <> rparen
+ else sdocWithDynFlags $ \dflags ->
+ error $ op_name ++ " with different types! s1: "
+ ++ showSDoc dflags (ppr s1) ++ ", s2: " ++ showSDoc dflags (ppr s2)
-- -----------------------------------------------------------------------------
-- ** Operations on LLVM Basic Types and Variables
@@ -215,33 +189,33 @@ commaCat xs = intercalate ", " $ map show xs
-- | Return the variable name or value of the 'LlvmVar'
-- in Llvm IR textual representation (e.g. @\@x@, @%y@ or @42@).
-getName :: LlvmVar -> String
-getName v@(LMGlobalVar _ _ _ _ _ _) = "@" ++ getPlainName v
-getName v@(LMLocalVar _ _ ) = "%" ++ getPlainName v
-getName v@(LMNLocalVar _ _ ) = "%" ++ getPlainName v
-getName v@(LMLitVar _ ) = getPlainName v
+ppName :: LlvmVar -> SDoc
+ppName v@(LMGlobalVar {}) = char '@' <> ppPlainName v
+ppName v@(LMLocalVar {}) = char '%' <> ppPlainName v
+ppName v@(LMNLocalVar {}) = char '%' <> ppPlainName v
+ppName v@(LMLitVar {}) = ppPlainName v
-- | Return the variable name or value of the 'LlvmVar'
-- in a plain textual representation (e.g. @x@, @y@ or @42@).
-getPlainName :: LlvmVar -> String
-getPlainName (LMGlobalVar x _ _ _ _ _) = unpackFS x
-getPlainName (LMLocalVar x LMLabel ) = show x
-getPlainName (LMLocalVar x _ ) = "l" ++ show x
-getPlainName (LMNLocalVar x _ ) = unpackFS x
-getPlainName (LMLitVar x ) = getLit x
+ppPlainName :: LlvmVar -> SDoc
+ppPlainName (LMGlobalVar x _ _ _ _ _) = ftext x
+ppPlainName (LMLocalVar x LMLabel ) = text (show x)
+ppPlainName (LMLocalVar x _ ) = text ('l' : show x)
+ppPlainName (LMNLocalVar x _ ) = ftext x
+ppPlainName (LMLitVar x ) = ppLit x
-- | Print a literal value. No type.
-getLit :: LlvmLit -> String
-getLit (LMIntLit i (LMInt 32)) = show (fromInteger i :: Int32)
-getLit (LMIntLit i (LMInt 64)) = show (fromInteger i :: Int64)
-getLit (LMIntLit i _ ) = show (fromInteger i :: Int)
--- See Note [LLVM Float Types].
-getLit (LMFloatLit r LMFloat ) = (dToStr . widenFp . narrowFp) r
-getLit (LMFloatLit r LMDouble) = dToStr r
-getLit f@(LMFloatLit _ _) = error $ "Can't print this float literal!" ++ show f
-getLit (LMVectorLit ls ) = "< " ++ commaCat ls ++ " >"
-getLit (LMNullLit _ ) = "null"
-getLit (LMUndefLit _ ) = "undef"
+ppLit :: LlvmLit -> SDoc
+ppLit (LMIntLit i (LMInt 32)) = ppr (fromInteger i :: Int32)
+ppLit (LMIntLit i (LMInt 64)) = ppr (fromInteger i :: Int64)
+ppLit (LMIntLit i _ ) = ppr ((fromInteger i)::Int)
+ppLit (LMFloatLit r LMFloat ) = ppFloat $ narrowFp r
+ppLit (LMFloatLit r LMDouble) = ppDouble r
+ppLit f@(LMFloatLit _ _) = sdocWithDynFlags (\dflags ->
+ error $ "Can't print this float literal!" ++ showSDoc dflags (ppr f))
+ppLit (LMVectorLit ls ) = char '<' <+> ppCommaJoin ls <+> char '>'
+ppLit (LMNullLit _ ) = text "null"
+ppLit (LMUndefLit _ ) = text "undef"
-- | Return the 'LlvmType' of the 'LlvmVar'
getVarType :: LlvmVar -> LlvmType
@@ -252,12 +226,12 @@ getVarType (LMLitVar l ) = getLitType l
-- | Return the 'LlvmType' of a 'LlvmLit'
getLitType :: LlvmLit -> LlvmType
-getLitType (LMIntLit _ t) = t
-getLitType (LMFloatLit _ t) = t
+getLitType (LMIntLit _ t) = t
+getLitType (LMFloatLit _ t) = t
getLitType (LMVectorLit []) = panic "getLitType"
getLitType (LMVectorLit ls) = LMVector (length ls) (getLitType (head ls))
-getLitType (LMNullLit t) = t
-getLitType (LMUndefLit t) = t
+getLitType (LMNullLit t) = t
+getLitType (LMUndefLit t) = t
-- | Return the 'LlvmType' of the 'LlvmStatic'
getStatType :: LlvmStatic -> LlvmType
@@ -273,14 +247,6 @@ getStatType (LMAdd t _) = getStatType t
getStatType (LMSub t _) = getStatType t
getStatType (LMComment _) = error "Can't call getStatType on LMComment!"
--- | Return the 'LlvmType' of the 'LMGlobal'
-getGlobalType :: LMGlobal -> LlvmType
-getGlobalType (v, _) = getVarType v
-
--- | Return the 'LlvmVar' part of a 'LMGlobal'
-getGlobalVar :: LMGlobal -> LlvmVar
-getGlobalVar (v, _) = v
-
-- | Return the 'LlvmLinkageType' for a 'LlvmVar'
getLink :: LlvmVar -> LlvmLinkageType
getLink (LMGlobalVar _ _ l _ _ _) = l
@@ -289,9 +255,10 @@ getLink _ = Internal
-- | Add a pointer indirection to the supplied type. 'LMLabel' and 'LMVoid'
-- cannot be lifted.
pLift :: LlvmType -> LlvmType
-pLift (LMLabel) = error "Labels are unliftable"
-pLift (LMVoid) = error "Voids are unliftable"
-pLift x = LMPointer x
+pLift LMLabel = error "Labels are unliftable"
+pLift LMVoid = error "Voids are unliftable"
+pLift LMMetadata = error "Metadatas are unliftable"
+pLift x = LMPointer x
-- | Lower a variable of 'LMPointer' type.
pVarLift :: LlvmVar -> LlvmVar
@@ -304,7 +271,7 @@ pVarLift (LMLitVar _ ) = error $ "Can't lower a literal type!"
-- constructors can be lowered.
pLower :: LlvmType -> LlvmType
pLower (LMPointer x) = x
-pLower x = error $ show x ++ " is a unlowerable type, need a pointer"
+pLower x = error $ showSDoc undefined (ppr x) ++ " is a unlowerable type, need a pointer"
-- | Lower a variable of 'LMPointer' type.
pVarLower :: LlvmVar -> LlvmVar
@@ -350,14 +317,17 @@ llvmWidthInBits _ (LMFloat80) = 80
llvmWidthInBits _ (LMFloat128) = 128
-- Could return either a pointer width here or the width of what
-- it points to. We will go with the former for now.
+-- PMW: At least judging by the way LLVM outputs constants, pointers
+-- should use the former, but arrays the latter.
llvmWidthInBits dflags (LMPointer _) = llvmWidthInBits dflags (llvmWord dflags)
-llvmWidthInBits dflags (LMArray _ _) = llvmWidthInBits dflags (llvmWord dflags)
+llvmWidthInBits dflags (LMArray n t) = n * llvmWidthInBits dflags t
llvmWidthInBits dflags (LMVector n ty) = n * llvmWidthInBits dflags ty
llvmWidthInBits _ LMLabel = 0
llvmWidthInBits _ LMVoid = 0
llvmWidthInBits dflags (LMStruct tys) = sum $ map (llvmWidthInBits dflags) tys
llvmWidthInBits _ (LMFunction _) = 0
llvmWidthInBits dflags (LMAlias (_,t)) = llvmWidthInBits dflags t
+llvmWidthInBits _ LMMetadata = panic "llvmWidthInBits: Meta-data has no runtime representation!"
-- -----------------------------------------------------------------------------
@@ -401,19 +371,13 @@ data LlvmFunctionDecl = LlvmFunctionDecl {
}
deriving (Eq)
-instance Show LlvmFunctionDecl where
- show (LlvmFunctionDecl n l c r varg p a)
- = let varg' = case varg of
- VarArgs | null args -> "..."
- | otherwise -> ", ..."
- _otherwise -> ""
- align = case a of
- Just a' -> " align " ++ show a'
- Nothing -> ""
- -- by default we don't print param attributes
- args = intercalate ", " $ map (show . fst) p
- in show l ++ " " ++ show c ++ " " ++ show r ++ " @" ++ unpackFS n ++
- "(" ++ args ++ varg' ++ ")" ++ align
+instance Outputable LlvmFunctionDecl where
+ ppr (LlvmFunctionDecl n l c r varg p a)
+ = let align = case a of
+ Just a' -> text " align " <> ppr a'
+ Nothing -> empty
+ in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <>
+ lparen <> ppParams varg p <> rparen <> align
type LlvmFunctionDecls = [LlvmFunctionDecl]
@@ -454,15 +418,15 @@ data LlvmParamAttr
| Nest
deriving (Eq)
-instance Show LlvmParamAttr where
- show ZeroExt = "zeroext"
- show SignExt = "signext"
- show InReg = "inreg"
- show ByVal = "byval"
- show SRet = "sret"
- show NoAlias = "noalias"
- show NoCapture = "nocapture"
- show Nest = "nest"
+instance Outputable LlvmParamAttr where
+ ppr ZeroExt = text "zeroext"
+ ppr SignExt = text "signext"
+ ppr InReg = text "inreg"
+ ppr ByVal = text "byval"
+ ppr SRet = text "sret"
+ ppr NoAlias = text "noalias"
+ ppr NoCapture = text "nocapture"
+ ppr Nest = text "nest"
-- | Llvm Function Attributes.
--
@@ -542,20 +506,20 @@ data LlvmFuncAttr
| Naked
deriving (Eq)
-instance Show LlvmFuncAttr where
- show AlwaysInline = "alwaysinline"
- show InlineHint = "inlinehint"
- show NoInline = "noinline"
- show OptSize = "optsize"
- show NoReturn = "noreturn"
- show NoUnwind = "nounwind"
- show ReadNone = "readnon"
- show ReadOnly = "readonly"
- show Ssp = "ssp"
- show SspReq = "ssqreq"
- show NoRedZone = "noredzone"
- show NoImplicitFloat = "noimplicitfloat"
- show Naked = "naked"
+instance Outputable LlvmFuncAttr where
+ ppr AlwaysInline = text "alwaysinline"
+ ppr InlineHint = text "inlinehint"
+ ppr NoInline = text "noinline"
+ ppr OptSize = text "optsize"
+ ppr NoReturn = text "noreturn"
+ ppr NoUnwind = text "nounwind"
+ ppr ReadNone = text "readnon"
+ ppr ReadOnly = text "readonly"
+ ppr Ssp = text "ssp"
+ ppr SspReq = text "ssqreq"
+ ppr NoRedZone = text "noredzone"
+ ppr NoImplicitFloat = text "noimplicitfloat"
+ ppr Naked = text "naked"
-- | Different types to call a function.
@@ -600,12 +564,12 @@ data LlvmCallConvention
| CC_X86_Stdcc
deriving (Eq)
-instance Show LlvmCallConvention where
- show CC_Ccc = "ccc"
- show CC_Fastcc = "fastcc"
- show CC_Coldcc = "coldcc"
- show (CC_Ncc i) = "cc " ++ show i
- show CC_X86_Stdcc = "x86_stdcallcc"
+instance Outputable LlvmCallConvention where
+ ppr CC_Ccc = text "ccc"
+ ppr CC_Fastcc = text "fastcc"
+ ppr CC_Coldcc = text "coldcc"
+ ppr (CC_Ncc i) = text "cc " <> ppr i
+ ppr CC_X86_Stdcc = text "x86_stdcallcc"
-- | Functions can have a fixed amount of parameters, or a variable amount.
@@ -659,20 +623,22 @@ data LlvmLinkageType
-- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM
-- assembly.
| External
+ -- | Symbol is private to the module and should not appear in the symbol table
+ | Private
deriving (Eq)
-instance Show LlvmLinkageType where
- show Internal = "internal"
- show LinkOnce = "linkonce"
- show Weak = "weak"
- show Appending = "appending"
- show ExternWeak = "extern_weak"
+instance Outputable LlvmLinkageType where
+ ppr Internal = text "internal"
+ ppr LinkOnce = text "linkonce"
+ ppr Weak = text "weak"
+ ppr Appending = text "appending"
+ ppr ExternWeak = text "extern_weak"
-- ExternallyVisible does not have a textual representation, it is
-- the linkage type a function resolves to if no other is specified
-- in Llvm.
- show ExternallyVisible = ""
- show External = "external"
-
+ ppr ExternallyVisible = empty
+ ppr External = text "external"
+ ppr Private = text "private"
-- -----------------------------------------------------------------------------
-- * LLVM Operations
@@ -709,25 +675,25 @@ data LlvmMachOp
| LM_MO_Xor -- ^ XOR bitwise logical operation.
deriving (Eq)
-instance Show LlvmMachOp where
- show LM_MO_Add = "add"
- show LM_MO_Sub = "sub"
- show LM_MO_Mul = "mul"
- show LM_MO_UDiv = "udiv"
- show LM_MO_SDiv = "sdiv"
- show LM_MO_URem = "urem"
- show LM_MO_SRem = "srem"
- show LM_MO_FAdd = "fadd"
- show LM_MO_FSub = "fsub"
- show LM_MO_FMul = "fmul"
- show LM_MO_FDiv = "fdiv"
- show LM_MO_FRem = "frem"
- show LM_MO_Shl = "shl"
- show LM_MO_LShr = "lshr"
- show LM_MO_AShr = "ashr"
- show LM_MO_And = "and"
- show LM_MO_Or = "or"
- show LM_MO_Xor = "xor"
+instance Outputable LlvmMachOp where
+ ppr LM_MO_Add = text "add"
+ ppr LM_MO_Sub = text "sub"
+ ppr LM_MO_Mul = text "mul"
+ ppr LM_MO_UDiv = text "udiv"
+ ppr LM_MO_SDiv = text "sdiv"
+ ppr LM_MO_URem = text "urem"
+ ppr LM_MO_SRem = text "srem"
+ ppr LM_MO_FAdd = text "fadd"
+ ppr LM_MO_FSub = text "fsub"
+ ppr LM_MO_FMul = text "fmul"
+ ppr LM_MO_FDiv = text "fdiv"
+ ppr LM_MO_FRem = text "frem"
+ ppr LM_MO_Shl = text "shl"
+ ppr LM_MO_LShr = text "lshr"
+ ppr LM_MO_AShr = text "ashr"
+ ppr LM_MO_And = text "and"
+ ppr LM_MO_Or = text "or"
+ ppr LM_MO_Xor = text "xor"
-- | Llvm compare operations.
@@ -753,23 +719,23 @@ data LlvmCmpOp
| LM_CMP_Fle -- ^ Float less than or equal
deriving (Eq)
-instance Show LlvmCmpOp where
- show LM_CMP_Eq = "eq"
- show LM_CMP_Ne = "ne"
- show LM_CMP_Ugt = "ugt"
- show LM_CMP_Uge = "uge"
- show LM_CMP_Ult = "ult"
- show LM_CMP_Ule = "ule"
- show LM_CMP_Sgt = "sgt"
- show LM_CMP_Sge = "sge"
- show LM_CMP_Slt = "slt"
- show LM_CMP_Sle = "sle"
- show LM_CMP_Feq = "oeq"
- show LM_CMP_Fne = "une"
- show LM_CMP_Fgt = "ogt"
- show LM_CMP_Fge = "oge"
- show LM_CMP_Flt = "olt"
- show LM_CMP_Fle = "ole"
+instance Outputable LlvmCmpOp where
+ ppr LM_CMP_Eq = text "eq"
+ ppr LM_CMP_Ne = text "ne"
+ ppr LM_CMP_Ugt = text "ugt"
+ ppr LM_CMP_Uge = text "uge"
+ ppr LM_CMP_Ult = text "ult"
+ ppr LM_CMP_Ule = text "ule"
+ ppr LM_CMP_Sgt = text "sgt"
+ ppr LM_CMP_Sge = text "sge"
+ ppr LM_CMP_Slt = text "slt"
+ ppr LM_CMP_Sle = text "sle"
+ ppr LM_CMP_Feq = text "oeq"
+ ppr LM_CMP_Fne = text "une"
+ ppr LM_CMP_Fgt = text "ogt"
+ ppr LM_CMP_Fge = text "oge"
+ ppr LM_CMP_Flt = text "olt"
+ ppr LM_CMP_Fle = text "ole"
-- | Llvm cast operations.
@@ -788,19 +754,19 @@ data LlvmCastOp
| LM_Bitcast -- ^ Cast between types where no bit manipulation is needed
deriving (Eq)
-instance Show LlvmCastOp where
- show LM_Trunc = "trunc"
- show LM_Zext = "zext"
- show LM_Sext = "sext"
- show LM_Fptrunc = "fptrunc"
- show LM_Fpext = "fpext"
- show LM_Fptoui = "fptoui"
- show LM_Fptosi = "fptosi"
- show LM_Uitofp = "uitofp"
- show LM_Sitofp = "sitofp"
- show LM_Ptrtoint = "ptrtoint"
- show LM_Inttoptr = "inttoptr"
- show LM_Bitcast = "bitcast"
+instance Outputable LlvmCastOp where
+ ppr LM_Trunc = text "trunc"
+ ppr LM_Zext = text "zext"
+ ppr LM_Sext = text "sext"
+ ppr LM_Fptrunc = text "fptrunc"
+ ppr LM_Fpext = text "fpext"
+ ppr LM_Fptoui = text "fptoui"
+ ppr LM_Fptosi = text "fptosi"
+ ppr LM_Uitofp = text "uitofp"
+ ppr LM_Sitofp = text "sitofp"
+ ppr LM_Ptrtoint = text "ptrtoint"
+ ppr LM_Inttoptr = text "inttoptr"
+ ppr LM_Bitcast = text "bitcast"
-- -----------------------------------------------------------------------------
@@ -812,8 +778,8 @@ instance Show LlvmCastOp where
-- regardless of underlying architecture.
--
-- See Note [LLVM Float Types].
-dToStr :: Double -> String
-dToStr d
+ppDouble :: Double -> SDoc
+ppDouble d
= let bs = doubleToBytes d
hex d' = case showHex d' "" of
[] -> error "dToStr: too few hex digits for float"
@@ -821,12 +787,12 @@ dToStr d
[x,y] -> [x,y]
_ -> error "dToStr: too many hex digits for float"
- str = map toUpper $ concat . fixEndian . (map hex) $ bs
- in "0x" ++ str
+ str = map toUpper $ concat $ fixEndian $ map hex bs
+ in text "0x" <> text str
-- Note [LLVM Float Types]
-- ~~~~~~~~~~~~~~~~~~~~~~~
--- We use 'dToStr' for both printing Float and Double floating point types. This is
+-- We use 'ppDouble' for both printing Float and Double floating point types. This is
-- as LLVM expects all floating point constants (single & double) to be in IEEE
-- 754 Double precision format. However, for single precision numbers (Float)
-- they should be *representable* in IEEE 754 Single precision format. So the
@@ -849,6 +815,9 @@ widenFp :: Float -> Double
{-# NOINLINE widenFp #-}
widenFp = float2Double
+ppFloat :: Float -> SDoc
+ppFloat = ppDouble . widenFp
+
-- | Reverse or leave byte data alone to fix endianness on this target.
fixEndian :: [a] -> [a]
#ifdef WORDS_BIGENDIAN
@@ -857,3 +826,13 @@ fixEndian = id
fixEndian = reverse
#endif
+
+--------------------------------------------------------------------------------
+-- * Misc functions
+--------------------------------------------------------------------------------
+
+ppCommaJoin :: (Outputable a) => [a] -> SDoc
+ppCommaJoin strs = hsep $ punctuate comma (map ppr strs)
+
+ppSpaceJoin :: (Outputable a) => [a] -> SDoc
+ppSpaceJoin strs = hsep (map ppr strs)
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index a157a258fe..d0f343fa92 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -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
-import qualified Pretty as Prt
import UniqSupply
-import Util
import SysTools ( figureLlvmVersion )
+import qualified Stream
import Control.Monad ( when )
import Data.IORef ( writeIORef )
-import Data.Maybe ( fromMaybe )
+import Data.Maybe ( fromMaybe, catMaybes )
import System.IO
-- -----------------------------------------------------------------------------
-- | Top-level of the LLVM Code generator
--
-llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
-llvmCodeGen dflags h us cmms
- = let cmm = concat cmms
- (cdata,env) = {-# SCC "llvm_split" #-}
- foldr split ([], initLlvmEnv dflags) cmm
- split (CmmData s d' ) (d,e) = ((s,d'):d,e)
- split (CmmProc h l live g) (d,e) =
- let lbl = strCLabel_llvm env $
- case mapLookup (g_entry g) h of
- Nothing -> l
- Just (Statics info_lbl _) -> info_lbl
- env' = funInsert lbl (llvmFunTy dflags live) e
- in (d,env')
- in do
- showPass dflags "LlVM CodeGen"
- dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" pprLlvmHeader
- bufh <- newBufHandle h
- Prt.bufLeftRender bufh $ withPprStyleDoc dflags (mkCodeStyle CStyle) pprLlvmHeader
- ver <- getLlvmVersion
- env' <- {-# SCC "llvm_datas_gen" #-}
- cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
- {-# SCC "llvm_procs_gen" #-}
- cmmProcLlvmGens dflags bufh us env' cmm 1 []
- bFlush bufh
- return ()
-
- where
- -- | Handle setting up the LLVM version.
- getLlvmVersion = do
- ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
- -- cache llvm version for later use
- writeIORef (llvmVersion dflags) ver
- debugTraceMsg dflags 2
- (text "Using LLVM version:" <+> text (show ver))
- let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
- when (ver < minSupportLlvmVersion && doWarn) $
- errorMsg dflags (text "You are using an old version of LLVM that"
- <> text " isn't supported anymore!"
- $+$ text "We will try though...")
- when (ver > maxSupportLlvmVersion && doWarn) $
- putMsg dflags (text "You are using a new version of LLVM that"
- <> text " hasn't been tested yet!"
- $+$ text "We will try though...")
- return ver
+llvmCodeGen :: DynFlags -> Handle -> UniqSupply
+ -> Stream.Stream IO RawCmmGroup ()
+ -> IO ()
+llvmCodeGen dflags h us cmm_stream
+ = do bufh <- newBufHandle h
+
+ -- Pass header
+ showPass dflags "LLVM CodeGen"
+ -- get llvm version, cache for later use
+ ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
+ writeIORef (llvmVersion dflags) ver
+
+ -- warn if unsupported
+ debugTraceMsg dflags 2
+ (text "Using LLVM version:" <+> text (show ver))
+ let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags
+ when (ver < minSupportLlvmVersion && doWarn) $
+ errorMsg dflags (text "You are using an old version of LLVM that"
+ <> text " isn't supported anymore!"
+ $+$ text "We will try though...")
+ when (ver > maxSupportLlvmVersion && doWarn) $
+ putMsg dflags (text "You are using a new version of LLVM that"
+ <> text " hasn't been tested yet!"
+ $+$ text "We will try though...")
+
+ -- run code generation
+ runLlvm dflags ver bufh us $
+ llvmCodeGen' (liftStream cmm_stream)
+
+ bFlush bufh
+
+llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM ()
+llvmCodeGen' cmm_stream
+ = do -- Preamble
+ renderLlvm pprLlvmHeader
+ ghcInternalFunctions
+ cmmMetaLlvmPrelude
+
+ -- Procedures
+ let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream
+ _ <- Stream.collect llvmStream
+
+ -- Declare aliases for forward references
+ renderLlvm . pprLlvmData =<< generateAliases
+
+ -- Postamble
+ cmmUsedLlvmGens
+
+llvmGroupLlvmGens :: RawCmmGroup -> LlvmM ()
+llvmGroupLlvmGens cmm = do
+
+ -- Insert functions into map, collect data
+ let split (CmmData s d' ) = return $ Just (s, d')
+ split (CmmProc h l live g) = do
+ -- Set function type
+ let l' = case mapLookup (g_entry g) h of
+ Nothing -> l
+ Just (Statics info_lbl _) -> info_lbl
+ lml <- strCLabel_llvm l'
+ funInsert lml =<< llvmFunTy live
+ return Nothing
+ cdata <- fmap catMaybes $ mapM split cmm
+
+ {-# SCC "llvm_datas_gen" #-}
+ cmmDataLlvmGens cdata
+ {-# SCC "llvm_procs_gen" #-}
+ mapM_ cmmLlvmGen cmm
-- -----------------------------------------------------------------------------
-- | Do LLVM code generation on all these Cmms data sections.
--
-cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)]
- -> [LlvmUnresData] -> IO ( LlvmEnv )
-
-cmmDataLlvmGens dflags h env [] lmdata
- = let (env', lmdata') = {-# SCC "llvm_resolve" #-}
- resolveLlvmDatas env lmdata
- lmdoc = {-# SCC "llvm_data_ppr" #-}
- vcat $ map pprLlvmData lmdata'
- in do
- dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" lmdoc
- {-# SCC "llvm_data_out" #-}
- Prt.bufLeftRender h $ withPprStyleDoc dflags (mkCodeStyle CStyle) lmdoc
- return env'
-
-cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
- = let lm@(l, _, ty, _) = {-# SCC "llvm_data_gen" #-}
- genLlvmData env cmm
- env' = {-# SCC "llvm_data_insert" #-}
- funInsert (strCLabel_llvm env l) ty env
- lmdata' = {-# SCC "llvm_data_append" #-}
- lm:lmdata
- in cmmDataLlvmGens dflags h env' cmms lmdata'
+cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM ()
+cmmDataLlvmGens statics
+ = do lmdatas <- mapM genLlvmData statics
--- -----------------------------------------------------------------------------
--- | Do LLVM code generation on all these Cmms procs.
---
-cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmDecl]
- -> Int -- ^ count, used for generating unique subsections
- -> [[LlvmVar]] -- ^ info tables that need to be marked as 'used'
- -> IO ()
-
-cmmProcLlvmGens _ _ _ _ [] _ []
- = return ()
-
-cmmProcLlvmGens dflags h _ _ [] _ ivars
- = let ivars' = concat ivars
- cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
- ty = (LMArray (length ivars') i8Ptr)
- usedArray = LMStaticArray (map cast ivars') ty
- lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
- (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray)
- in Prt.bufLeftRender h $ {-# SCC "llvm_used_ppr" #-}
- withPprStyleDoc dflags (mkCodeStyle CStyle) $
- pprLlvmData ([lmUsed], [])
-
-cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
- = cmmProcLlvmGens dflags h us env cmms count ivars
-
-cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do
- (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
- let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
- Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-}
- withPprStyleDoc dflags (mkCodeStyle CStyle) $ vcat docs
- cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
+ let (gss, tss) = unzip lmdatas
+ let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _)
+ = funInsert l ty
+ regGlobal _ = return ()
+ mapM_ regGlobal (concat gss)
+
+ renderLlvm $ pprLlvmData (concat gss, concat tss)
-- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
-cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmDecl
- -> IO ( UniqSupply, LlvmEnv, [LlvmCmmDecl] )
-cmmLlvmGen dflags us env cmm = do
+cmmLlvmGen ::RawCmmDecl -> LlvmM ()
+cmmLlvmGen cmm@CmmProc{} = do
+
-- rewrite assignments to global regs
+ dflags <- getDynFlag id
let fixed_cmm = {-# SCC "llvm_fix_regs" #-}
fixStgRegisters dflags cmm
- dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
- (pprCmmGroup [fixed_cmm])
+ dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])
-- generate llvm code from cmm
- let ((env', llvmBC), usGen) = {-# SCC "llvm_proc_gen" #-}
- initUs us $ genLlvmProc env fixed_cmm
+ llvmBC <- withClearVars $ genLlvmProc fixed_cmm
- dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
- (vcat $ map (fst . pprLlvmCmmDecl env' 0) llvmBC)
+ -- allocate IDs for info table and code, so the mangler can later
+ -- make sure they end up next to each other.
+ itableSection <- freshSectionId
+ _codeSection <- freshSectionId
- return (usGen, env', llvmBC)
+ -- pretty print
+ (docs, ivars) <- fmap unzip $ mapM (pprLlvmCmmDecl itableSection) llvmBC
+
+ -- Output, note down used variables
+ renderLlvm (vcat docs)
+ mapM_ markUsedVar $ concat ivars
+
+cmmLlvmGen _ = return ()
+
+-- -----------------------------------------------------------------------------
+-- | Generate meta data nodes
+--
+
+cmmMetaLlvmPrelude :: LlvmM ()
+cmmMetaLlvmPrelude = do
+ metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do
+ -- Generate / lookup meta data IDs
+ tbaaId <- getMetaUniqueId
+ setUniqMeta uniq tbaaId
+ parentId <- maybe (return Nothing) getUniqMeta parent
+ -- Build definition
+ return $ MetaUnamed tbaaId $ MetaStruct
+ [ MetaStr name
+ , case parentId of
+ Just p -> MetaNode p
+ Nothing -> MetaVar $ LMLitVar $ LMNullLit i8Ptr
+ ]
+ renderLlvm $ ppLlvmMetas metas
+
+-- -----------------------------------------------------------------------------
+-- | Marks variables as used where necessary
+--
+cmmUsedLlvmGens :: LlvmM ()
+cmmUsedLlvmGens = do
+
+ -- LLVM would discard variables that are internal and not obviously
+ -- used if we didn't provide these hints. This will generate a
+ -- definition of the form
+ --
+ -- @llvm.used = appending global [42 x i8*] [i8* bitcast <var> to i8*, ...]
+ --
+ -- Which is the LLVM way of protecting them against getting removed.
+ ivars <- getUsedVars
+ let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
+ ty = (LMArray (length ivars) i8Ptr)
+ usedArray = LMStaticArray (map cast ivars) ty
+ sectName = Just $ fsLit "llvm.metadata"
+ lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant
+ lmUsed = LMGlobal lmUsedVar (Just usedArray)
+ if null ivars
+ then return ()
+ else renderLlvm $ pprLlvmData ([lmUsed], [])
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index bcfce3401e..dda2c9e05b 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -13,15 +13,23 @@ module LlvmCodeGen.Base (
LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion,
maxSupportLlvmVersion,
- LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert,
- funLookup, funInsert, getLlvmVer, setLlvmVer, getLlvmPlatform,
- getDflags, ghcInternalFunctions,
+ LlvmM,
+ runLlvm, liftStream, withClearVars, varLookup, varInsert,
+ markStackReg, checkStackReg,
+ funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,
+ dumpIfSetLlvm, renderLlvm, runUs, markUsedVar, getUsedVars,
+ ghcInternalFunctions,
+
+ getMetaUniqueId,
+ setUniqMeta, getUniqMeta,
+ freshSectionId,
cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
llvmPtrBits, mkLlvmFunc, tysToParams,
- strCLabel_llvm, genCmmLabelRef, genStringLabelRef
+ strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
+ getGlobalPtr, generateAliases,
) where
@@ -36,9 +44,15 @@ import DynFlags
import FastString
import Cmm
import qualified Outputable as Outp
+import qualified Pretty as Prt
import Platform
import UniqFM
import Unique
+import BufWrite ( BufHandle )
+import UniqSet
+import UniqSupply
+import ErrUtils
+import qualified Stream
-- ----------------------------------------------------------------------------
-- * Some Data Types
@@ -93,30 +107,32 @@ llvmGhcCC dflags
| otherwise = CC_Ncc 10
-- | Llvm Function type for Cmm function
-llvmFunTy :: DynFlags -> LiveGlobalRegs -> LlvmType
-llvmFunTy dflags live = LMFunction $ llvmFunSig' dflags live (fsLit "a") ExternallyVisible
+llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
+llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible
-- | Llvm Function signature
-llvmFunSig :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl
-llvmFunSig env live lbl link
- = llvmFunSig' (getDflags env) live (strCLabel_llvm env lbl) link
-
-llvmFunSig' :: DynFlags -> LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmFunctionDecl
-llvmFunSig' dflags live lbl link
- = let toParams x | isPointer x = (x, [NoAlias, NoCapture])
- | otherwise = (x, [])
- in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
- (map (toParams . getVarType) (llvmFunArgs dflags live))
- (llvmFunAlign dflags)
+llvmFunSig :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
+llvmFunSig live lbl link = do
+ lbl' <- strCLabel_llvm lbl
+ llvmFunSig' live lbl' link
+
+llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
+llvmFunSig' live lbl link
+ = do let toParams x | isPointer x = (x, [NoAlias, NoCapture])
+ | otherwise = (x, [])
+ dflags <- getDynFlags
+ return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
+ (map (toParams . getVarType) (llvmFunArgs dflags live))
+ (llvmFunAlign dflags)
-- | Create a Haskell function in LLVM.
-mkLlvmFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
- -> LlvmFunction
-mkLlvmFunc env live lbl link sec blks
- = let dflags = getDflags env
- funDec = llvmFunSig env live lbl link
- funArgs = map (fsLit . getPlainName) (llvmFunArgs dflags live)
- in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
+mkLlvmFunc :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
+ -> LlvmM LlvmFunction
+mkLlvmFunc live lbl link sec blks
+ = do funDec <- llvmFunSig live lbl link
+ dflags <- getDynFlags
+ let funArgs = map (fsLit . Outp.showSDoc dflags . ppPlainName) (llvmFunArgs dflags live)
+ return $ LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
-- | Alignment to use for functions
llvmFunAlign :: DynFlags -> LMAlign
@@ -166,102 +182,292 @@ minSupportLlvmVersion :: LlvmVersion
minSupportLlvmVersion = 28
maxSupportLlvmVersion :: LlvmVersion
-maxSupportLlvmVersion = 33
+maxSupportLlvmVersion = 34
-- ----------------------------------------------------------------------------
-- * Environment Handling
--
--- two maps, one for functions and one for local vars.
-newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, DynFlags)
+data LlvmEnv = LlvmEnv
+ { envVersion :: LlvmVersion -- ^ LLVM version
+ , envDynFlags :: DynFlags -- ^ Dynamic flags
+ , envOutput :: BufHandle -- ^ Output buffer
+ , envUniq :: UniqSupply -- ^ Supply of unique values
+ , envNextSection :: Int -- ^ Supply of fresh section IDs
+ , envFreshMeta :: Int -- ^ Supply of fresh metadata IDs
+ , envUniqMeta :: UniqFM Int -- ^ Global metadata nodes
+ , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type
+ , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]
+ , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)
+
+ -- the following get cleared for every function (see @withClearVars@)
+ , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type
+ , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude)
+ }
type LlvmEnvMap = UniqFM LlvmType
--- | Get initial Llvm environment.
-initLlvmEnv :: DynFlags -> LlvmEnv
-initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags)
- where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions dflags ]
+-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
+newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
+instance Monad LlvmM where
+ return x = LlvmM $ \env -> return (x, env)
+ m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env
+ runLlvmM (f x) env'
+instance Functor LlvmM where
+ fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env
+ return (f x, env')
--- | Here we pre-initialise some functions that are used internally by GHC
--- so as to make sure they have the most general type in the case that
--- user code also uses these functions but with a different type than GHC
--- internally. (Main offender is treating return type as 'void' instead of
--- 'void *'. Fixes trac #5486.
-ghcInternalFunctions :: DynFlags -> [(LMString, LlvmFunctionDecl)]
-ghcInternalFunctions dflags =
- [ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
- , mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
- , mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags]
- , mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]
- ]
- where
- mk n ret args =
- let n' = fsLit n
- in (n', LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
- FixedArgs (tysToParams args) Nothing)
-
--- | Clear variables from the environment.
-clearVars :: LlvmEnv -> LlvmEnv
-clearVars (LlvmEnv (e1, _, n, p)) = {-# SCC "llvm_env_clear" #-}
- LlvmEnv (e1, emptyUFM, n, p)
-
--- | Insert local variables into the environment.
-varInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
-varInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_vinsert" #-}
- LlvmEnv (e1, addToUFM e2 s t, n, p)
-
--- | Insert functions into the environment.
-funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
-funInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_finsert" #-}
- LlvmEnv (addToUFM e1 s t, e2, n, p)
-
--- | Lookup local variables in the environment.
-varLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
-varLookup s (LlvmEnv (_, e2, _, _)) = {-# SCC "llvm_env_vlookup" #-}
- lookupUFM e2 s
-
--- | Lookup functions in the environment.
-funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
-funLookup s (LlvmEnv (e1, _, _, _)) = {-# SCC "llvm_env_flookup" #-}
- lookupUFM e1 s
+instance HasDynFlags LlvmM where
+ getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)
+
+-- | Lifting of IO actions. Not exported, as we want to encapsulate IO.
+liftIO :: IO a -> LlvmM a
+liftIO m = LlvmM $ \env -> do x <- m
+ return (x, env)
+
+-- | Get initial Llvm environment.
+runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO ()
+runLlvm dflags ver out us m = do
+ _ <- runLlvmM m env
+ return ()
+ where env = LlvmEnv { envFunMap = emptyUFM
+ , envVarMap = emptyUFM
+ , envStackRegs = []
+ , envUsedVars = []
+ , envAliases = emptyUniqSet
+ , envVersion = ver
+ , envDynFlags = dflags
+ , envOutput = out
+ , envUniq = us
+ , envFreshMeta = 0
+ , envUniqMeta = emptyUFM
+ , envNextSection = 1
+ }
+
+-- | Get environment (internal)
+getEnv :: (LlvmEnv -> a) -> LlvmM a
+getEnv f = LlvmM (\env -> return (f env, env))
+
+-- | Modify environment (internal)
+modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()
+modifyEnv f = LlvmM (\env -> return ((), f env))
+
+-- | Lift a stream into the LlvmM monad
+liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x
+liftStream s = Stream.Stream $ do
+ r <- liftIO $ Stream.runStream s
+ case r of
+ Left b -> return (Left b)
+ Right (a, r2) -> return (Right (a, liftStream r2))
+
+-- | Clear variables from the environment for a subcomputation
+withClearVars :: LlvmM a -> LlvmM a
+withClearVars m = LlvmM $ \env -> do
+ (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] }
+ return (x, env' { envVarMap = emptyUFM, envStackRegs = [] })
+
+-- | Insert variables or functions into the environment.
+varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM ()
+varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t }
+funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t }
+
+-- | Lookup variables or functions in the environment.
+varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)
+varLookup s = getEnv (flip lookupUFM s . envVarMap)
+funLookup s = getEnv (flip lookupUFM s . envFunMap)
+
+-- | Set a register as allocated on the stack
+markStackReg :: GlobalReg -> LlvmM ()
+markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env }
+
+-- | Check whether a register is allocated on the stack
+checkStackReg :: GlobalReg -> LlvmM Bool
+checkStackReg r = getEnv ((elem r) . envStackRegs)
+
+-- | Allocate a new global unnamed metadata identifier
+getMetaUniqueId :: LlvmM Int
+getMetaUniqueId = LlvmM $ \env -> return (envFreshMeta env, env { envFreshMeta = envFreshMeta env + 1})
-- | Get the LLVM version we are generating code for
-getLlvmVer :: LlvmEnv -> LlvmVersion
-getLlvmVer (LlvmEnv (_, _, n, _)) = n
+getLlvmVer :: LlvmM LlvmVersion
+getLlvmVer = getEnv envVersion
--- | Set the LLVM version we are generating code for
-setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv
-setLlvmVer n (LlvmEnv (e1, e2, _, p)) = LlvmEnv (e1, e2, n, p)
+-- | Get the platform we are generating code for
+getDynFlag :: (DynFlags -> a) -> LlvmM a
+getDynFlag f = getEnv (f . envDynFlags)
-- | Get the platform we are generating code for
-getLlvmPlatform :: LlvmEnv -> Platform
-getLlvmPlatform (LlvmEnv (_, _, _, d)) = targetPlatform d
+getLlvmPlatform :: LlvmM Platform
+getLlvmPlatform = getDynFlag targetPlatform
+
+-- | Dumps the document if the corresponding flag has been set by the user
+dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM ()
+dumpIfSetLlvm flag hdr doc = do
+ dflags <- getDynFlags
+ liftIO $ dumpIfSet_dyn dflags flag hdr doc
+
+-- | Prints the given contents to the output handle
+renderLlvm :: Outp.SDoc -> LlvmM ()
+renderLlvm sdoc = do
+
+ -- Write to output
+ dflags <- getDynFlags
+ out <- getEnv envOutput
+ let doc = Outp.withPprStyleDoc dflags (Outp.mkCodeStyle Outp.CStyle) sdoc
+ liftIO $ Prt.bufLeftRender out doc
+
+ -- Dump, if requested
+ dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc
+ return ()
+
+-- | Run a @UniqSM@ action with our unique supply
+runUs :: UniqSM a -> LlvmM a
+runUs m = LlvmM $ \env -> do
+ let (x, us') = initUs (envUniq env) m
+ return (x, env { envUniq = us' })
+
+-- | Marks a variable as "used"
+markUsedVar :: LlvmVar -> LlvmM ()
+markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env }
+
+-- | Return all variables marked as "used" so far
+getUsedVars :: LlvmM [LlvmVar]
+getUsedVars = getEnv envUsedVars
+
+-- | Saves that at some point we didn't know the type of the label and
+-- generated a reference to a type variable instead
+saveAlias :: LMString -> LlvmM ()
+saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl }
+
+-- | Sets metadata node for a given unique
+setUniqMeta :: Unique -> Int -> LlvmM ()
+setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m }
+-- | Gets metadata node for given unique
+getUniqMeta :: Unique -> LlvmM (Maybe Int)
+getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)
+
+-- | Returns a fresh section ID
+freshSectionId :: LlvmM Int
+freshSectionId = LlvmM $ \env -> return (envNextSection env, env { envNextSection = envNextSection env + 1})
+
+-- ----------------------------------------------------------------------------
+-- * Internal functions
+--
--- | Get the DynFlags for this compilation pass
-getDflags :: LlvmEnv -> DynFlags
-getDflags (LlvmEnv (_, _, _, d)) = d
+-- | Here we pre-initialise some functions that are used internally by GHC
+-- so as to make sure they have the most general type in the case that
+-- user code also uses these functions but with a different type than GHC
+-- internally. (Main offender is treating return type as 'void' instead of
+-- 'void *'). Fixes trac #5486.
+ghcInternalFunctions :: LlvmM ()
+ghcInternalFunctions = do
+ dflags <- getDynFlags
+ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
+ mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
+ mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags]
+ mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]
+ where
+ mk n ret args = do
+ let n' = fsLit n
+ decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
+ FixedArgs (tysToParams args) Nothing
+ renderLlvm $ ppLlvmFunctionDecl decl
+ funInsert n' (LMFunction decl)
-- ----------------------------------------------------------------------------
-- * Label handling
--
-- | Pretty print a 'CLabel'.
-strCLabel_llvm :: LlvmEnv -> CLabel -> LMString
-strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-}
- (fsLit . toString . pprCLabel (getLlvmPlatform env)) l
- where dflags = getDflags env
- style = Outp.mkCodeStyle Outp.CStyle
- toString doc = Outp.renderWithStyle dflags doc style
-
--- | Create an external definition for a 'CLabel' defined in another module.
-genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal
-genCmmLabelRef env = genStringLabelRef (getDflags env) . strCLabel_llvm env
-
--- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'.
-genStringLabelRef :: DynFlags -> LMString -> LMGlobal
-genStringLabelRef dflags cl
- = let ty = LMPointer $ LMArray 0 (llvmWord dflags)
- in (LMGlobalVar cl ty External Nothing Nothing False, Nothing)
+strCLabel_llvm :: CLabel -> LlvmM LMString
+strCLabel_llvm lbl = do
+ platform <- getLlvmPlatform
+ dflags <- getDynFlags
+ let sdoc = pprCLabel platform lbl
+ str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle)
+ return (fsLit str)
+
+strDisplayName_llvm :: CLabel -> LlvmM LMString
+strDisplayName_llvm lbl = do
+ platform <- getLlvmPlatform
+ dflags <- getDynFlags
+ let sdoc = pprCLabel platform lbl
+ depth = Outp.PartWay 1
+ style = Outp.mkUserStyle (const Outp.NameNotInScope2, const True) depth
+ str = Outp.renderWithStyle dflags sdoc style
+ return (fsLit (dropInfoSuffix str))
+
+dropInfoSuffix :: String -> String
+dropInfoSuffix = go
+ where go "_info" = []
+ go "_static_info" = []
+ go "_con_info" = []
+ go (x:xs) = x:go xs
+ go [] = []
+
+strProcedureName_llvm :: CLabel -> LlvmM LMString
+strProcedureName_llvm lbl = do
+ platform <- getLlvmPlatform
+ dflags <- getDynFlags
+ let sdoc = pprCLabel platform lbl
+ depth = Outp.PartWay 1
+ style = Outp.mkUserStyle (const Outp.NameUnqual, const False) depth
+ str = Outp.renderWithStyle dflags sdoc style
+ return (fsLit str)
+
+-- ----------------------------------------------------------------------------
+-- * Global variables / forward references
+--
+
+-- | Create/get a pointer to a global value. Might return an alias if
+-- the value in question hasn't been defined yet. We especially make
+-- no guarantees on the type of the returned pointer.
+getGlobalPtr :: LMString -> LlvmM LlvmVar
+getGlobalPtr llvmLbl = do
+ m_ty <- funLookup llvmLbl
+ let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing
+ case m_ty of
+ -- Directly reference if we have seen it already
+ Just ty -> return $ mkGlbVar llvmLbl ty Global
+ -- Otherwise use a forward alias of it
+ Nothing -> do
+ saveAlias llvmLbl
+ return $ mkGlbVar (llvmLbl `appendFS` fsLit "$alias") i8 Alias
+
+-- | Generate definitions for aliases forward-referenced by @getGlobalPtr@.
+--
+-- Must be called at a point where we are sure that no new global definitions
+-- will be generated anymore!
+generateAliases :: LlvmM ([LMGlobal], [LlvmType])
+generateAliases = do
+ delayed <- fmap uniqSetToList $ getEnv envAliases
+ defss <- flip mapM delayed $ \lbl -> do
+ let var ty = LMGlobalVar lbl (LMPointer ty) External Nothing Nothing Global
+ aliasLbl = lbl `appendFS` fsLit "$alias"
+ aliasVar = LMGlobalVar aliasLbl i8Ptr Private Nothing Nothing Alias
+ -- If we have a definition, set the alias value using a
+ -- cost. Otherwise, declare it as an undefined external symbol.
+ m_ty <- funLookup lbl
+ case m_ty of
+ Just ty -> return [LMGlobal aliasVar $ Just $ LMBitc (LMStaticPointer (var ty)) i8Ptr]
+ Nothing -> return [LMGlobal (var i8) Nothing,
+ LMGlobal aliasVar $ Just $ LMStaticPointer (var i8) ]
+ -- Reset forward list
+ modifyEnv $ \env -> env { envAliases = emptyUniqSet }
+ return (concat defss, [])
+
+-- Note [Llvm Forward References]
+--
+-- The issue here is that LLVM insists on being strongly typed at
+-- every corner, so the first time we mention something, we have to
+-- settle what type we assign to it. That makes things awkward, as Cmm
+-- will often reference things before their definition, and we have no
+-- idea what (LLVM) type it is going to be before that point.
+--
+-- Our work-around is to define "aliases" of a standard type (i8 *) in
+-- these kind of situations, which we later tell LLVM to be either
+-- references to their actual local definitions (involving a cast) or
+-- an external reference. This obviously only works for pointers.
-- ----------------------------------------------------------------------------
-- * Misc
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 915981752e..6f898fa56c 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -29,232 +29,216 @@ import Platform
import OrdList
import UniqSupply
import Unique
-import Util
-import Data.List ( partition )
+import Data.List ( nub )
+import Data.Maybe ( catMaybes )
type LlvmStatements = OrdList LlvmStatement
-- -----------------------------------------------------------------------------
-- | Top-level of the LLVM proc Code generator
--
-genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl])
-genLlvmProc env (CmmProc infos lbl live graph) = do
+genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]
+genLlvmProc (CmmProc infos lbl live graph) = do
let blocks = toBlockListEntryFirstFalseFallthrough graph
- (env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], [])
+ (lmblocks, lmdata) <- basicBlocksCodeGen live blocks
let info = mapLookup (g_entry graph) infos
proc = CmmProc info lbl live (ListGraph lmblocks)
- return (env', proc:lmdata)
+ return (proc:lmdata)
-genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!"
+genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!"
-- -----------------------------------------------------------------------------
-- * Block code generation
--
--- | Generate code for a list of blocks that make up a complete procedure.
-basicBlocksCodeGen :: LlvmEnv
- -> LiveGlobalRegs
- -> [CmmBlock]
- -> ( [LlvmBasicBlock] , [LlvmCmmDecl] )
- -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] )
-basicBlocksCodeGen env live [] (blocks0, tops0)
- = return (env, fblocks, tops)
- where
- dflags = getDflags env
- blocks = reverse blocks0
- tops = reverse tops0
- (blocks', allocs) = mapAndUnzip dominateAllocs blocks
- allocs' = concat allocs
- (BasicBlock id fstmts : rblks) = blocks'
- fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks
-
-basicBlocksCodeGen env live (block:blocks) (lblocks, ltops)
- = do (env', lb, lt) <- basicBlockCodeGen env block
- basicBlocksCodeGen env' live blocks (lb : lblocks, reverse lt ++ ltops)
+-- | Generate code for a list of blocks that make up a complete
+-- procedure. The first block in the list is exepected to be the entry
+-- point and will get the prologue.
+basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock]
+ -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])
+basicBlocksCodeGen _ [] = panic "no entry block!"
+basicBlocksCodeGen live (entryBlock:cmmBlocks)
+ = do (prologue, prologueTops) <- funPrologue live (entryBlock:cmmBlocks)
+ -- Generate code
+ (BasicBlock bid entry, entryTops) <- basicBlockCodeGen entryBlock
+ (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks
--- | Allocations need to be extracted so they can be moved to the entry
--- of a function to make sure they dominate all possible paths in the CFG.
-dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement])
-dominateAllocs (BasicBlock id stmts)
- = let (allocs, stmts') = partition isAlloc stmts
- isAlloc (Assignment _ (Alloca _ _)) = True
- isAlloc _other = False
- in (BasicBlock id stmts', allocs)
+ -- Compose
+ let entryBlock = BasicBlock bid (fromOL prologue ++ entry)
+ return (entryBlock : blocks, prologueTops ++ entryTops ++ concat topss)
-- | Generate code for one block
-basicBlockCodeGen :: LlvmEnv
- -> CmmBlock
- -> UniqSM ( LlvmEnv, LlvmBasicBlock, [LlvmCmmDecl] )
-basicBlockCodeGen env block
+basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )
+basicBlockCodeGen block
= do let (CmmEntry id, nodes, tail) = blockSplit block
- let stmts = blockToList nodes
- (env', mid_instrs, top) <- stmtsToInstrs env stmts (nilOL, [])
- (env'', tail_instrs, top') <- stmtToInstrs env' tail
+ (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes
+ (tail_instrs, top') <- stmtToInstrs tail
let instrs = fromOL (mid_instrs `appOL` tail_instrs)
- return (env'', BasicBlock id instrs, top' ++ top)
+ return (BasicBlock id instrs, top' ++ top)
-- -----------------------------------------------------------------------------
-- * CmmNode code generation
--
-- A statement conversion return data.
--- * LlvmEnv: The new environment
-- * LlvmStatements: The compiled LLVM statements.
-- * LlvmCmmDecl: Any global data needed.
-type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmDecl])
+type StmtData = (LlvmStatements, [LlvmCmmDecl])
-- | Convert a list of CmmNode's to LlvmStatement's
-stmtsToInstrs :: LlvmEnv -> [CmmNode e x] -> (LlvmStatements, [LlvmCmmDecl])
- -> UniqSM StmtData
-stmtsToInstrs env [] (llvm, top)
- = return (env, llvm, top)
+stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData
+stmtsToInstrs stmts
+ = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts
+ return (concatOL instrss, concat topss)
-stmtsToInstrs env (stmt : stmts) (llvm, top)
- = do (env', instrs, tops) <- stmtToInstrs env stmt
- stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops)
+-- | Convert a CmmStmt to a list of LlvmStatement's
+stmtToInstrs :: CmmNode e x -> LlvmM StmtData
+stmtToInstrs stmt = case stmt of
--- | Convert a CmmNode to a list of LlvmStatement's
-stmtToInstrs :: LlvmEnv -> CmmNode e x
- -> UniqSM StmtData
-stmtToInstrs env stmt = case stmt of
+ CmmComment _ -> return (nilOL, []) -- nuke comments
- CmmComment _ -> return (env, nilOL, []) -- nuke comments
+ CmmAssign reg src -> genAssign reg src
+ CmmStore addr src -> genStore addr src
- CmmAssign reg src -> genAssign env reg src
- CmmStore addr src -> genStore env addr src
-
- CmmBranch id -> genBranch env id
- CmmCondBranch arg true false -> genCondBranch env arg true false
- CmmSwitch arg ids -> genSwitch env arg ids
+ CmmBranch id -> genBranch id
+ CmmCondBranch arg true false
+ -> genCondBranch arg true false
+ CmmSwitch arg ids -> genSwitch arg ids
-- Foreign Call
- CmmUnsafeForeignCall target res args -> genCall env target res args
+ CmmUnsafeForeignCall target res args
+ -> genCall target res args
-- Tail call
CmmCall { cml_target = arg,
- cml_args_regs = live } -> genJump env arg live
+ cml_args_regs = live } -> genJump arg live
_ -> panic "Llvm.CodeGen.stmtToInstrs"
+-- | Wrapper function to declare an instrinct function by function type
+getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData
+getInstrinct2 fname fty@(LMFunction funSig) = do
+
+ let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant
+
+ fn <- funLookup fname
+ tops <- case fn of
+ Just _ ->
+ return []
+ Nothing -> do
+ funInsert fname fty
+ return [CmmData Data [([],[fty])]]
+
+ return (fv, nilOL, tops)
+
+getInstrinct2 _ _ = error "getInstrinct2: Non-function type!"
+
+-- | Declares an instrinct function by return and parameter types
+getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData
+getInstrinct fname retTy parTys =
+ let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy
+ FixedArgs (tysToParams parTys) Nothing
+ fty = LMFunction funSig
+ in getInstrinct2 fname fty
+
-- | Memory barrier instruction for LLVM >= 3.0
-barrier :: LlvmEnv -> UniqSM StmtData
-barrier env = do
+barrier :: LlvmM StmtData
+barrier = do
let s = Fence False SyncSeqCst
- return (env, unitOL s, [])
+ return (unitOL s, [])
-- | Memory barrier instruction for LLVM < 3.0
-oldBarrier :: LlvmEnv -> UniqSM StmtData
-oldBarrier env = do
- let dflags = getDflags env
- let fname = fsLit "llvm.memory.barrier"
- let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid
- FixedArgs (tysToParams [i1, i1, i1, i1, i1]) (llvmFunAlign dflags)
- let fty = LMFunction funSig
-
- let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False
- let tops = case funLookup fname env of
- Just _ -> []
- Nothing -> [CmmData Data [([],[fty])]]
+oldBarrier :: LlvmM StmtData
+oldBarrier = do
+
+ (fv, _, tops) <- getInstrinct (fsLit "llvm.memory.barrier") LMVoid [i1, i1, i1, i1, i1]
let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue]
let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs
- let env' = funInsert fname fty env
- return (env', unitOL s1, tops)
+ return (unitOL s1, tops)
where
lmTrue :: LlvmVar
lmTrue = mkIntLit i1 (-1)
-- | Foreign Calls
-genCall :: LlvmEnv -> ForeignTarget -> [CmmFormal] -> [CmmActual]
- -> UniqSM StmtData
+genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]
+ -> LlvmM StmtData
-- Write barrier needs to be handled specially as it is implemented as an LLVM
-- intrinsic function.
-genCall env (PrimTarget MO_WriteBarrier) _ _
- | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC]
- = return (env, nilOL, [])
- | getLlvmVer env > 29 = barrier env
- | otherwise = oldBarrier env
-
-genCall env (PrimTarget MO_Touch) _ _
- = return (env, nilOL, [])
-
-genCall env (PrimTarget (MO_UF_Conv w)) [dst] [e] = do
- let (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst)
- ty = cmmToLlvmType $ localRegType dst
+genCall (PrimTarget MO_WriteBarrier) _ _ = do
+ platform <- getLlvmPlatform
+ ver <- getLlvmVer
+ case () of
+ _ | platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC]
+ -> return (nilOL, [])
+ | ver > 29 -> barrier
+ | otherwise -> oldBarrier
+
+genCall (PrimTarget MO_Touch) _ _
+ = return (nilOL, [])
+
+genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = do
+ dstV <- getCmmReg (CmmLocal dst)
+ let ty = cmmToLlvmType $ localRegType dst
width = widthToLlvmFloat w
castV <- mkLocalVar ty
- (env2, ve, stmts2, top2) <- exprToVar env1 e
+ (ve, stmts, top) <- exprToVar e
let stmt3 = Assignment castV $ Cast LM_Uitofp ve width
stmt4 = Store castV dstV
- stmts = stmts1 `appOL` stmts2 `snocOL` stmt3 `snocOL` stmt4
- return (env2, stmts, top1 ++ top2)
+ return (stmts `snocOL` stmt3 `snocOL` stmt4, top)
-genCall _ (PrimTarget (MO_UF_Conv _)) [_] args =
+genCall (PrimTarget (MO_UF_Conv _)) [_] args =
panic $ "genCall: Too many arguments to MO_UF_Conv. " ++
"Can only handle 1, given" ++ show (length args) ++ "."
-- Handle prefetching data
-genCall env t@(PrimTarget MO_Prefetch_Data) [] args = do
- let dflags = getDflags env
- argTy = [i8Ptr, i32, i32, i32]
+genCall t@(PrimTarget MO_Prefetch_Data) [] args = do
+ ver <- getLlvmVer
+ let argTy | ver <= 29 = [i8Ptr, i32, i32]
+ | otherwise = [i8Ptr, i32, i32, i32]
funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
let (_, arg_hints) = foreignTargetHints t
let args_hints' = zip args arg_hints
- (env1, argVars, stmts1, top1) <- arg_vars env args_hints' ([], nilOL, [])
- (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t
- (argVars', stmts3) <- castVars dflags $ zip argVars argTy
-
- let arguments = argVars' ++ [mkIntLit i32 0, mkIntLit i32 3, mkIntLit i32 1]
- call = Expr $ Call StdCall fptr arguments []
+ (argVars, stmts1, top1) <- arg_vars args_hints' ([], nilOL, [])
+ (fptr, stmts2, top2) <- getFunPtr funTy t
+ (argVars', stmts3) <- castVars $ zip argVars argTy
+
+ trash <- getTrashStmts
+ let argSuffix | ver <= 29 = [mkIntLit i32 0, mkIntLit i32 3]
+ | otherwise = [mkIntLit i32 0, mkIntLit i32 3, mkIntLit i32 1]
+ call = Expr $ Call StdCall fptr (argVars' ++ argSuffix) []
stmts = stmts1 `appOL` stmts2 `appOL` stmts3
- `appOL` trashStmts (getDflags env) `snocOL` call
- return (env2, stmts, top1 ++ top2)
-
--- Handle popcnt function specifically since GHC only really has i32 and i64
--- types and things like Word8 are backed by an i32 and just present a logical
--- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM
--- is strict about types.
-genCall env t@(PrimTarget (MO_PopCnt w)) [dst] args = do
- let dflags = getDflags env
- width = widthToLlvmInt w
- dstTy = cmmToLlvmType $ localRegType dst
- funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible
- CC_Ccc width FixedArgs (tysToParams [width]) Nothing
- (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst)
+ `appOL` trash `snocOL` call
+ return (stmts, top1 ++ top2)
- let (_, arg_hints) = foreignTargetHints t
- let args_hints = zip args arg_hints
- (env2, argsV, stmts2, top2) <- arg_vars env1 args_hints ([], nilOL, [])
- (env3, fptr, stmts3, top3) <- getFunPtr env2 funTy t
- (argsV', stmts4) <- castVars dflags $ zip argsV [width]
- (retV, s1) <- doExpr width $ Call StdCall fptr argsV' []
- ([retV'], stmts5) <- castVars dflags [(retV,dstTy)]
- let s2 = Store retV' dstV
-
- let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL`
- s1 `appOL` stmts5 `snocOL` s2
- return (env3, stmts, top1 ++ top2 ++ top3)
+-- Handle PopCnt and BSwap that need to only convert arg and return types
+genCall t@(PrimTarget (MO_PopCnt w)) dsts args =
+ genCallSimpleCast w t dsts args
+genCall t@(PrimTarget (MO_BSwap w)) dsts args =
+ genCallSimpleCast w t dsts args
-- Handle memcpy function specifically since llvm's intrinsic version takes
-- some extra parameters.
-genCall env t@(PrimTarget op) [] args'
+genCall t@(PrimTarget op) [] args'
| op == MO_Memcpy ||
op == MO_Memset ||
op == MO_Memmove = do
- let dflags = getDflags env
- (args, alignVal) = splitAlignVal args'
- (isVolTy, isVolVal) = if getLlvmVer env >= 28
- then ([i1], [mkIntLit i1 0]) else ([], [])
+ ver <- getLlvmVer
+ dflags <- getDynFlags
+ let (args, alignVal) = splitAlignVal args'
+ (isVolTy, isVolVal)
+ | ver >= 28 = ([i1], [mkIntLit i1 0])
+ | otherwise = ([], [])
argTy | op == MO_Memset = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy
| otherwise = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy
funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
@@ -262,16 +246,16 @@ genCall env t@(PrimTarget op) [] args'
let (_, arg_hints) = foreignTargetHints t
let args_hints = zip args arg_hints
- (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, [])
- (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t
- (argVars', stmts3) <- castVars dflags $ zip argVars argTy
+ (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, [])
+ (fptr, stmts2, top2) <- getFunPtr funTy t
+ (argVars', stmts3) <- castVars $ zip argVars argTy
+ stmts4 <- getTrashStmts
let arguments = argVars' ++ (alignVal:isVolVal)
call = Expr $ Call StdCall fptr arguments []
stmts = stmts1 `appOL` stmts2 `appOL` stmts3
- `appOL` trashStmts (getDflags env) `snocOL` call
- return (env2, stmts, top1 ++ top2)
-
+ `appOL` stmts4 `snocOL` call
+ return (stmts, top1 ++ top2)
where
splitAlignVal xs = (init xs, extractLit $ last xs)
@@ -284,9 +268,9 @@ genCall env t@(PrimTarget op) [] args'
mkIntLit i32 0
-- Handle all other foreign calls and prim ops.
-genCall env target res args = do
+genCall target res args = do
- let dflags = getDflags env
+ dflags <- getDynFlags
-- parameter types
let arg_type (_, AddrHint) = i8Ptr
@@ -301,10 +285,11 @@ genCall env target res args = do
++ " 0 or 1, given " ++ show (length t) ++ "."
-- extract Cmm call convention, and translate to LLVM call convention
+ platform <- getLlvmPlatform
let lmconv = case target of
ForeignTarget _ (ForeignConvention conv _ _ _) ->
case conv of
- StdCallConv -> case platformArch (getLlvmPlatform env) of
+ StdCallConv -> case platformArch platform of
ArchX86 -> CC_X86_Stdcc
ArchX86_64 -> CC_X86_Stdcc
_ -> CC_Ccc
@@ -341,22 +326,22 @@ genCall env target res args = do
lmconv retTy FixedArgs argTy (llvmFunAlign dflags)
-
- (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, [])
- (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy target
+ (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, [])
+ (fptr, stmts2, top2) <- getFunPtr funTy target
let retStmt | ccTy == TailCall = unitOL $ Return Nothing
| never_returns = unitOL $ Unreachable
| otherwise = nilOL
- let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts (getDflags env)
+ stmts3 <- getTrashStmts
+ let stmts = stmts1 `appOL` stmts2 `appOL` stmts3
-- make the actual call
case retTy of
LMVoid -> do
let s1 = Expr $ Call ccTy fptr argVars fnAttrs
let allStmts = stmts `snocOL` s1 `appOL` retStmt
- return (env2, allStmts, top1 ++ top2)
+ return (allStmts, top1 ++ top2)
_ -> do
(v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
@@ -365,13 +350,13 @@ genCall env target res args = do
ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
++ " 1, given " ++ show (length t) ++ "."
let creg = ret_reg res
- let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
- let allStmts = stmts `snocOL` s1 `appOL` stmts3
+ vreg <- getCmmReg (CmmLocal creg)
+ let allStmts = stmts `snocOL` s1
if retTy == pLower (getVarType vreg)
then do
let s2 = Store v1 vreg
- return (env3, allStmts `snocOL` s2 `appOL` retStmt,
- top1 ++ top2 ++ top3)
+ return (allStmts `snocOL` s2 `appOL` retStmt,
+ top1 ++ top2)
else do
let ty = pLower $ getVarType vreg
let op = case ty of
@@ -383,102 +368,110 @@ genCall env target res args = do
(v2, s2) <- doExpr ty $ Cast op v1 ty
let s3 = Store v2 vreg
- return (env3, allStmts `snocOL` s2 `snocOL` s3
- `appOL` retStmt, top1 ++ top2 ++ top3)
+ return (allStmts `snocOL` s2 `snocOL` s3
+ `appOL` retStmt, top1 ++ top2)
+
+-- Handle simple function call that only need simple type casting, of the form:
+-- truncate arg >>= \a -> call(a) >>= zext
+--
+-- since GHC only really has i32 and i64 types and things like Word8 are backed
+-- by an i32 and just present a logical i8 range. So we must handle conversions
+-- from i32 to i8 explicitly as LLVM is strict about types.
+genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]
+ -> LlvmM StmtData
+genCallSimpleCast w t@(PrimTarget op) [dst] args = do
+ let width = widthToLlvmInt w
+ dstTy = cmmToLlvmType $ localRegType dst
+
+ fname <- cmmPrimOpFunctions op
+ (fptr, _, top3) <- getInstrinct fname width [width]
+
+ dstV <- getCmmReg (CmmLocal dst)
+
+ let (_, arg_hints) = foreignTargetHints t
+ let args_hints = zip args arg_hints
+ (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, [])
+ (argsV', stmts4) <- castVars $ zip argsV [width]
+ (retV, s1) <- doExpr width $ Call StdCall fptr argsV' []
+ ([retV'], stmts5) <- castVars [(retV,dstTy)]
+ let s2 = Store retV' dstV
+ let stmts = stmts2 `appOL` stmts4 `snocOL`
+ s1 `appOL` stmts5 `snocOL` s2
+ return (stmts, top2 ++ top3)
+genCallSimpleCast _ _ dsts _ =
+ panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts")
-- | Create a function pointer from a target.
-getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> ForeignTarget
- -> UniqSM ExprData
-getFunPtr env funTy targ = case targ of
- ForeignTarget (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl
+getFunPtr :: (LMString -> LlvmType) -> ForeignTarget
+ -> LlvmM ExprData
+getFunPtr funTy targ = case targ of
+ ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do
+ name <- strCLabel_llvm lbl
+ getHsFunc' name (funTy name)
ForeignTarget expr _ -> do
- (env', v1, stmts, top) <- exprToVar env expr
+ (v1, stmts, top) <- exprToVar expr
+ dflags <- getDynFlags
let fty = funTy $ fsLit "dynamic"
cast = case getVarType v1 of
ty | isPointer ty -> LM_Bitcast
ty | isInt ty -> LM_Inttoptr
ty -> panic $ "genCall: Expr is of bad type for function"
- ++ " call! (" ++ show (ty) ++ ")"
+ ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")"
(v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
- return (env', v2, stmts `snocOL` s1, top)
-
- PrimTarget mop -> litCase $ cmmPrimOpFunctions env mop
-
- where
- litCase name = do
- case funLookup name env of
- Just ty'@(LMFunction sig) -> do
- -- Function in module in right form
- let fun = LMGlobalVar name ty' (funcLinkage sig)
- Nothing Nothing False
- return (env, fun, nilOL, [])
-
- Just ty' -> do
- -- label in module but not function pointer, convert
- let fty@(LMFunction sig) = funTy name
- fun = LMGlobalVar name (pLift ty') (funcLinkage sig)
- Nothing Nothing False
- (v1, s1) <- doExpr (pLift fty)
- $ Cast LM_Bitcast fun (pLift fty)
- return (env, v1, unitOL s1, [])
-
- Nothing -> do
- -- label not in module, create external reference
- let fty@(LMFunction sig) = funTy name
- fun = LMGlobalVar name fty (funcLinkage sig)
- Nothing Nothing False
- top = [CmmData Data [([],[fty])]]
- env' = funInsert name fty env
- return (env', fun, nilOL, top)
+ return (v2, stmts `snocOL` s1, top)
+ PrimTarget mop -> do
+ name <- cmmPrimOpFunctions mop
+ let fty = funTy name
+ getInstrinct2 name fty
-- | Conversion of call arguments.
-arg_vars :: LlvmEnv
- -> [(CmmActual, ForeignHint)]
+arg_vars :: [(CmmActual, ForeignHint)]
-> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
- -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmDecl])
+ -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
-arg_vars env [] (vars, stmts, tops)
- = return (env, vars, stmts, tops)
+arg_vars [] (vars, stmts, tops)
+ = return (vars, stmts, tops)
-arg_vars env ((e, AddrHint):rest) (vars, stmts, tops)
- = do (env', v1, stmts', top') <- exprToVar env e
+arg_vars ((e, AddrHint):rest) (vars, stmts, tops)
+ = do (v1, stmts', top') <- exprToVar e
+ dflags <- getDynFlags
let op = case getVarType v1 of
ty | isPointer ty -> LM_Bitcast
ty | isInt ty -> LM_Inttoptr
a -> panic $ "genCall: Can't cast llvmType to i8*! ("
- ++ show a ++ ")"
+ ++ showSDoc dflags (ppr a) ++ ")"
(v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
- arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
+ arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
tops ++ top')
-arg_vars env ((e, _):rest) (vars, stmts, tops)
- = do (env', v1, stmts', top') <- exprToVar env e
- arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
+arg_vars ((e, _):rest) (vars, stmts, tops)
+ = do (v1, stmts', top') <- exprToVar e
+ arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
-- | Cast a collection of LLVM variables to specific types.
-castVars :: DynFlags -> [(LlvmVar, LlvmType)]
- -> UniqSM ([LlvmVar], LlvmStatements)
-castVars dflags vars = do
- done <- mapM (uncurry (castVar dflags)) vars
+castVars :: [(LlvmVar, LlvmType)]
+ -> LlvmM ([LlvmVar], LlvmStatements)
+castVars vars = do
+ done <- mapM (uncurry castVar) vars
let (vars', stmts) = unzip done
return (vars', toOL stmts)
-- | Cast an LLVM variable to a specific type, panicing if it can't be done.
-castVar :: DynFlags -> LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement)
-castVar dflags v t
- | getVarType v == t
+castVar :: LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement)
+castVar v t | getVarType v == t
= return (v, Nop)
| otherwise
- = let op = case (getVarType v, t) of
+ = do dflags <- getDynFlags
+ let op = case (getVarType v, t) of
(LMInt n, LMInt m)
-> if n < m then LM_Sext else LM_Trunc
(vt, _) | isFloat vt && isFloat t
@@ -492,14 +485,24 @@ castVar dflags v t
(vt, _) | isVector vt && isVector t -> LM_Bitcast
(vt, _) -> panic $ "castVars: Can't cast this type ("
- ++ show vt ++ ") to (" ++ show t ++ ")"
- in doExpr t $ Cast op v t
+ ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")"
+ doExpr t $ Cast op v t
-- | Decide what C function to use to implement a CallishMachOp
-cmmPrimOpFunctions :: LlvmEnv -> CallishMachOp -> LMString
-cmmPrimOpFunctions env mop
- = case mop of
+cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString
+cmmPrimOpFunctions mop = do
+
+ ver <- getLlvmVer
+ dflags <- getDynFlags
+ let intrinTy1 = (if ver >= 28
+ then "p0i8.p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags)
+ intrinTy2 = (if ver >= 28
+ then "p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags)
+ unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
+ ++ " not supported here")
+
+ return $ case mop of
MO_F32_Exp -> fsLit "expf"
MO_F32_Log -> fsLit "logf"
MO_F32_Sqrt -> fsLit "llvm.sqrt.f32"
@@ -538,7 +541,8 @@ cmmPrimOpFunctions env mop
MO_Memmove -> fsLit $ "llvm.memmove." ++ intrinTy1
MO_Memset -> fsLit $ "llvm.memset." ++ intrinTy2
- (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ show (widthToLlvmInt w)
+ (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
+ (MO_BSwap w) -> fsLit $ "llvm.bswap." ++ showSDoc dflags (ppr $ widthToLlvmInt w)
MO_Prefetch_Data -> fsLit "llvm.prefetch"
@@ -551,44 +555,36 @@ cmmPrimOpFunctions env mop
MO_Touch -> unsupported
MO_UF_Conv _ -> unsupported
- where
- dflags = getDflags env
- intrinTy1 = (if getLlvmVer env >= 28
- then "p0i8.p0i8." else "") ++ show (llvmWord dflags)
- intrinTy2 = (if getLlvmVer env >= 28
- then "p0i8." else "") ++ show (llvmWord dflags)
- unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
- ++ " not supported here")
-
-- | Tail function calls
-genJump :: LlvmEnv -> CmmExpr -> [GlobalReg] -> UniqSM StmtData
+genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData
-- Call to known function
-genJump env (CmmLit (CmmLabel lbl)) live = do
- (env', vf, stmts, top) <- getHsFunc env live lbl
- (stgRegs, stgStmts) <- funEpilogue env live
+genJump (CmmLit (CmmLabel lbl)) live = do
+ (vf, stmts, top) <- getHsFunc live lbl
+ (stgRegs, stgStmts) <- funEpilogue live
let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs
let s2 = Return Nothing
- return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
+ return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)
-- Call to unknown function / address
-genJump env expr live = do
- let fty = llvmFunTy (getDflags env) live
- (env', vf, stmts, top) <- exprToVar env expr
+genJump expr live = do
+ fty <- llvmFunTy live
+ (vf, stmts, top) <- exprToVar expr
+ dflags <- getDynFlags
let cast = case getVarType vf of
ty | isPointer ty -> LM_Bitcast
ty | isInt ty -> LM_Inttoptr
ty -> panic $ "genJump: Expr is of bad type for function call! ("
- ++ show (ty) ++ ")"
+ ++ showSDoc dflags (ppr ty) ++ ")"
(v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)
- (stgRegs, stgStmts) <- funEpilogue env live
+ (stgRegs, stgStmts) <- funEpilogue live
let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs
let s3 = Return Nothing
- return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
+ return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,
top)
@@ -596,81 +592,81 @@ genJump env expr live = do
--
-- We use stack allocated variables for CmmReg. The optimiser will replace
-- these with registers when possible.
-genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData
-genAssign env reg val = do
- let dflags = getDflags env
- (env1, vreg, stmts1, top1) = getCmmReg env reg
- (env2, vval, stmts2, top2) <- exprToVar env1 val
- let stmts = stmts1 `appOL` stmts2
+genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData
+genAssign reg val = do
+ vreg <- getCmmReg reg
+ (vval, stmts2, top2) <- exprToVar val
+ let stmts = stmts2
let ty = (pLower . getVarType) vreg
+ dflags <- getDynFlags
case ty of
-- Some registers are pointer types, so need to cast value to pointer
LMPointer _ | getVarType vval == llvmWord dflags -> do
(v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
let s2 = Store v vreg
- return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
+ return (stmts `snocOL` s1 `snocOL` s2, top2)
LMVector _ _ -> do
(v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty
let s2 = Store v vreg
- return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
+ return (stmts `snocOL` s1 `snocOL` s2, top2)
_ -> do
let s1 = Store vval vreg
- return (env2, stmts `snocOL` s1, top1 ++ top2)
+ return (stmts `snocOL` s1, top2)
-- | CmmStore operation
-genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData
+genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData
-- First we try to detect a few common cases and produce better code for
-- these then the default case. We are mostly trying to detect Cmm code
-- like I32[Sp + n] and use 'getelementptr' operations instead of the
-- generic case that uses casts and pointer arithmetic
-genStore env addr@(CmmReg (CmmGlobal r)) val
- = genStore_fast env addr r 0 val
+genStore addr@(CmmReg (CmmGlobal r)) val
+ = genStore_fast addr r 0 val
-genStore env addr@(CmmRegOff (CmmGlobal r) n) val
- = genStore_fast env addr r n val
+genStore addr@(CmmRegOff (CmmGlobal r) n) val
+ = genStore_fast addr r n val
-genStore env addr@(CmmMachOp (MO_Add _) [
+genStore addr@(CmmMachOp (MO_Add _) [
(CmmReg (CmmGlobal r)),
(CmmLit (CmmInt n _))])
val
- = genStore_fast env addr r (fromInteger n) val
+ = genStore_fast addr r (fromInteger n) val
-genStore env addr@(CmmMachOp (MO_Sub _) [
+genStore addr@(CmmMachOp (MO_Sub _) [
(CmmReg (CmmGlobal r)),
(CmmLit (CmmInt n _))])
val
- = genStore_fast env addr r (negate $ fromInteger n) val
+ = genStore_fast addr r (negate $ fromInteger n) val
-- generic case
-genStore env addr val = genStore_slow env addr val [other]
+genStore addr val
+ = do other <- getTBAAMeta otherN
+ genStore_slow addr val other
-- | CmmStore operation
-- This is a special case for storing to a global register pointer
-- offset such as I32[Sp+8].
-genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr
- -> UniqSM StmtData
-genStore_fast env addr r n val
- = let dflags = getDflags env
- gr = lmGlobalRegVar (getDflags env) r
- meta = [getTBAA r]
- grt = (pLower . getVarType) gr
- (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
- in case isPointer grt && rem == 0 of
+genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr
+ -> LlvmM StmtData
+genStore_fast addr r n val
+ = do dflags <- getDynFlags
+ (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
+ meta <- getTBAARegMeta r
+ let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
+ case isPointer grt && rem == 0 of
True -> do
- (env', vval, stmts, top) <- exprToVar env val
- (gv, s1) <- doExpr grt $ Load gr
+ (vval, stmts, top) <- exprToVar val
(ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
-- We might need a different pointer type, so check
case pLower grt == getVarType vval of
-- were fine
True -> do
let s3 = MetaStmt meta $ Store vval ptr
- return (env', stmts `snocOL` s1 `snocOL` s2
+ return (stmts `appOL` s1 `snocOL` s2
`snocOL` s3, top)
-- cast to pointer type needed
@@ -678,68 +674,69 @@ genStore_fast env addr r n val
let ty = (pLift . getVarType) vval
(ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty
let s4 = MetaStmt meta $ Store vval ptr'
- return (env', stmts `snocOL` s1 `snocOL` s2
+ return (stmts `appOL` s1 `snocOL` s2
`snocOL` s3 `snocOL` s4, top)
-- If its a bit type then we use the slow method since
-- we can't avoid casting anyway.
- False -> genStore_slow env addr val meta
+ False -> genStore_slow addr val meta
-- | CmmStore operation
-- Generic case. Uses casts and pointer arithmetic if needed.
-genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> [MetaData] -> UniqSM StmtData
-genStore_slow env addr val meta = do
- (env1, vaddr, stmts1, top1) <- exprToVar env addr
- (env2, vval, stmts2, top2) <- exprToVar env1 val
+genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData
+genStore_slow addr val meta = do
+ (vaddr, stmts1, top1) <- exprToVar addr
+ (vval, stmts2, top2) <- exprToVar val
let stmts = stmts1 `appOL` stmts2
+ dflags <- getDynFlags
case getVarType vaddr of
-- sometimes we need to cast an int to a pointer before storing
LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do
(v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty
let s2 = MetaStmt meta $ Store v vaddr
- return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
+ return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
LMPointer _ -> do
let s1 = MetaStmt meta $ Store vval vaddr
- return (env2, stmts `snocOL` s1, top1 ++ top2)
+ return (stmts `snocOL` s1, top1 ++ top2)
i@(LMInt _) | i == llvmWord dflags -> do
let vty = pLift $ getVarType vval
(vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty
let s2 = MetaStmt meta $ Store vval vptr
- return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
+ return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)
other ->
pprPanic "genStore: ptr not right type!"
(PprCmm.pprExpr addr <+> text (
"Size of Ptr: " ++ show (llvmPtrBits dflags) ++
", Size of var: " ++ show (llvmWidthInBits dflags other) ++
- ", Var: " ++ show vaddr))
- where dflags = getDflags env
+ ", Var: " ++ showSDoc dflags (ppr vaddr)))
-- | Unconditional branch
-genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData
-genBranch env id =
+genBranch :: BlockId -> LlvmM StmtData
+genBranch id =
let label = blockIdToLlvm id
- in return (env, unitOL $ Branch label, [])
+ in return (unitOL $ Branch label, [])
-- | Conditional branch
-genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> BlockId -> UniqSM StmtData
-genCondBranch env cond idT idF = do
+genCondBranch :: CmmExpr -> BlockId -> BlockId -> LlvmM StmtData
+genCondBranch cond idT idF = do
let labelT = blockIdToLlvm idT
let labelF = blockIdToLlvm idF
-- See Note [Literals and branch conditions].
- (env', vc, stmts, top) <- exprToVarOpt env i1Option cond
+ (vc, stmts, top) <- exprToVarOpt i1Option cond
if getVarType vc == i1
then do
let s1 = BranchIf vc labelT labelF
- return $ (env', stmts `snocOL` s1, top)
- else
- panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"
+ return (stmts `snocOL` s1, top)
+ else do
+ dflags <- getDynFlags
+ panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")"
{- Note [Literals and branch conditions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -797,9 +794,9 @@ For a real example of this, see ./rts/StgStdThunks.cmm
--
-- N.B. We remove Nothing's from the list of branches, as they are 'undefined'.
-- However, they may be defined one day, so we better document this behaviour.
-genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData
-genSwitch env cond maybe_ids = do
- (env', vc, stmts, top) <- exprToVar env cond
+genSwitch :: CmmExpr -> [Maybe BlockId] -> LlvmM StmtData
+genSwitch cond maybe_ids = do
+ (vc, stmts, top) <- exprToVar cond
let ty = getVarType vc
let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ]
@@ -808,7 +805,7 @@ genSwitch env cond maybe_ids = do
let (_, defLbl) = head labels
let s1 = Switch vc defLbl labels
- return $ (env', stmts `snocOL` s1, top)
+ return $ (stmts `snocOL` s1, top)
-- -----------------------------------------------------------------------------
@@ -816,11 +813,10 @@ genSwitch env cond maybe_ids = do
--
-- | An expression conversion return data:
--- * LlvmEnv: The new enviornment
-- * LlvmVar: The var holding the result of the expression
-- * LlvmStatements: Any statements needed to evaluate the expression
-- * LlvmCmmDecl: Any global data needed for this expression
-type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmDecl])
+type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl])
-- | Values which can be passed to 'exprToVar' to configure its
-- behaviour in certain circumstances.
@@ -840,47 +836,47 @@ wordOption = EOption False
-- | Convert a CmmExpr to a list of LlvmStatements with the result of the
-- expression being stored in the returned LlvmVar.
-exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData
-exprToVar env = exprToVarOpt env wordOption
+exprToVar :: CmmExpr -> LlvmM ExprData
+exprToVar = exprToVarOpt wordOption
-exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData
-exprToVarOpt env opt e = case e of
+exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData
+exprToVarOpt opt e = case e of
CmmLit lit
- -> genLit opt env lit
+ -> genLit opt lit
CmmLoad e' ty
- -> genLoad env e' ty
+ -> genLoad e' ty
-- Cmmreg in expression is the value, so must load. If you want actual
-- reg pointer, call getCmmReg directly.
CmmReg r -> do
- let (env', vreg, stmts, top) = getCmmReg env r
- (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg
- case (isPointer . getVarType) v1 of
+ (v1, ty, s1) <- getCmmRegVal r
+ case isPointer ty of
True -> do
-- Cmm wants the value, so pointer types must be cast to ints
+ dflags <- getDynFlags
(v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags)
- return (env', v2, stmts `snocOL` s1 `snocOL` s2, top)
+ return (v2, s1 `snocOL` s2, [])
- False -> return (env', v1, stmts `snocOL` s1, top)
+ False -> return (v1, s1, [])
CmmMachOp op exprs
- -> genMachOp env opt op exprs
+ -> genMachOp opt op exprs
CmmRegOff r i
- -> exprToVar env $ expandCmmReg dflags (r, i)
+ -> do dflags <- getDynFlags
+ exprToVar $ expandCmmReg dflags (r, i)
CmmStackSlot _ _
-> panic "exprToVar: CmmStackSlot not supported!"
- where dflags = getDflags env
-- | Handle CmmMachOp expressions
-genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
+genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
-- Unary Machop
-genMachOp env _ op [x] = case op of
+genMachOp _ op [x] = case op of
MO_Not w ->
let all1 = mkIntLit (widthToLlvmInt w) (-1)
@@ -980,29 +976,28 @@ genMachOp env _ op [x] = case op of
MO_VF_Quot _ _ -> panicOp
where
- dflags = getDflags env
-
negate ty v2 negOp = do
- (env', vx, stmts, top) <- exprToVar env x
+ (vx, stmts, top) <- exprToVar x
(v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx
- return (env', v1, stmts `snocOL` s1, top)
+ return (v1, stmts `snocOL` s1, top)
negateVec ty v2 negOp = do
- (env', vx, stmts1, top) <- exprToVar env x
- ([vx'], stmts2) <- castVars dflags [(vx, ty)]
+ (vx, stmts1, top) <- exprToVar x
+ ([vx'], stmts2) <- castVars [(vx, ty)]
(v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'
- return (env', v1, stmts1 `appOL` stmts2 `snocOL` s1, top)
+ return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top)
fiConv ty convOp = do
- (env', vx, stmts, top) <- exprToVar env x
+ (vx, stmts, top) <- exprToVar x
(v1, s1) <- doExpr ty $ Cast convOp vx ty
- return (env', v1, stmts `snocOL` s1, top)
+ return (v1, stmts `snocOL` s1, top)
sameConv from ty reduce expand = do
- x'@(env', vx, stmts, top) <- exprToVar env x
+ x'@(vx, stmts, top) <- exprToVar x
let sameConv' op = do
(v1, s1) <- doExpr ty $ Cast op vx ty
- return (env', v1, stmts `snocOL` s1, top)
+ return (v1, stmts `snocOL` s1, top)
+ dflags <- getDynFlags
let toWidth = llvmWidthInBits dflags ty
-- LLVM doesn't like trying to convert to same width, so
-- need to check for that as we do get Cmm code doing it.
@@ -1015,88 +1010,82 @@ genMachOp env _ op [x] = case op of
++ "with one argument! (" ++ show op ++ ")"
-- Handle GlobalRegs pointers
-genMachOp env opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
- = genMachOp_fast env opt o r (fromInteger n) e
+genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
+ = genMachOp_fast opt o r (fromInteger n) e
-genMachOp env opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
- = genMachOp_fast env opt o r (negate . fromInteger $ n) e
+genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]
+ = genMachOp_fast opt o r (negate . fromInteger $ n) e
-- Generic case
-genMachOp env opt op e = genMachOp_slow env opt op e
+genMachOp opt op e = genMachOp_slow opt op e
-- | Handle CmmMachOp expressions
-- This is a specialised method that handles Global register manipulations like
-- 'Sp - 16', using the getelementptr instruction.
-genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
- -> UniqSM ExprData
-genMachOp_fast env opt op r n e
- = let dflags = getDflags env
- gr = lmGlobalRegVar dflags r
- grt = (pLower . getVarType) gr
- (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
- in case isPointer grt && rem == 0 of
+genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]
+ -> LlvmM ExprData
+genMachOp_fast opt op r n e
+ = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
+ dflags <- getDynFlags
+ let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
+ case isPointer grt && rem == 0 of
True -> do
- (gv, s1) <- doExpr grt $ Load gr
(ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
(var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags)
- return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, [])
+ return (var, s1 `snocOL` s2 `snocOL` s3, [])
- False -> genMachOp_slow env opt op e
+ False -> genMachOp_slow opt op e
-- | Handle CmmMachOp expressions
-- This handles all the cases not handle by the specialised genMachOp_fast.
-genMachOp_slow :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData
+genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData
-- Element extraction
-genMachOp_slow env _ (MO_V_Extract l w) [val, idx] = do
- (env1, vval, stmts1, top1) <- exprToVar env val
- (env2, vidx, stmts2, top2) <- exprToVar env1 idx
- ([vval'], stmts3) <- castVars dflags [(vval, LMVector l ty)]
- (v1, s1) <- doExpr ty $ Extract vval' vidx
- return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2)
+genMachOp_slow _ (MO_V_Extract l w) [val, idx] = do
+ (vval, stmts1, top1) <- exprToVar val
+ (vidx, stmts2, top2) <- exprToVar idx
+ ([vval'], stmts3) <- castVars [(vval, LMVector l ty)]
+ (v1, s1) <- doExpr ty $ Extract vval' vidx
+ return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2)
where
- dflags = getDflags env
ty = widthToLlvmInt w
-genMachOp_slow env _ (MO_VF_Extract l w) [val, idx] = do
- (env1, vval, stmts1, top1) <- exprToVar env val
- (env2, vidx, stmts2, top2) <- exprToVar env1 idx
- ([vval'], stmts3) <- castVars dflags [(vval, LMVector l ty)]
- (v1, s1) <- doExpr ty $ Extract vval' vidx
- return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2)
+genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = do
+ (vval, stmts1, top1) <- exprToVar val
+ (vidx, stmts2, top2) <- exprToVar idx
+ ([vval'], stmts3) <- castVars [(vval, LMVector l ty)]
+ (v1, s1) <- doExpr ty $ Extract vval' vidx
+ return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2)
where
- dflags = getDflags env
ty = widthToLlvmFloat w
-- Element insertion
-genMachOp_slow env _ (MO_V_Insert l w) [val, elt, idx] = do
- (env1, vval, stmts1, top1) <- exprToVar env val
- (env2, velt, stmts2, top2) <- exprToVar env1 elt
- (env3, vidx, stmts3, top3) <- exprToVar env2 idx
- ([vval'], stmts4) <- castVars dflags [(vval, ty)]
- (v1, s1) <- doExpr ty $ Insert vval' velt vidx
- return (env3, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1,
+genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = do
+ (vval, stmts1, top1) <- exprToVar val
+ (velt, stmts2, top2) <- exprToVar elt
+ (vidx, stmts3, top3) <- exprToVar idx
+ ([vval'], stmts4) <- castVars [(vval, ty)]
+ (v1, s1) <- doExpr ty $ Insert vval' velt vidx
+ return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1,
top1 ++ top2 ++ top3)
where
- dflags = getDflags env
ty = LMVector l (widthToLlvmInt w)
-genMachOp_slow env _ (MO_VF_Insert l w) [val, elt, idx] = do
- (env1, vval, stmts1, top1) <- exprToVar env val
- (env2, velt, stmts2, top2) <- exprToVar env1 elt
- (env3, vidx, stmts3, top3) <- exprToVar env2 idx
- ([vval'], stmts4) <- castVars dflags [(vval, ty)]
- (v1, s1) <- doExpr ty $ Insert vval' velt vidx
- return (env3, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1,
+genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = do
+ (vval, stmts1, top1) <- exprToVar val
+ (velt, stmts2, top2) <- exprToVar elt
+ (vidx, stmts3, top3) <- exprToVar idx
+ ([vval'], stmts4) <- castVars [(vval, ty)]
+ (v1, s1) <- doExpr ty $ Insert vval' velt vidx
+ return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1,
top1 ++ top2 ++ top3)
where
- dflags = getDflags env
ty = LMVector l (widthToLlvmFloat w)
-- Binary MachOp
-genMachOp_slow env opt op [x, y] = case op of
+genMachOp_slow opt op [x, y] = case op of
MO_Eq _ -> genBinComp opt LM_CMP_Eq
MO_Ne _ -> genBinComp opt LM_CMP_Ne
@@ -1177,21 +1166,19 @@ genMachOp_slow env opt op [x, y] = case op of
MO_VF_Neg {} -> panicOp
where
- dflags = getDflags env
-
binLlvmOp ty binOp = do
- (env1, vx, stmts1, top1) <- exprToVar env x
- (env2, vy, stmts2, top2) <- exprToVar env1 y
+ (vx, stmts1, top1) <- exprToVar x
+ (vy, stmts2, top2) <- exprToVar y
if getVarType vx == getVarType vy
then do
(v1, s1) <- doExpr (ty vx) $ binOp vx vy
- return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1,
+ return (v1, stmts1 `appOL` stmts2 `snocOL` s1,
top1 ++ top2)
else do
-- Error. Continue anyway so we can debug the generated ll file.
- let dflags = getDflags env
- style = mkCodeStyle CStyle
+ dflags <- getDynFlags
+ let style = mkCodeStyle CStyle
toString doc = renderWithStyle dflags doc style
cmmToStr = (lines . toString . PprCmm.pprExpr)
let dx = Comment $ map fsLit $ cmmToStr x
@@ -1199,31 +1186,32 @@ genMachOp_slow env opt op [x, y] = case op of
(v1, s1) <- doExpr (ty vx) $ binOp vx vy
let allStmts = stmts1 `appOL` stmts2 `snocOL` dx
`snocOL` dy `snocOL` s1
- return (env2, v1, allStmts, top1 ++ top2)
+ return (v1, allStmts, top1 ++ top2)
binCastLlvmOp ty binOp = do
- (env1, vx, stmts1, top1) <- exprToVar env x
- (env2, vy, stmts2, top2) <- exprToVar env1 y
- ([vx', vy'], stmts3) <- castVars dflags [(vx, ty), (vy, ty)]
+ (vx, stmts1, top1) <- exprToVar x
+ (vy, stmts2, top2) <- exprToVar y
+ ([vx', vy'], stmts3) <- castVars [(vx, ty), (vy, ty)]
(v1, s1) <- doExpr ty $ binOp vx' vy'
- return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1,
+ return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1,
top1 ++ top2)
-- | Need to use EOption here as Cmm expects word size results from
-- comparisons while LLVM return i1. Need to extend to llvmWord type
-- if expected. See Note [Literals and branch conditions].
genBinComp opt cmp = do
- ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)
+ ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)
+ dflags <- getDynFlags
if getVarType v1 == i1
then case i1Expected opt of
True -> return ed
False -> do
let w_ = llvmWord dflags
(v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_
- return (env', v2, stmts `snocOL` s1, top)
+ return (v2, stmts `snocOL` s1, top)
else
panic $ "genBinComp: Compare returned type other then i1! "
- ++ (show $ getVarType v1)
+ ++ (showSDoc dflags $ ppr $ getVarType v1)
genBinMach op = binLlvmOp getVarType (LlvmOp op)
@@ -1233,11 +1221,12 @@ genMachOp_slow env opt op [x, y] = case op of
-- CmmExpr's. This is the LLVM assembly equivalent of the NCG
-- implementation. Its much longer due to type information/safety.
-- This should actually compile to only about 3 asm instructions.
- isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData
+ isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData
isSMulOK _ x y = do
- (env1, vx, stmts1, top1) <- exprToVar env x
- (env2, vy, stmts2, top2) <- exprToVar env1 y
+ (vx, stmts1, top1) <- exprToVar x
+ (vy, stmts2, top2) <- exprToVar y
+ dflags <- getDynFlags
let word = getVarType vx
let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx)
let shift = llvmWidthInBits dflags word
@@ -1256,127 +1245,151 @@ genMachOp_slow env opt op [x, y] = case op of
(dst, s8) <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2
let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4
`snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8
- return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts,
+ return (dst, stmts1 `appOL` stmts2 `appOL` stmts,
top1 ++ top2)
else
- panic $ "isSMulOK: Not bit type! (" ++ show word ++ ")"
+ panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")"
panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encourntered"
++ "with two arguments! (" ++ show op ++ ")"
-- More then two expression, invalid!
-genMachOp_slow _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
+genMachOp_slow _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!"
-- | Handle CmmLoad expression.
-genLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData
+genLoad :: CmmExpr -> CmmType -> LlvmM ExprData
-- First we try to detect a few common cases and produce better code for
-- these then the default case. We are mostly trying to detect Cmm code
-- like I32[Sp + n] and use 'getelementptr' operations instead of the
-- generic case that uses casts and pointer arithmetic
-genLoad env e@(CmmReg (CmmGlobal r)) ty
- = genLoad_fast env e r 0 ty
+genLoad e@(CmmReg (CmmGlobal r)) ty
+ = genLoad_fast e r 0 ty
-genLoad env e@(CmmRegOff (CmmGlobal r) n) ty
- = genLoad_fast env e r n ty
+genLoad e@(CmmRegOff (CmmGlobal r) n) ty
+ = genLoad_fast e r n ty
-genLoad env e@(CmmMachOp (MO_Add _) [
+genLoad e@(CmmMachOp (MO_Add _) [
(CmmReg (CmmGlobal r)),
(CmmLit (CmmInt n _))])
ty
- = genLoad_fast env e r (fromInteger n) ty
+ = genLoad_fast e r (fromInteger n) ty
-genLoad env e@(CmmMachOp (MO_Sub _) [
+genLoad e@(CmmMachOp (MO_Sub _) [
(CmmReg (CmmGlobal r)),
(CmmLit (CmmInt n _))])
ty
- = genLoad_fast env e r (negate $ fromInteger n) ty
+ = genLoad_fast e r (negate $ fromInteger n) ty
-- generic case
-genLoad env e ty = genLoad_slow env e ty [other]
+genLoad e ty
+ = do other <- getTBAAMeta otherN
+ genLoad_slow e ty other
-- | Handle CmmLoad expression.
-- This is a special case for loading from a global register pointer
-- offset such as I32[Sp+8].
-genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType
- -> UniqSM ExprData
-genLoad_fast env e r n ty =
- let dflags = getDflags env
- gr = lmGlobalRegVar dflags r
- meta = [getTBAA r]
- grt = (pLower . getVarType) gr
- ty' = cmmToLlvmType ty
+genLoad_fast :: CmmExpr -> GlobalReg -> Int -> CmmType
+ -> LlvmM ExprData
+genLoad_fast e r n ty = do
+ dflags <- getDynFlags
+ (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)
+ meta <- getTBAARegMeta r
+ let ty' = cmmToLlvmType ty
(ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8)
- in case isPointer grt && rem == 0 of
+ case isPointer grt && rem == 0 of
True -> do
- (gv, s1) <- doExpr grt $ Load gr
(ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]
-- We might need a different pointer type, so check
case grt == ty' of
-- were fine
True -> do
- (var, s3) <- doExpr ty' (MetaExpr meta $ Load ptr)
- return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3,
+ (var, s3) <- doExpr ty' (MExpr meta $ Load ptr)
+ return (var, s1 `snocOL` s2 `snocOL` s3,
[])
-- cast to pointer type needed
False -> do
let pty = pLift ty'
(ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty
- (var, s4) <- doExpr ty' (MetaExpr meta $ Load ptr')
- return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3
+ (var, s4) <- doExpr ty' (MExpr meta $ Load ptr')
+ return (var, s1 `snocOL` s2 `snocOL` s3
`snocOL` s4, [])
-- If its a bit type then we use the slow method since
-- we can't avoid casting anyway.
- False -> genLoad_slow env e ty meta
+ False -> genLoad_slow e ty meta
-- | Handle Cmm load expression.
-- Generic case. Uses casts and pointer arithmetic if needed.
-genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> [MetaData] -> UniqSM ExprData
-genLoad_slow env e ty meta = do
- (env', iptr, stmts, tops) <- exprToVar env e
+genLoad_slow :: CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData
+genLoad_slow e ty meta = do
+ (iptr, stmts, tops) <- exprToVar e
+ dflags <- getDynFlags
case getVarType iptr of
LMPointer _ -> do
(dvar, load) <- doExpr (cmmToLlvmType ty)
- (MetaExpr meta $ Load iptr)
- return (env', dvar, stmts `snocOL` load, tops)
+ (MExpr meta $ Load iptr)
+ return (dvar, stmts `snocOL` load, tops)
i@(LMInt _) | i == llvmWord dflags -> do
let pty = LMPointer $ cmmToLlvmType ty
(ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty
(dvar, load) <- doExpr (cmmToLlvmType ty)
- (MetaExpr meta $ Load ptr)
- return (env', dvar, stmts `snocOL` cast `snocOL` load, tops)
+ (MExpr meta $ Load ptr)
+ return (dvar, stmts `snocOL` cast `snocOL` load, tops)
- other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
+ other -> do dflags <- getDynFlags
+ pprPanic "exprToVar: CmmLoad expression is not right type!"
(PprCmm.pprExpr e <+> text (
"Size of Ptr: " ++ show (llvmPtrBits dflags) ++
", Size of var: " ++ show (llvmWidthInBits dflags other) ++
- ", Var: " ++ show iptr))
- where dflags = getDflags env
-
--- | Handle CmmReg expression
---
--- We allocate CmmReg on the stack. This avoids having to map a CmmReg to an
--- equivalent SSA form and avoids having to deal with Phi node insertion.
--- This is also the approach recommended by LLVM developers.
-getCmmReg :: LlvmEnv -> CmmReg -> ExprData
-getCmmReg env r@(CmmLocal (LocalReg un _))
- = let exists = varLookup un env
- (newv, stmts) = allocReg r
- nenv = varInsert un (pLower $ getVarType newv) env
- in case exists of
- Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, [])
- Nothing -> (nenv, newv, stmts, [])
-
-getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar (getDflags env) g, nilOL, [])
-
-
--- | Allocate a CmmReg on the stack
+ ", Var: " ++ showSDoc dflags (ppr iptr)))
+
+
+-- | Handle CmmReg expression. This will return a pointer to the stack
+-- location of the register. Throws an error if it isn't allocated on
+-- the stack.
+getCmmReg :: CmmReg -> LlvmM LlvmVar
+getCmmReg (CmmLocal (LocalReg un _))
+ = do exists <- varLookup un
+ dflags <- getDynFlags
+ case exists of
+ Just ety -> return (LMLocalVar un $ pLift ety)
+ Nothing -> fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!"
+ -- This should never happen, as every local variable should
+ -- have been assigned a value at some point, triggering
+ -- "funPrologue" to allocate it on the stack.
+
+getCmmReg (CmmGlobal g)
+ = do onStack <- checkStackReg g
+ dflags <- getDynFlags
+ if onStack
+ then return (lmGlobalRegVar dflags g)
+ else fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!"
+
+-- | Return the value of a given register, as well as its type. Might
+-- need to be load from stack.
+getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)
+getCmmRegVal reg =
+ case reg of
+ CmmGlobal g -> do
+ onStack <- checkStackReg g
+ dflags <- getDynFlags
+ if onStack then loadFromStack else do
+ let r = lmGlobalRegArg dflags g
+ return (r, getVarType r, nilOL)
+ _ -> loadFromStack
+ where loadFromStack = do
+ ptr <- getCmmReg reg
+ let ty = pLower $ getVarType ptr
+ (v, s) <- doExpr ty (Load ptr)
+ return (v, ty, unitOL s)
+
+-- | Allocate a local CmmReg on the stack
allocReg :: CmmReg -> (LlvmVar, LlvmStatements)
allocReg (CmmLocal (LocalReg un ty))
= let ty' = cmmToLlvmType ty
@@ -1389,8 +1402,8 @@ allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"
-- | Generate code for a literal
-genLit :: EOption -> LlvmEnv -> CmmLit -> UniqSM ExprData
-genLit opt env (CmmInt i w)
+genLit :: EOption -> CmmLit -> LlvmM ExprData
+genLit opt (CmmInt i w)
-- See Note [Literals and branch conditions].
= let width | i1Expected opt = i1
| otherwise = LMInt (widthInBits w)
@@ -1398,56 +1411,41 @@ genLit opt env (CmmInt i w)
-- , fsLit $ "Width : " ++ show w
-- , fsLit $ "Width' : " ++ show (widthInBits w)
-- ]
- in return (env, mkIntLit width i, nilOL, [])
+ in return (mkIntLit width i, nilOL, [])
-genLit _ env (CmmFloat r w)
- = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
+genLit _ (CmmFloat r w)
+ = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),
nilOL, [])
-
-genLit opt env (CmmVec ls)
+
+genLit opt (CmmVec ls)
= do llvmLits <- mapM toLlvmLit ls
- return (env, LMLitVar $ LMVectorLit llvmLits, nilOL, [])
+ return (LMLitVar $ LMVectorLit llvmLits, nilOL, [])
where
- toLlvmLit :: CmmLit -> UniqSM LlvmLit
+ toLlvmLit :: CmmLit -> LlvmM LlvmLit
toLlvmLit lit = do
- (_, llvmLitVar, _, _) <- genLit opt env lit
+ (llvmLitVar, _, _) <- genLit opt lit
case llvmLitVar of
LMLitVar llvmLit -> return llvmLit
_ -> panic "genLit"
-genLit _ env cmm@(CmmLabel l)
- = let dflags = getDflags env
- label = strCLabel_llvm env l
- ty = funLookup label env
- lmty = cmmToLlvmType $ cmmLitType dflags cmm
- in case ty of
- -- Make generic external label definition and then pointer to it
- Nothing -> do
- let glob@(var, _) = genStringLabelRef dflags label
- let ldata = [CmmData Data [([glob], [])]]
- let env' = funInsert label (pLower $ getVarType var) env
- (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
- return (env', v1, unitOL s1, ldata)
-
- -- Referenced data exists in this module, retrieve type and make
- -- pointer to it.
- Just ty' -> do
- let var = LMGlobalVar label (LMPointer ty')
- ExternallyVisible Nothing Nothing False
- (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
- return (env, v1, unitOL s1, [])
-
-genLit opt env (CmmLabelOff label off) = do
- let dflags = getDflags env
- (env', vlbl, stmts, stat) <- genLit opt env (CmmLabel label)
+genLit _ cmm@(CmmLabel l)
+ = do var <- getGlobalPtr =<< strCLabel_llvm l
+ dflags <- getDynFlags
+ let lmty = cmmToLlvmType $ cmmLitType dflags cmm
+ (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)
+ return (v1, unitOL s1, [])
+
+genLit opt (CmmLabelOff label off) = do
+ dflags <- getDynFlags
+ (vlbl, stmts, stat) <- genLit opt (CmmLabel label)
let voff = toIWord dflags off
(v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff
- return (env', v1, stmts `snocOL` s1, stat)
+ return (v1, stmts `snocOL` s1, stat)
-genLit opt env (CmmLabelDiffOff l1 l2 off) = do
- let dflags = getDflags env
- (env1, vl1, stmts1, stat1) <- genLit opt env (CmmLabel l1)
- (env2, vl2, stmts2, stat2) <- genLit opt env1 (CmmLabel l2)
+genLit opt (CmmLabelDiffOff l1 l2 off) = do
+ dflags <- getDynFlags
+ (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1)
+ (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2)
let voff = toIWord dflags off
let ty1 = getVarType vl1
let ty2 = getVarType vl2
@@ -1457,16 +1455,16 @@ genLit opt env (CmmLabelDiffOff l1 l2 off) = do
then do
(v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2
(v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff
- return (env2, v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
+ return (v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2,
stat1 ++ stat2)
else
panic "genLit: CmmLabelDiffOff encountered with different label ty!"
-genLit opt env (CmmBlock b)
- = genLit opt env (CmmLabel $ infoTblLbl b)
+genLit opt (CmmBlock b)
+ = genLit opt (CmmLabel $ infoTblLbl b)
-genLit _ _ CmmHighStackMark
+genLit _ CmmHighStackMark
= panic "genStaticLit - CmmHighStackMark unsupported!"
@@ -1474,51 +1472,82 @@ genLit _ _ CmmHighStackMark
-- * Misc
--
--- | Function prologue. Load STG arguments into variables for function.
-funPrologue :: DynFlags -> LiveGlobalRegs -> [LlvmStatement]
-funPrologue dflags live = concat $ map getReg $ activeStgRegs platform
- where platform = targetPlatform dflags
- isLive r = r `elem` alwaysLive || r `elem` live
- getReg rr =
- let reg = lmGlobalRegVar dflags rr
- arg = lmGlobalRegArg dflags rr
- ty = (pLower . getVarType) reg
- trash = LMLitVar $ LMUndefLit ty
- alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
- in
- if isLive rr
- then [alloc, Store arg reg]
- else [alloc, Store trash reg]
-
+-- | Find CmmRegs that get assigned and allocate them on the stack
+--
+-- Any register that gets written needs to be allcoated on the
+-- stack. This avoids having to map a CmmReg to an equivalent SSA form
+-- and avoids having to deal with Phi node insertion. This is also
+-- the approach recommended by LLVM developers.
+--
+-- On the other hand, this is unecessarily verbose if the register in
+-- question is never written. Therefore we skip it where we can to
+-- save a few lines in the output and hopefully speed compilation up a
+-- bit.
+funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData
+funPrologue live cmmBlocks = do
+
+ trash <- getTrashRegs
+ let getAssignedRegs :: CmmNode O O -> [CmmReg]
+ getAssignedRegs (CmmAssign reg _) = [reg]
+ -- Calls will trash all registers. Unfortunately, this needs them to
+ -- be stack-allocated in the first place.
+ getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs
+ getAssignedRegs _ = []
+ getRegsBlock (_, body, _) = concatMap getAssignedRegs $ blockToList body
+ assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks
+ isLive r = r `elem` alwaysLive || r `elem` live
+
+ dflags <- getDynFlags
+ stmtss <- flip mapM assignedRegs $ \reg ->
+ case reg of
+ CmmLocal (LocalReg un _) -> do
+ let (newv, stmts) = allocReg reg
+ varInsert un (pLower $ getVarType newv)
+ return stmts
+ CmmGlobal r -> do
+ let reg = lmGlobalRegVar dflags r
+ arg = lmGlobalRegArg dflags r
+ ty = (pLower . getVarType) reg
+ trash = LMLitVar $ LMUndefLit ty
+ rval = if isLive r then arg else trash
+ alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
+ markStackReg r
+ return $ toOL [alloc, Store rval reg]
+
+ return (concatOL stmtss, [])
-- | Function epilogue. Load STG variables to use as argument for call.
-- STG Liveness optimisation done here.
-funEpilogue :: LlvmEnv -> LiveGlobalRegs -> UniqSM ([LlvmVar], LlvmStatements)
+funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)
+funEpilogue live = do
+
+ -- Have information and liveness optimisation is enabled?
+ let liveRegs = alwaysLive ++ live
+ isSSE (FloatReg _) = True
+ isSSE (DoubleReg _) = True
+ isSSE (XmmReg _) = True
+ isSSE _ = False
+
+ -- Set to value or "undef" depending on whether the register is
+ -- actually live
+ dflags <- getDynFlags
+ let loadExpr r = do
+ (v, _, s) <- getCmmRegVal (CmmGlobal r)
+ return (Just $ v, s)
+ loadUndef r = do
+ let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)
+ return (Just $ LMLitVar $ LMUndefLit ty, nilOL)
+ platform <- getDynFlag targetPlatform
+ loads <- flip mapM (activeStgRegs platform) $ \r -> case () of
+ _ | r `elem` liveRegs -> loadExpr r
+ | not (isSSE r) -> loadUndef r
+ | otherwise -> return (Nothing, nilOL)
--- Have information and liveness optimisation is enabled
-funEpilogue env live = do
- loads <- mapM loadExpr (filter isPassed (activeStgRegs platform))
let (vars, stmts) = unzip loads
- return (vars, concatOL stmts)
- where
- dflags = getDflags env
- platform = targetPlatform dflags
- isLive r = r `elem` alwaysLive || r `elem` live
- isPassed r = not (isSSE r) || isLive r
- isSSE (FloatReg _) = True
- isSSE (DoubleReg _) = True
- isSSE (XmmReg _) = True
- isSSE _ = False
- loadExpr r | isLive r = do
- let reg = lmGlobalRegVar dflags r
- (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg
- return (v, unitOL s)
- loadExpr r = do
- let ty = (pLower . getVarType $ lmGlobalRegVar dflags r)
- return (LMLitVar $ LMUndefLit ty, unitOL Nop)
-
-
--- | A serries of statements to trash all the STG registers.
+ return (catMaybes vars, concatOL stmts)
+
+
+-- | A series of statements to trash all the STG registers.
--
-- In LLVM we pass the STG registers around everywhere in function calls.
-- So this means LLVM considers them live across the entire function, when
@@ -1529,59 +1558,47 @@ funEpilogue env live = do
-- before the call by assigning the 'undef' value to them. The ones we
-- need are restored from the Cmm local var and the ones we don't need
-- are fine to be trashed.
-trashStmts :: DynFlags -> LlvmStatements
-trashStmts dflags = concatOL $ map trashReg $ activeStgRegs platform
- where platform = targetPlatform dflags
- trashReg r =
- let reg = lmGlobalRegVar dflags r
- ty = (pLower . getVarType) reg
- trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg
- in case callerSaves (targetPlatform dflags) r of
- True -> trash
- False -> nilOL
-
+getTrashStmts :: LlvmM LlvmStatements
+getTrashStmts = do
+ regs <- getTrashRegs
+ stmts <- flip mapM regs $ \ r -> do
+ reg <- getCmmReg (CmmGlobal r)
+ let ty = (pLower . getVarType) reg
+ return $ Store (LMLitVar $ LMUndefLit ty) reg
+ return $ toOL stmts
+
+getTrashRegs :: LlvmM [GlobalReg]
+getTrashRegs = do plat <- getLlvmPlatform
+ return $ filter (callerSaves plat) (activeStgRegs plat)
-- | Get a function pointer to the CLabel specified.
--
-- This is for Haskell functions, function type is assumed, so doesn't work
-- with foreign functions.
-getHsFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> UniqSM ExprData
-getHsFunc env live lbl
- = let dflags = getDflags env
- fn = strCLabel_llvm env lbl
- ty = funLookup fn env
- in case ty of
- -- Function in module in right form
- Just ty'@(LMFunction sig) -> do
- let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing False
- return (env, fun, nilOL, [])
-
- -- label in module but not function pointer, convert
- Just ty' -> do
- let fun = LMGlobalVar fn (pLift ty') ExternallyVisible
- Nothing Nothing False
- (v1, s1) <- doExpr (pLift (llvmFunTy dflags live)) $
- Cast LM_Bitcast fun (pLift (llvmFunTy dflags live))
- return (env, v1, unitOL s1, [])
-
- -- label not in module, create external reference
- Nothing -> do
- let ty' = LMFunction $ llvmFunSig env live lbl ExternallyVisible
- let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing False
- let top = CmmData Data [([],[ty'])]
- let env' = funInsert fn ty' env
- return (env', fun, nilOL, [top])
-
+getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData
+getHsFunc live lbl
+ = do fty <- llvmFunTy live
+ name <- strCLabel_llvm lbl
+ getHsFunc' name fty
+
+getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData
+getHsFunc' name fty
+ = do fun <- getGlobalPtr name
+ if getVarType fun == fty
+ then return (fun, nilOL, [])
+ else do (v1, s1) <- doExpr (pLift fty)
+ $ Cast LM_Bitcast fun (pLift fty)
+ return (v1, unitOL s1, [])
-- | Create a new local var
-mkLocalVar :: LlvmType -> UniqSM LlvmVar
+mkLocalVar :: LlvmType -> LlvmM LlvmVar
mkLocalVar ty = do
- un <- getUniqueUs
+ un <- runUs getUniqueUs
return $ LMLocalVar un ty
-- | Execute an expression, assigning result to a var
-doExpr :: LlvmType -> LlvmExpression -> UniqSM (LlvmVar, LlvmStatement)
+doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)
doExpr ty expr = do
v <- mkLocalVar ty
return (v, Assignment v expr)
@@ -1618,3 +1635,13 @@ panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s
pprPanic :: String -> SDoc -> a
pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d
+
+-- | Returns TBAA meta data by unique
+getTBAAMeta :: Unique -> LlvmM [MetaAnnot]
+getTBAAMeta u = do
+ mi <- getUniqMeta u
+ return [MetaAnnot tbaa (MetaNode i) | let Just i = mi]
+
+-- | Returns TBAA meta data for given register
+getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot]
+getTBAARegMeta = getTBAAMeta . getTBAA
diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs
index 83b5453aa9..6212cfc9fb 100644
--- a/compiler/llvmGen/LlvmCodeGen/Data.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Data.hs
@@ -3,7 +3,7 @@
--
module LlvmCodeGen.Data (
- genLlvmData, resolveLlvmDatas, resolveLlvmData
+ genLlvmData
) where
#include "HsVersions.h"
@@ -18,8 +18,6 @@ import Cmm
import FastString
import qualified Outputable
-import Data.List (foldl')
-
-- ----------------------------------------------------------------------------
-- * Constants
--
@@ -32,43 +30,23 @@ structStr = fsLit "_struct"
-- * Top level
--
--- | Pass a CmmStatic section to an equivalent Llvm code. Can't
--- complete this completely though as we need to pass all CmmStatic
--- sections before all references can be resolved. This last step is
--- done by 'resolveLlvmData'.
-genLlvmData :: LlvmEnv -> (Section, CmmStatics) -> LlvmUnresData
-genLlvmData env (sec, Statics lbl xs) =
- let dflags = getDflags env
- static = map genData xs
- label = strCLabel_llvm env lbl
-
- types = map getStatTypes static
- getStatTypes (Left x) = cmmToLlvmType $ cmmLitType dflags x
- getStatTypes (Right x) = getStatType x
+-- | Pass a CmmStatic section to an equivalent Llvm code.
+genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData
+genLlvmData (sec, Statics lbl xs) = do
+ label <- strCLabel_llvm lbl
+ static <- mapM genData xs
+ let types = map getStatType static
strucTy = LMStruct types
alias = LMAlias ((label `appendFS` structStr), strucTy)
- in (lbl, sec, alias, static)
-
-resolveLlvmDatas :: LlvmEnv -> [LlvmUnresData] -> (LlvmEnv, [LlvmData])
-resolveLlvmDatas env ldata
- = foldl' res (env, []) ldata
- where res (e, xs) ll =
- let (e', nd) = resolveLlvmData e ll
- in (e', nd:xs)
-
--- | Fix up CLabel references now that we should have passed all CmmData.
-resolveLlvmData :: LlvmEnv -> LlvmUnresData -> (LlvmEnv, LlvmData)
-resolveLlvmData env (lbl, sec, alias, unres) =
- let (env', static, refs) = resDatas env unres ([], [])
struct = Just $ LMStaticStruc static alias
- label = strCLabel_llvm env lbl
link = if (externallyVisibleCLabel lbl)
then ExternallyVisible else Internal
- const = isSecConstant sec
+ const = if isSecConstant sec then Constant else Global
glob = LMGlobalVar label alias link Nothing Nothing const
- in (env', ((glob,struct):refs, [alias]))
+
+ return ([LMGlobal glob struct], [alias])
-- | Should a data in this section be considered constant
isSecConstant :: Section -> Bool
@@ -82,80 +60,19 @@ isSecConstant (OtherSection _) = False
-- ----------------------------------------------------------------------------
--- ** Resolve Data/CLabel references
---
-
--- | Resolve data list
-resDatas :: LlvmEnv -> [UnresStatic] -> ([LlvmStatic], [LMGlobal])
- -> (LlvmEnv, [LlvmStatic], [LMGlobal])
-
-resDatas env [] (stats, glob)
- = (env, stats, glob)
-
-resDatas env (cmm:rest) (stats, globs)
- = let (env', nstat, nglob) = resData env cmm
- in resDatas env' rest (stats ++ [nstat], globs ++ nglob)
-
--- | Resolve an individual static label if it needs to be.
---
--- We check the 'LlvmEnv' to see if the reference has been defined in this
--- module. If it has we can retrieve its type and make a pointer, otherwise
--- we introduce a generic external definition for the referenced label and
--- then make a pointer.
-resData :: LlvmEnv -> UnresStatic -> (LlvmEnv, LlvmStatic, [LMGlobal])
-
-resData env (Right stat) = (env, stat, [])
-
-resData env (Left cmm@(CmmLabel l)) =
- let dflags = getDflags env
- label = strCLabel_llvm env l
- ty = funLookup label env
- lmty = cmmToLlvmType $ cmmLitType dflags cmm
- in case ty of
- -- Make generic external label defenition and then pointer to it
- Nothing ->
- let glob@(var, _) = genStringLabelRef dflags label
- env' = funInsert label (pLower $ getVarType var) env
- ptr = LMStaticPointer var
- in (env', LMPtoI ptr lmty, [glob])
- -- Referenced data exists in this module, retrieve type and make
- -- pointer to it.
- Just ty' ->
- let var = LMGlobalVar label (LMPointer ty')
- ExternallyVisible Nothing Nothing False
- ptr = LMStaticPointer var
- in (env, LMPtoI ptr lmty, [])
-
-resData env (Left (CmmLabelOff label off)) =
- let dflags = getDflags env
- (env', var, glob) = resData env (Left (CmmLabel label))
- offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
- in (env', LMAdd var offset, glob)
-
-resData env (Left (CmmLabelDiffOff l1 l2 off)) =
- let dflags = getDflags env
- (env1, var1, glob1) = resData env (Left (CmmLabel l1))
- (env2, var2, glob2) = resData env1 (Left (CmmLabel l2))
- var = LMSub var1 var2
- offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
- in (env2, LMAdd var offset, glob1 ++ glob2)
-
-resData _ _ = panic "resData: Non CLabel expr as left type!"
-
--- ----------------------------------------------------------------------------
-- * Generate static data
--
-- | Handle static data
-genData :: CmmStatic -> UnresStatic
+genData :: CmmStatic -> LlvmM LlvmStatic
-genData (CmmString str) =
+genData (CmmString str) = do
let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) str
ve = v ++ [LMStaticLit $ LMIntLit 0 i8]
- in Right $ LMStaticArray ve (LMArray (length ve) i8)
+ return $ LMStaticArray ve (LMArray (length ve) i8)
genData (CmmUninitialised bytes)
- = Right $ LMUninitType (LMArray bytes i8)
+ = return $ LMUninitType (LMArray bytes i8)
genData (CmmStaticLit lit)
= genStaticLit lit
@@ -164,27 +81,47 @@ genData (CmmStaticLit lit)
--
-- Will either generate the code or leave it unresolved if it is a 'CLabel'
-- which isn't yet known.
-genStaticLit :: CmmLit -> UnresStatic
+genStaticLit :: CmmLit -> LlvmM LlvmStatic
genStaticLit (CmmInt i w)
- = Right $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w))
+ = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w))
genStaticLit (CmmFloat r w)
- = Right $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w))
+ = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w))
genStaticLit (CmmVec ls)
- = Right $ LMStaticLit (LMVectorLit (map toLlvmLit ls))
+ = do sls <- mapM toLlvmLit ls
+ return $ LMStaticLit (LMVectorLit sls)
where
- toLlvmLit :: CmmLit -> LlvmLit
- toLlvmLit lit = case genStaticLit lit of
- Right (LMStaticLit llvmLit) -> llvmLit
- _ -> panic "genStaticLit"
+ toLlvmLit :: CmmLit -> LlvmM LlvmLit
+ toLlvmLit lit = do
+ slit <- genStaticLit lit
+ case slit of
+ LMStaticLit llvmLit -> return llvmLit
+ _ -> panic "genStaticLit"
-- Leave unresolved, will fix later
-genStaticLit c@(CmmLabel _ ) = Left $ c
-genStaticLit c@(CmmLabelOff _ _) = Left $ c
-genStaticLit c@(CmmLabelDiffOff _ _ _) = Left $ c
+genStaticLit cmm@(CmmLabel l) = do
+ var <- getGlobalPtr =<< strCLabel_llvm l
+ dflags <- getDynFlags
+ let ptr = LMStaticPointer var
+ lmty = cmmToLlvmType $ cmmLitType dflags cmm
+ return $ LMPtoI ptr lmty
+
+genStaticLit (CmmLabelOff label off) = do
+ dflags <- getDynFlags
+ var <- genStaticLit (CmmLabel label)
+ let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
+ return $ LMAdd var offset
+
+genStaticLit (CmmLabelDiffOff l1 l2 off) = do
+ dflags <- getDynFlags
+ var1 <- genStaticLit (CmmLabel l1)
+ var2 <- genStaticLit (CmmLabel l2)
+ let var = LMSub var1 var2
+ offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
+ return $ LMAdd var offset
-genStaticLit (CmmBlock b) = Left $ CmmLabel $ infoTblLbl b
+genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b
genStaticLit (CmmHighStackMark)
= panic "genStaticLit: CmmHighStackMark unsupported!"
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index c699631e9c..1c63d3f67f 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -11,7 +11,6 @@ module LlvmCodeGen.Ppr (
import Llvm
import LlvmCodeGen.Base
import LlvmCodeGen.Data
-import LlvmCodeGen.Regs
import CLabel
import Cmm
@@ -28,12 +27,7 @@ import Unique
-- | Header code for LLVM modules
pprLlvmHeader :: SDoc
-pprLlvmHeader = sdocWithDynFlags $ \dflags ->
- moduleLayout
- $+$ text ""
- $+$ ppLlvmFunctionDecls (map snd (ghcInternalFunctions dflags))
- $+$ ppLlvmMetas stgTBAA
- $+$ text ""
+pprLlvmHeader = moduleLayout
-- | LLVM module layout description for the host target
@@ -61,6 +55,9 @@ moduleLayout = sdocWithPlatform $ \platform ->
Platform { platformArch = ArchARM {}, platformOS = OSAndroid } ->
text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
$+$ text "target triple = \"arm-unknown-linux-androideabi\""
+ Platform { platformArch = ArchARM {}, platformOS = OSQNXNTO } ->
+ text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
+ $+$ text "target triple = \"arm-unknown-nto-qnx8.0.0eabi\""
Platform { platformArch = ArchARM {}, platformOS = OSiOS } ->
text "target datalayout = \"e-p:32:32:32-i1:8:8-i8:8:8-i16:16:16-i32:32:32-i64:64:64-f32:32:32-f64:64:64-v64:64:64-v128:64:128-a0:0:64-n32\""
$+$ text "target triple = \"arm-apple-darwin10\""
@@ -72,63 +69,61 @@ moduleLayout = sdocWithPlatform $ \platform ->
-- | Pretty print LLVM data code
pprLlvmData :: LlvmData -> SDoc
pprLlvmData (globals, types) =
- let tryConst (v, Just s ) = ppLlvmGlobal (v, Just s)
- tryConst g@(_, Nothing) = ppLlvmGlobal g
-
- ppLlvmTys (LMAlias a) = ppLlvmAlias a
+ let ppLlvmTys (LMAlias a) = ppLlvmAlias a
ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f
ppLlvmTys _other = empty
types' = vcat $ map ppLlvmTys types
- globals' = vcat $ map tryConst globals
+ globals' = ppLlvmGlobals globals
in types' $+$ globals'
-- | Pretty print LLVM code
-pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (SDoc, [LlvmVar])
-pprLlvmCmmDecl _ _ (CmmData _ lmdata)
- = (vcat $ map pprLlvmData lmdata, [])
+pprLlvmCmmDecl :: Int -> LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])
+pprLlvmCmmDecl _ (CmmData _ lmdata)
+ = return (vcat $ map pprLlvmData lmdata, [])
-pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl live (ListGraph blks))
- = let (idoc, ivar) = case mb_info of
- Nothing -> (empty, [])
+pprLlvmCmmDecl count (CmmProc mb_info entry_lbl live (ListGraph blks))
+ = do (idoc, ivar) <- case mb_info of
+ Nothing -> return (empty, [])
Just (Statics info_lbl dat)
- -> pprInfoTable env count info_lbl (Statics entry_lbl dat)
- in (idoc $+$ (
- let sec = mkLayoutSection (count + 1)
- (lbl',sec') = case mb_info of
+ -> pprInfoTable count info_lbl (Statics entry_lbl dat)
+
+ let sec = mkLayoutSection (count + 1)
+ (lbl',sec') = case mb_info of
Nothing -> (entry_lbl, Nothing)
Just (Statics info_lbl _) -> (info_lbl, sec)
- link = if externallyVisibleCLabel lbl'
+ link = if externallyVisibleCLabel lbl'
then ExternallyVisible
else Internal
- lmblocks = map (\(BasicBlock id stmts) ->
+ lmblocks = map (\(BasicBlock id stmts) ->
LlvmBlock (getUnique id) stmts) blks
- fun = mkLlvmFunc env live lbl' link sec' lmblocks
- in ppLlvmFunction fun
- ), ivar)
+
+ fun <- mkLlvmFunc live lbl' link sec' lmblocks
+
+ return (idoc $+$ ppLlvmFunction fun, ivar)
-- | Pretty print CmmStatic
-pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (SDoc, [LlvmVar])
-pprInfoTable env count info_lbl stat
- = let dflags = getDflags env
- unres = genLlvmData env (Text, stat)
- (_, (ldata, ltypes)) = resolveLlvmData env unres
-
- setSection ((LMGlobalVar _ ty l _ _ c), d)
- = let sec = mkLayoutSection count
- ilabel = strCLabel_llvm env info_lbl
- `appendFS` fsLit iTableSuf
- gv = LMGlobalVar ilabel ty l sec (llvmInfAlign dflags) c
- v = if l == Internal then [gv] else []
- in ((gv, d), v)
- setSection v = (v,[])
-
- (ldata', llvmUsed) = setSection (last ldata)
- in if length ldata /= 1
+pprInfoTable :: Int -> CLabel -> CmmStatics -> LlvmM (SDoc, [LlvmVar])
+pprInfoTable count info_lbl stat
+ = do (ldata, ltypes) <- genLlvmData (Text, stat)
+
+ dflags <- getDynFlags
+ let setSection (LMGlobal (LMGlobalVar _ ty l _ _ c) d) = do
+ lbl <- strCLabel_llvm info_lbl
+ let sec = mkLayoutSection count
+ ilabel = lbl `appendFS` fsLit iTableSuf
+ gv = LMGlobalVar ilabel ty l sec (llvmInfAlign dflags) c
+ v = if l == Internal then [gv] else []
+ funInsert ilabel ty
+ return (LMGlobal gv d, v)
+ setSection v = return (v,[])
+
+ (ldata', llvmUsed) <- setSection (last ldata)
+ if length ldata /= 1
then Outputable.panic "LlvmCodeGen.Ppr: invalid info table!"
- else (pprLlvmData ([ldata'], ltypes), llvmUsed)
+ else return (pprLlvmData ([ldata'], ltypes), llvmUsed)
-- | We generate labels for info tables by converting them to the same label
diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs
index 7271c2f3d9..1b87929499 100644
--- a/compiler/llvmGen/LlvmCodeGen/Regs.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs
@@ -4,7 +4,7 @@
module LlvmCodeGen.Regs (
lmGlobalRegArg, lmGlobalRegVar, alwaysLive,
- stgTBAA, top, base, stack, heap, rx, other, tbaa, getTBAA
+ stgTBAA, baseN, stackN, heapN, rxN, otherN, tbaa, getTBAA
) where
#include "HsVersions.h"
@@ -15,6 +15,7 @@ import CmmExpr
import DynFlags
import FastString
import Outputable ( panic )
+import Unique
-- | Get the LlvmVar function variable storing the real register
lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar
@@ -76,48 +77,38 @@ lmGlobalReg dflags suf reg
alwaysLive :: [GlobalReg]
alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node]
--- | STG Type Based Alias Analysis metadata
-stgTBAA :: [LlvmMeta]
+-- | STG Type Based Alias Analysis hierarchy
+stgTBAA :: [(Unique, LMString, Maybe Unique)]
stgTBAA
- = [ MetaUnamed topN [MetaStr (fsLit "top")]
- , MetaUnamed stackN [MetaStr (fsLit "stack"), MetaNode topN]
- , MetaUnamed heapN [MetaStr (fsLit "heap"), MetaNode topN]
- , MetaUnamed rxN [MetaStr (fsLit "rx"), MetaNode heapN]
- , MetaUnamed baseN [MetaStr (fsLit "base"), MetaNode topN]
+ = [ (topN, fsLit "top", Nothing)
+ , (stackN, fsLit "stack", Just topN)
+ , (heapN, fsLit "heap", Just topN)
+ , (rxN, fsLit "rx", Just heapN)
+ , (baseN, fsLit "base", Just topN)
-- FIX: Not 100% sure about 'others' place. Might need to be under 'heap'.
-- OR I think the big thing is Sp is never aliased, so might want
-- to change the hieracy to have Sp on its own branch that is never
-- aliased (e.g never use top as a TBAA node).
- , MetaUnamed otherN [MetaStr (fsLit "other"), MetaNode topN]
+ , (otherN, fsLit "other", Just topN)
]
-- | Id values
-topN, stackN, heapN, rxN, baseN, otherN:: LlvmMetaUnamed
-topN = LMMetaUnamed 0
-stackN = LMMetaUnamed 1
-heapN = LMMetaUnamed 2
-rxN = LMMetaUnamed 3
-baseN = LMMetaUnamed 4
-otherN = LMMetaUnamed 5
-
--- | The various TBAA types
-top, heap, stack, rx, base, other :: MetaData
-top = (tbaa, topN)
-heap = (tbaa, heapN)
-stack = (tbaa, stackN)
-rx = (tbaa, rxN)
-base = (tbaa, baseN)
-other = (tbaa, otherN)
+topN, stackN, heapN, rxN, baseN, otherN :: Unique
+topN = getUnique (fsLit "LlvmCodeGen.Regs.topN")
+stackN = getUnique (fsLit "LlvmCodeGen.Regs.stackN")
+heapN = getUnique (fsLit "LlvmCodeGen.Regs.heapN")
+rxN = getUnique (fsLit "LlvmCodeGen.Regs.rxN")
+baseN = getUnique (fsLit "LlvmCodeGen.Regs.baseN")
+otherN = getUnique (fsLit "LlvmCodeGen.Regs.otherN")
-- | The TBAA metadata identifier
tbaa :: LMString
tbaa = fsLit "tbaa"
-- | Get the correct TBAA metadata information for this register type
-getTBAA :: GlobalReg -> MetaData
-getTBAA BaseReg = base
-getTBAA Sp = stack
-getTBAA Hp = heap
-getTBAA (VanillaReg _ _) = rx
-getTBAA _ = top
-
+getTBAA :: GlobalReg -> Unique
+getTBAA BaseReg = baseN
+getTBAA Sp = stackN
+getTBAA Hp = heapN
+getTBAA (VanillaReg _ _) = rxN
+getTBAA _ = topN
View Lorry Controller Status