LLVM: Fix bug with calling tail with empty list

[ghc-hetmet.git] / compiler / llvmGen / Llvm / PpLlvm.hs

diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index fffb72d..2227fb6 100644 (file)
--- 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)
@@ -216,9 +230,12 @@ ppCmpOp op left right =
   let cmpOp
         | isInt (getVarType left) && isInt (getVarType right) = text "icmp"
         | isFloat (getVarType left) && isFloat (getVarType right) = text "fcmp"
+        | otherwise = text "icmp" -- Just continue as its much easier to debug
+        {-
         | otherwise = error ("can't compare different types, left = "
                 ++ (show $ getVarType left) ++ ", right = "
                 ++ (show $ getVarType right))
+        -}
   in cmpOp <+> texts op <+> texts (getVarType left)
         <+> (text $ getName left) <> comma <+> (text $ getName right)