[commit: ghc] : Add ability to call functions with metadata as arguments to LLVM backend. (3b1d920)
David Terei
davidterei at gmail.com
Fri Jun 28 03:56:33 CEST 2013
Repository : http://darcs.haskell.org/ghc.git/
On branch :
https://github.com/ghc/ghc/commit/3b1d920ef867b459abebe22c27102fd1e685607c
>---------------------------------------------------------------
commit 3b1d920ef867b459abebe22c27102fd1e685607c
Author: David Terei <davidterei at gmail.com>
Date: Tue Jun 18 17:38:47 2013 -0700
Add ability to call functions with metadata as arguments to LLVM
backend.
>---------------------------------------------------------------
compiler/llvmGen/Llvm.hs | 2 +-
compiler/llvmGen/Llvm/AbsSyn.hs | 21 +++++++++++++++++++++
compiler/llvmGen/Llvm/MetaData.hs | 26 ++++++++++++++++++--------
compiler/llvmGen/Llvm/PpLlvm.hs | 7 ++++---
compiler/llvmGen/Llvm/Types.hs | 11 +++++++----
5 files changed, 51 insertions(+), 16 deletions(-)
diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs
index 32bd35b..b5892c1 100644
--- a/compiler/llvmGen/Llvm.hs
+++ b/compiler/llvmGen/Llvm.hs
@@ -25,7 +25,7 @@ module Llvm (
-- * Call Handling
LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..),
- LlvmLinkageType(..), LlvmFuncAttr(..),
+ LlvmLinkageType(..), LlvmFuncAttr(..), MetaArgs(..),
-- * Operations and Comparisons
LlvmCmpOp(..), LlvmMachOp(..), LlvmCastOp(..),
diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs
index 00abb71..6163fc8 100644
--- a/compiler/llvmGen/Llvm/AbsSyn.hs
+++ b/compiler/llvmGen/Llvm/AbsSyn.hs
@@ -65,6 +65,16 @@ data LlvmFunction = LlvmFunction {
type LlvmFunctions = [LlvmFunction]
+-- | LLVM function call arguments.
+data MetaArgs
+ = ArgVar LlvmVar -- ^ Regular LLVM variable as argument.
+ | ArgMeta MetaExpr -- ^ Metadata as argument.
+ deriving (Eq)
+
+instance Show MetaArgs where
+ show (ArgVar v) = show v
+ show (ArgMeta m) = show m
+
-- | LLVM ordering types for synchronization purposes. (Introduced in LLVM
-- 3.0). Please see the LLVM documentation for a better description.
data LlvmSyncOrdering
@@ -252,6 +262,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 [MetaArgs] [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
diff --git a/compiler/llvmGen/Llvm/MetaData.hs b/compiler/llvmGen/Llvm/MetaData.hs
index 92e8ecd..0471e59 100644
--- a/compiler/llvmGen/Llvm/MetaData.hs
+++ b/compiler/llvmGen/Llvm/MetaData.hs
@@ -73,6 +73,16 @@ data MetaVal
| MetaValNode Int
deriving (Eq)
+instance Show MetaExpr where
+ show (MetaStr s ) = "metadata !\"" ++ unpackFS s ++ "\""
+ show (MetaNode n ) = "metadata !" ++ show n
+ show (MetaVar v ) = show v
+ show (MetaExpr es) = intercalate ", " $ map show es
+
+instance Show MetaVal where
+ show (MetaValExpr e) = "!{ " ++ show e ++ "}"
+ show (MetaValNode n) = "!" ++ show n
+
-- | Associated some metadata with a specific label for attaching to an
-- instruction.
type MetaData = (LMString, MetaVal)
@@ -86,15 +96,15 @@ data MetaDecl
-- ('!0 = metadata !{ <metadata expression> }' form).
| MetaUnamed Int MetaExpr
-instance Show MetaExpr where
- show (MetaStr s ) = "metadata !\"" ++ unpackFS s ++ "\""
- show (MetaNode n ) = "metadata !" ++ show n
- show (MetaVar v ) = show v
- show (MetaExpr es) = intercalate ", " $ map show es
+-- | LLVM function call arguments.
+data MetaArgs
+ = ArgVar LlvmVar -- ^ Regular LLVM variable as argument.
+ | ArgMeta MetaExpr -- ^ Metadata as argument.
+ deriving (Eq)
-instance Show MetaVal where
- show (MetaValExpr e) = "!{ " ++ show e ++ "}"
- show (MetaValNode n) = "!" ++ show n
+instance Show MetaArgs where
+ show (ArgVar v) = show v
+ show (ArgMeta m) = show m
{-
Note: Metadata encoding
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index 33f31fc..3e86cee 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -228,6 +228,7 @@ ppLlvmExpression expr
Alloca tp amount -> ppAlloca tp amount
LlvmOp op left right -> ppMachOp op left right
Call tp fp args attrs -> ppCall tp fp 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
@@ -246,8 +247,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 :: (Show a) => LlvmCallType -> LlvmVar -> [a] -> [LlvmFuncAttr] -> SDoc
+ppCall ct fptr args attrs = case fptr of
--
-- if local var function pointer, unwrap
LMLocalVar _ (LMPointer (LMFunction d)) -> ppCall' d
@@ -263,7 +264,7 @@ 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
+ ppValues = ppCommaJoin args
ppParams = map (texts . fst) params
ppArgTy = (hcat $ intersperse comma ppParams) <>
(case argTy of
diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs
index f6385b1..fe77d75 100644
--- a/compiler/llvmGen/Llvm/Types.hs
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -47,6 +47,7 @@ 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
@@ -64,6 +65,8 @@ instance Show LlvmType where
show (LMLabel ) = "label"
show (LMVoid ) = "void"
show (LMStruct tys ) = "<{" ++ (commaCat tys) ++ "}>"
+ show (LMAlias (s,_) ) = "%" ++ unpackFS s
+ show (LMMetadata ) = "metadata"
show (LMFunction (LlvmFunctionDecl _ _ _ r varg p _))
= let varg' = case varg of
@@ -74,7 +77,6 @@ instance Show LlvmType where
args = intercalate ", " $ map (show . fst) p
in show r ++ " (" ++ args ++ varg' ++ ")"
- show (LMAlias (s,_)) = "%" ++ unpackFS s
-- | An LLVM section definition. If Nothing then let LLVM decide the section
type LMSection = Maybe LMString
@@ -252,9 +254,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
More information about the ghc-commits
mailing list