Fix fencepost and byte/word bugs in cloneArray/copyArray (#7185)

3 files changed, 46 insertions, 28 deletions

diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index 615e2fd625..25129747be 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -38,7 +38,7 @@ module CmmUtils(
 	cmmNegate, 
   	cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
   	cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
-  	cmmUShrWord, cmmAddWord, cmmMulWord,
+        cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord,
 
 	isTrivialCmmExpr, hasNoGlobalRegs,
 	
@@ -285,7 +285,7 @@ cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty
 -----------------------
 cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
   cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
-  cmmUShrWord, cmmAddWord, cmmMulWord
+  cmmUShrWord, cmmAddWord, cmmMulWord, cmmQuotWord
   :: CmmExpr -> CmmExpr -> CmmExpr
 cmmOrWord  e1 e2 = CmmMachOp mo_wordOr  [e1, e2]
 cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
@@ -306,6 +306,7 @@ cmmNegate e			  = CmmMachOp (MO_S_Neg (cmmExprWidth e)) [e]
 
 blankWord :: CmmStatic
 blankWord = CmmUninitialised wORD_SIZE
+cmmQuotWord e1 e2 = CmmMachOp mo_wordUQuot [e1, e2]
 
 ---------------------------------------------------
 --
diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs
index a2e50e0c0d..c128cb7f79 100644
--- a/compiler/codeGen/CgPrimOp.hs
+++ b/compiler/codeGen/CgPrimOp.hs
@@ -34,6 +34,7 @@ import DynFlags
 import FastString
 
 import Control.Monad
+import Data.Bits
 
 -- ---------------------------------------------------------------------------
 -- Code generation for PrimOps
@@ -843,8 +844,7 @@ doWritePtrArrayOp addr idx val
           cmmOffsetExpr
            (cmmOffsetExprW (cmmOffsetB addr (arrPtrsHdrSize dflags))
                           (loadArrPtrsSize dflags addr))
-           (CmmMachOp mo_wordUShr [idx,
-                                   CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)])
+           (card idx)
           ) (CmmLit (CmmInt 1 W8))
 
 loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr
@@ -1020,10 +1020,8 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do
     src_off <- assignTemp_ src_off0
     n <- assignTemp_ n0
 
-    card_words <- assignTemp $ (n `cmmUShrWord`
-                                (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)))
-                  `cmmAddWord` CmmLit (mkIntCLit 1)
-    size <- assignTemp $ n `cmmAddWord` card_words
+    card_bytes <- assignTemp $ cardRoundUp n
+    size <- assignTemp $ n `cmmAddWord` bytesToWordsRoundUp card_bytes
     words <- assignTemp $ arrPtrsHdrSizeW dflags `cmmAddWord` size
 
     arr_r <- newTemp bWord
@@ -1047,14 +1045,13 @@ emitCloneArray info_p res_r src0 src_off0 n0 live = do
 
     emitMemsetCall (cmmOffsetExprW dst_p n)
         (CmmLit (mkIntCLit 1))
-        (card_words `cmmMulWord` wordSize)
+        card_bytes
         (CmmLit (mkIntCLit wORD_SIZE))
         live
     stmtC $ CmmAssign (CmmLocal res_r) arr
   where
     arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit $ fixedHdrSize dflags +
                                  (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
-    wordSize = CmmLit (mkIntCLit wORD_SIZE)
     myCapability = CmmReg baseReg `cmmSubWord`
                    CmmLit (mkIntCLit oFFSET_Capability_r)
 
@@ -1066,13 +1063,24 @@ emitSetCards dst_start dst_cards_start n live = do
     start_card <- assignTemp $ card dst_start
     emitMemsetCall (dst_cards_start `cmmAddWord` start_card)
         (CmmLit (mkIntCLit 1))
-        ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card)
-         `cmmAddWord` CmmLit (mkIntCLit 1))
-        (CmmLit (mkIntCLit wORD_SIZE))
+        (cardRoundUp n)
+        (CmmLit (mkIntCLit 1)) -- no alignment (1 byte)
         live
-  where
-    -- Convert an element index to a card index
-    card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
+
+-- Convert an element index to a card index
+card :: CmmExpr -> CmmExpr
+card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
+
+-- Convert a number of elements to a number of cards, rounding up
+cardRoundUp :: CmmExpr -> CmmExpr
+cardRoundUp i = card (i `cmmAddWord` (CmmLit (mkIntCLit ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1))))
+
+bytesToWordsRoundUp :: CmmExpr -> CmmExpr
+bytesToWordsRoundUp e = (e `cmmAddWord` CmmLit (mkIntCLit (wORD_SIZE - 1)))
+                        `cmmQuotWord` wordSize
+
+wordSize :: CmmExpr
+wordSize = CmmLit (mkIntCLit wORD_SIZE)
 
 -- | Emit a call to @memcpy@.
 emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index d9585c6d61..b4b67491eb 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -49,6 +49,7 @@ import Outputable
 import Util
 
 import Control.Monad (liftM)
+import Data.Bits
 
 ------------------------------------------------------------------------
 --	Primitive operations and foreign calls
@@ -1095,10 +1096,8 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do
     src_off <- assignTempE src_off0
     n       <- assignTempE n0
 
-    card_words <- assignTempE $ (n `cmmUShrWord`
-                                (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)))
-                  `cmmAddWord` CmmLit (mkIntCLit 1)
-    size <- assignTempE $ n `cmmAddWord` card_words
+    card_bytes <- assignTempE $ cardRoundUp n
+    size <- assignTempE $ n `cmmAddWord` bytesToWordsRoundUp card_bytes
     dflags <- getDynFlags
     words <- assignTempE $ arrPtrsHdrSizeW dflags `cmmAddWord` size
 
@@ -1122,13 +1121,12 @@ emitCloneArray info_p res_r src0 src_off0 n0 = do
 
     emitMemsetCall (cmmOffsetExprW dst_p n)
         (CmmLit (mkIntCLit 1))
-        (card_words `cmmMulWord` wordSize)
+        card_bytes
         (CmmLit (mkIntCLit wORD_SIZE))
     emit $ mkAssign (CmmLocal res_r) arr
   where
     arrPtrsHdrSizeW dflags = CmmLit $ mkIntCLit $ fixedHdrSize dflags +
                                  (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE)
-    wordSize = CmmLit (mkIntCLit wORD_SIZE)
     myCapability = CmmReg baseReg `cmmSubWord`
                    CmmLit (mkIntCLit oFFSET_Capability_r)
 
@@ -1140,12 +1138,23 @@ emitSetCards dst_start dst_cards_start n = do
     start_card <- assignTempE $ card dst_start
     emitMemsetCall (dst_cards_start `cmmAddWord` start_card)
         (CmmLit (mkIntCLit 1))
-        ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card)
-         `cmmAddWord` CmmLit (mkIntCLit 1))
-         (CmmLit (mkIntCLit wORD_SIZE))
-  where
-    -- Convert an element index to a card index
-    card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
+        (cardRoundUp n)
+        (CmmLit (mkIntCLit 1)) -- no alignment (1 byte)
+
+-- Convert an element index to a card index
+card :: CmmExpr -> CmmExpr
+card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))
+
+-- Convert a number of elements to a number of cards, rounding up
+cardRoundUp :: CmmExpr -> CmmExpr
+cardRoundUp i = card (i `cmmAddWord` (CmmLit (mkIntCLit ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS) - 1))))
+
+bytesToWordsRoundUp :: CmmExpr -> CmmExpr
+bytesToWordsRoundUp e = (e `cmmAddWord` CmmLit (mkIntCLit (wORD_SIZE - 1)))
+                        `cmmQuotWord` wordSize
+
+wordSize :: CmmExpr
+wordSize = CmmLit (mkIntCLit wORD_SIZE)
 
 -- | Emit a call to @memcpy@.
 emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()