Fix array primop alignment

2 files changed, 35 insertions, 21 deletions

diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs
index 04654d40d3..6aa0a2dd08 100644
--- a/compiler/GHC/StgToCmm/Monad.hs
+++ b/compiler/GHC/StgToCmm/Monad.hs
@@ -21,7 +21,7 @@ module GHC.StgToCmm.Monad (
 
         emit, emitDecl,
         emitProcWithConvention, emitProcWithStackFrame,
-        emitOutOfLine, emitAssign, emitStore,
+        emitOutOfLine, emitAssign, emitStore, emitStore',
         emitComment, emitTick, emitUnwind,
 
         newTemp,
@@ -725,8 +725,11 @@ emitAssign :: CmmReg  -> CmmExpr -> FCode ()
 emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))
 
 -- | Assumes natural alignment.
-emitStore :: CmmExpr  -> CmmExpr -> FCode ()
-emitStore l r = emitCgStmt (CgStmt (CmmStore l r NaturallyAligned))
+emitStore :: CmmExpr -> CmmExpr -> FCode ()
+emitStore = emitStore' NaturallyAligned
+
+emitStore' :: AlignmentSpec -> CmmExpr -> CmmExpr -> FCode ()
+emitStore' alignment l r = emitCgStmt (CgStmt (CmmStore l r alignment))
 
 emit :: CmmAGraph -> FCode ()
 emit ag
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index 17fe2d9373..4d7294a3ec 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -2057,13 +2057,20 @@ genericFabsOp _ _ _ = panic "genericFabsOp"
 ------------------------------------------------------------------------------
 -- Helpers for translating various minor variants of array indexing.
 
+alignmentFromTypes :: CmmType  -- ^ element type
+                   -> CmmType  -- ^ index type
+                   -> AlignmentSpec
+alignmentFromTypes ty idx_ty
+  | typeWidth ty < typeWidth idx_ty = NaturallyAligned
+  | otherwise                       = Unaligned
+
 doIndexOffAddrOp :: Maybe MachOp
                  -> CmmType
                  -> [LocalReg]
                  -> [CmmExpr]
                  -> FCode ()
 doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]
-   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx
+   = mkBasicIndexedRead NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx
 doIndexOffAddrOp _ _ _ _
    = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp"
 
@@ -2074,7 +2081,8 @@ doIndexOffAddrOpAs :: Maybe MachOp
                    -> [CmmExpr]
                    -> FCode ()
 doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]
-   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx
+   = let alignment = alignmentFromTypes rep idx_rep
+     in mkBasicIndexedRead alignment 0 maybe_post_read_cast rep res addr idx_rep idx
 doIndexOffAddrOpAs _ _ _ _ _
    = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs"
 
@@ -2086,7 +2094,7 @@ doIndexByteArrayOp :: Maybe MachOp
 doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
    = do profile <- getProfile
         doByteArrayBoundsCheck idx addr rep rep
-        mkBasicIndexedRead (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx
+        mkBasicIndexedRead NaturallyAligned (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx
 doIndexByteArrayOp _ _ _ _
    = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp"
 
@@ -2099,7 +2107,8 @@ doIndexByteArrayOpAs :: Maybe MachOp
 doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]
    = do profile <- getProfile
         doByteArrayBoundsCheck idx addr idx_rep rep
-        mkBasicIndexedRead (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx
+        let alignment = alignmentFromTypes rep idx_rep
+        mkBasicIndexedRead alignment (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx
 doIndexByteArrayOpAs _ _ _ _ _
    = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs"
 
@@ -2111,7 +2120,7 @@ doReadPtrArrayOp res addr idx
    = do profile <- getProfile
         platform <- getPlatform
         doPtrArrayBoundsCheck idx addr
-        mkBasicIndexedRead (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx
+        mkBasicIndexedRead NaturallyAligned (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx
 
 doWriteOffAddrOp :: Maybe MachOp
                  -> CmmType
@@ -2150,7 +2159,7 @@ doWritePtrArrayOp addr idx val
 
        -- Update remembered set for non-moving collector
        whenUpdRemSetEnabled
-           $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform hdr_size ty addr ty idx)
+           $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform NaturallyAligned hdr_size ty addr ty idx)
        -- This write barrier is to ensure that the heap writes to the object
        -- referred to by val have happened before we write val into the array.
        -- See #12469 for details.
@@ -2164,8 +2173,7 @@ doWritePtrArrayOp addr idx val
          cmmOffsetExpr platform
           (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size)
                          (loadArrPtrsSize profile addr))
-          (CmmMachOp (mo_wordUShr platform) [idx,
-                                           mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))])
+          (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))])
          ) (CmmLit (CmmInt 1 W8))
 
 loadArrPtrsSize :: Profile -> CmmExpr -> CmmExpr
@@ -2173,7 +2181,8 @@ loadArrPtrsSize profile addr = cmmLoadBWord platform (cmmOffsetB platform addr o
  where off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (profileConstants profile)
        platform = profilePlatform profile
 
-mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes
+mkBasicIndexedRead :: AlignmentSpec
+                   -> ByteOff      -- Initial offset in bytes
                    -> Maybe MachOp -- Optional result cast
                    -> CmmType      -- Type of element we are accessing
                    -> LocalReg     -- Destination
@@ -2181,13 +2190,13 @@ mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes
                    -> CmmType      -- Type of element by which we are indexing
                    -> CmmExpr      -- Index
                    -> FCode ()
-mkBasicIndexedRead off Nothing ty res base idx_ty idx
+mkBasicIndexedRead alignment off Nothing ty res base idx_ty idx
    = do platform <- getPlatform
-        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr platform off ty base idx_ty idx)
-mkBasicIndexedRead off (Just cast) ty res base idx_ty idx
+        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx)
+mkBasicIndexedRead alignment off (Just cast) ty res base idx_ty idx
    = do platform <- getPlatform
         emitAssign (CmmLocal res) (CmmMachOp cast [
-                                   cmmLoadIndexOffExpr platform off ty base idx_ty idx])
+                                   cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx])
 
 mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes
                     -> Maybe MachOp -- Optional value cast
@@ -2198,7 +2207,8 @@ mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes
                     -> FCode ()
 mkBasicIndexedWrite off Nothing base idx_ty idx val
    = do platform <- getPlatform
-        emitStore (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) val
+        let alignment = alignmentFromTypes (cmmExprType platform val) idx_ty
+        emitStore' alignment (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) val
 mkBasicIndexedWrite off (Just cast) base idx_ty idx val
    = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])
 
@@ -2215,14 +2225,15 @@ cmmIndexOffExpr platform off width base idx
    = cmmIndexExpr platform width (cmmOffsetB platform base off) idx
 
 cmmLoadIndexOffExpr :: Platform
+                    -> AlignmentSpec
                     -> ByteOff  -- Initial offset in bytes
                     -> CmmType  -- Type of element we are accessing
                     -> CmmExpr  -- Base address
                     -> CmmType  -- Type of element by which we are indexing
                     -> CmmExpr  -- Index
                     -> CmmExpr
-cmmLoadIndexOffExpr platform off ty base idx_ty idx
-   = CmmLoad (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) ty NaturallyAligned
+cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx
+   = CmmLoad (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) ty alignment
 
 setInfo :: CmmExpr -> CmmExpr -> CmmAGraph
 setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr
@@ -2988,7 +2999,7 @@ doReadSmallPtrArrayOp res addr idx = do
     profile <- getProfile
     platform <- getPlatform
     doSmallPtrArrayBoundsCheck idx addr
-    mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr
+    mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr
         (gcWord platform) idx
 
 doWriteSmallPtrArrayOp :: CmmExpr
@@ -3004,7 +3015,7 @@ doWriteSmallPtrArrayOp addr idx val = do
 
     -- Update remembered set for non-moving collector
     tmp <- newTemp ty
-    mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx
+    mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx
     whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp))
 
     emitPrimCall [] MO_WriteBarrier [] -- #12469