Merge branch 'master' of http://darcs.haskell.org/ghc

7 files changed, 81 insertions, 109 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
 
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index 56d8386431..be5c79cf64 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -7,15 +7,12 @@ module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where
 #include "HsVersions.h"
 
 import Llvm
-
 import LlvmCodeGen.Base
 import LlvmCodeGen.CodeGen
 import LlvmCodeGen.Data
 import LlvmCodeGen.Ppr
-
 import LlvmMangler
 
-import CLabel
 import CgUtils ( fixStgRegisters )
 import OldCmm
 import OldPprCmm
@@ -42,19 +39,17 @@ llvmCodeGen dflags h us cmms
         (cdata,env) = foldr split ([],initLlvmEnv) cmm
         split (CmmData s d' ) (d,e) = ((s,d'):d,e)
         split (CmmProc i l _) (d,e) =
-            let lbl = strCLabel_llvm $ if not (null i)
-                   then entryLblToInfoLbl l
-                   else l
+            let lbl = strCLabel_llvm $ case i of
+                        Nothing                   -> l
+                        Just (Statics info_lbl _) -> info_lbl
                 env' = funInsert lbl llvmFunTy e
             in (d,env')
     in do
         bufh <- newBufHandle h
         Prt.bufLeftRender bufh $ pprLlvmHeader
-        ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
-        
+        ver  <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
         env' <- cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
         cmmProcLlvmGens dflags bufh us env' cmm 1 []
-
         bFlush bufh
         return  ()
 
@@ -62,7 +57,7 @@ llvmCodeGen dflags h us cmms
 -- -----------------------------------------------------------------------------
 -- | Do LLVM code generation on all these Cmms data sections.
 --
-cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,[CmmStatic])]
+cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)]
                 -> [LlvmUnresData] -> IO ( LlvmEnv )
 
 cmmDataLlvmGens dflags h env [] lmdata
@@ -83,41 +78,44 @@ cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
 -- | Do LLVM code generation on all these Cmms procs.
 --
 cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmTop]
-      -> Int          -- ^ count, used for generating unique subsections
-      -> [LlvmVar]    -- ^ info tables that need to be marked as 'used'
+      -> Int         -- ^ count, used for generating unique subsections
+      -> [[LlvmVar]] -- ^ info tables that need to be marked as 'used'
       -> IO ()
 
 cmmProcLlvmGens _ _ _ _ [] _ []
   = return ()
 
 cmmProcLlvmGens _ h _ _ [] _ ivars
-  = let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
-        ty     = (LMArray (length ivars) i8Ptr)
-        usedArray = LMStaticArray (map cast ivars) ty
+  = let ivars' = concat ivars
+        cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
+        ty     = (LMArray (length ivars') i8Ptr)
+        usedArray = LMStaticArray (map cast ivars') ty
         lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
                   (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray)
     in Prt.bufLeftRender h $ pprLlvmData ([lmUsed], [])
 
-cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars
-  = do
-    (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
+cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
+ = cmmProcLlvmGens dflags h us env cmms count ivars
 
+cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivars
+ = cmmProcLlvmGens dflags h us env cmms count ivars
+
+cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do
+    (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
     let (docs, ivar) = mapAndUnzip (pprLlvmCmmTop env' count) llvm
     Prt.bufLeftRender h $ Prt.vcat docs
-
-    cmmProcLlvmGens dflags h us' env' cmms (count + 2) (concat ivar ++ ivars)
+    cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
 
 
 -- | Complete LLVM code generation phase for a single top-level chunk of Cmm.
 cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmTop
             -> IO ( UniqSupply, LlvmEnv, [LlvmCmmTop] )
-cmmLlvmGen dflags us env cmm
-  = do
+cmmLlvmGen dflags us env cmm = do
     -- rewrite assignments to global regs
     let fixed_cmm = fixStgRegisters cmm
 
     dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
-        (pprCmm $ Cmm [fixed_cmm])
+        (pprCmm (targetPlatform dflags) $ Cmm [fixed_cmm])
 
     -- generate llvm code from cmm
     let ((env', llvmBC), usGen) = initUs us $ genLlvmProc env fixed_cmm
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 59cdad4918..1c7592ad2d 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -41,7 +41,7 @@ import Unique
 -- * Some Data Types
 --
 
-type LlvmCmmTop = GenCmmTop LlvmData [CmmStatic] (ListGraph LlvmStatement)
+type LlvmCmmTop = GenCmmTop [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement)
 type LlvmBasicBlock = GenBasicBlock LlvmStatement
 
 -- | Unresolved code.
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index eb002742e1..c9ad76efd5 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -29,28 +29,19 @@ import Util
 import Data.List ( partition )
 import Control.Monad ( liftM )
 
-type LlvmStatements = OrdList LlvmStatement
 
+type LlvmStatements = OrdList LlvmStatement
 
 -- -----------------------------------------------------------------------------
 -- | Top-level of the LLVM proc Code generator
 --
 genLlvmProc :: LlvmEnv -> RawCmmTop -> UniqSM (LlvmEnv, [LlvmCmmTop])
-genLlvmProc env (CmmData _ _)
-  = return (env, [])
-
-genLlvmProc env (CmmProc _ _ (ListGraph []))
-  = return (env, [])
-
-genLlvmProc env (CmmProc info lbl (ListGraph blocks))
-  = do
-        (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], [])
-
-        let proc    = CmmProc info lbl (ListGraph lmblocks)
-        let tops    = lmdata ++ [proc]
-
-        return (env', tops)
+genLlvmProc env (CmmProc info lbl (ListGraph blocks)) = do
+    (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], [])
+    let proc = CmmProc info lbl (ListGraph lmblocks)
+    return (env', proc:lmdata)
 
+genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!"
 
 -- -----------------------------------------------------------------------------
 -- * Block code generation
diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs
index 3e486a544f..ef86abfd6f 100644
--- a/compiler/llvmGen/LlvmCodeGen/Data.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Data.hs
@@ -37,8 +37,8 @@ structStr = fsLit "_struct"
 -- complete this completely though as we need to pass all CmmStatic
 -- sections before all references can be resolved. This last step is
 -- done by 'resolveLlvmData'.
-genLlvmData :: (Section, [CmmStatic]) -> LlvmUnresData
-genLlvmData (sec, CmmDataLabel lbl:xs) =
+genLlvmData :: (Section, CmmStatics) -> LlvmUnresData
+genLlvmData (sec, Statics lbl xs) =
     let static  = map genData xs
         label   = strCLabel_llvm lbl
 
@@ -50,8 +50,6 @@ genLlvmData (sec, CmmDataLabel lbl:xs) =
         alias   = LMAlias ((label `appendFS` structStr), strucTy)
     in (lbl, sec, alias, static)
 
-genLlvmData _ = panic "genLlvmData: CmmData section doesn't start with label!"
-
 
 resolveLlvmDatas ::  LlvmEnv -> [LlvmUnresData] -> [LlvmData]
                  -> (LlvmEnv, [LlvmData])
@@ -150,7 +148,6 @@ resData _ _ = panic "resData: Non CLabel expr as left type!"
 --
 
 -- | Handle static data
--- Don't handle 'CmmAlign' or a 'CmmDataLabel'.
 genData :: CmmStatic -> UnresStatic
 
 genData (CmmString str) =
@@ -164,12 +161,6 @@ genData (CmmUninitialised bytes)
 genData (CmmStaticLit lit)
     = genStaticLit lit
 
-genData (CmmAlign _)
-    = panic "genData: Can't handle CmmAlign!"
-
-genData (CmmDataLabel _)
-    = panic "genData: Can't handle data labels not at top of data!"
-
 
 -- | Generate Llvm code for a static literal.
 --
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 9f25c08826..40f7ce05f1 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -82,16 +82,16 @@ pprLlvmCmmTop :: LlvmEnv -> Int -> LlvmCmmTop -> (Doc, [LlvmVar])
 pprLlvmCmmTop _ _ (CmmData _ lmdata)
   = (vcat $ map pprLlvmData lmdata, [])
 
-pprLlvmCmmTop env count (CmmProc info lbl (ListGraph blks))
-  = let static = CmmDataLabel lbl : info
-        (idoc, ivar) = if not (null info)
-                          then pprInfoTable env count lbl static
-                          else (empty, [])
+pprLlvmCmmTop env count (CmmProc mb_info entry_lbl (ListGraph blks))
+  = let (idoc, ivar) = case mb_info of
+                        Nothing -> (empty, [])
+                        Just (Statics info_lbl dat)
+                         -> pprInfoTable env count info_lbl (Statics entry_lbl dat)
     in (idoc $+$ (
         let sec = mkLayoutSection (count + 1)
-            (lbl',sec') = if not (null info)
-                            then (entryLblToInfoLbl lbl, sec)
-                            else (lbl, Nothing)
+            (lbl',sec') = case mb_info of
+                           Nothing                   -> (entry_lbl, Nothing)
+                           Just (Statics info_lbl _) -> (info_lbl,  sec)
             link = if externallyVisibleCLabel lbl'
                       then ExternallyVisible
                       else Internal
@@ -103,14 +103,14 @@ pprLlvmCmmTop env count (CmmProc info lbl (ListGraph blks))
 
 
 -- | Pretty print CmmStatic
-pprInfoTable :: LlvmEnv -> Int -> CLabel -> [CmmStatic] -> (Doc, [LlvmVar])
-pprInfoTable env count lbl stat
+pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (Doc, [LlvmVar])
+pprInfoTable env count info_lbl stat
   = let unres = genLlvmData (Text, stat)
         (_, (ldata, ltypes)) = resolveLlvmData env unres
 
         setSection ((LMGlobalVar _ ty l _ _ c), d)
             = let sec = mkLayoutSection count
-                  ilabel = strCLabel_llvm (entryLblToInfoLbl lbl)
+                  ilabel = strCLabel_llvm info_lbl
                               `appendFS` fsLit iTableSuf
                   gv = LMGlobalVar ilabel ty l sec llvmInfAlign c
                   v = if l == Internal then [gv] else []