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, 52 insertions, 26 deletions

diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index e9215d5021..f3f9e74a0b 100644
--- a/compiler/cmm/CmmMachOp.hs
+++ b/compiler/cmm/CmmMachOp.hs
@@ -21,6 +21,7 @@ module CmmMachOp
     -- CallishMachOp
     , CallishMachOp(..), callishMachOpHints
     , pprCallishMachOp
+    , machOpMemcpyishAlign
 
     -- Atomic read-modify-write
     , AtomicMachOp(..)
@@ -565,12 +566,12 @@ data CallishMachOp
                      -- would the majority of use cases in ghc anyways
 
 
-  -- Note that these three MachOps all take 1 extra parameter than the
-  -- standard C lib versions. The extra (last) parameter contains
-  -- alignment of the pointers. Used for optimisation in backends.
-  | MO_Memcpy
-  | MO_Memset
-  | MO_Memmove
+  -- These three MachOps are parameterised by the known alignment
+  -- of the destination and source (for memcpy/memmove) pointers.
+  -- This information may be used for optimisation in backends.
+  | MO_Memcpy Int
+  | MO_Memset Int
+  | MO_Memmove Int
 
   | MO_PopCnt Width
   | MO_Clz Width
@@ -600,8 +601,16 @@ pprCallishMachOp mo = text (show mo)
 
 callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint])
 callishMachOpHints op = case op of
-  MO_Memcpy  -> ([], [AddrHint,AddrHint,NoHint,NoHint])
-  MO_Memset  -> ([], [AddrHint,NoHint,NoHint,NoHint])
-  MO_Memmove -> ([], [AddrHint,AddrHint,NoHint,NoHint])
-  _          -> ([],[])
+  MO_Memcpy _  -> ([], [AddrHint,AddrHint,NoHint])
+  MO_Memset _  -> ([], [AddrHint,NoHint,NoHint])
+  MO_Memmove _ -> ([], [AddrHint,AddrHint,NoHint])
+  _            -> ([],[])
   -- empty lists indicate NoHint
+
+-- | The alignment of a 'memcpy'-ish operation.
+machOpMemcpyishAlign :: CallishMachOp -> Maybe Int
+machOpMemcpyishAlign op = case op of
+  MO_Memcpy  align -> Just align
+  MO_Memset  align -> Just align
+  MO_Memmove align -> Just align
+  _                -> Nothing
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index fca231e988..694d79ead9 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -975,22 +975,38 @@ machOps = listToUFM $
         ( "i2f64",    flip MO_SF_Conv W64 )
         ]
 
+callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
 callishMachOps = listToUFM $
         map (\(x, y) -> (mkFastString x, y)) [
-        ( "write_barrier", MO_WriteBarrier ),
-        ( "memcpy", MO_Memcpy ),
-        ( "memset", MO_Memset ),
-        ( "memmove", MO_Memmove ),
+        ( "write_barrier", (,) MO_WriteBarrier ),
+        ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),
+        ( "memset", memcpyLikeTweakArgs MO_Memset ),
+        ( "memmove", memcpyLikeTweakArgs MO_Memmove ),
 
-        ("prefetch0",MO_Prefetch_Data 0),
-        ("prefetch1",MO_Prefetch_Data 1),
-        ("prefetch2",MO_Prefetch_Data 2),
-        ("prefetch3",MO_Prefetch_Data 3)
+        ("prefetch0", (,) $ MO_Prefetch_Data 0),
+        ("prefetch1", (,) $ MO_Prefetch_Data 1),
+        ("prefetch2", (,) $ MO_Prefetch_Data 2),
+        ("prefetch3", (,) $ MO_Prefetch_Data 3)
 
         -- ToDo: the rest, maybe
         -- edit: which rest?
         -- also: how do we tell CMM Lint how to type check callish macops?
     ]
+  where
+    memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])
+    memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"
+    memcpyLikeTweakArgs op args@(_:_) =
+        -- Force alignment with result to ensure pprPgmError fires
+        align `seq` (op align, args')
+      where
+        args' = init args
+        align = case last args of
+          CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger
+          e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e)
+        -- The alignment of memcpy-ish operations must be a
+        -- compile-time constant. We verify this here, passing it around
+        -- in the MO_* constructor. In order to do this, however, we
+        -- must intercept the arguments in primCall.
 
 parseSafety :: String -> P Safety
 parseSafety "safe"   = return PlaySafe
@@ -1207,10 +1223,11 @@ primCall
 primCall results_code name args_code
   = case lookupUFM callishMachOps name of
         Nothing -> fail ("unknown primitive " ++ unpackFS name)
-        Just p  -> return $ do
+        Just f  -> return $ do
                 results <- sequence results_code
                 args <- sequence args_code
-                code (emitPrimCall (map fst results) p args)
+                let (p, args') = f args
+                code (emitPrimCall (map fst results) p args')
 
 doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()
 doStore rep addr_code val_code
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 92c818242d..3703f0ae1f 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -238,13 +238,13 @@ pprStmt stmt =
         hargs    = zip args arg_hints
 
         fn_call
-          -- The mem primops carry an extra alignment arg, must drop it.
+          -- The mem primops carry an extra alignment arg.
           -- We could maybe emit an alignment directive using this info.
           -- We also need to cast mem primops to prevent conflicts with GCC
           -- builtins (see bug #5967).
-          | op `elem` [MO_Memcpy, MO_Memset, MO_Memmove]
+          | Just _align <- machOpMemcpyishAlign op
           = (ptext (sLit ";EF_(") <> fn <> char ')' <> semi) $$
-            pprForeignCall fn cconv hresults (init hargs)
+            pprForeignCall fn cconv hresults hargs
           | otherwise
           = pprCall fn cconv hresults hargs
 
@@ -745,9 +745,9 @@ pprCallishMachOp_for_C mop
         MO_F32_Exp      -> ptext (sLit "expf")
         MO_F32_Sqrt     -> ptext (sLit "sqrtf")
         MO_WriteBarrier -> ptext (sLit "write_barrier")
-        MO_Memcpy       -> ptext (sLit "memcpy")
-        MO_Memset       -> ptext (sLit "memset")
-        MO_Memmove      -> ptext (sLit "memmove")
+        MO_Memcpy _     -> ptext (sLit "memcpy")
+        MO_Memset _     -> ptext (sLit "memset")
+        MO_Memmove _    -> ptext (sLit "memmove")
         (MO_BSwap w)    -> ptext (sLit $ bSwapLabel w)
         (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)
         (MO_Clz w)      -> ptext (sLit $ clzLabel w)