From 65a442fccd081d9370ae4ee4e74f116139b5c2c8 Mon Sep 17 00:00:00 2001 From: Matthew Craven <5086-clyring@users.noreply.gitlab.haskell.org> Date: Tue, 14 Mar 2023 22:13:38 -0400 Subject: StgToCmm: Upgrade -fcheck-prim-bounds behavior Fixes #21054. Additionally, we can now check for range overlap when generating Cmm for primops that use memcpy internally. --- compiler/GHC/Cmm/CLabel.hs | 7 +- compiler/GHC/StgToCmm/Foreign.hs | 30 ++- compiler/GHC/StgToCmm/Prim.hs | 240 ++++++++++++-------- rts/RtsMessages.c | 9 + .../should_fail/CheckBoundsCompareByteArray2.hs | 19 ++ .../should_fail/CheckBoundsCompareByteArray3.hs | 19 ++ .../should_fail/CheckBoundsReadInt64Array.hs | 16 ++ .../should_fail/CheckBoundsReadSmallArray.hs | 14 ++ .../should_fail/CheckBoundsReadWord64Array.hs | 16 ++ .../CheckBoundsReadWord8ArrayAsWord32.hs | 17 ++ .../should_fail/CheckOverlapCopyAddrToByteArray.hs | 14 ++ .../should_fail/CheckOverlapCopyByteArray.hs | 15 ++ testsuite/tests/codeGen/should_fail/all.T | 16 +- .../tests/codeGen/should_run/CheckBoundsOK.hs | 241 +++++++++++++++++++++ testsuite/tests/codeGen/should_run/all.T | 1 + 15 files changed, 568 insertions(+), 106 deletions(-) create mode 100644 testsuite/tests/codeGen/should_fail/CheckBoundsCompareByteArray2.hs create mode 100644 testsuite/tests/codeGen/should_fail/CheckBoundsCompareByteArray3.hs create mode 100644 testsuite/tests/codeGen/should_fail/CheckBoundsReadInt64Array.hs create mode 100644 testsuite/tests/codeGen/should_fail/CheckBoundsReadSmallArray.hs create mode 100644 testsuite/tests/codeGen/should_fail/CheckBoundsReadWord64Array.hs create mode 100644 testsuite/tests/codeGen/should_fail/CheckBoundsReadWord8ArrayAsWord32.hs create mode 100644 testsuite/tests/codeGen/should_fail/CheckOverlapCopyAddrToByteArray.hs create mode 100644 testsuite/tests/codeGen/should_fail/CheckOverlapCopyByteArray.hs create mode 100644 testsuite/tests/codeGen/should_run/CheckBoundsOK.hs 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']) -- cgit v1.2.1