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.

1 files changed, 18 insertions, 4 deletions

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)