Add ability to call functions with metadata as arguments to LLVM

backend.

5 files changed, 51 insertions, 16 deletions

diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs
index 32bd35b8e1..b5892c17d2 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 00abb71b8c..6163fc842c 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 92e8ecdeb4..0471e59358 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 33f31fcde1..3e86cee085 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 f6385b1189..fe77d7580c 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