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.

3 files changed, 22 insertions, 13 deletions

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)