Encode alignment in MO_Memcpy and friends

Summary:
Alignment needs to be a compile-time constant. Previously the code
generators had to jump through hoops to ensure this was the case as the
alignment was passed as a CmmExpr in the arguments list. Now we take
care of this up front.

This fixes #8131.

Authored-by: Reid Barton <rwbarton@gmail.com>
Dusted-off-by: Ben Gamari <ben@smart-cactus.org>

Tests for T8131

Test Plan: Validate

Reviewers: rwbarton, austin

Reviewed By: rwbarton, austin

Subscribers: bgamari, carter, thomie

Differential Revision: https://phabricator.haskell.org/D624

GHC Trac Issues: #8131

1 files changed, 20 insertions, 23 deletions

diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 2c48c28a28..ffe9d619f6 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -24,7 +24,8 @@ import Hoopl
 import DynFlags
 import FastString
 import ForeignCall
-import Outputable
+import Outputable hiding (panic, pprPanic)
+import qualified Outputable
 import Platform
 import OrdList
 import UniqSupply
@@ -230,16 +231,13 @@ genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = do
 
 -- Handle memcpy function specifically since llvm's intrinsic version takes
 -- some extra parameters.
-genCall t@(PrimTarget op) [] args'
- | op == MO_Memcpy ||
-   op == MO_Memset ||
-   op == MO_Memmove = do
+genCall t@(PrimTarget op) [] args
+ | Just align <- machOpMemcpyishAlign op = do
     dflags <- getDynFlags
-    let (args, alignVal) = splitAlignVal args'
-        isVolTy = [i1]
+    let isVolTy = [i1]
         isVolVal = [mkIntLit i1 0]
-        argTy | op == MO_Memset = [i8Ptr, i8,    llvmWord dflags, i32] ++ isVolTy
-              | otherwise       = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy
+        argTy | MO_Memset _ <- op = [i8Ptr, i8,    llvmWord dflags, i32] ++ isVolTy
+              | otherwise         = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy
         funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
                              CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
 
@@ -250,21 +248,12 @@ genCall t@(PrimTarget op) [] args'
     (argVars', stmts3)            <- castVars $ zip argVars argTy
 
     stmts4 <- getTrashStmts
-    let arguments = argVars' ++ (alignVal:isVolVal)
+    let alignVal = mkIntLit i32 align
+        arguments = argVars' ++ (alignVal:isVolVal)
         call = Expr $ Call StdCall fptr arguments []
         stmts = stmts1 `appOL` stmts2 `appOL` stmts3
                 `appOL` stmts4 `snocOL` call
     return (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 (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
 
 -- Handle all other foreign calls and prim ops.
 genCall target res args = do
@@ -534,9 +523,9 @@ cmmPrimOpFunctions mop = do
     MO_F64_Cosh   -> fsLit "cosh"
     MO_F64_Tanh   -> fsLit "tanh"
 
-    MO_Memcpy     -> fsLit $ "llvm.memcpy."  ++ intrinTy1
-    MO_Memmove    -> fsLit $ "llvm.memmove." ++ intrinTy1
-    MO_Memset     -> fsLit $ "llvm.memset."  ++ intrinTy2
+    MO_Memcpy _   -> fsLit $ "llvm.memcpy."  ++ intrinTy1
+    MO_Memmove _  -> fsLit $ "llvm.memmove." ++ intrinTy1
+    MO_Memset _   -> fsLit $ "llvm.memset."  ++ intrinTy2
 
     (MO_PopCnt w) -> fsLit $ "llvm.ctpop."  ++ showSDoc dflags (ppr $ widthToLlvmInt w)
     (MO_BSwap w)  -> fsLit $ "llvm.bswap."  ++ showSDoc dflags (ppr $ widthToLlvmInt w)
@@ -1646,6 +1635,14 @@ toIWord :: Integral a => DynFlags -> a -> LlvmVar
 toIWord dflags = mkIntLit (llvmWord dflags)
 
 
+-- | Error functions
+panic :: String -> a
+panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s
+
+pprPanic :: String -> SDoc -> a
+pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d
+
+
 -- | Returns TBAA meta data by unique
 getTBAAMeta :: Unique -> LlvmM [MetaAnnot]
 getTBAAMeta u = do