X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FllvmGen%2FLlvm%2FPpLlvm.hs;h=82c6bfa65e8c64cfe4a9d6e8b690d570f377a32c;hb=d9a655dad8e013e41c74dca98fb86c4ed6f29879;hp=fffb72db20a91a5e317f0fcb6c9b475d6dbfee0b;hpb=3aadff5e31bf6b665cf7ae7606c94cdab85624d2;p=ghc-hetmet.git

diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index fffb72d..82c6bfa 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -10,8 +10,8 @@ module Llvm.PpLlvm (
     ppLlvmComment,
     ppLlvmGlobals,
     ppLlvmGlobal,
-    ppLlvmType,
-    ppLlvmTypes,
+    ppLlvmAlias,
+    ppLlvmAliases,
     ppLlvmFunctionDecls,
     ppLlvmFunctionDecl,
     ppLlvmFunctions,
@@ -38,9 +38,11 @@ import Unique
 
 -- | Print out a whole LLVM module.
 ppLlvmModule :: LlvmModule -> Doc
-ppLlvmModule (LlvmModule comments globals decls funcs)
+ppLlvmModule (LlvmModule comments aliases globals decls funcs)
   = ppLlvmComments comments
     $+$ empty
+    $+$ ppLlvmAliases aliases
+    $+$ empty
     $+$ ppLlvmGlobals globals
     $+$ empty
     $+$ ppLlvmFunctionDecls decls
@@ -83,19 +85,12 @@ ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth
 
 
 -- | Print out a list of LLVM type aliases.
-ppLlvmTypes :: [LlvmType] -> Doc
-ppLlvmTypes tys = vcat $ map ppLlvmType tys
+ppLlvmAliases :: [LlvmAlias] -> Doc
+ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
 
 -- | Print out an LLVM type alias.
-ppLlvmType :: LlvmType -> Doc
-
-ppLlvmType al@(LMAlias _ t)
-  = texts al <+> equals <+> text "type" <+> texts t
-
-ppLlvmType (LMFunction t)
-  = ppLlvmFunctionDecl t
-
-ppLlvmType _ = empty
+ppLlvmAlias :: LlvmAlias -> Doc
+ppLlvmAlias (name, ty) = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty
 
 
 -- | Print out a list of function definitions.
@@ -104,17 +99,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
@@ -153,6 +161,7 @@ ppLlvmStatement stmt
         Return      result        -> ppReturn result
         Expr        expr          -> ppLlvmExpression expr
         Unreachable               -> text "unreachable"
+        Nop                       -> empty
 
 
 -- | Print out an LLVM expression.
@@ -164,10 +173,11 @@ ppLlvmExpression expr
         Call       tp fp args attrs -> ppCall tp fp args attrs
         Cast       op from to       -> ppCast op from to
         Compare    op left right    -> ppCmpOp op left right
-        GetElemPtr ptr indexes      -> ppGetElementPtr ptr indexes
+        GetElemPtr inb ptr indexes  -> ppGetElementPtr inb ptr indexes
         Load       ptr              -> ppLoad ptr
         Malloc     tp amount        -> ppMalloc tp amount
         Phi        tp precessors    -> ppPhi tp precessors
+        Asm        asm c ty v se sk -> ppAsm asm c ty v se sk
 
 
 --------------------------------------------------------------------------------
@@ -194,7 +204,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 +227,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)
 
@@ -251,10 +265,11 @@ ppAlloca tp amount =
   in text "alloca" <+> texts tp <> comma <+> texts amount'
 
 
-ppGetElementPtr :: LlvmVar -> [Int] -> Doc
-ppGetElementPtr ptr idx =
-  let indexes = hcat $ map ((comma <+> texts i32 <+>) . texts) idx
-  in text "getelementptr" <+> texts ptr <> indexes
+ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> Doc
+ppGetElementPtr inb ptr idx =
+  let indexes = comma <+> ppCommaJoin idx
+      inbound = if inb then text "inbounds" else empty
+  in text "getelementptr" <+> inbound <+> texts ptr <> indexes
 
 
 ppReturn :: Maybe LlvmVar -> Doc
@@ -286,6 +301,18 @@ ppSwitch scrut dflt targets =
         <+> ppTargets targets
 
 
+ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> Doc
+ppAsm asm constraints rty vars sideeffect alignstack =
+  let asm'  = doubleQuotes $ ftext asm
+      cons  = doubleQuotes $ ftext constraints
+      rty'  = texts rty 
+      vars' = lparen <+> ppCommaJoin vars <+> rparen
+      side  = if sideeffect then text "sideeffect" else empty
+      align = if alignstack then text "alignstack" else empty
+  in text "call" <+> rty' <+> text "asm" <+> side <+> align <+> asm' <> comma
+        <+> cons <> vars'
+
+
 --------------------------------------------------------------------------------
 -- * Misc functions
 --------------------------------------------------------------------------------