Fix printing of llvm IR to work with llvm-3.0

2 files changed, 40 insertions, 48 deletions

diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index 82c6bfa65e..217d02debf 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -113,15 +113,18 @@ ppLlvmFunction (LlvmFunction dec args attrs sec body) =
 -- | 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
+  = let varg' = case varg of
+                      VarArgs | null p    -> text "..."
+                              | otherwise -> text ", ..."
+                      _otherwise          -> empty
         align = case a of
-                     Just a' -> space <> text "align" <+> texts a'
+                     Just a' -> 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
+        (hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align
 
 
 -- | Print out a list of function declaration.
@@ -132,7 +135,18 @@ ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
 -- Declarations define the function type but don't define the actual body of
 -- the function.
 ppLlvmFunctionDecl :: LlvmFunctionDecl -> Doc
-ppLlvmFunctionDecl dec = text "declare" <+> texts dec
+ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
+  = let varg' = case varg of
+                      VarArgs | null p    -> text "..."
+                              | otherwise -> text ", ..."
+                      _otherwise          -> empty
+        align = case a of
+                     Just a' -> text " align" <+> texts a'
+                     Nothing -> empty
+        args = hcat $ intersperse (comma <> space) $
+                  map (\(t,a) -> texts t <+> ppSpaceJoin a) p
+    in text "declare" <+> texts l <+> texts c <+> texts r <+> text "@" <>
+        ftext n <> lparen <> args <> varg' <> rparen <> align
 
 
 -- | Print out a list of LLVM blocks.
@@ -204,7 +218,7 @@ 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
-                ppParams = map (\(ty,p) -> texts ty <+> ppSpaceJoin p) params
+                ppParams = map (texts . fst) params
                 ppArgTy  = (hcat $ intersperse comma ppParams) <>
                            (case argTy of
                                VarArgs   -> text ", ..."
@@ -317,15 +331,14 @@ ppAsm asm constraints rty vars sideeffect alignstack =
 -- * Misc functions
 --------------------------------------------------------------------------------
 ppCommaJoin :: (Show a) => [a] -> Doc
-ppCommaJoin strs = hcat $ intersperse comma (map texts strs)
+ppCommaJoin strs = hcat $ intersperse (comma <> space) (map texts strs)
 
 ppSpaceJoin :: (Show a) => [a] -> Doc
 ppSpaceJoin strs = hcat $ intersperse space (map texts strs)
 
 -- | Convert SDoc to Doc
 llvmSDoc :: Out.SDoc -> Doc
-llvmSDoc d
-	= Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d
+llvmSDoc d = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d
 
 -- | Showable to Doc
 texts :: (Show a) => a -> Doc
diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs
index 3637c86467..101342606d 100644
--- a/compiler/llvmGen/Llvm/Types.hs
+++ b/compiler/llvmGen/Llvm/Types.hs
@@ -7,6 +7,7 @@ module Llvm.Types where
 #include "HsVersions.h"
 
 import Data.Char
+import Data.List (intercalate)
 import Numeric
 
 import Constants
@@ -59,12 +60,12 @@ instance Show LlvmType where
   show (LMStruct tys  ) = "<{" ++ (commaCat tys) ++ "}>"
 
   show (LMFunction (LlvmFunctionDecl _ _ _ r varg p _))
-    = let args = ((drop 1).concat) $ -- use drop since it can handle empty lists
-                  map (\(t,a) -> "," ++ show t ++ " " ++ spaceCat a) p
-          varg' = case varg of
-                        VarArgs | not (null args) -> ", ..."
-                                | otherwise       -> "..."
-                        _otherwise                -> ""
+    = let varg' = case varg of
+                        VarArgs | null args -> "..."
+                                | otherwise -> ", ..."
+                        _otherwise          -> ""
+          -- by default we don't print param attributes
+          args = intercalate ", " $ map (show . fst) p
       in show r ++ " (" ++ args ++ varg' ++ ")"
 
   show (LMAlias (s,_)) = "%" ++ unpackFS s
@@ -135,29 +136,13 @@ instance Show LlvmStatic where
   show (LMStaticLit   l  ) = show l
   show (LMUninitType    t) = show t ++ " undef"
   show (LMStaticStr   s t) = show t ++ " c\"" ++ unpackFS s ++ "\\00\""
-
-  show (LMStaticArray d t)
-      = let struc = case d of
-              [] -> "[]"
-              ts -> "[" ++ show (head ts) ++
-                      concat (map (\x -> "," ++ show x) (tail ts)) ++ "]"
-        in show t ++ " " ++ struc
-
-  show (LMStaticStruc d t)
-      = let struc = case d of
-              [] -> "<{}>"
-              ts -> "<{" ++ show (head ts) ++
-                      concat (map (\x -> "," ++ show x) (tail ts)) ++ "}>"
-        in show t ++ " " ++ struc
-
+  show (LMStaticArray d t) = show t ++ " [" ++ commaCat d ++ "]"
+  show (LMStaticStruc d t) = show t ++ "<{" ++ commaCat d ++ "}>"
   show (LMStaticPointer v) = show v
-
   show (LMBitc v t)
       = show t ++ " bitcast (" ++ show v ++ " to " ++ show t ++ ")"
-
   show (LMPtoI v t)
       = show t ++ " ptrtoint (" ++ show v ++ " to " ++ show t ++ ")"
-
   show (LMAdd s1 s2)
       = let ty1 = getStatType s1
             op  = if isFloat ty1 then " fadd (" else " add ("
@@ -176,13 +161,7 @@ instance Show LlvmStatic where
 
 -- | Concatenate an array together, separated by commas
 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))
+commaCat xs = intercalate ", " $ map show xs
 
 -- -----------------------------------------------------------------------------
 -- ** Operations on LLVM Basic Types and Variables
@@ -207,12 +186,12 @@ getPlainName (LMLitVar    x          ) = getLit x
 
 -- | Print a literal value. No type.
 getLit :: LlvmLit -> String
-getLit (LMIntLit   i _) = show ((fromInteger i)::Int)
+getLit (LMIntLit   i _       ) = show ((fromInteger i)::Int)
 getLit (LMFloatLit r LMFloat ) = fToStr $ realToFrac r
 getLit (LMFloatLit r LMDouble) = dToStr r
 getLit f@(LMFloatLit _ _) = error $ "Can't print this float literal!" ++ show f
-getLit (LMNullLit _) = "null"
-getLit (LMUndefLit _) = "undef"
+getLit (LMNullLit _     ) = "null"
+getLit (LMUndefLit _    ) = "undef"
 
 -- | Return the 'LlvmType' of the 'LlvmVar'
 getVarType :: LlvmVar -> LlvmType
@@ -366,15 +345,15 @@ data LlvmFunctionDecl = LlvmFunctionDecl {
 
 instance Show LlvmFunctionDecl where
   show (LlvmFunctionDecl n l c r varg p a)
-    = let args = ((drop 1).concat) $ -- use drop since it can handle empty lists
-                  map (\(t,a) -> "," ++ show t ++ " " ++ spaceCat a) p
-          varg' = case varg of
-                        VarArgs | not (null args) -> ", ..."
-                                | otherwise       -> "..."
-                        _otherwise                -> ""
+    = let varg' = case varg of
+                        VarArgs | null args -> "..."
+                                | otherwise -> ", ..."
+                        _otherwise          -> ""
           align = case a of
                        Just a' -> " align " ++ show a'
                        Nothing -> ""
+          -- by default we don't print param attributes
+          args = intercalate ", " $ map (show . fst) p
       in show l ++ " " ++ show c ++ " " ++ show r ++ " @" ++ unpackFS n ++
              "(" ++ args ++ varg' ++ ")" ++ align