copyArray# bug

[Roman Leshchinskiy]

I've been chasing a segfault in the dev version of vector and I think I 
finally traced it to a bug in the implementation of copyArray# and 
copyMutableArray#. More specifically, I think emitSetCards in 
StgCmmPrim.hs (and CgPrimOp.hs) will sometimes fail to mark the last 
card as dirty because in the current implementation, the number of cards 
to mark is computed solely from the number of copied elements while it 
really depends on which cards the first and the last elements belong to. 
That is, the number of elements to copy might be less than the number of 
elements per card but the copied range might still span two cards.

The attached patch fixes this (and the segfault in vector) and also 
makes copyArray# return immediately if the number of elements to copy is 
0. Could someone who is familiar with the code please review it and tell 
me if it looks sensible. If it does, I'll make the same modification to 
CgPrimOp.hs (which has exactly the same code) and commit. Unfortunately, 
I have no idea how to write a testcase for this since the bug is only 
triggered in very specific circumstances.

It seems that all released versions of GHC that implement 
copyArray#/copyMutableArray# have this problem. At least, vector's 
testsuite now segfaults with all of them in roughly the same place after 
recent modifications I've made (which involve calling copyArray# a lot). 
If I'm right then I would suggest not to use copyArray# and 
copyMutableArray# for GHC < 7.8.

Roman

-------------- next part --------------
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index cbb2aa7..6c291f1 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -1069,27 +1069,30 @@ emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
               -> FCode ()
 emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do
     dflags <- getDynFlags
-    -- Passed as arguments (be careful)
-    src     <- assignTempE src0
-    src_off <- assignTempE src_off0
-    dst     <- assignTempE dst0
-    dst_off <- assignTempE dst_off0
     n       <- assignTempE n0
+    nonzero <- getCode $ do
+        -- Passed as arguments (be careful)
+        src     <- assignTempE src0
+        src_off <- assignTempE src_off0
+        dst     <- assignTempE dst0
+        dst_off <- assignTempE dst_off0
 
-    -- Set the dirty bit in the header.
-    emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
+        -- Set the dirty bit in the header.
+        emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
 
-    dst_elems_p <- assignTempE $ cmmOffsetB dflags dst (arrPtrsHdrSize dflags)
-    dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off
-    src_p <- assignTempE $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off
-    bytes <- assignTempE $ cmmMulWord dflags n (mkIntExpr dflags (wORD_SIZE dflags))
+        dst_elems_p <- assignTempE $ cmmOffsetB dflags dst (arrPtrsHdrSize dflags)
+        dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off
+        src_p <- assignTempE $ cmmOffsetExprW dflags (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off
+        bytes <- assignTempE $ cmmMulWord dflags n (mkIntExpr dflags (wORD_SIZE dflags))
 
-    copy src dst dst_p src_p bytes
+        copy src dst dst_p src_p bytes
 
-    -- The base address of the destination card table
-    dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p (loadArrPtrsSize dflags dst)
+        -- The base address of the destination card table
+        dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p (loadArrPtrsSize dflags dst)
 
-    emitSetCards dst_off dst_cards_p n
+        emitSetCards dst_off dst_cards_p n
+
+    emit =<< mkCmmIfThen (cmmNeWord dflags n (mkIntExpr dflags 0)) nonzero
 
 -- | Takes an info table label, a register to return the newly
 -- allocated array in, a source array, an offset in the source array,
@@ -1142,10 +1145,11 @@ emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 emitSetCards dst_start dst_cards_start n = do
     dflags <- getDynFlags
     start_card <- assignTempE $ card dflags dst_start
+    end_card <- assignTempE $ card dflags (cmmSubWord dflags (cmmAddWord dflags dst_start n) (mkIntExpr dflags 1))
     emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)
-        (mkIntExpr dflags 1)
-        (cardRoundUp dflags n)
-        (mkIntExpr dflags 1) -- no alignment (1 byte)
+                   (mkIntExpr dflags 1)
+                   (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1))
+                   (mkIntExpr dflags 1) -- no alignment (1 byte)
 
 -- Convert an element index to a card index
 card :: DynFlags -> CmmExpr -> CmmExpr