Merge remote-tracking branch 'origin/master' into newcg

* origin/master: (756 commits)
  don't crash if argv[0] == NULL (#7037)
  -package P was loading all versions of P in GHCi (#7030)
  Add a Note, copying text from #2437
  improve the --help docs a bit (#7008)
  Copy Data.HashTable's hashString into our Util module
  Build fix
  Build fixes
  Parse error: suggest brackets and indentation.
  Don't build the ghc DLL on Windows; works around trac #5987
  On Windows, detect if DLLs have too many symbols; trac #5987
  Add some more Integer rules; fixes #6111
  Fix PA dfun construction with silent superclass args
  Add silent superclass parameters to the vectoriser
  Add silent superclass parameters (again)
  Mention Generic1 in the user's guide
  Make the GHC API a little more powerful.
  tweak llvm version warning message
  New version of the patch for #5461.
  Fix Word64ToInteger conversion rule.
  Implemented feature request on reconfigurable pretty-printing in GHCi (#5461)
  ...

Conflicts:
	compiler/basicTypes/UniqSupply.lhs
	compiler/cmm/CmmBuildInfoTables.hs
	compiler/cmm/CmmLint.hs
	compiler/cmm/CmmOpt.hs
	compiler/cmm/CmmPipeline.hs
	compiler/cmm/CmmStackLayout.hs
	compiler/cmm/MkGraph.hs
	compiler/cmm/OldPprCmm.hs
	compiler/codeGen/CodeGen.lhs
	compiler/codeGen/StgCmm.hs
	compiler/codeGen/StgCmmBind.hs
	compiler/codeGen/StgCmmLayout.hs
	compiler/codeGen/StgCmmUtils.hs
	compiler/main/CodeOutput.lhs
	compiler/main/HscMain.hs
	compiler/nativeGen/AsmCodeGen.lhs
	compiler/simplStg/SimplStg.lhs

6 files changed, 137 insertions, 97 deletions

diff --git a/compiler/llvmGen/Llvm.hs b/compiler/llvmGen/Llvm.hs
index 32df9e3217..d05a90609e 100644
--- a/compiler/llvmGen/Llvm.hs
+++ b/compiler/llvmGen/Llvm.hs
@@ -49,7 +49,6 @@ module Llvm (
         ppLlvmModule, ppLlvmComments, ppLlvmComment, ppLlvmGlobals,
         ppLlvmGlobal, ppLlvmFunctionDecls, ppLlvmFunctionDecl, ppLlvmFunctions,
         ppLlvmFunction, ppLlvmAlias, ppLlvmAliases, ppLlvmMetas, ppLlvmMeta,
-        llvmSDoc
 
     ) where
 
diff --git a/compiler/llvmGen/Llvm/PpLlvm.hs b/compiler/llvmGen/Llvm/PpLlvm.hs
index c2177782f2..2b2725d187 100644
--- a/compiler/llvmGen/Llvm/PpLlvm.hs
+++ b/compiler/llvmGen/Llvm/PpLlvm.hs
@@ -19,9 +19,6 @@ module Llvm.PpLlvm (
     ppLlvmFunctions,
     ppLlvmFunction,
 
-    -- * Utility functions
-    llvmSDoc
-
     ) where
 
 #include "HsVersions.h"
@@ -30,8 +27,7 @@ import Llvm.AbsSyn
 import Llvm.Types
 
 import Data.List ( intersperse )
-import Pretty
-import qualified Outputable as Out
+import Outputable
 import Unique
 
 --------------------------------------------------------------------------------
@@ -39,7 +35,7 @@ import Unique
 --------------------------------------------------------------------------------
 
 -- | Print out a whole LLVM module.
-ppLlvmModule :: LlvmModule -> Doc
+ppLlvmModule :: LlvmModule -> SDoc
 ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)
   = ppLlvmComments comments $+$ newLine
     $+$ ppLlvmAliases aliases $+$ newLine
@@ -49,20 +45,20 @@ ppLlvmModule (LlvmModule comments aliases meta globals decls funcs)
     $+$ ppLlvmFunctions funcs
 
 -- | Print out a multi-line comment, can be inside a function or on its own
-ppLlvmComments :: [LMString] -> Doc
+ppLlvmComments :: [LMString] -> SDoc
 ppLlvmComments comments = vcat $ map ppLlvmComment comments
 
 -- | Print out a comment, can be inside a function or on its own
-ppLlvmComment :: LMString -> Doc
+ppLlvmComment :: LMString -> SDoc
 ppLlvmComment com = semi <+> ftext com
 
 
 -- | Print out a list of global mutable variable definitions
-ppLlvmGlobals :: [LMGlobal] -> Doc
+ppLlvmGlobals :: [LMGlobal] -> SDoc
 ppLlvmGlobals ls = vcat $ map ppLlvmGlobal ls
 
 -- | Print out a global mutable variable definition
-ppLlvmGlobal :: LMGlobal -> Doc
+ppLlvmGlobal :: LMGlobal -> SDoc
 ppLlvmGlobal (var@(LMGlobalVar _ _ link x a c), dat) =
     let sect = case x of
             Just x' -> text ", section" <+> doubleQuotes (ftext x')
@@ -85,21 +81,21 @@ ppLlvmGlobal oth = error $ "Non Global var ppr as global! " ++ show oth
 
 
 -- | Print out a list of LLVM type aliases.
-ppLlvmAliases :: [LlvmAlias] -> Doc
+ppLlvmAliases :: [LlvmAlias] -> SDoc
 ppLlvmAliases tys = vcat $ map ppLlvmAlias tys
 
 -- | Print out an LLVM type alias.
-ppLlvmAlias :: LlvmAlias -> Doc
+ppLlvmAlias :: LlvmAlias -> SDoc
 ppLlvmAlias (name, ty)
   = text "%" <> ftext name <+> equals <+> text "type" <+> texts ty
 
 
 -- | Print out a list of LLVM metadata.
-ppLlvmMetas :: [LlvmMeta] -> Doc
+ppLlvmMetas :: [LlvmMeta] -> SDoc
 ppLlvmMetas metas = vcat $ map ppLlvmMeta metas
 
 -- | Print out an LLVM metadata definition.
-ppLlvmMeta :: LlvmMeta -> Doc
+ppLlvmMeta :: LlvmMeta -> SDoc
 ppLlvmMeta (MetaUnamed (LMMetaUnamed u) metas)
   = exclamation <> int u <> text " = metadata !{" <>
     hcat (intersperse comma $ map ppLlvmMetaVal metas) <> text "}"
@@ -112,7 +108,7 @@ ppLlvmMeta (MetaNamed n metas)
     pprNode n = exclamation <> int n
 
 -- | Print out an LLVM metadata value.
-ppLlvmMetaVal :: LlvmMetaVal -> Doc
+ppLlvmMetaVal :: LlvmMetaVal -> SDoc
 ppLlvmMetaVal (MetaStr  s) = text "metadata !" <> doubleQuotes (ftext s)
 ppLlvmMetaVal (MetaVar  v) = texts v
 ppLlvmMetaVal (MetaNode (LMMetaUnamed u))
@@ -120,11 +116,11 @@ ppLlvmMetaVal (MetaNode (LMMetaUnamed u))
 
 
 -- | Print out a list of function definitions.
-ppLlvmFunctions :: LlvmFunctions -> Doc
+ppLlvmFunctions :: LlvmFunctions -> SDoc
 ppLlvmFunctions funcs = vcat $ map ppLlvmFunction funcs
 
 -- | Print out a function definition.
-ppLlvmFunction :: LlvmFunction -> Doc
+ppLlvmFunction :: LlvmFunction -> SDoc
 ppLlvmFunction (LlvmFunction dec args attrs sec body) =
     let attrDoc = ppSpaceJoin attrs
         secDoc = case sec of
@@ -139,7 +135,7 @@ ppLlvmFunction (LlvmFunction dec args attrs sec body) =
         $+$ newLine
 
 -- | Print out a function defenition header.
-ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc
+ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc
 ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
   = let varg' = case varg of
                       VarArgs | null p    -> text "..."
@@ -155,13 +151,13 @@ ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args
         (hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align
 
 -- | Print out a list of function declaration.
-ppLlvmFunctionDecls :: LlvmFunctionDecls -> Doc
+ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc
 ppLlvmFunctionDecls decs = vcat $ map ppLlvmFunctionDecl decs
 
 -- | Print out a function declaration.
 -- Declarations define the function type but don't define the actual body of
 -- the function.
-ppLlvmFunctionDecl :: LlvmFunctionDecl -> Doc
+ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc
 ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
   = let varg' = case varg of
                       VarArgs | null p    -> text "..."
@@ -177,12 +173,12 @@ ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a)
 
 
 -- | Print out a list of LLVM blocks.
-ppLlvmBlocks :: LlvmBlocks -> Doc
+ppLlvmBlocks :: LlvmBlocks -> SDoc
 ppLlvmBlocks blocks = vcat $ map ppLlvmBlock blocks
 
 -- | Print out an LLVM block.
 -- It must be part of a function definition.
-ppLlvmBlock :: LlvmBlock -> Doc
+ppLlvmBlock :: LlvmBlock -> SDoc
 ppLlvmBlock (LlvmBlock blockId stmts)
   = go blockId stmts
   where
@@ -201,12 +197,12 @@ ppLlvmBlock (LlvmBlock blockId stmts)
            $+$ ppRest
 
 -- | Print out an LLVM block label.
-ppLlvmBlockLabel :: LlvmBlockId -> Doc
-ppLlvmBlockLabel id = (llvmSDoc $ pprUnique id) <> colon
+ppLlvmBlockLabel :: LlvmBlockId -> SDoc
+ppLlvmBlockLabel id = pprUnique id <> colon
 
 
 -- | Print out an LLVM statement.
-ppLlvmStatement :: LlvmStatement -> Doc
+ppLlvmStatement :: LlvmStatement -> SDoc
 ppLlvmStatement stmt =
   let ind = (text "  " <>)
   in case stmt of
@@ -226,7 +222,7 @@ ppLlvmStatement stmt =
 
 
 -- | Print out an LLVM expression.
-ppLlvmExpression :: LlvmExpression -> Doc
+ppLlvmExpression :: LlvmExpression -> SDoc
 ppLlvmExpression expr
   = case expr of
         Alloca     tp amount        -> ppAlloca tp amount
@@ -248,7 +244,7 @@ ppLlvmExpression expr
 
 -- | Should always be a function pointer. So a global var of function type
 -- (since globals are always pointers) or a local var of pointer function type.
-ppCall :: LlvmCallType -> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> Doc
+ppCall :: LlvmCallType -> LlvmVar -> [LlvmVar] -> [LlvmFuncAttr] -> SDoc
 ppCall ct fptr vals attrs = case fptr of
                            --
     -- if local var function pointer, unwrap
@@ -278,13 +274,13 @@ ppCall ct fptr vals attrs = case fptr of
                     <+> rparen <+> attrDoc
 
 
-ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> Doc
+ppMachOp :: LlvmMachOp -> LlvmVar -> LlvmVar -> SDoc
 ppMachOp op left right =
   (texts op) <+> (texts (getVarType left)) <+> (text $ getName left)
         <> comma <+> (text $ getName right)
 
 
-ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> Doc
+ppCmpOp :: LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc
 ppCmpOp op left right =
   let cmpOp
         | isInt (getVarType left) && isInt (getVarType right) = text "icmp"
@@ -299,16 +295,16 @@ ppCmpOp op left right =
         <+> (text $ getName left) <> comma <+> (text $ getName right)
 
 
-ppAssignment :: LlvmVar -> Doc -> Doc
+ppAssignment :: LlvmVar -> SDoc -> SDoc
 ppAssignment var expr = (text $ getName var) <+> equals <+> expr
 
-ppFence :: Bool -> LlvmSyncOrdering -> Doc
+ppFence :: Bool -> LlvmSyncOrdering -> SDoc
 ppFence st ord =
   let singleThread = case st of True  -> text "singlethread"
                                 False -> empty
   in text "fence" <+> singleThread <+> ppSyncOrdering ord
 
-ppSyncOrdering :: LlvmSyncOrdering -> Doc
+ppSyncOrdering :: LlvmSyncOrdering -> SDoc
 ppSyncOrdering SyncUnord     = text "unordered"
 ppSyncOrdering SyncMonotonic = text "monotonic"
 ppSyncOrdering SyncAcquire   = text "acquire"
@@ -316,59 +312,59 @@ ppSyncOrdering SyncRelease   = text "release"
 ppSyncOrdering SyncAcqRel    = text "acq_rel"
 ppSyncOrdering SyncSeqCst    = text "seq_cst"
 
-ppLoad :: LlvmVar -> Doc
+ppLoad :: LlvmVar -> SDoc
 ppLoad var = text "load" <+> texts var
 
 
-ppStore :: LlvmVar -> LlvmVar -> Doc
+ppStore :: LlvmVar -> LlvmVar -> SDoc
 ppStore val dst = text "store" <+> texts val <> comma <+> texts dst
 
 
-ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> Doc
+ppCast :: LlvmCastOp -> LlvmVar -> LlvmType -> SDoc
 ppCast op from to = texts op <+> texts from <+> text "to" <+> texts to
 
 
-ppMalloc :: LlvmType -> Int -> Doc
+ppMalloc :: LlvmType -> Int -> SDoc
 ppMalloc tp amount =
   let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
   in text "malloc" <+> texts tp <> comma <+> texts amount'
 
 
-ppAlloca :: LlvmType -> Int -> Doc
+ppAlloca :: LlvmType -> Int -> SDoc
 ppAlloca tp amount =
   let amount' = LMLitVar $ LMIntLit (toInteger amount) i32
   in text "alloca" <+> texts tp <> comma <+> texts amount'
 
 
-ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> Doc
+ppGetElementPtr :: Bool -> LlvmVar -> [LlvmVar] -> SDoc
 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
+ppReturn :: Maybe LlvmVar -> SDoc
 ppReturn (Just var) = text "ret" <+> texts var
 ppReturn Nothing    = text "ret" <+> texts LMVoid
 
 
-ppBranch :: LlvmVar -> Doc
+ppBranch :: LlvmVar -> SDoc
 ppBranch var = text "br" <+> texts var
 
 
-ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> Doc
+ppBranchIf :: LlvmVar -> LlvmVar -> LlvmVar -> SDoc
 ppBranchIf cond trueT falseT
   = text "br" <+> texts cond <> comma <+> texts trueT <> comma <+> texts falseT
 
 
-ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> Doc
+ppPhi :: LlvmType -> [(LlvmVar,LlvmVar)] -> SDoc
 ppPhi tp preds =
   let ppPreds (val, label) = brackets $ (text $ getName val) <> comma
         <+> (text $ getName label)
   in text "phi" <+> texts tp <+> hcat (intersperse comma $ map ppPreds preds)
 
 
-ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> Doc
+ppSwitch :: LlvmVar -> LlvmVar -> [(LlvmVar,LlvmVar)] -> SDoc
 ppSwitch scrut dflt targets =
   let ppTarget  (val, lab) = texts val <> comma <+> texts lab
       ppTargets  xs        = brackets $ vcat (map ppTarget xs)
@@ -376,7 +372,7 @@ ppSwitch scrut dflt targets =
         <+> ppTargets targets
 
 
-ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> Doc
+ppAsm :: LMString -> LMString -> LlvmType -> [LlvmVar] -> Bool -> Bool -> SDoc
 ppAsm asm constraints rty vars sideeffect alignstack =
   let asm'  = doubleQuotes $ ftext asm
       cons  = doubleQuotes $ ftext constraints
@@ -388,15 +384,15 @@ ppAsm asm constraints rty vars sideeffect alignstack =
         <+> cons <> vars'
 
 
-ppMetaStatement :: [MetaData] -> LlvmStatement -> Doc
+ppMetaStatement :: [MetaData] -> LlvmStatement -> SDoc
 ppMetaStatement meta stmt = ppLlvmStatement stmt <> ppMetas meta
 
 
-ppMetaExpr :: [MetaData] -> LlvmExpression -> Doc
+ppMetaExpr :: [MetaData] -> LlvmExpression -> SDoc
 ppMetaExpr meta expr = ppLlvmExpression expr <> ppMetas meta
 
 
-ppMetas :: [MetaData] -> Doc
+ppMetas :: [MetaData] -> SDoc
 ppMetas meta = hcat $ map ppMeta meta
   where
     ppMeta (name, (LMMetaUnamed n))
@@ -406,25 +402,21 @@ ppMetas meta = hcat $ map ppMeta meta
 --------------------------------------------------------------------------------
 -- * Misc functions
 --------------------------------------------------------------------------------
-ppCommaJoin :: (Show a) => [a] -> Doc
+ppCommaJoin :: (Show a) => [a] -> SDoc
 ppCommaJoin strs = hcat $ intersperse (comma <> space) (map texts strs)
 
-ppSpaceJoin :: (Show a) => [a] -> Doc
+ppSpaceJoin :: (Show a) => [a] -> SDoc
 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
-
--- | Showable to Doc
-texts :: (Show a) => a -> Doc
+-- | Showable to SDoc
+texts :: (Show a) => a -> SDoc
 texts = (text . show)
 
 -- | Blank line.
-newLine :: Doc
+newLine :: SDoc
 newLine = text ""
 
 -- | Exclamation point.
-exclamation :: Doc
+exclamation :: SDoc
 exclamation = text "!"
 
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index 531d90a8ee..5c2e420545 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -27,6 +27,7 @@ import UniqSupply
 import Util
 import SysTools ( figureLlvmVersion )
 
+import Control.Monad ( when )
 import Data.IORef ( writeIORef )
 import Data.Maybe ( fromMaybe )
 import System.IO
@@ -48,12 +49,10 @@ llvmCodeGen dflags h us cmms
             in (d,env')
     in do
         showPass dflags "LlVM CodeGen"
-        dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc pprLlvmHeader
+        dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" pprLlvmHeader
         bufh <- newBufHandle h
-        Prt.bufLeftRender bufh $ pprLlvmHeader
-        ver  <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
-        -- cache llvm version for later use
-        writeIORef (llvmVersion dflags) ver
+        Prt.bufLeftRender bufh $ withPprStyleDoc dflags (mkCodeStyle CStyle) pprLlvmHeader
+        ver  <- getLlvmVersion
         env' <- {-# SCC "llvm_datas_gen" #-}
                 cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
         {-# SCC "llvm_procs_gen" #-}
@@ -61,6 +60,22 @@ llvmCodeGen dflags h us cmms
         bFlush bufh
         return  ()
 
+  where
+    -- | Handle setting up the LLVM version.
+    getLlvmVersion = do
+        ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
+        -- cache llvm version for later use
+        writeIORef (llvmVersion dflags) ver
+        when (ver < minSupportLlvmVersion) $
+            errorMsg dflags (text "You are using an old version of LLVM that"
+                             <> text " isn't supported anymore!"
+                             $+$ text "We will try though...")
+        when (ver > maxSupportLlvmVersion) $
+            putMsg dflags (text "You are using a new version of LLVM that"
+                           <> text " hasn't been tested yet!"
+                           $+$ text "We will try though...")
+        return ver
+
 
 -- -----------------------------------------------------------------------------
 -- | Do LLVM code generation on all these Cmms data sections.
@@ -72,11 +87,11 @@ cmmDataLlvmGens dflags h env [] lmdata
   = let (env', lmdata') = {-# SCC "llvm_resolve" #-}
                           resolveLlvmDatas env lmdata
         lmdoc = {-# SCC "llvm_data_ppr" #-}
-                Prt.vcat $ map pprLlvmData lmdata'
+                vcat $ map pprLlvmData lmdata'
     in do
-        dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc lmdoc
+        dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" lmdoc
         {-# SCC "llvm_data_out" #-}
-            Prt.bufLeftRender h lmdoc
+            Prt.bufLeftRender h $ withPprStyleDoc dflags (mkCodeStyle CStyle) lmdoc
         return env'
 
 cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
@@ -100,7 +115,7 @@ cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmDecl
 cmmProcLlvmGens _ _ _ _ [] _ []
   = return ()
 
-cmmProcLlvmGens _ h _ _ [] _ ivars
+cmmProcLlvmGens dflags h _ _ [] _ ivars
   = let ivars' = concat ivars
         cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
         ty     = (LMArray (length ivars') i8Ptr)
@@ -108,6 +123,7 @@ cmmProcLlvmGens _ h _ _ [] _ ivars
         lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
                   (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray)
     in Prt.bufLeftRender h $ {-# SCC "llvm_used_ppr" #-}
+                             withPprStyleDoc dflags (mkCodeStyle CStyle) $
                              pprLlvmData ([lmUsed], [])
 
 cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
@@ -119,7 +135,8 @@ cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivar
 cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do
     (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
     let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm
-    Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-} Prt.vcat docs
+    Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-}
+                          withPprStyleDoc dflags (mkCodeStyle CStyle) $ vcat docs
     cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars)
 
 
@@ -132,14 +149,14 @@ cmmLlvmGen dflags us env cmm = do
                     fixStgRegisters cmm
 
     dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm"
-        (pprCmmGroup (targetPlatform dflags) [fixed_cmm])
+        (pprCmmGroup [fixed_cmm])
 
     -- generate llvm code from cmm
     let ((env', llvmBC), usGen) = {-# SCC "llvm_proc_gen" #-}
                                   initUs us $ genLlvmProc env fixed_cmm
 
     dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
-        (vcat $ map (docToSDoc . fst . pprLlvmCmmDecl env' 0) llvmBC)
+        (vcat $ map (fst . pprLlvmCmmDecl env' 0) llvmBC)
 
     return (usGen, env', llvmBC)
 
diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs
index 9bdb115505..19ca511f16 100644
--- a/compiler/llvmGen/LlvmCodeGen/Base.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Base.hs
@@ -9,7 +9,8 @@ module LlvmCodeGen.Base (
         LlvmCmmDecl, LlvmBasicBlock,
         LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
 
-        LlvmVersion, defaultLlvmVersion,
+        LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion,
+        maxSupportLlvmVersion,
 
         LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert,
         funLookup, funInsert, getLlvmVer, setLlvmVer, getLlvmPlatform,
@@ -144,7 +145,13 @@ type LlvmVersion = Int
 
 -- | The LLVM Version we assume if we don't know
 defaultLlvmVersion :: LlvmVersion
-defaultLlvmVersion = 28
+defaultLlvmVersion = 30
+
+minSupportLlvmVersion :: LlvmVersion
+minSupportLlvmVersion = 28
+
+maxSupportLlvmVersion :: LlvmVersion
+maxSupportLlvmVersion = 31
 
 -- ----------------------------------------------------------------------------
 -- * Environment Handling
@@ -226,7 +233,10 @@ getDflags (LlvmEnv (_, _, _, d)) = d
 -- | Pretty print a 'CLabel'.
 strCLabel_llvm :: LlvmEnv -> CLabel -> LMString
 strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-}
-    (fsLit . show . llvmSDoc . pprCLabel (getLlvmPlatform env)) l
+    (fsLit . toString . pprCLabel (getLlvmPlatform env)) l
+    where dflags = getDflags env
+          style = Outp.mkCodeStyle Outp.CStyle
+          toString doc = Outp.renderWithStyle dflags doc style
 
 -- | Create an external definition for a 'CLabel' defined in another module.
 genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 059328f868..79a0c00543 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -172,7 +172,7 @@ genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual]
 
 -- Write barrier needs to be handled specially as it is implemented as an LLVM
 -- intrinsic function.
-genCall env (CmmPrim MO_WriteBarrier) _ _ _
+genCall env (CmmPrim MO_WriteBarrier _) _ _ _
  | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC]
     = return (env, nilOL, [])
  | getLlvmVer env > 29 = barrier env
@@ -182,7 +182,7 @@ genCall env (CmmPrim MO_WriteBarrier) _ _ _
 -- types and things like Word8 are backed by an i32 and just present a logical
 -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM
 -- is strict about types.
-genCall env t@(CmmPrim (MO_PopCnt w)) [CmmHinted dst _] args _ = do
+genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do
     let width = widthToLlvmInt w
         dstTy = cmmToLlvmType $ localRegType dst
         funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible
@@ -202,10 +202,12 @@ genCall env t@(CmmPrim (MO_PopCnt w)) [CmmHinted dst _] args _ = do
 
 -- Handle memcpy function specifically since llvm's intrinsic version takes
 -- some extra parameters.
-genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy ||
-                                                  op == MO_Memset ||
-                                                  op == MO_Memmove = do
-    let (isVolTy, isVolVal) = if getLlvmVer env >= 28
+genCall env t@(CmmPrim op _) [] args' CmmMayReturn
+ | op == MO_Memcpy ||
+   op == MO_Memset ||
+   op == MO_Memmove = do
+    let (args, alignVal) = splitAlignVal args'
+        (isVolTy, isVolVal) = if getLlvmVer env >= 28
                                  then ([i1], [mkIntLit i1 0]) else ([], [])
         argTy | op == MO_Memset = [i8Ptr, i8,    llvmWord, i32] ++ isVolTy
               | otherwise       = [i8Ptr, i8Ptr, llvmWord, i32] ++ isVolTy
@@ -216,11 +218,25 @@ genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy ||
     (env2, fptr, stmts2, top2)    <- getFunPtr env1 funTy t
     (argVars', stmts3)            <- castVars $ zip argVars argTy
 
-    let arguments = argVars' ++ isVolVal
+    let arguments = argVars' ++ (alignVal:isVolVal)
         call = Expr $ Call StdCall fptr arguments []
         stmts = stmts1 `appOL` stmts2 `appOL` stmts3
                 `appOL` trashStmts `snocOL` call
     return (env2, stmts, top1 ++ top2)
+  
+  where
+    splitAlignVal xs = (init xs, extractLit $ last xs)
+
+    -- Fix for trac #6158. Since LLVM 3.1, opt fails when given anything other
+    -- than a direct constant (i.e. 'i32 8') as the alignment argument for the
+    -- memcpy & co llvm intrinsic functions. So we handle this directly now.
+    extractLit (CmmHinted (CmmLit (CmmInt i _)) _) = mkIntLit i32 i
+    extractLit _other = trace ("WARNING: Non constant alignment value given" ++ 
+                               " for memcpy! Please report to GHC developers")
+                        mkIntLit i32 0
+
+genCall env (CmmPrim _ (Just stmts)) _ _ _
+    = stmtsToInstrs env stmts (nilOL, [])
 
 -- Handle all other foreign calls and prim ops.
 genCall env target res args ret = do
@@ -240,7 +256,7 @@ genCall env target res args ret = do
     -- extract Cmm call convention
     let cconv = case target of
             CmmCallee _ conv -> conv
-            CmmPrim   _      -> PrimCallConv
+            CmmPrim   _ _    -> PrimCallConv
 
     -- translate to LLVM call convention
     let lmconv = case cconv of
@@ -337,7 +353,7 @@ getFunPtr env funTy targ = case targ of
         (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
         return (env', v2, stmts `snocOL` s1, top)
 
-    CmmPrim mop -> litCase $ cmmPrimOpFunctions env mop
+    CmmPrim mop _ -> litCase $ cmmPrimOpFunctions env mop
 
     where
         litCase name = do
@@ -469,17 +485,21 @@ cmmPrimOpFunctions env mop
 
     (MO_PopCnt w) -> fsLit $ "llvm.ctpop."  ++ show (widthToLlvmInt w)
 
-    MO_WriteBarrier ->
-        panic $ "cmmPrimOpFunctions: MO_WriteBarrier not supported here"
-    MO_Touch ->
-        panic $ "cmmPrimOpFunctions: MO_Touch not supported here"
+    MO_S_QuotRem {}  -> unsupported
+    MO_U_QuotRem {}  -> unsupported
+    MO_U_QuotRem2 {} -> unsupported
+    MO_Add2 {}       -> unsupported
+    MO_U_Mul2 {}     -> unsupported
+    MO_WriteBarrier  -> unsupported
+    MO_Touch         -> unsupported
 
     where
         intrinTy1 = (if getLlvmVer env >= 28
                        then "p0i8.p0i8." else "") ++ show llvmWord
         intrinTy2 = (if getLlvmVer env >= 28
                        then "p0i8." else "") ++ show llvmWord
-    
+        unsupported = panic ("cmmPrimOpFunctions: " ++ show mop
+                          ++ " not supported here")
 
 -- | Tail function calls
 genJump :: LlvmEnv -> CmmExpr -> Maybe [GlobalReg] -> UniqSM StmtData
@@ -627,7 +647,7 @@ genStore_slow env addr val meta = do
 
         other ->
             pprPanic "genStore: ptr not right type!"
-                    (PprCmm.pprExpr (getLlvmPlatform env) addr <+> text (
+                    (PprCmm.pprExpr addr <+> text (
                         "Size of Ptr: " ++ show llvmPtrBits ++
                         ", Size of var: " ++ show (llvmWidthInBits other) ++
                         ", Var: " ++ show vaddr))
@@ -942,7 +962,10 @@ genMachOp_slow env opt op [x, y] = case op of
 
                 else do
                     -- Error. Continue anyway so we can debug the generated ll file.
-                    let cmmToStr = (lines . show . llvmSDoc . PprCmm.pprExpr (getLlvmPlatform env))
+                    let dflags = getDflags env
+                        style = mkCodeStyle CStyle
+                        toString doc = renderWithStyle dflags doc style
+                        cmmToStr = (lines . toString . PprCmm.pprExpr)
                     let dx = Comment $ map fsLit $ cmmToStr x
                     let dy = Comment $ map fsLit $ cmmToStr y
                     (v1, s1) <- doExpr (ty vx) $ binOp vx vy
@@ -1101,7 +1124,7 @@ genLoad_slow env e ty meta = do
                     return (env', dvar, stmts `snocOL` cast `snocOL` load, tops)
 
          other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
-                        (PprCmm.pprExpr (getLlvmPlatform env) e <+> text (
+                        (PprCmm.pprExpr e <+> text (
                             "Size of Ptr: " ++ show llvmPtrBits ++
                             ", Size of var: " ++ show (llvmWidthInBits other) ++
                             ", Var: " ++ show iptr))
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 187d1ecf03..1c715989a8 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -17,8 +17,7 @@ import CLabel
 import OldCmm
 
 import FastString
-import qualified Outputable
-import Pretty
+import Outputable
 import Unique
 
 
@@ -27,7 +26,7 @@ import Unique
 --
 
 -- | Header code for LLVM modules
-pprLlvmHeader :: Doc
+pprLlvmHeader :: SDoc
 pprLlvmHeader =
     moduleLayout
     $+$ text ""
@@ -37,7 +36,7 @@ pprLlvmHeader =
 
 
 -- | LLVM module layout description for the host target
-moduleLayout :: Doc
+moduleLayout :: SDoc
 moduleLayout =
 #if i386_TARGET_ARCH
 
@@ -76,7 +75,7 @@ moduleLayout =
 
 
 -- | Pretty print LLVM data code
-pprLlvmData :: LlvmData -> Doc
+pprLlvmData :: LlvmData -> SDoc
 pprLlvmData (globals, types) =
     let tryConst (v, Just s )   = ppLlvmGlobal (v, Just s)
         tryConst g@(_, Nothing) = ppLlvmGlobal g
@@ -91,7 +90,7 @@ pprLlvmData (globals, types) =
 
 
 -- | Pretty print LLVM code
-pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (Doc, [LlvmVar])
+pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (SDoc, [LlvmVar])
 pprLlvmCmmDecl _ _ (CmmData _ lmdata)
   = (vcat $ map pprLlvmData lmdata, [])
 
@@ -116,7 +115,7 @@ pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl (ListGraph blks))
 
 
 -- | Pretty print CmmStatic
-pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (Doc, [LlvmVar])
+pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (SDoc, [LlvmVar])
 pprInfoTable env count info_lbl stat
   = let unres = genLlvmData env (Text, stat)
         (_, (ldata, ltypes)) = resolveLlvmData env unres