[commit: ghc] master: Fix #6158. LLVM 3.1 doesn't like certain constructions that 3.0 and (41b37a2)

[David Terei]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/41b37a233e92b3f7df07f1d8d4240e80643dff96

>---------------------------------------------------------------

commit 41b37a233e92b3f7df07f1d8d4240e80643dff96
Author: David Terei <davidterei at gmail.com>
Date:   Mon Jun 25 00:51:47 2012 -0700

    Fix #6158. LLVM 3.1 doesn't like certain constructions that 3.0 and
    earlier did, so we avoid them.

>---------------------------------------------------------------

 compiler/llvmGen/LlvmCodeGen/CodeGen.hs |   18 +++++++++++++++---
 1 files changed, 15 insertions(+), 3 deletions(-)

diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index e9d8ac5..79a0c00 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -202,11 +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
+genCall env t@(CmmPrim op _) [] args' CmmMayReturn
  | op == MO_Memcpy ||
    op == MO_Memset ||
    op == MO_Memmove = do
-    let (isVolTy, isVolVal) = if getLlvmVer env >= 28
+    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
@@ -217,12 +218,23 @@ genCall env t@(CmmPrim op _) [] args CmmMayReturn
     (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, [])