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

3 files changed, 18 insertions, 48 deletions

diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index a115980183..299d6b702b 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -923,7 +923,7 @@ genCCall' _ _ (PrimTarget MO_Touch) _ _
 genCCall' _ _ (PrimTarget (MO_Prefetch_Data _)) _ _
  = return $ nilOL
 
-genCCall' dflags gcp target dest_regs args0
+genCCall' dflags gcp target dest_regs args
   = ASSERT(not $ any (`elem` [II16]) $ map cmmTypeSize argReps)
         -- we rely on argument promotion in the codeGen
     do
@@ -978,17 +978,7 @@ genCCall' dflags gcp target dest_regs args0
                                     map (widthInBytes . typeWidth) argReps
                                 GCPLinux -> roundTo 16 finalStack
 
-        -- need to remove alignment information
-        args | PrimTarget mop <- target,
-                        (mop == MO_Memcpy ||
-                         mop == MO_Memset ||
-                         mop == MO_Memmove)
-                      = init args0
-
-                      | otherwise
-                      = args0
-
-        argReps = map (cmmExprType dflags) args0
+        argReps = map (cmmExprType dflags) args
 
         roundTo a x | x `mod` a == 0 = x
                     | otherwise = x + a - (x `mod` a)
@@ -1173,9 +1163,9 @@ genCCall' dflags gcp target dest_regs args0
 
                     MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False)
 
-                    MO_Memcpy    -> (fsLit "memcpy", False)
-                    MO_Memset    -> (fsLit "memset", False)
-                    MO_Memmove   -> (fsLit "memmove", False)
+                    MO_Memcpy _  -> (fsLit "memcpy", False)
+                    MO_Memset _  -> (fsLit "memset", False)
+                    MO_Memmove _ -> (fsLit "memmove", False)
 
                     MO_BSwap w   -> (fsLit $ bSwapLabel w, False)
                     MO_PopCnt w  -> (fsLit $ popCntLabel w, False)
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index a9d861946e..4792933366 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -404,19 +404,8 @@ genCCall (PrimTarget MO_WriteBarrier) _ _
 genCCall (PrimTarget (MO_Prefetch_Data _)) _ _
  = return $ nilOL
 
-genCCall target dest_regs args0
- = do
-        -- need to remove alignment information
-        let args | PrimTarget mop <- target,
-                            (mop == MO_Memcpy ||
-                             mop == MO_Memset ||
-                             mop == MO_Memmove)
-                          = init args0
-
-                          | otherwise
-                          = args0
-
-        -- work out the arguments, and assign them to integer regs
+genCCall target dest_regs args
+ = do   -- work out the arguments, and assign them to integer regs
         argcode_and_vregs       <- mapM arg_to_int_vregs args
         let (argcodes, vregss)  = unzip argcode_and_vregs
         let vregs               = concat vregss
@@ -653,9 +642,9 @@ outOfLineMachOp_table mop
 
         MO_UF_Conv w -> fsLit $ word2FloatLabel w
 
-        MO_Memcpy    -> fsLit "memcpy"
-        MO_Memset    -> fsLit "memset"
-        MO_Memmove   -> fsLit "memmove"
+        MO_Memcpy _  -> fsLit "memcpy"
+        MO_Memset _  -> fsLit "memset"
+        MO_Memmove _ -> fsLit "memmove"
 
         MO_BSwap w   -> fsLit $ bSwapLabel w
         MO_PopCnt w  -> fsLit $ popCntLabel w
diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs
index 7b7cc54bbe..a052fdacdf 100644
--- a/compiler/nativeGen/X86/CodeGen.hs
+++ b/compiler/nativeGen/X86/CodeGen.hs
@@ -1645,10 +1645,8 @@ genCCall
 -- Unroll memcpy calls if the source and destination pointers are at
 -- least DWORD aligned and the number of bytes to copy isn't too
 -- large.  Otherwise, call C's memcpy.
-genCCall dflags is32Bit (PrimTarget MO_Memcpy) _
-         [dst, src,
-          (CmmLit (CmmInt n _)),
-          (CmmLit (CmmInt align _))]
+genCCall dflags is32Bit (PrimTarget (MO_Memcpy align)) _
+         [dst, src, CmmLit (CmmInt n _)]
     | fromInteger insns <= maxInlineMemcpyInsns dflags && align .&. 3 == 0 = do
         code_dst <- getAnyReg dst
         dst_r <- getNewRegNat size
@@ -1694,11 +1692,10 @@ genCCall dflags is32Bit (PrimTarget MO_Memcpy) _
         dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone
                    (ImmInteger (n - i))
 
-genCCall dflags _ (PrimTarget MO_Memset) _
+genCCall dflags _ (PrimTarget (MO_Memset align)) _
          [dst,
           CmmLit (CmmInt c _),
-          CmmLit (CmmInt n _),
-          CmmLit (CmmInt align _)]
+          CmmLit (CmmInt n _)]
     | fromInteger insns <= maxInlineMemsetInsns dflags && align .&. 3 == 0 = do
         code_dst <- getAnyReg dst
         dst_r <- getNewRegNat size
@@ -2507,19 +2504,13 @@ outOfLineCmmOp mop res args
       let target = ForeignTarget targetExpr
                            (ForeignConvention CCallConv [] [] CmmMayReturn)
 
-      stmtToInstrs (CmmUnsafeForeignCall target (catMaybes [res]) args')
+      stmtToInstrs (CmmUnsafeForeignCall target (catMaybes [res]) args)
   where
         -- Assume we can call these functions directly, and that they're not in a dynamic library.
         -- TODO: Why is this ok? Under linux this code will be in libm.so
         --       Is is because they're really implemented as a primitive instruction by the assembler??  -- BL 2009/12/31
         lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction
 
-        args' = case mop of
-                    MO_Memcpy    -> init args
-                    MO_Memset    -> init args
-                    MO_Memmove   -> init args
-                    _            -> args
-
         fn = case mop of
               MO_F32_Sqrt  -> fsLit "sqrtf"
               MO_F32_Sin   -> fsLit "sinf"
@@ -2553,9 +2544,9 @@ outOfLineCmmOp mop res args
               MO_F64_Tanh  -> fsLit "tanh"
               MO_F64_Pwr   -> fsLit "pow"
 
-              MO_Memcpy    -> fsLit "memcpy"
-              MO_Memset    -> fsLit "memset"
-              MO_Memmove   -> fsLit "memmove"
+              MO_Memcpy _  -> fsLit "memcpy"
+              MO_Memset _  -> fsLit "memset"
+              MO_Memmove _ -> fsLit "memmove"
 
               MO_PopCnt _  -> fsLit "popcnt"
               MO_BSwap _   -> fsLit "bswap"