StgToCmm: Upgrade -fcheck-prim-bounds behaviorwip/fcheck-prim-bounds-9.6

Fixes #21054. Additionally, we can now check for range overlap
when generating Cmm for primops that use memcpy internally.

15 files changed, 568 insertions, 106 deletions

diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index c492e8e7c1..e1e69a6296 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -65,6 +65,7 @@ module GHC.Cmm.CLabel (
         mkSMAP_DIRTY_infoLabel,
         mkBadAlignmentLabel,
         mkOutOfBoundsAccessLabel,
+        mkMemcpyRangeOverlapLabel,
         mkArrWords_infoLabel,
         mkSRTInfoLabel,
 
@@ -649,7 +650,8 @@ mkDirty_MUT_VAR_Label,
     mkCAFBlackHoleInfoTableLabel,
     mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,
     mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel,
-    mkOutOfBoundsAccessLabel, mkMUT_VAR_CLEAN_infoLabel :: CLabel
+    mkOutOfBoundsAccessLabel, mkMemcpyRangeOverlapLabel,
+    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
@@ -667,7 +669,8 @@ 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
+mkOutOfBoundsAccessLabel        = mkForeignLabel (fsLit "rtsOutOfBoundsAccess")  Nothing ForeignLabelInExternalPackage IsFunction
+mkMemcpyRangeOverlapLabel       = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") 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/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs
index 95b7d1c5fd..4e225c1fd5 100644
--- a/compiler/GHC/StgToCmm/Foreign.hs
+++ b/compiler/GHC/StgToCmm/Foreign.hs
@@ -8,7 +8,9 @@
 
 module GHC.StgToCmm.Foreign (
   cgForeignCall,
-  emitPrimCall, emitCCall,
+  emitPrimCall,
+  emitCCall,
+  emitCCallNeverReturns,
   emitForeignCall,
   emitSaveThreadState,
   saveThreadState,
@@ -194,17 +196,31 @@ continuation, resulting in just one proc point instead of two. Yay!
 -}
 
 
-emitCCall :: [(CmmFormal,ForeignHint)]
-          -> CmmExpr
-          -> [(CmmActual,ForeignHint)]
-          -> FCode ()
-emitCCall hinted_results fn hinted_args
+emitCCall' :: CmmReturnInfo
+           -> [(CmmFormal,ForeignHint)]
+           -> CmmExpr
+           -> [(CmmActual,ForeignHint)]
+           -> FCode ()
+emitCCall' ret_info hinted_results fn hinted_args
   = void $ emitForeignCall PlayRisky results target args
   where
     (args, arg_hints) = unzip hinted_args
     (results, result_hints) = unzip hinted_results
     target = ForeignTarget fn fc
-    fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn
+    fc = ForeignConvention CCallConv arg_hints result_hints ret_info
+
+emitCCall :: [(CmmFormal,ForeignHint)]
+          -> CmmExpr
+          -> [(CmmActual,ForeignHint)]
+          -> FCode ()
+emitCCall = emitCCall' CmmMayReturn
+
+emitCCallNeverReturns
+  :: [(CmmFormal,ForeignHint)]
+  -> CmmExpr
+  -> [(CmmActual,ForeignHint)]
+  -> FCode ()
+emitCCallNeverReturns = emitCCall' CmmNeverReturns
 
 
 emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs
index e17a937a9e..a02154fb81 100644
--- a/compiler/GHC/StgToCmm/Prim.hs
+++ b/compiler/GHC/StgToCmm/Prim.hs
@@ -311,7 +311,7 @@ emitPrimOp cfg primop =
 --  #define sizzeofByteArrayzh(r,a) \
 --     r = ((StgArrBytes *)(a))->bytes
   SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->
-    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform))
+    emitAssign (CmmLocal res) (byteArraySize platform profile arg)
 
 --  #define sizzeofMutableByteArrayzh(r,a) \
 --      r = ((StgArrBytes *)(a))->bytes
@@ -320,7 +320,7 @@ emitPrimOp cfg primop =
 --  #define getSizzeofMutableByteArrayzh(r,a) \
 --      r = ((StgArrBytes *)(a))->bytes
   GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->
-    emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform))
+    emitAssign (CmmLocal res) (byteArraySize platform profile arg)
 
 
 --  #define touchzh(o)                  /* nothing */
@@ -394,15 +394,10 @@ emitPrimOp cfg primop =
 -- Getting the size of pointer arrays
 
   SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] ->
-    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg
-      (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)))
-        (bWord platform))
+    emitAssign (CmmLocal res) (ptrArraySize platform profile arg)
   SizeofMutableArrayOp      -> emitPrimOp cfg SizeofArrayOp
   SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] ->
-    emit $ mkAssign (CmmLocal res)
-     (cmmLoadIndexW platform arg
-     (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)))
-        (bWord platform))
+    emitAssign (CmmLocal res) (smallPtrArraySize platform profile arg)
 
   SizeofSmallMutableArrayOp    -> emitPrimOp cfg SizeofSmallArrayOp
   GetSizeofSmallMutableArrayOp -> emitPrimOp cfg SizeofSmallArrayOp
@@ -2097,8 +2092,8 @@ doWriteOffAddrOp :: Maybe MachOp
                  -> [LocalReg]
                  -> [CmmExpr]
                  -> FCode ()
-doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]
-   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val
+doWriteOffAddrOp castOp idx_ty [] [addr,idx, val]
+   = mkBasicIndexedWrite 0 addr idx_ty idx (maybeCast castOp val)
 doWriteOffAddrOp _ _ _ _
    = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp"
 
@@ -2107,11 +2102,12 @@ doWriteByteArrayOp :: Maybe MachOp
                    -> [LocalReg]
                    -> [CmmExpr]
                    -> FCode ()
-doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]
+doWriteByteArrayOp castOp idx_ty [] [addr,idx, rawVal]
    = do profile <- getProfile
         platform <- getPlatform
+        let val = maybeCast castOp rawVal
         doByteArrayBoundsCheck idx addr idx_ty (cmmExprType platform val)
-        mkBasicIndexedWrite (arrWordsHdrSize profile) maybe_pre_write_cast addr idx_ty idx val
+        mkBasicIndexedWrite (arrWordsHdrSize profile) addr idx_ty idx val
 doWriteByteArrayOp _ _ _ _
    = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp"
 
@@ -2134,7 +2130,7 @@ doWritePtrArrayOp addr idx val
        -- referred to by val have happened before we write val into the array.
        -- See #12469 for details.
        emitPrimCall [] MO_WriteBarrier []
-       mkBasicIndexedWrite hdr_size Nothing addr ty idx val
+       mkBasicIndexedWrite hdr_size addr ty idx val
 
        emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))
        -- the write barrier.  We must write a byte into the mark table:
@@ -2142,15 +2138,10 @@ doWritePtrArrayOp addr idx val
        emit $ mkStore (
          cmmOffsetExpr platform
           (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size)
-                         (loadArrPtrsSize profile addr))
+                         (ptrArraySize platform profile addr))
           (CmmMachOp (mo_wordUShr platform) [idx, mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))])
          ) (CmmLit (CmmInt 1 W8))
 
-loadArrPtrsSize :: Profile -> CmmExpr -> CmmExpr
-loadArrPtrsSize profile addr = cmmLoadBWord platform (cmmOffsetB platform addr off)
- where off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (profileConstants profile)
-       platform = profilePlatform profile
-
 mkBasicIndexedRead :: AlignmentSpec
                    -> ByteOff      -- Initial offset in bytes
                    -> Maybe MachOp -- Optional result cast
@@ -2169,18 +2160,15 @@ mkBasicIndexedRead alignment off (Just cast) ty res base idx_ty idx
                                    cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx])
 
 mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes
-                    -> Maybe MachOp -- Optional value cast
                     -> CmmExpr      -- Base address
                     -> CmmType      -- Type of element by which we are indexing
                     -> CmmExpr      -- Index
                     -> CmmExpr      -- Value to write
                     -> FCode ()
-mkBasicIndexedWrite off Nothing base idx_ty idx val
+mkBasicIndexedWrite off base idx_ty idx val
    = do platform <- getPlatform
         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])
 
 -- ----------------------------------------------------------------------------
 -- Misc utils
@@ -2208,6 +2196,30 @@ cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx
 setInfo :: CmmExpr -> CmmExpr -> CmmAGraph
 setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr
 
+maybeCast :: Maybe MachOp -> CmmExpr -> CmmExpr
+maybeCast Nothing val = val
+maybeCast (Just cast) val = CmmMachOp cast [val]
+
+ptrArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr
+ptrArraySize platform profile arr =
+  cmmLoadBWord platform (cmmOffsetB platform arr sz_off)
+  where sz_off = fixedHdrSize profile
+               + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)
+
+smallPtrArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr
+smallPtrArraySize platform profile arr =
+  cmmLoadBWord platform (cmmOffsetB platform arr sz_off)
+  where sz_off = fixedHdrSize profile
+               + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)
+
+byteArraySize :: Platform -> Profile -> CmmExpr -> CmmExpr
+byteArraySize platform profile arr =
+  cmmLoadBWord platform (cmmOffsetB platform arr sz_off)
+  where sz_off = fixedHdrSize profile
+               + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)
+
+
+
 ------------------------------------------------------------------------------
 -- Helpers for translating vector primops.
 
@@ -2453,10 +2465,9 @@ doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do
     profile <- getProfile
     platform <- getPlatform
 
-    ifNonZero n $ do
-        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
+    whenCheckBounds $ ifNonZero n $ do
+        emitRangeBoundsCheck ba1_off n (byteArraySize platform profile ba1)
+        emitRangeBoundsCheck ba2_off n (byteArraySize platform profile ba2)
 
     ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off
     ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off
@@ -2519,7 +2530,7 @@ doCopyByteArrayOp = emitCopyByteArray copy
     -- Copy data (we assume the arrays aren't overlapping since
     -- they're of different types)
     copy _src _dst dst_p src_p bytes align =
-        emitMemcpyCall dst_p src_p bytes align
+        emitCheckedMemcpyCall dst_p src_p bytes align
 
 -- | Takes a source 'MutableByteArray#', an offset in the source
 -- array, a destination 'MutableByteArray#', an offset into the
@@ -2548,10 +2559,9 @@ emitCopyByteArray copy src src_off dst dst_off n = do
     profile <- getProfile
     platform <- getPlatform
 
-    ifNonZero n $ do
-        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
+    whenCheckBounds $ ifNonZero n $ do
+        emitRangeBoundsCheck src_off n (byteArraySize platform profile src)
+        emitRangeBoundsCheck dst_off n (byteArraySize platform profile dst)
 
     let byteArrayAlignment = wordAlignment platform
         srcOffAlignment = cmmExprAlignment src_off
@@ -2569,11 +2579,10 @@ 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 = cmmOffsetB platform (cmmAddWord platform off bytes) (-1)
-        doByteArrayBoundsCheck (last_touched_idx src_off) src b8 b8
+    whenCheckBounds $ ifNonZero bytes $ do
+        emitRangeBoundsCheck src_off bytes (byteArraySize platform profile src)
     src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off
-    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)
+    emitCheckedMemcpyCall dst_p src_p bytes (mkAlignment 1)
 
 -- | Takes a source 'MutableByteArray#', an offset in the source array, a
 -- destination 'Addr#', and the number of bytes to copy.  Copies the given
@@ -2590,18 +2599,20 @@ 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 = cmmOffsetB platform (cmmAddWord platform off bytes) (-1)
-        doByteArrayBoundsCheck (last_touched_idx dst_off) dst b8 b8
+    whenCheckBounds $ ifNonZero bytes $ do
+        emitRangeBoundsCheck dst_off bytes (byteArraySize platform profile dst)
     dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off
-    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)
+    emitCheckedMemcpyCall 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)
+    emit =<< mkCmmIfThen' pred code (Just True)
+      -- This function is used for range operation bounds-checks;
+      -- Most calls to those ops will not have range length zero.
+
 
 -- ----------------------------------------------------------------------------
 -- Setting byte arrays
@@ -2615,8 +2626,8 @@ doSetByteArrayOp ba off len c = do
     profile <- getProfile
     platform <- getPlatform
 
-    doByteArrayBoundsCheck off ba b8 b8
-    doByteArrayBoundsCheck (cmmOffset platform (cmmAddWord platform off len) (-1)) ba b8 b8
+    whenCheckBounds $ ifNonZero len $
+      emitRangeBoundsCheck off len (byteArraySize platform profile ba)
 
     let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap
         offsetAlignment = cmmExprAlignment off
@@ -2687,7 +2698,7 @@ doCopyArrayOp = emitCopyArray copy
     -- they're of different types)
     copy _src _dst dst_p src_p bytes =
         do platform <- getPlatform
-           emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)
+           emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes)
                (wordAlignment platform)
 
 
@@ -2729,8 +2740,11 @@ 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
+        whenCheckBounds $ do
+          emitRangeBoundsCheck src_off (mkIntExpr platform n)
+                                       (ptrArraySize platform profile src)
+          emitRangeBoundsCheck dst_off (mkIntExpr platform n)
+                                       (ptrArraySize platform profile dst)
 
         -- Nonmoving collector write barrier
         emitCopyUpdRemSetPush platform (arrPtrsHdrSize profile) dst dst_off n
@@ -2749,7 +2763,7 @@ emitCopyArray copy src0 src_off dst0 dst_off0 n =
 
         -- The base address of the destination card table
         dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p
-                       (loadArrPtrsSize profile dst)
+                       (ptrArraySize platform profile dst)
 
         emitSetCards dst_off dst_cards_p n
 
@@ -2761,7 +2775,7 @@ doCopySmallArrayOp = emitCopySmallArray copy
     -- they're of different types)
     copy _src _dst dst_p src_p bytes =
         do platform <- getPlatform
-           emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)
+           emitCheckedMemcpyCall dst_p src_p (mkIntExpr platform bytes)
                (wordAlignment platform)
 
 
@@ -2798,9 +2812,11 @@ 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
+        whenCheckBounds $ do
+          emitRangeBoundsCheck src_off (mkIntExpr platform n)
+                                       (smallPtrArraySize platform profile src)
+          emitRangeBoundsCheck dst_off (mkIntExpr platform n)
+                                       (smallPtrArraySize platform profile dst)
 
         -- Nonmoving collector write barrier
         emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize profile) dst dst_off n
@@ -2895,7 +2911,7 @@ emitCloneSmallArray info_p res_r src src_off n = do
 
     emit $ mkAssign (CmmLocal res_r) (CmmReg arr)
 
--- | Takes and offset in the destination array, the base address of
+-- | Takes an offset in the destination array, the base address of
 -- the card table, and the number of elements affected (*not* the
 -- number of cards). The number of elements may not be zero.
 -- Marks the relevant cards as dirty.
@@ -2948,7 +2964,7 @@ doWriteSmallPtrArrayOp addr idx val = do
     whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp))
 
     emitPrimCall [] MO_WriteBarrier [] -- #12469
-    mkBasicIndexedWrite (smallArrPtrsHdrSize profile) Nothing addr ty idx val
+    mkBasicIndexedWrite (smallArrPtrsHdrSize profile) addr ty idx val
     emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))
 
 ------------------------------------------------------------------------------
@@ -3074,6 +3090,26 @@ emitMemcpyCall dst src n align =
         (MO_Memcpy (alignmentBytes align))
         [ dst, src, n ]
 
+-- | Emit a call to @memcpy@, but check for range
+-- overlap when -fcheck-prim-bounds is on.
+emitCheckedMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()
+emitCheckedMemcpyCall dst src n align = do
+    whenCheckBounds (getPlatform >>= doCheck)
+    emitMemcpyCall dst src n align
+  where
+    doCheck platform = do
+        overlapCheckFailed <- getCode $
+          emitCCallNeverReturns [] (mkLblExpr mkMemcpyRangeOverlapLabel) []
+        emit =<< mkCmmIfThen' rangesOverlap overlapCheckFailed (Just False)
+      where
+        rangesOverlap = (checkDiff dst src `or` checkDiff src dst) `ne` zero
+        checkDiff p q = (p `minus` q) `uLT` n
+        or = cmmOrWord platform
+        minus = cmmSubWord platform
+        uLT  = cmmULtWord platform
+        ne   = cmmNeWord platform
+        zero = zeroExpr platform
+
 -- | Emit a call to @memmove@.
 emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()
 emitMemmoveCall dst src n align =
@@ -3168,50 +3204,68 @@ emitCtzCall res x width =
 -- Array bounds checking
 ---------------------------------------------------------------------------
 
-doBoundsCheck :: CmmExpr  -- ^ accessed index
-              -> CmmExpr  -- ^ array size (in elements)
-              -> FCode ()
-doBoundsCheck idx sz = do
-    do_bounds_check <- stgToCmmDoBoundsCheck <$> getStgToCmmConfig
-    platform        <- getPlatform
-    when do_bounds_check (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
+whenCheckBounds :: FCode () -> FCode ()
+whenCheckBounds a = do
+  config <- getStgToCmmConfig
+  case stgToCmmDoBoundsCheck config of
+    False -> pure ()
+    True  -> a
 
--- 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 #-}
+emitBoundsCheck :: CmmExpr  -- ^ accessed index
+                -> CmmExpr  -- ^ array size (in elements)
+                -> FCode ()
+emitBoundsCheck idx sz = do
+    assertM (stgToCmmDoBoundsCheck <$> getStgToCmmConfig)
+    platform <- getPlatform
+    boundsCheckFailed <- getCode $
+      emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) []
+    let isOutOfBounds = cmmUGeWord platform idx sz
+    emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False)
+
+emitRangeBoundsCheck :: CmmExpr  -- ^ first accessed index
+                     -> CmmExpr  -- ^ number of accessed indices (non-zero)
+                     -> CmmExpr  -- ^ array size (in elements)
+                     -> FCode ()
+emitRangeBoundsCheck idx len arrSizeExpr = do
+    assertM (stgToCmmDoBoundsCheck <$> getStgToCmmConfig)
+    config <- getStgToCmmConfig
+    platform <- getPlatform
+    arrSize <- assignTempE arrSizeExpr
+    -- arrSizeExpr is probably a load we don't want to duplicate
+    rangeTooLargeReg <- newTemp (bWord platform)
+    lastSafeIndexReg <- newTemp (bWord platform)
+    _ <- withSequel (AssignTo [lastSafeIndexReg, rangeTooLargeReg] False) $
+      cmmPrimOpApp config WordSubCOp [arrSize, len] Nothing
+    boundsCheckFailed <- getCode $
+      emitCCallNeverReturns [] (mkLblExpr mkOutOfBoundsAccessLabel) []
+    let
+      rangeTooLarge = CmmReg (CmmLocal rangeTooLargeReg)
+      lastSafeIndex = CmmReg (CmmLocal lastSafeIndexReg)
+      badStartIndex = (idx `uGT` lastSafeIndex)
+      isOutOfBounds = (rangeTooLarge `or` badStartIndex) `neq` zero
+      uGT = cmmUGtWord platform
+      or = cmmOrWord platform
+      neq = cmmNeWord platform
+      zero = zeroExpr platform
+    emit =<< mkCmmIfThen' isOutOfBounds boundsCheckFailed (Just False)
 
 doPtrArrayBoundsCheck
     :: CmmExpr  -- ^ accessed index (in bytes)
     -> CmmExpr  -- ^ pointer to @StgMutArrPtrs@
     -> FCode ()
-doPtrArrayBoundsCheck idx arr = do
+doPtrArrayBoundsCheck idx arr = whenCheckBounds $ do
     profile <- getProfile
     platform <- getPlatform
-    let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off)
-        sz_off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)
-    doBoundsCheck idx sz
+    emitBoundsCheck idx (ptrArraySize platform profile arr)
 
 doSmallPtrArrayBoundsCheck
     :: CmmExpr  -- ^ accessed index (in bytes)
     -> CmmExpr  -- ^ pointer to @StgMutArrPtrs@
     -> FCode ()
-doSmallPtrArrayBoundsCheck idx arr = do
+doSmallPtrArrayBoundsCheck idx arr = whenCheckBounds $ do
     profile <- getProfile
     platform <- getPlatform
-    let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off)
-        sz_off = fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)
-    doBoundsCheck idx sz
+    emitBoundsCheck idx (smallPtrArraySize platform profile arr)
 
 doByteArrayBoundsCheck
     :: CmmExpr  -- ^ accessed index (in elements)
@@ -3219,18 +3273,18 @@ doByteArrayBoundsCheck
     -> CmmType  -- ^ indexing type
     -> CmmType  -- ^ element type
     -> FCode ()
-doByteArrayBoundsCheck idx arr idx_ty elem_ty = do
+doByteArrayBoundsCheck idx arr idx_ty elem_ty = whenCheckBounds $ do
     profile <- getProfile
     platform <- getPlatform
-    let sz = cmmLoadBWord platform (cmmOffset platform arr sz_off)
-        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
+    let elem_w = typeWidth elem_ty
+        idx_w = typeWidth idx_ty
+        elem_sz = mkIntExpr platform $ widthInBytes elem_w
+        arr_sz = byteArraySize platform profile arr
+        effective_arr_sz =
+          cmmUShrWord platform arr_sz (mkIntExpr platform (widthInLog idx_w))
+    if elem_w == idx_w
+      then emitBoundsCheck idx effective_arr_sz  -- aligned => simpler check
+      else assert (idx_w == W8) (emitRangeBoundsCheck idx elem_sz arr_sz)
 
 ---------------------------------------------------------------------------
 -- Pushing to the update remembered set
diff --git a/rts/RtsMessages.c b/rts/RtsMessages.c
index 2a92c8d228..507d007484 100644
--- a/rts/RtsMessages.c
+++ b/rts/RtsMessages.c
@@ -338,3 +338,12 @@ rtsOutOfBoundsAccess()
 {
     barf("Encountered out of bounds array access.");
 }
+
+// Used by code generator
+void rtsMemcpyRangeOverlap(void) STG_NORETURN;
+
+void
+rtsMemcpyRangeOverlap()
+{
+    barf("Encountered overlapping source/destination ranges in a memcpy-using op.");
+}
diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsCompareByteArray2.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsCompareByteArray2.hs
new file mode 100644
index 0000000000..768948c7d8
--- /dev/null
+++ b/testsuite/tests/codeGen/should_fail/CheckBoundsCompareByteArray2.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 (-1#) b_arr 0# 4# of
+                0# -> (# s4, () #)
+
diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsCompareByteArray3.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsCompareByteArray3.hs
new file mode 100644
index 0000000000..8a7dcd3123
--- /dev/null
+++ b/testsuite/tests/codeGen/should_fail/CheckBoundsCompareByteArray3.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 2# b_arr 3# (-1#) of
+                0# -> (# s4, () #)
+
diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsReadInt64Array.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsReadInt64Array.hs
new file mode 100644
index 0000000000..1e08b4e84d
--- /dev/null
+++ b/testsuite/tests/codeGen/should_fail/CheckBoundsReadInt64Array.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# 23# s0 of
+        (# s1, marr #) ->
+          case readInt64Array# marr 2# s1 of
+            (# s2, _n #) -> (# s2, () #)
+
diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsReadSmallArray.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsReadSmallArray.hs
new file mode 100644
index 0000000000..c9d8261f21
--- /dev/null
+++ b/testsuite/tests/codeGen/should_fail/CheckBoundsReadSmallArray.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import GHC.Exts
+import GHC.IO
+
+main :: IO ()
+main = do
+    IO $ \s0 ->
+      case newSmallArray# 5# () s0 of
+        (# s1, marr #) -> readSmallArray# marr (-1#) s1
+
diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsReadWord64Array.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsReadWord64Array.hs
new file mode 100644
index 0000000000..f5337d26c3
--- /dev/null
+++ b/testsuite/tests/codeGen/should_fail/CheckBoundsReadWord64Array.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# 23# s0 of
+        (# s1, marr #) ->
+          case readWord64Array# marr (-1#) s1 of
+            (# s2, _n #) -> (# s2, () #)
+
diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsReadWord8ArrayAsWord32.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsReadWord8ArrayAsWord32.hs
new file mode 100644
index 0000000000..4bade0a101
--- /dev/null
+++ b/testsuite/tests/codeGen/should_fail/CheckBoundsReadWord8ArrayAsWord32.hs
@@ -0,0 +1,17 @@
+{-# 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 readWord8ArrayAsWord32# marr (-3#) s1 of
+            -- only the last byte of the desired word32 is in bounds
+            (# s2, _n #) -> (# s2, () #)
+
diff --git a/testsuite/tests/codeGen/should_fail/CheckOverlapCopyAddrToByteArray.hs b/testsuite/tests/codeGen/should_fail/CheckOverlapCopyAddrToByteArray.hs
new file mode 100644
index 0000000000..7da97ef234
--- /dev/null
+++ b/testsuite/tests/codeGen/should_fail/CheckOverlapCopyAddrToByteArray.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import GHC.Exts
+import GHC.IO
+
+main :: IO ()
+main = do
+    IO $ \s0 ->
+      case newPinnedByteArray# 7# s0 of
+        (# s1, marr #) -> case mutableByteArrayContents# marr of
+          ptr -> (# copyAddrToByteArray# ptr marr 3# 4# s1, () #)
diff --git a/testsuite/tests/codeGen/should_fail/CheckOverlapCopyByteArray.hs b/testsuite/tests/codeGen/should_fail/CheckOverlapCopyByteArray.hs
new file mode 100644
index 0000000000..a6fdcb2dc4
--- /dev/null
+++ b/testsuite/tests/codeGen/should_fail/CheckOverlapCopyByteArray.hs
@@ -0,0 +1,15 @@
+{-# 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 unsafeFreezeByteArray# marr s1 of
+          (# s2, arr #) -> (# copyByteArray# arr 3# marr 0# 4# s2, () #)
+
diff --git a/testsuite/tests/codeGen/should_fail/all.T b/testsuite/tests/codeGen/should_fail/all.T
index 3f2dacee46..60e863663a 100644
--- a/testsuite/tests/codeGen/should_fail/all.T
+++ b/testsuite/tests/codeGen/should_fail/all.T
@@ -10,10 +10,18 @@ def check_bounds_test(name):
          [ignore_stderr, exit_code(127 if opsys('mingw32') else 134)],
          compile_and_run, ['-fcheck-prim-bounds'])
 
-check_bounds_test('CheckBoundsWriteArray')
-check_bounds_test('CheckBoundsIndexArray')
+check_bounds_test('CheckBoundsWriteArray') # Check past end
+check_bounds_test('CheckBoundsIndexArray') # Check past end
+check_bounds_test('CheckBoundsReadSmallArray') # Check before start
 check_bounds_test('CheckBoundsReadInt8Array')
-check_bounds_test('CheckBoundsReadWord8ArrayAsInt32')
+check_bounds_test('CheckBoundsReadInt64Array')  # read past end
+check_bounds_test('CheckBoundsReadWord64Array') # read before start
+check_bounds_test('CheckBoundsReadWord8ArrayAsInt32')  # Check last byte
+check_bounds_test('CheckBoundsReadWord8ArrayAsWord32') # Check first byte
 check_bounds_test('CheckBoundsCopyByteArray')
-check_bounds_test('CheckBoundsCompareByteArray')
+check_bounds_test('CheckBoundsCompareByteArray')  # Check last byte, 2nd array
+check_bounds_test('CheckBoundsCompareByteArray2') # Check first byte, 1st array
+check_bounds_test('CheckBoundsCompareByteArray3') # Check negative length
+check_bounds_test('CheckOverlapCopyByteArray')
+check_bounds_test('CheckOverlapCopyAddrToByteArray')
 
diff --git a/testsuite/tests/codeGen/should_run/CheckBoundsOK.hs b/testsuite/tests/codeGen/should_run/CheckBoundsOK.hs
new file mode 100644
index 0000000000..096566f60e
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/CheckBoundsOK.hs
@@ -0,0 +1,241 @@
+-- This test verifies that correct (not out-of-bounds) uses
+-- of primops that we can bounds-check with -fcheck-prim-bounds
+-- do not cause spurious bounds-checking failures.
+
+-- Currently this tests most ByteArray#, Array#, and SmallArray# operations.
+-- (Theoretically it could also test Addr# operations,
+-- since those /can/ be bounds-checked with the JS back-end.)
+
+{-# LANGUAGE CPP #-}
+
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+module Main where
+
+import Data.Array.Byte
+import Data.Bits
+import Control.Monad
+import GHC.Exts
+import GHC.IO
+import GHC.Word
+import GHC.Int
+import GHC.Float
+import GHC.Stable
+import System.IO
+
+#define TEST_READ_WRITE(CONDITION, READ_OP, INDEX_OP, WRITE_OP) \
+  when (CONDITION) $ IO $ \s0 -> \
+    case (READ_OP) arrU# i# s0 of \
+      (# s1, v# #) -> case (WRITE_OP) arrP# i# v# s1 of \
+        s2 -> (# (WRITE_OP) arrU# i# ((INDEX_OP) arrF# i#) s2, () #)
+
+#define ALIGNED_RW(WIDTH, READ_OP, INDEX_OP, WRITE_OP) \
+  TEST_READ_WRITE(i < size `div` (WIDTH), READ_OP, INDEX_OP, WRITE_OP)
+
+#define UNALIGNED_RW(WIDTH, READ_OP, INDEX_OP, WRITE_OP) \
+  TEST_READ_WRITE(i + (WIDTH) <= size, READ_OP, INDEX_OP, WRITE_OP)
+
+#define TEST_CAS(WIDTH, CON, CAS_OP) \
+  when (i < size `div` (WIDTH)) $ IO $ \s0 -> \
+    case (0, 7) of \
+      (CON v0, CON v7) -> case (CAS_OP) arrU# i# v0 v7 s0 of \
+        (# s1, v' #) -> (# s1, () #)
+
+
+wrapEffect :: (State# RealWorld -> State# RealWorld) -> IO ()
+wrapEffect eff = IO (\s0 -> (# eff s0, () #))
+
+
+testByteArraysOfSize :: Int -> IO ()
+testByteArraysOfSize (size@(I# size#)) = do
+  let mkArr op = IO $ \s0 -> case op size# s0 of
+        (# s1, newArr #)
+          -> (# setByteArray# newArr 0# size# 123# s1,
+                MutableByteArray newArr #)
+  MutableByteArray arrU# <- mkArr newByteArray#
+  MutableByteArray arrP# <- mkArr newPinnedByteArray#
+  ByteArray arrF# <- do
+    MutableByteArray arrToFreeze <- mkArr newByteArray#
+    IO $ \s0 -> case unsafeFreezeByteArray# arrToFreeze s0 of
+      (# s1, frozenArr #) -> (# s1, ByteArray frozenArr #)
+  let !nws = finiteBitSize (0 :: Int) `div` 8
+      !bufP = mutableByteArrayContents# arrP#
+
+
+  forM_ [0..size] $ \i@(I# i#) -> do
+    -- test valid aligned read/write ops
+    -- (expressed via CPP macro because of non-uniform representations)
+    ALIGNED_RW(1, readWord8Array#, indexWord8Array#, writeWord8Array#)
+    ALIGNED_RW(2, readWord16Array#, indexWord16Array#, writeWord16Array#)
+    ALIGNED_RW(4, readWord32Array#, indexWord32Array#, writeWord32Array#)
+    ALIGNED_RW(8, readWord64Array#, indexWord64Array#, writeWord64Array#)
+    ALIGNED_RW(nws, readWordArray#, indexWordArray#, writeWordArray#)
+
+    ALIGNED_RW(1, readInt8Array#, indexInt8Array#, writeInt8Array#)
+    ALIGNED_RW(2, readInt16Array#, indexInt16Array#, writeInt16Array#)
+    ALIGNED_RW(4, readInt32Array#, indexInt32Array#, writeInt32Array#)
+    ALIGNED_RW(8, readInt64Array#, indexInt64Array#, writeInt64Array#)
+    ALIGNED_RW(nws, readIntArray#, indexIntArray#, writeIntArray#)
+
+    ALIGNED_RW(4, readFloatArray#, indexFloatArray#, writeFloatArray#)
+    ALIGNED_RW(8, readDoubleArray#, indexDoubleArray#, writeDoubleArray#)
+
+    ALIGNED_RW(1, readCharArray#, indexCharArray#, writeCharArray#)
+    ALIGNED_RW(4, readWideCharArray#, indexWideCharArray#, writeWideCharArray#)
+
+    -- TODO: What is the right condition is for Addr# with the JS backend?
+    ALIGNED_RW(nws, readAddrArray#, indexAddrArray#, writeAddrArray#)
+    ALIGNED_RW(nws, readStablePtrArray#, indexStablePtrArray#, writeStablePtrArray#)
+
+
+    -- test valid unaligned read/write ops
+    -- (expressed via CPP macro because of non-uniform representations)
+    -- no primops for unaligned word8 access
+    UNALIGNED_RW(2, readWord8ArrayAsWord16#, indexWord8ArrayAsWord16#, writeWord8ArrayAsWord16#)
+    UNALIGNED_RW(4, readWord8ArrayAsWord32#, indexWord8ArrayAsWord32#, writeWord8ArrayAsWord32#)
+    UNALIGNED_RW(8, readWord8ArrayAsWord64#, indexWord8ArrayAsWord64#, writeWord8ArrayAsWord64#)
+    UNALIGNED_RW(nws, readWord8ArrayAsWord#, indexWord8ArrayAsWord#, writeWord8ArrayAsWord#)
+
+    -- no primops for unaligned int8 access
+    UNALIGNED_RW(2, readWord8ArrayAsInt16#, indexWord8ArrayAsInt16#, writeWord8ArrayAsInt16#)
+    UNALIGNED_RW(4, readWord8ArrayAsInt32#, indexWord8ArrayAsInt32#, writeWord8ArrayAsInt32#)
+    UNALIGNED_RW(8, readWord8ArrayAsInt64#, indexWord8ArrayAsInt64#, writeWord8ArrayAsInt64#)
+    UNALIGNED_RW(nws, readWord8ArrayAsInt#, indexWord8ArrayAsInt#, writeWord8ArrayAsInt#)
+
+    UNALIGNED_RW(4, readWord8ArrayAsFloat#, indexWord8ArrayAsFloat#, writeWord8ArrayAsFloat#)
+    UNALIGNED_RW(8, readWord8ArrayAsDouble#, indexWord8ArrayAsDouble#, writeWord8ArrayAsDouble#)
+
+    UNALIGNED_RW(1, readWord8ArrayAsChar#, indexWord8ArrayAsChar#, writeWord8ArrayAsChar#)
+    UNALIGNED_RW(4, readWord8ArrayAsWideChar#, indexWord8ArrayAsWideChar#, writeWord8ArrayAsWideChar#)
+
+    -- TODO: What is the right condition is for Addr# with the JS backend?
+    UNALIGNED_RW(nws, readWord8ArrayAsAddr#, indexWord8ArrayAsAddr#, writeWord8ArrayAsAddr#)
+    UNALIGNED_RW(nws, readWord8ArrayAsStablePtr#, indexWord8ArrayAsStablePtr#, writeWord8ArrayAsStablePtr#)
+
+
+    when (i < size `div` nws) $ do
+      let testFetchModify :: (MutableByteArray# RealWorld -> Int# -> Int#
+                          -> State# RealWorld -> (# State# RealWorld, Int# #))
+                          -> IO ()
+          testFetchModify op
+            = IO (\s -> case op arrU# i# 137# s of (# s', _ #) -> (# s', () #) )
+      testFetchModify fetchXorIntArray#
+      testFetchModify fetchOrIntArray#
+      testFetchModify fetchNandIntArray#
+      testFetchModify fetchAndIntArray#
+      testFetchModify fetchSubIntArray#
+      testFetchModify fetchAddIntArray#
+
+      IO $ \s0 -> case atomicReadIntArray# arrU# i# s0 of
+        (# s1, v #) -> (# atomicWriteIntArray# arrP# i# v s1, () #)
+
+
+    TEST_CAS(8, I64#, casInt64Array#)
+    TEST_CAS(4, I32#, casInt32Array#)
+    TEST_CAS(2, I16#, casInt16Array#)
+    TEST_CAS(1, I8# , casInt8Array#)
+    TEST_CAS(nws, I#, casIntArray#)
+
+
+  -- test valid range ops
+  forM_ [0..size] $ \rangeLen@(I# rangeLen#) -> do
+    let ixs | rangeLen == 0 = [-4 .. size + 4] -- empty ranges are not out-of-bounds
+            | otherwise     = [0 .. size - rangeLen]
+    forM_ ixs $ \i@(I# i#) -> do
+      wrapEffect (setByteArray# arrU# i# rangeLen# 234#)
+      forM_ ixs $ \j@(I# j#) -> do
+        wrapEffect (copyByteArray# arrF# i# arrU# j# rangeLen#)
+        wrapEffect (copyMutableByteArray# arrU# i# arrP# j# rangeLen#)
+        wrapEffect (copyMutableByteArray# arrU# i# arrU# j# rangeLen#)
+        case compareByteArrays# arrF# i# arrF# j# rangeLen# of
+          v -> wrapEffect (setByteArray# arrP# j# rangeLen# (v `andI#` 255#))
+        let !rangeP = bufP `plusAddr#` j#
+        wrapEffect (copyAddrToByteArray# rangeP arrU# i# rangeLen#)
+        wrapEffect (copyMutableByteArrayToAddr# arrU# i# rangeP rangeLen#)
+        wrapEffect (copyByteArrayToAddr# arrF# i# rangeP rangeLen#)
+
+
+
+data Array a = Array (Array# a)
+data MutableArray s a = MutableArray (MutableArray# s a)
+data SmallArray a = SmallArray (SmallArray# a)
+data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a)
+
+
+testArraysOfSize :: Int -> IO ()
+testArraysOfSize (size@(I# size#)) = do
+  let mkArr v = IO $ \s0 -> case newArray# size# v s0 of
+        (# s1, newArr #) -> (# s1, MutableArray newArr #)
+  MutableArray arrM# <- mkArr 0
+  Array arrF# <- do
+    MutableArray arrToFreeze <- mkArr 0
+    forM_ [0 .. size - 1] $ \(i@(I# i#)) -> do
+      wrapEffect (writeArray# arrM# i# i)
+      wrapEffect (writeArray# arrToFreeze i# i)
+
+    IO $ \s0 -> case unsafeFreezeArray# arrToFreeze s0 of
+      (# s1, frozenArr #) -> (# s1, Array frozenArr #)
+
+  forM_ [0 .. size - 1] $ \(i@(I# i#)) -> do
+
+    -- test read/index/write
+    IO $ \s0 -> case readArray# arrM# i# s0 of
+      (# s1, vm #) -> case indexArray# arrF# i# of
+        (# vf #) -> (# writeArray# arrM# i# (vm + vf) s1, () #)
+
+    -- test casArray
+    IO $ \s0 -> case casArray# arrM# i# 0 7 s0 of
+      (# s1, _, _ #) -> (# s1, () #)
+
+  -- test valid range ops
+  forM_ [0..size] $ \rangeLen@(I# rangeLen#) -> do
+    let ixs | rangeLen == 0 = [-4 .. size + 4] -- empty ranges are not out-of-bounds
+            | otherwise     = [0 .. size - rangeLen]
+    forM_ ixs $ \(i@(I# i#)) -> do
+      forM_ ixs $ \(j@(I# j#)) -> do
+        wrapEffect (copyArray# arrF# i# arrM# j# rangeLen#)
+        wrapEffect (copyMutableArray# arrM# i# arrM# j# rangeLen#)
+
+
+testSmallArraysOfSize :: Int -> IO ()
+testSmallArraysOfSize (size@(I# size#)) = do
+  let mkArr v = IO $ \s0 -> case newSmallArray# size# v s0 of
+        (# s1, newArr #) -> (# s1, SmallMutableArray newArr #)
+  SmallMutableArray arrM# <- mkArr 0
+  SmallArray arrF# <- do
+    SmallMutableArray arrToFreeze <- mkArr 0
+    forM_ [0 .. size - 1] $ \(i@(I# i#)) -> do
+      wrapEffect (writeSmallArray# arrM# i# i)
+      wrapEffect (writeSmallArray# arrToFreeze i# i)
+
+    IO $ \s0 -> case unsafeFreezeSmallArray# arrToFreeze s0 of
+      (# s1, frozenArr #) -> (# s1, SmallArray frozenArr #)
+
+  forM_ [0 .. size - 1] $ \(i@(I# i#)) -> do
+
+    -- test read/index/write
+    IO $ \s0 -> case readSmallArray# arrM# i# s0 of
+      (# s1, vm #) -> case indexSmallArray# arrF# i# of
+        (# vf #) -> (# writeSmallArray# arrM# i# (vm + vf) s1, () #)
+
+    -- test casSmallArray
+    IO $ \s0 -> case casSmallArray# arrM# i# 0 7 s0 of
+      (# s1, _, _ #) -> (# s1, () #)
+
+  -- test valid range ops
+  forM_ [0..size] $ \rangeLen@(I# rangeLen#) -> do
+    let ixs | rangeLen == 0 = [-4 .. size + 4] -- empty ranges are not out-of-bounds
+            | otherwise     = [0 .. size - rangeLen]
+    forM_ ixs $ \(i@(I# i#)) -> do
+      forM_ ixs $ \(j@(I# j#)) -> do
+        wrapEffect (copySmallArray# arrF# i# arrM# j# rangeLen#)
+        wrapEffect (copySmallMutableArray# arrM# i# arrM# j# rangeLen#)
+
+
+main :: IO ()
+main = forM_ ([0..4] ++ [24..32]) $ \size -> do
+  testByteArraysOfSize size
+  testArraysOfSize size
+  testSmallArraysOfSize size
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index 74f2586fd0..04e765dccb 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -229,3 +229,4 @@ test('T20640b', normal, compile_and_run, [''])
 test('T22296',[only_ways(llvm_ways)
               ,unless(arch('x86_64'), skip)],compile_and_run,[''])
 test('T22798', normal, compile_and_run, ['-fregs-graph'])
+test('CheckBoundsOK', js_broken(23123), compile_and_run, ['-fcheck-prim-bounds'])