codeGen: Introduce flag to bounds-check array accesses

Here we introduce code generator support for instrument array primops
with bounds checking, enabled with the `-fcheck-prim-bounds` flag.

Introduced to debug #20769.

12 files changed, 242 insertions, 1 deletions

diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index 6dd774421d..fad545f662 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -61,6 +61,7 @@ module GHC.Cmm.CLabel (
         mkSMAP_FROZEN_DIRTY_infoLabel,
         mkSMAP_DIRTY_infoLabel,
         mkBadAlignmentLabel,
+        mkOutOfBoundsAccessLabel,
         mkArrWords_infoLabel,
         mkSRTInfoLabel,
 
@@ -601,7 +602,7 @@ mkDirty_MUT_VAR_Label,
     mkCAFBlackHoleInfoTableLabel,
     mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,
     mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel,
-    mkMUT_VAR_CLEAN_infoLabel :: CLabel
+    mkOutOfBoundsAccessLabel, mkMUT_VAR_CLEAN_infoLabel :: CLabel
 mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
 mkNonmovingWriteBarrierEnabledLabel
                                 = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData
@@ -619,6 +620,7 @@ mkSMAP_FROZEN_CLEAN_infoLabel   = CmmLabel rtsUnitId (NeedExternDecl False) (fsL
 mkSMAP_FROZEN_DIRTY_infoLabel   = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
 mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
 mkBadAlignmentLabel             = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment")      CmmEntry
+mkOutOfBoundsAccessLabel        = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") Nothing ForeignLabelInExternalPackage IsFunction
 mkMUT_VAR_CLEAN_infoLabel       = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN")     CmmInfo
 
 mkSRTInfoLabel :: Int -> CLabel
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index c66cb85bfe..d0d114dba8 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -149,6 +149,7 @@ data GeneralFlag
    | Opt_DoCmmLinting
    | Opt_DoAsmLinting
    | Opt_DoAnnotationLinting
+   | Opt_DoBoundsChecking
    | Opt_NoLlvmMangler                  -- hidden flag
    | Opt_FastLlvm                       -- hidden flag
    | Opt_NoTypeableBinds
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 3af4ede9bf..044f2b3d5d 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3397,6 +3397,7 @@ fFlagsDeps = [
   flagSpec "solve-constant-dicts"             Opt_SolveConstantDicts,
   flagSpec "catch-bottoms"                    Opt_CatchBottoms,
   flagSpec "alignment-sanitisation"           Opt_AlignmentSanitisation,
+  flagSpec "check-prim-bounds"                Opt_DoBoundsChecking,
   flagSpec "num-constant-folding"             Opt_NumConstantFolding,
   flagSpec "core-constant-folding"            Opt_CoreConstantFolding,
   flagSpec "fast-pap-calls"                   Opt_FastPAPCalls,
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index c8a2ba8aad..e0af686b47 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -2128,6 +2128,7 @@ doIndexByteArrayOp :: Maybe MachOp
                    -> FCode ()
 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
 doIndexByteArrayOp _ _ _ _
    = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp"
@@ -2140,6 +2141,7 @@ doIndexByteArrayOpAs :: Maybe MachOp
                     -> FCode ()
 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
 doIndexByteArrayOpAs _ _ _ _ _
    = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs"
@@ -2151,6 +2153,7 @@ doReadPtrArrayOp :: LocalReg
 doReadPtrArrayOp res addr idx
    = do profile <- getProfile
         platform <- getPlatform
+        doPtrArrayBoundsCheck idx addr
         mkBasicIndexedRead (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx
 
 doWriteOffAddrOp :: Maybe MachOp
@@ -2170,6 +2173,8 @@ doWriteByteArrayOp :: Maybe MachOp
                    -> FCode ()
 doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]
    = do profile <- getProfile
+        platform <- getPlatform
+        doByteArrayBoundsCheck idx addr idx_ty (cmmExprType platform val)
         mkBasicIndexedWrite (arrWordsHdrSize profile) maybe_pre_write_cast addr idx_ty idx val
 doWriteByteArrayOp _ _ _ _
    = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp"
@@ -2183,6 +2188,9 @@ doWritePtrArrayOp addr idx val
        platform <- getPlatform
        let ty = cmmExprType platform val
            hdr_size = arrPtrsHdrSize profile
+
+       doPtrArrayBoundsCheck idx addr
+
        -- Update remembered set for non-moving collector
        whenUpdRemSetEnabled
            $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform hdr_size ty addr ty idx)
@@ -2191,6 +2199,7 @@ doWritePtrArrayOp addr idx val
        -- See #12469 for details.
        emitPrimCall [] MO_WriteBarrier []
        mkBasicIndexedWrite hdr_size Nothing addr ty idx val
+
        emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
        -- the write barrier.  We must write a byte into the mark table:
        -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]
@@ -2547,6 +2556,12 @@ doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr ->
 doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do
     profile <- getProfile
     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
+
     ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off
     ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off
 
@@ -2636,6 +2651,12 @@ emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr
 emitCopyByteArray copy src src_off dst dst_off n = do
     profile <- getProfile
     platform <- getPlatform
+
+    ifNonZero n $ do
+        let last_touched_idx off = cmmOffset platform (cmmAddWord platform off n) (-1)
+        doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8
+        doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8
+
     let byteArrayAlignment = wordAlignment platform
         srcOffAlignment = cmmExprAlignment src_off
         dstOffAlignment = cmmExprAlignment dst_off
@@ -2652,6 +2673,9 @@ doCopyByteArrayToAddrOp src src_off dst_p bytes = do
     -- Use memcpy (we are allowed to assume the arrays aren't overlapping)
     profile <- getProfile
     platform <- getPlatform
+    ifNonZero bytes $ do
+        let last_touched_idx off = cmmOffset 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)
 
@@ -2670,9 +2694,18 @@ doCopyAddrToByteArrayOp src_p dst dst_off bytes = do
     -- Use memcpy (we are allowed to assume the arrays aren't overlapping)
     profile <- getProfile
     platform <- getPlatform
+    ifNonZero bytes $ do
+        let last_touched_idx off = cmmOffset 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)
 
+ifNonZero :: CmmExpr -> FCode () -> FCode ()
+ifNonZero e it = do
+    platform <- getPlatform
+    let pred = cmmNeWord platform e (zeroExpr platform)
+    code <- getCode it
+    emit =<< mkCmmIfThen' pred code (Just False)
 
 -- ----------------------------------------------------------------------------
 -- Setting byte arrays
@@ -2686,6 +2719,9 @@ doSetByteArrayOp ba off len c = do
     profile <- getProfile
     platform <- getPlatform
 
+    doByteArrayBoundsCheck off ba b8 b8
+    doByteArrayBoundsCheck (cmmAddWord platform off c) ba b8 b8
+
     let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap
         offsetAlignment = cmmExprAlignment off
         align = min byteArrayAlignment offsetAlignment
@@ -2797,6 +2833,9 @@ emitCopyArray copy src0 src_off dst0 dst_off0 n =
         dst     <- assignTempE dst0
         dst_off <- assignTempE dst_off0
 
+        doPtrArrayBoundsCheck (cmmAddWord platform src_off (mkIntExpr platform n)) src
+        doPtrArrayBoundsCheck (cmmAddWord platform dst_off (mkIntExpr platform n)) dst
+
         -- Nonmoving collector write barrier
         emitCopyUpdRemSetPush platform (arrPtrsHdrSize profile) dst dst_off n
 
@@ -2863,6 +2902,10 @@ emitCopySmallArray copy src0 src_off dst0 dst_off n =
         src     <- assignTempE src0
         dst     <- assignTempE dst0
 
+        when (n /= 0) $ do
+            doSmallPtrArrayBoundsCheck (cmmAddWord platform src_off (mkIntExpr platform n)) src
+            doSmallPtrArrayBoundsCheck (cmmAddWord platform dst_off (mkIntExpr platform n)) dst
+
         -- Nonmoving collector write barrier
         emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize profile) dst dst_off n
 
@@ -2988,6 +3031,7 @@ doReadSmallPtrArrayOp :: LocalReg
 doReadSmallPtrArrayOp res addr idx = do
     profile <- getProfile
     platform <- getPlatform
+    doSmallPtrArrayBoundsCheck idx addr
     mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr
         (gcWord platform) idx
 
@@ -3000,6 +3044,8 @@ doWriteSmallPtrArrayOp addr idx val = do
     platform <- getPlatform
     let ty = cmmExprType platform val
 
+    doSmallPtrArrayBoundsCheck idx addr
+
     -- Update remembered set for non-moving collector
     tmp <- newTemp ty
     mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx
@@ -3026,6 +3072,7 @@ doAtomicByteArrayRMW
 doAtomicByteArrayRMW res amop mba idx idx_ty n = do
     profile <- getProfile
     platform <- getPlatform
+    doByteArrayBoundsCheck idx mba idx_ty idx_ty
     let width = typeWidth idx_ty
         addr  = cmmIndexOffExpr platform (arrWordsHdrSize profile)
                 width mba idx
@@ -3054,6 +3101,7 @@ doAtomicReadByteArray
 doAtomicReadByteArray res mba idx idx_ty = do
     profile <- getProfile
     platform <- getPlatform
+    doByteArrayBoundsCheck idx mba idx_ty idx_ty
     let width = typeWidth idx_ty
         addr  = cmmIndexOffExpr platform (arrWordsHdrSize profile)
                 width mba idx
@@ -3081,6 +3129,7 @@ doAtomicWriteByteArray
 doAtomicWriteByteArray mba idx idx_ty val = do
     profile <- getProfile
     platform <- getPlatform
+    doByteArrayBoundsCheck idx mba idx_ty idx_ty
     let width = typeWidth idx_ty
         addr  = cmmIndexOffExpr platform (arrWordsHdrSize profile)
                 width mba idx
@@ -3109,6 +3158,7 @@ doCasByteArray
 doCasByteArray res mba idx idx_ty old new = do
     profile <- getProfile
     platform <- getPlatform
+    doByteArrayBoundsCheck idx mba idx_ty idx_ty
     let width = typeWidth idx_ty
         addr = cmmIndexOffExpr platform (arrWordsHdrSize profile)
                width mba idx
@@ -3219,6 +3269,74 @@ emitCtzCall res x width =
         [ x ]
 
 ---------------------------------------------------------------------------
+-- Array bounds checking
+---------------------------------------------------------------------------
+
+doBoundsCheck :: CmmExpr  -- ^ accessed index
+              -> CmmExpr  -- ^ array size (in elements)
+              -> FCode ()
+doBoundsCheck idx sz = do
+    dflags <- getDynFlags
+    platform <- getPlatform
+    when (gopt Opt_DoBoundsChecking dflags) (doCheck platform)
+  where
+    doCheck platform = do
+        boundsCheckFailed <- getCode $ emitCCall [] (mkLblExpr mkOutOfBoundsAccessLabel) []
+        emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False)
+      where
+        uGE = cmmUGeWord platform
+        and = cmmAndWord platform
+        zero = zeroExpr platform
+        ne  = cmmNeWord platform
+        isOutOfBounds = ((idx `uGE` sz) `and` (idx `ne` zero)) `ne` zero
+
+-- We want to make sure that the array size computation is pushed into the
+-- Opt_DoBoundsChecking check to avoid regregressing compiler performance when
+-- it's disabled.
+{-# INLINE doBoundsCheck #-}
+
+doPtrArrayBoundsCheck
+    :: CmmExpr  -- ^ accessed index (in bytes)
+    -> CmmExpr  -- ^ pointer to @StgMutArrPtrs@
+    -> FCode ()
+doPtrArrayBoundsCheck idx arr = do
+    profile <- getProfile
+    platform <- getPlatform
+    let sz = CmmLoad (cmmOffset platform arr sz_off) (bWord platform)
+        sz_off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)
+    doBoundsCheck idx sz
+
+doSmallPtrArrayBoundsCheck
+    :: CmmExpr  -- ^ accessed index (in bytes)
+    -> CmmExpr  -- ^ pointer to @StgMutArrPtrs@
+    -> FCode ()
+doSmallPtrArrayBoundsCheck idx arr = do
+    profile <- getProfile
+    platform <- getPlatform
+    let sz = CmmLoad (cmmOffset platform arr sz_off) (bWord platform)
+        sz_off = fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)
+    doBoundsCheck idx sz
+
+doByteArrayBoundsCheck
+    :: CmmExpr  -- ^ accessed index (in elements)
+    -> CmmExpr  -- ^ pointer to @StgArrBytes@
+    -> CmmType  -- ^ indexing type
+    -> CmmType  -- ^ element type
+    -> FCode ()
+doByteArrayBoundsCheck idx arr idx_ty elem_ty = do
+    profile <- getProfile
+    platform <- getPlatform
+    let sz = CmmLoad (cmmOffset 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
+        -- Ensure that the last byte of the access is within the array
+        idx_bytes = cmmOffsetB platform
+          (cmmMulWord platform idx (mkIntExpr platform idx_sz))
+          (elem_sz - 1)
+    doBoundsCheck idx_bytes sz
+
+---------------------------------------------------------------------------
 -- Pushing to the update remembered set
 ---------------------------------------------------------------------------
 
diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst
index 569923ade4..77bb7f0e2c 100644
--- a/docs/users_guide/debugging.rst
+++ b/docs/users_guide/debugging.rst
@@ -999,6 +999,18 @@ Checking for consistency
     cases. This is helpful when debugging demand analysis or type checker bugs
     which can sometimes manifest as segmentation faults.
 
+.. ghc-flag:: -fcheck-prim-bounds
+    :shortdesc: Instrument array primops with bounds checks.
+    :type: dynamic
+
+    Typically primops operations like ``writeArray#`` exhibit unsafe behavior,
+    relying on the user to perform any bounds checking. This flag instructs the
+    code generator to instrument such operations with bound checking logic
+    which aborts the program when an out-of-bounds access is detected.
+
+    Note that this is only intended to be used as a debugging measure, not as
+    the primary means of catching out-of-bounds accesses.
+
 .. _checking-determinism:
 
 Checking for determinism
diff --git a/rts/RtsMessages.c b/rts/RtsMessages.c
index 33be410001..9ecd831a83 100644
--- a/rts/RtsMessages.c
+++ b/rts/RtsMessages.c
@@ -323,3 +323,12 @@ rtsBadAlignmentBarf()
 {
     barf("Encountered incorrectly aligned pointer. This can't be good.");
 }
+
+// Used by code generator
+void rtsOutOfBoundsAccess(void) GNUC3_ATTRIBUTE(__noreturn__);
+
+void
+rtsOutOfBoundsAccess()
+{
+    barf("Encountered out of bounds array access.");
+}
diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsCopyByteArray.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsCopyByteArray.hs
new file mode 100644
index 0000000000..d5e5e6b65f
--- /dev/null
+++ b/testsuite/tests/codeGen/should_fail/CheckBoundsCopyByteArray.hs
@@ -0,0 +1,20 @@
+{-# 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, src_marr #) ->
+          case newByteArray# 4# s1 of
+            (# s2, dst_marr #) ->
+              case unsafeFreezeByteArray# src_marr s2 of
+                (# s3, src_arr #) ->
+                  case copyByteArray# src_arr 0# dst_marr 1# 4# s3 of
+                    s4 -> (# s4, () #)
+
diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsIndexArray.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsIndexArray.hs
new file mode 100644
index 0000000000..12712e49cc
--- /dev/null
+++ b/testsuite/tests/codeGen/should_fail/CheckBoundsIndexArray.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import GHC.Exts
+import GHC.IO
+
+main :: IO ()
+main = do
+    IO $ \s0 ->
+      case newArray# 4# () s0 of
+        (# s1, marr #) ->
+          case unsafeFreezeArray# marr s1 of
+            (# s2, arr #) ->
+              case indexArray# arr 5# of
+                (# () #) -> (# s2, () #)
+
diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsReadInt8Array.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsReadInt8Array.hs
new file mode 100644
index 0000000000..ee0a302431
--- /dev/null
+++ b/testsuite/tests/codeGen/should_fail/CheckBoundsReadInt8Array.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import GHC.Exts
+import GHC.IO
+
+main :: IO ()
+main = do
+    IO $ \s0 ->
+      case newByteArray# 5# s0 of
+        (# s1, marr #) ->
+          case readInt8Array# marr 5# s1 of
+            (# s2, _n #) -> (# s2, () #)
+
diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsReadWord8ArrayAsInt32.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsReadWord8ArrayAsInt32.hs
new file mode 100644
index 0000000000..f756fb1f65
--- /dev/null
+++ b/testsuite/tests/codeGen/should_fail/CheckBoundsReadWord8ArrayAsInt32.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import GHC.Exts
+import GHC.IO
+
+main :: IO ()
+main = do
+    IO $ \s0 ->
+      case newByteArray# 7# s0 of
+        (# s1, marr #) ->
+          case readWord8ArrayAsInt32# marr 4# s1 of
+            (# s2, _n #) -> (# s2, () #)
+
diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsWriteArray.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsWriteArray.hs
new file mode 100644
index 0000000000..f2ec9246f8
--- /dev/null
+++ b/testsuite/tests/codeGen/should_fail/CheckBoundsWriteArray.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import GHC.Exts
+import GHC.IO
+
+main :: IO ()
+main = do
+    IO $ \s0 ->
+      case newArray# 5# () s0 of
+        (# s1, marr #) ->
+          case writeArray# marr 5# () s1 of
+            s2 -> (# s2, () #)
+
diff --git a/testsuite/tests/codeGen/should_fail/all.T b/testsuite/tests/codeGen/should_fail/all.T
index 67015e46a8..01a4802d09 100644
--- a/testsuite/tests/codeGen/should_fail/all.T
+++ b/testsuite/tests/codeGen/should_fail/all.T
@@ -4,3 +4,15 @@
 # memcpy operations
 test('T8131', [cmm_src, only_ways(llvm_ways)], compile_fail, ['-no-hs-main'])
 
+def check_bounds_test(name):
+    """ A -fcheck-prim-bounds test that is expected to fail. """
+    test(name,
+         [ignore_stderr, exit_code(3 if opsys('mingw32') else 134)],
+         compile_and_run, ['-fcheck-prim-bounds'])
+
+check_bounds_test('CheckBoundsWriteArray')
+check_bounds_test('CheckBoundsIndexArray')
+check_bounds_test('CheckBoundsReadInt8Array')
+check_bounds_test('CheckBoundsReadWord8ArrayAsInt32')
+check_bounds_test('CheckBoundsCopyByteArray')
+