Add support for parameter attributes to the llvm BE binding

These allow annotations of the code produced by the backend
which should bring some perforamnce gains. At the moment
the attributes aren't being used though.

7 files changed, 108 insertions, 28 deletions

diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs
index 907ab3935f..dcb8706cec 100644
--- a/compiler/llvmGen/Llvm.hs
+++ b/compiler/llvmGen/Llvm.hs
@@ -18,6 +18,7 @@ module Llvm (
         LlvmFunctions, LlvmFunctionDecls,
         LlvmStatement(..), LlvmExpression(..),
         LlvmBlocks, LlvmBlock(..), LlvmBlockId,
+        LlvmParamAttr(..), LlvmParameter,
 
         -- * Call Handling
         LlvmCallConvention(..), LlvmCallType(..), LlvmParameterListType(..),
diff --git a/compiler/llvmGen/Llvm/AbsSyn.hs b/compiler/llvmGen/Llvm/AbsSyn.hs
index 05a0f08cfd..1fed3a88dd 100644
--- a/compiler/llvmGen/Llvm/AbsSyn.hs
+++ b/compiler/llvmGen/Llvm/AbsSyn.hs
@@ -43,6 +43,9 @@ data LlvmFunction = LlvmFunction {
     -- | The signature of this declared function.
     funcDecl  :: LlvmFunctionDecl,
 
+    -- | The functions arguments
+    funcArgs  :: [LMString],
+
     -- | The function attributes.
     funcAttrs :: [LlvmFuncAttr],
 
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index fffb72db20..9afb76e596 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -104,17 +104,30 @@ ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
 
 -- | Print out a function definition.
 ppLlvmFunction :: LlvmFunction -> Doc
-ppLlvmFunction (LlvmFunction dec attrs sec body) =
+ppLlvmFunction (LlvmFunction dec args attrs sec body) =
     let attrDoc = ppSpaceJoin attrs
         secDoc = case sec of
-                      Just s' -> text "section " <+> (doubleQuotes $ ftext s')
+                      Just s' -> text "section" <+> (doubleQuotes $ ftext s')
                       Nothing -> empty
-    in text "define" <+> texts dec
+    in text "define" <+> ppLlvmFunctionHeader dec args
         <+> attrDoc <+> secDoc
         $+$ lbrace
         $+$ ppLlvmBlocks body
         $+$ rbrace
 
+-- | Print out a function defenition header.
+ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc
+ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
+  = let varg' = if varg == VarArgs then text ", ..." else empty
+        align = case a of
+                     Just a' -> space <> text "align" <+> texts a'
+                     Nothing -> empty
+        args' = map (\((ty,p),n) -> texts ty <+> ppSpaceJoin p <+> text "%"
+                                    <> ftext n)
+                    (zip p args)
+    in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <>
+        (hcat $ intersperse comma args') <> varg' <> rparen <> align
+
 
 -- | Print out a list of function declaration.
 ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc
@@ -194,7 +207,8 @@ ppCall ct fptr vals attrs = case fptr of
         ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) =
             let tc = if ct == TailCall then text "tail " else empty
                 ppValues = ppCommaJoin vals
-                ppArgTy = either ppCommaJoin (\x -> ppCommaJoin $ map getVarType x) params <>
+                ppParams = map (\(ty,p) -> texts ty <+> ppSpaceJoin p) params
+                ppArgTy  = (hcat $ intersperse comma ppParams) <>
                            (case argTy of
                                VarArgs   -> text ", ..."
                                FixedArgs -> empty)
diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs
index 19a441f1b3..50b365676e 100644
--- a/compiler/llvmGen/Llvm/Types.hs
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -57,10 +57,11 @@ instance Show LlvmType where
   show (LMVoid        ) = "void"
   show (LMStruct tys  ) = "{" ++ (commaCat tys) ++ "}"
 
-  show (LMFunction (LlvmFunctionDecl _ _ _ r VarArgs p _))
-        = show r ++ " (" ++ (either commaCat commaCat p) ++ ", ...)"
-  show (LMFunction (LlvmFunctionDecl _ _ _ r FixedArgs p _))
-        = show r ++ " (" ++ (either commaCat commaCat p) ++ ")"
+  show (LMFunction (LlvmFunctionDecl _ _ _ r varg p _))
+    = let varg' = if varg == VarArgs then ", ..." else ""
+          args = (tail.concat) $
+                  map (\(t,a) -> "," ++ show t ++ " " ++ spaceCat a) p
+    in show r ++ " (" ++ args ++ varg' ++ ")"
 
   show (LMAlias s _   ) = "%" ++ unpackFS s
 
@@ -168,6 +169,11 @@ commaCat :: Show a => [a] -> String
 commaCat [] = ""
 commaCat x  = show (head x) ++ (concat $ map (\y -> "," ++ show y) (tail x))
 
+-- | Concatenate an array together, separated by commas
+spaceCat :: Show a => [a] -> String
+spaceCat [] = ""
+spaceCat x  = show (head x) ++ (concat $ map (\y -> " " ++ show y) (tail x))
+
 -- -----------------------------------------------------------------------------
 -- ** Operations on LLVM Basic Types and Variables
 --
@@ -326,19 +332,18 @@ llvmWordPtr = pLift llvmWord
 
 -- | An LLVM Function
 data LlvmFunctionDecl = LlvmFunctionDecl {
-        -- | Unique identifier of the function.
+        -- | Unique identifier of the function
         decName       :: LMString,
-        -- | LinkageType of the function.
+        -- | LinkageType of the function
         funcLinkage   :: LlvmLinkageType,
-        -- | The calling convention of the function.
+        -- | The calling convention of the function
         funcCc        :: LlvmCallConvention,
         -- | Type of the returned value
         decReturnType :: LlvmType,
         -- | Indicates if this function uses varargs
         decVarargs    :: LlvmParameterListType,
-        -- | Signature of the parameters, can be just types or full vars
-        -- if parameter names are required.
-        decParams     :: Either [LlvmType] [LlvmVar],
+        -- | Parameter types and attributes
+        decParams     :: [LlvmParameter],
         -- | Function align value, must be power of 2
         funcAlign     :: LMAlign
   }
@@ -350,11 +355,59 @@ instance Show LlvmFunctionDecl where
           align = case a of
                        Just a' -> " align " ++ show a'
                        Nothing -> ""
+          args = (tail.concat) $
+                  map (\(t,a) -> "," ++ show t ++ " " ++ spaceCat a) p
     in show l ++ " " ++ show c ++ " " ++ show r ++ " @" ++ unpackFS n ++
-        "(" ++ (either commaCat commaCat p) ++ varg' ++ ")" ++ align
+        "(" ++ args ++ varg' ++ ")" ++ align
 
 type LlvmFunctionDecls = [LlvmFunctionDecl]
 
+type LlvmParameter = (LlvmType, [LlvmParamAttr])
+
+-- | LLVM Parameter Attributes.
+--
+-- Parameter attributes are used to communicate additional information about
+-- the result or parameters of a function
+data LlvmParamAttr
+  -- | This indicates to the code generator that the parameter or return value
+  -- should be zero-extended to a 32-bit value by the caller (for a parameter)
+  -- or the callee (for a return value).
+  = ZeroExt
+  -- | This indicates to the code generator that the parameter or return value
+  -- should be sign-extended to a 32-bit value by the caller (for a parameter)
+  -- or the callee (for a return value).
+  | SignExt
+  -- | This indicates that this parameter or return value should be treated in
+  -- a special target-dependent fashion during while emitting code for a
+  -- function call or return (usually, by putting it in a register as opposed
+  -- to memory).
+  | InReg
+  -- | This indicates that the pointer parameter should really be passed by
+  -- value to the function.
+  | ByVal
+  -- | This indicates that the pointer parameter specifies the address of a
+  -- structure that is the return value of the function in the source program.
+  | SRet
+  -- | This indicates that the pointer does not alias any global or any other
+  -- parameter.
+  | NoAlias
+  -- | This indicates that the callee does not make any copies of the pointer
+  -- that outlive the callee itself
+  | NoCapture
+  -- | This indicates that the pointer parameter can be excised using the
+  -- trampoline intrinsics.
+  | 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"
 
 -- | Llvm Function Attributes.
 --
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 5e0df3ef86..83469c80f5 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -14,7 +14,7 @@ module LlvmCodeGen.Base (
 
         cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
         llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
-        llvmPtrBits, llvmGhcCC,
+        llvmPtrBits, mkLlvmFunc, tysToParams,
 
         strCLabel_llvm, genCmmLabelRef, genStringLabelRef
 
@@ -82,17 +82,22 @@ llvmGhcCC = CC_Ncc 10
 
 -- | Llvm Function type for Cmm function
 llvmFunTy :: LlvmType
-llvmFunTy
-  = LMFunction $
-        LlvmFunctionDecl (fsLit "a") ExternallyVisible llvmGhcCC LMVoid FixedArgs
-            (Left $ map getVarType llvmFunArgs) llvmFunAlign
+llvmFunTy = LMFunction $ llvmFunSig' (fsLit "a") ExternallyVisible
 
 -- | Llvm Function signature
 llvmFunSig :: CLabel -> LlvmLinkageType -> LlvmFunctionDecl
-llvmFunSig lbl link
-  = let n = strCLabel_llvm lbl
-    in LlvmFunctionDecl n link llvmGhcCC LMVoid FixedArgs
-        (Right llvmFunArgs) llvmFunAlign
+llvmFunSig lbl link = llvmFunSig' (strCLabel_llvm lbl) link
+
+llvmFunSig' :: LMString -> LlvmLinkageType -> LlvmFunctionDecl
+llvmFunSig' lbl link = LlvmFunctionDecl lbl link llvmGhcCC LMVoid FixedArgs
+                        (tysToParams $ map getVarType llvmFunArgs) llvmFunAlign
+
+-- | Create a Haskell function in LLVM.
+mkLlvmFunc :: CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks -> LlvmFunction
+mkLlvmFunc lbl link sec blks
+  = let funDec = llvmFunSig lbl link
+        funArgs = map (fsLit . getPlainName) llvmFunArgs
+    in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
 
 -- | Alignment to use for functions
 llvmFunAlign :: LMAlign
@@ -110,6 +115,11 @@ llvmFunArgs = map lmGlobalRegArg activeStgRegs
 llvmStdFunAttrs :: [LlvmFuncAttr]
 llvmStdFunAttrs = [NoUnwind]
 
+-- | Convert a list of types to a list of function parameters
+-- (each with no parameter attributes)
+tysToParams :: [LlvmType] -> [LlvmParameter]
+tysToParams = map (\ty -> (ty, []))
+
 -- | Pointer width
 llvmPtrBits :: Int
 llvmPtrBits = widthInBits $ typeWidth gcWord
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 85094f7803..c945f97d31 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -153,7 +153,7 @@ genCall :: LlvmEnv -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals
 genCall env (CmmPrim MO_WriteBarrier) _ _ _ = do
     let fname = fsLit "llvm.memory.barrier"
     let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid
-                FixedArgs (Left [i1, i1, i1, i1, i1]) llvmFunAlign
+                    FixedArgs (tysToParams [i1, i1, i1, i1, i1]) llvmFunAlign
     let fty = LMFunction funSig
 
     let fv   = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing False
@@ -217,7 +217,7 @@ genCall env target res args ret = do
     -- fun type
     let ccTy  = StdCall -- tail calls should be done through CmmJump
     let retTy = ret_type res
-    let argTy = Left $ map arg_type args
+    let argTy = tysToParams $ map arg_type args
     let funTy name = LMFunction $ LlvmFunctionDecl name ExternallyVisible
                         lmconv retTy FixedArgs argTy llvmFunAlign
 
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 8137713774..2a96efbf8e 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -90,10 +90,9 @@ pprLlvmCmmTop env count (CmmProc info lbl _ (ListGraph blks))
             link = if externallyVisibleCLabel lbl'
                       then ExternallyVisible
                       else Internal
-            funDec = llvmFunSig lbl' link
             lmblocks = map (\(BasicBlock id stmts) ->
                                 LlvmBlock (getUnique id) stmts) blks
-            fun = LlvmFunction funDec [NoUnwind] sec' lmblocks
+            fun = mkLlvmFunc lbl' link  sec' lmblocks
         in ppLlvmFunction fun
     ), ivar)