codeGen: Fix two buglets in -fbounds-check logicwip/bounds-checking

@Bodigrim noticed that the `compareByteArray#` bounds-checking logic had
flipped arguments and an off-by-one. For the sake of clarity I also
refactored occurrences of `cmmOffset` to rather use `cmmOffsetB`. I
suspect the former should be retired.

3 files changed, 30 insertions, 10 deletions

diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index e0af686b47..1e784c16a1 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -2558,9 +2558,9 @@ doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do
     platform <- getPlatform
 
     ifNonZero n $ do
-        let last_touched_idx off = cmmOffset platform (cmmAddWord platform off n) (-1)
-        doByteArrayBoundsCheck ba1_off (last_touched_idx ba1_off) b8 b8
-        doByteArrayBoundsCheck ba2_off (last_touched_idx ba2_off) b8 b8
+        let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off n) (-1)
+        doByteArrayBoundsCheck (last_touched_idx ba1_off) ba1 b8 b8
+        doByteArrayBoundsCheck (last_touched_idx ba2_off) ba2 b8 b8
 
     ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off
     ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off
@@ -2653,7 +2653,7 @@ emitCopyByteArray copy src src_off dst dst_off n = do
     platform <- getPlatform
 
     ifNonZero n $ do
-        let last_touched_idx off = cmmOffset platform (cmmAddWord platform off n) (-1)
+        let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off n) (-1)
         doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8
         doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8
 
@@ -2674,7 +2674,7 @@ doCopyByteArrayToAddrOp src src_off dst_p bytes = do
     profile <- getProfile
     platform <- getPlatform
     ifNonZero bytes $ do
-        let last_touched_idx off = cmmOffset platform (cmmAddWord platform off bytes) (-1)
+        let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off bytes) (-1)
         doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8
     src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off
     emitMemcpyCall dst_p src_p bytes (mkAlignment 1)
@@ -2695,7 +2695,7 @@ doCopyAddrToByteArrayOp src_p dst dst_off bytes = do
     profile <- getProfile
     platform <- getPlatform
     ifNonZero bytes $ do
-        let last_touched_idx off = cmmOffset platform (cmmAddWord platform off bytes) (-1)
+        let last_touched_idx off = cmmOffsetB platform (cmmAddWord platform off bytes) (-1)
         doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8
     dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off
     emitMemcpyCall dst_p src_p bytes (mkAlignment 1)
@@ -2720,7 +2720,7 @@ doSetByteArrayOp ba off len c = do
     platform <- getPlatform
 
     doByteArrayBoundsCheck off ba b8 b8
-    doByteArrayBoundsCheck (cmmAddWord platform off c) ba b8 b8
+    doByteArrayBoundsCheck (cmmOffset platform (cmmAddWord platform off len) (-1)) ba b8 b8
 
     let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap
         offsetAlignment = cmmExprAlignment off
@@ -3302,7 +3302,7 @@ doPtrArrayBoundsCheck
 doPtrArrayBoundsCheck idx arr = do
     profile <- getProfile
     platform <- getPlatform
-    let sz = CmmLoad (cmmOffset platform arr sz_off) (bWord platform)
+    let sz = CmmLoad (cmmOffsetB platform arr sz_off) (bWord platform)
         sz_off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)
     doBoundsCheck idx sz
 
@@ -3313,7 +3313,7 @@ doSmallPtrArrayBoundsCheck
 doSmallPtrArrayBoundsCheck idx arr = do
     profile <- getProfile
     platform <- getPlatform
-    let sz = CmmLoad (cmmOffset platform arr sz_off) (bWord platform)
+    let sz = CmmLoad (cmmOffsetB platform arr sz_off) (bWord platform)
         sz_off = fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)
     doBoundsCheck idx sz
 
@@ -3326,7 +3326,7 @@ doByteArrayBoundsCheck
 doByteArrayBoundsCheck idx arr idx_ty elem_ty = do
     profile <- getProfile
     platform <- getPlatform
-    let sz = CmmLoad (cmmOffset platform arr sz_off) (bWord platform)
+    let sz = CmmLoad (cmmOffsetB platform arr sz_off) (bWord platform)
         sz_off = fixedHdrSize profile + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)
         elem_sz = widthInBytes $ typeWidth elem_ty
         idx_sz = widthInBytes $ typeWidth idx_ty
diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsCompareByteArray.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsCompareByteArray.hs
new file mode 100644
index 0000000000..e20dcc1647
--- /dev/null
+++ b/testsuite/tests/codeGen/should_fail/CheckBoundsCompareByteArray.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE NondecreasingIndentation  #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import GHC.Exts
+import GHC.IO
+
+main :: IO ()
+main = do
+    IO $ \s0 ->
+      case newByteArray# 4# s0 of
+        (# s1, a_marr #) -> case newByteArray# 4# s1 of
+          (# s2, b_marr #) -> case unsafeFreezeByteArray# a_marr s2 of
+            (# s3, a_arr #) -> case unsafeFreezeByteArray# b_marr s2 of
+              (# s4, b_arr #) -> case compareByteArrays# a_arr 0# b_arr 1# 4# of
+                0# -> (# s4, () #)
+
diff --git a/testsuite/tests/codeGen/should_fail/all.T b/testsuite/tests/codeGen/should_fail/all.T
index 01a4802d09..e23fa03f82 100644
--- a/testsuite/tests/codeGen/should_fail/all.T
+++ b/testsuite/tests/codeGen/should_fail/all.T
@@ -15,4 +15,5 @@ check_bounds_test('CheckBoundsIndexArray')
 check_bounds_test('CheckBoundsReadInt8Array')
 check_bounds_test('CheckBoundsReadWord8ArrayAsInt32')
 check_bounds_test('CheckBoundsCopyByteArray')
+check_bounds_test('CheckBoundsCompareByteArray')