[Git][ghc/ghc][wip/9.4.6-backports] 7 commits: StgToCmm: Upgrade -fcheck-prim-bounds behavior
Zubin (@wz1000)
gitlab at gitlab.haskell.org
Thu Aug 3 16:55:32 UTC 2023
Zubin pushed to branch wip/9.4.6-backports at Glasgow Haskell Compiler / GHC
Commits:
937479db by Matthew Craven at 2023-08-03T22:24:59+05:30
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.
(cherry picked from commit 65a442fccd081d9370ae4ee4e74f116139b5c2c8)
- - - - -
fe93bd91 by Ben Gamari at 2023-08-03T22:24:59+05:30
hadrian: Ensure that way-flags are passed to CC
Previously the way-specific compilation flags (e.g. `-DDEBUG`,
`-DTHREADED_RTS`) would not be passed to the CC invocations. This meant
that C dependency files would not correctly reflect
dependencies predicated on the way, resulting in the rather
painful #23554.
Closes #23554.
(cherry picked from commit cca74dab6809f8cf7ffc2ec9df689e06aa425110)
- - - - -
9cb3519c by Ben Gamari at 2023-08-03T22:24:59+05:30
codeGen: Ensure that array reads have necessary barriers
This was the cause of #23541.
(cherry picked from commit 453c0531f2edf49b75c73bc45944600d8d7bf767)
- - - - -
2ca3c80a by Ben Gamari at 2023-08-03T22:24:59+05:30
codeGen: Ensure that TSAN is aware of writeArray# write barriers
By using a proper release store instead of a fence.
(cherry picked from commit aca20a5d4fde1c6429c887624bb95c9b54b7af73)
- - - - -
683fa79a by Ben Gamari at 2023-08-03T22:24:59+05:30
rts/win32: Ensure reliability of IO manager shutdown
When the Win32 threaded IO manager shuts down, `ioManagerDie` sends an
`IO_MANAGER_DIE` event to the IO manager thread using the
`io_manager_event` event object. Finally, it will closes the event object,
and invalidate `io_manager_event`.
Previously, `readIOManagerEvent` would see that `io_manager_event` is
invalid and return `0`, suggesting that everything is right with the
world. This meant that if `ioManagerDie` invalidated the handle before
the event manager was blocked on the event we would end up in a
situation where the event manager would never realize it was asked to
shut down.
Fix this by ensuring that `readIOManagerEvent` instead returns
`IO_MANAGER_DIE` when we detect that the event object has been
invalidated by `ioManagerDie`.
Fixes #23691.
(cherry picked from commit 6448f0c0b42e482ae514088c1c15ad6110be231f)
- - - - -
9bd6502a by Ben Gamari at 2023-08-03T22:24:59+05:30
linker/PEi386: Don't sign-extend symbol section number
Previously we incorrectly interpreted PE section numbers as signed
values. However, this isn't the case; rather, it's an unsigned 16-bit number
with a few special bit-patterns (0xffff and 0xfffe). This resulted in #22941
as the linker would conclude that the sections were invalid.
Fixing this required quite a bit of refactoring.
Closes #22941.
(cherry picked from commit 9a284cd594715d9c6a4d7f43548215f1663691fa)
- - - - -
73da339e by Zubin Duggal at 2023-08-03T22:24:59+05:30
Bump submodule: process 1.6.17.0 (#23760)
- - - - -
22 changed files:
- compiler/GHC/Cmm/CLabel.hs
- compiler/GHC/StgToCmm/Foreign.hs
- compiler/GHC/StgToCmm/Prim.hs
- hadrian/src/Settings/Builders/Common.hs
- hadrian/src/Settings/Builders/Ghc.hs
- hadrian/src/Settings/Packages.hs
- libraries/process
- rts/RtsMessages.c
- rts/linker/PEi386.c
- rts/linker/PEi386.h
- rts/win32/ThrIOManager.c
- + testsuite/tests/codeGen/should_fail/CheckBoundsCompareByteArray2.hs
- + testsuite/tests/codeGen/should_fail/CheckBoundsCompareByteArray3.hs
- + testsuite/tests/codeGen/should_fail/CheckBoundsReadInt64Array.hs
- + testsuite/tests/codeGen/should_fail/CheckBoundsReadSmallArray.hs
- + testsuite/tests/codeGen/should_fail/CheckBoundsReadWord64Array.hs
- + testsuite/tests/codeGen/should_fail/CheckBoundsReadWord8ArrayAsWord32.hs
- + testsuite/tests/codeGen/should_fail/CheckOverlapCopyAddrToByteArray.hs
- + testsuite/tests/codeGen/should_fail/CheckOverlapCopyByteArray.hs
- testsuite/tests/codeGen/should_fail/all.T
- + testsuite/tests/codeGen/should_run/CheckBoundsOK.hs
- testsuite/tests/codeGen/should_run/all.T
Changes:
=====================================
compiler/GHC/Cmm/CLabel.hs
=====================================
@@ -65,6 +65,7 @@ module GHC.Cmm.CLabel (
mkSMAP_DIRTY_infoLabel,
mkBadAlignmentLabel,
mkOutOfBoundsAccessLabel,
+ mkMemcpyRangeOverlapLabel,
mkArrWords_infoLabel,
mkSRTInfoLabel,
@@ -643,7 +644,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
@@ -661,7 +663,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
=====================================
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 ()
=====================================
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
@@ -2069,7 +2064,7 @@ doIndexOffAddrOp :: Maybe MachOp
-> [CmmExpr]
-> FCode ()
doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]
- = mkBasicIndexedRead NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx
+ = mkBasicIndexedRead False NaturallyAligned 0 maybe_post_read_cast rep res addr rep idx
doIndexOffAddrOp _ _ _ _
= panic "GHC.StgToCmm.Prim: doIndexOffAddrOp"
@@ -2081,7 +2076,7 @@ doIndexOffAddrOpAs :: Maybe MachOp
-> FCode ()
doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]
= let alignment = alignmentFromTypes rep idx_rep
- in mkBasicIndexedRead alignment 0 maybe_post_read_cast rep res addr idx_rep idx
+ in mkBasicIndexedRead False alignment 0 maybe_post_read_cast rep res addr idx_rep idx
doIndexOffAddrOpAs _ _ _ _ _
= panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs"
@@ -2093,7 +2088,7 @@ doIndexByteArrayOp :: Maybe MachOp
doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]
= do profile <- getProfile
doByteArrayBoundsCheck idx addr rep rep
- mkBasicIndexedRead NaturallyAligned (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx
+ mkBasicIndexedRead False NaturallyAligned (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx
doIndexByteArrayOp _ _ _ _
= panic "GHC.StgToCmm.Prim: doIndexByteArrayOp"
@@ -2107,7 +2102,7 @@ doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]
= do profile <- getProfile
doByteArrayBoundsCheck idx addr idx_rep rep
let alignment = alignmentFromTypes rep idx_rep
- mkBasicIndexedRead alignment (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx
+ mkBasicIndexedRead False alignment (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx
doIndexByteArrayOpAs _ _ _ _ _
= panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs"
@@ -2119,15 +2114,15 @@ doReadPtrArrayOp res addr idx
= do profile <- getProfile
platform <- getPlatform
doPtrArrayBoundsCheck idx addr
- mkBasicIndexedRead NaturallyAligned (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx
+ mkBasicIndexedRead True NaturallyAligned (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx
doWriteOffAddrOp :: Maybe MachOp
-> CmmType
-> [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 False 0 addr idx_ty idx (maybeCast castOp val)
doWriteOffAddrOp _ _ _ _
= panic "GHC.StgToCmm.Prim: doWriteOffAddrOp"
@@ -2136,11 +2131,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 False (arrWordsHdrSize profile) addr idx_ty idx val
doWriteByteArrayOp _ _ _ _
= panic "GHC.StgToCmm.Prim: doWriteByteArrayOp"
@@ -2162,8 +2158,7 @@ doWritePtrArrayOp addr idx val
-- This write barrier is to ensure that the heap writes to the object
-- 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 True 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:
@@ -2171,16 +2166,12 @@ 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
+mkBasicIndexedRead :: Bool -- Should this imply an acquire barrier
+ -> AlignmentSpec
-> ByteOff -- Initial offset in bytes
-> Maybe MachOp -- Optional result cast
-> CmmType -- Type of element we are accessing
@@ -2189,27 +2180,40 @@ mkBasicIndexedRead :: AlignmentSpec
-> CmmType -- Type of element by which we are indexing
-> CmmExpr -- Index
-> FCode ()
-mkBasicIndexedRead alignment off Nothing ty res base idx_ty idx
- = do platform <- getPlatform
- emitAssign (CmmLocal res) (cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx)
-mkBasicIndexedRead alignment off (Just cast) ty res base idx_ty idx
+mkBasicIndexedRead barrier alignment off mb_cast ty res base idx_ty idx
= do platform <- getPlatform
- emitAssign (CmmLocal res) (CmmMachOp cast [
- cmmLoadIndexOffExpr platform alignment off ty base idx_ty idx])
-
-mkBasicIndexedWrite :: ByteOff -- Initial offset in bytes
- -> Maybe MachOp -- Optional value cast
+ let addr = cmmIndexOffExpr platform off (typeWidth idx_ty) base idx
+ result <-
+ if barrier
+ then do
+ res <- newTemp ty
+ emitPrimCall [res] (MO_AtomicRead (typeWidth ty) MemOrderAcquire) [addr]
+ return $ CmmReg (CmmLocal res)
+ else
+ return $ CmmLoad addr ty alignment
+
+ let casted =
+ case mb_cast of
+ Just cast -> CmmMachOp cast [result]
+ Nothing -> result
+ emitAssign (CmmLocal res) casted
+
+mkBasicIndexedWrite :: Bool -- Should this imply a release barrier
+ -> ByteOff -- Initial offset in bytes
-> 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 barrier 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])
+ addr = cmmIndexOffExpr platform off (typeWidth idx_ty) base idx
+ if barrier
+ then let w = typeWidth idx_ty
+ op = MO_AtomicWrite w MemOrderRelease
+ in emitPrimCall [] op [addr, val]
+ else emitStore' alignment addr val
-- ----------------------------------------------------------------------------
-- Misc utils
@@ -2237,6 +2241,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.
@@ -2482,10 +2510,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
@@ -2548,7 +2575,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
@@ -2577,10 +2604,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
@@ -2598,11 +2624,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
@@ -2619,18 +2644,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
@@ -2644,8 +2671,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
@@ -2716,7 +2743,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)
@@ -2758,8 +2785,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
@@ -2778,7 +2808,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
@@ -2790,7 +2820,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)
@@ -2827,9 +2857,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
@@ -2924,7 +2956,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.
@@ -2957,7 +2989,7 @@ doReadSmallPtrArrayOp res addr idx = do
profile <- getProfile
platform <- getPlatform
doSmallPtrArrayBoundsCheck idx addr
- mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr
+ mkBasicIndexedRead True NaturallyAligned (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr
(gcWord platform) idx
doWriteSmallPtrArrayOp :: CmmExpr
@@ -2973,11 +3005,11 @@ doWriteSmallPtrArrayOp addr idx val = do
-- Update remembered set for non-moving collector
tmp <- newTemp ty
- mkBasicIndexedRead NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx
+ mkBasicIndexedRead False NaturallyAligned (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx
whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp))
- emitPrimCall [] MO_WriteBarrier [] -- #12469
- mkBasicIndexedWrite (smallArrPtrsHdrSize profile) Nothing addr ty idx val
+ -- Write barrier needed due to #12469
+ mkBasicIndexedWrite True (smallArrPtrsHdrSize profile) addr ty idx val
emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))
------------------------------------------------------------------------------
@@ -3103,6 +3135,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 at .
emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()
emitMemmoveCall dst src n align =
@@ -3197,50 +3249,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)
@@ -3248,18 +3318,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
=====================================
hadrian/src/Settings/Builders/Common.hs
=====================================
@@ -6,7 +6,8 @@ module Settings.Builders.Common (
module Settings,
module UserSettings,
cIncludeArgs, ldArgs, cArgs, cppArgs, cWarnings,
- packageDatabaseArgs, bootPackageDatabaseArgs
+ packageDatabaseArgs, bootPackageDatabaseArgs,
+ wayCcArgs,
) where
import Hadrian.Haskell.Cabal.Type
@@ -65,3 +66,11 @@ bootPackageDatabaseArgs = do
dbPath <- expr $ packageDbPath stage
expr $ need [dbPath -/- packageDbStamp]
stage0 ? packageDatabaseArgs
+
+wayCcArgs :: Args
+wayCcArgs = do
+ way <- getWay
+ mconcat [ (Threaded `wayUnit` way) ? arg "-DTHREADED_RTS"
+ , (Debug `wayUnit` way) ? arg "-DDEBUG"
+ , (way == debug || way == debugDynamic) ? arg "-DTICKY_TICKY"
+ ]
=====================================
hadrian/src/Settings/Builders/Ghc.hs
=====================================
@@ -236,11 +236,14 @@ wayGhcArgs = do
mconcat [ if Dynamic `wayUnit` way
then pure ["-fPIC", "-dynamic"]
else arg "-static"
- , (Threaded `wayUnit` way) ? arg "-optc-DTHREADED_RTS"
- , (Debug `wayUnit` way) ? arg "-optc-DDEBUG"
, (Profiling `wayUnit` way) ? arg "-prof"
- , (way == debug || way == debugDynamic) ?
- pure ["-ticky", "-DTICKY_TICKY"] ]
+ , (way == debug || way == debugDynamic) ? arg "-ticky"
+ , wayCcArgs
+ -- We must pass CPP flags via -optc as well to ensure that they
+ -- are passed to the preprocessor when, e.g., compiling Cmm
+ -- sources.
+ , map ("-optc"++) <$> wayCcArgs
+ ]
packageGhcArgs :: Args
packageGhcArgs = do
=====================================
hadrian/src/Settings/Packages.hs
=====================================
@@ -6,6 +6,7 @@ import Oracles.Setting
import Oracles.Flag
import Packages
import Settings
+import Settings.Builders.Common (wayCcArgs)
-- | Package-specific command-line arguments.
packageArgs :: Args
@@ -310,6 +311,7 @@ rtsPackageArgs = package rts ? do
let cArgs = mconcat
[ rtsWarnings
+ , wayCcArgs
, arg "-fomit-frame-pointer"
-- RTS *must* be compiled with optimisations. The INLINE_HEADER macro
-- requires that functions are inlined to work as expected. Inlining
=====================================
libraries/process
=====================================
@@ -1 +1 @@
-Subproject commit a4d1a80ec065bb52e39273faf395e515174efa3f
+Subproject commit e60ab049b92238b0111654589f17b6ee68249f01
=====================================
rts/RtsMessages.c
=====================================
@@ -338,3 +338,12 @@ rtsOutOfBoundsAccess(void)
{
barf("Encountered out of bounds array access.");
}
+
+// Used by code generator
+void rtsMemcpyRangeOverlap(void) GNUC3_ATTRIBUTE(__noreturn__);
+
+void
+rtsMemcpyRangeOverlap()
+{
+ barf("Encountered overlapping source/destination ranges in a memcpy-using op.");
+}
=====================================
rts/linker/PEi386.c
=====================================
@@ -737,8 +737,16 @@ size_t getSymbolSize ( COFF_HEADER_INFO *info )
}
}
+// Constants which may be returned by getSymSectionNumber.
+// See https://learn.microsoft.com/en-us/windows/win32/debug/pe-format#section-number-values
+#define PE_SECTION_UNDEFINED ((uint32_t) 0)
+#define PE_SECTION_ABSOLUTE ((uint32_t) -1)
+#define PE_SECTION_DEBUG ((uint32_t) -2)
+
+// Returns either PE_SECTION_{UNDEFINED,ABSOLUTE,DEBUG} or the (one-based)
+// section number of the given symbol.
__attribute__ ((always_inline)) inline
-int32_t getSymSectionNumber ( COFF_HEADER_INFO *info, COFF_symbol* sym )
+uint32_t getSymSectionNumber ( COFF_HEADER_INFO *info, COFF_symbol* sym )
{
ASSERT(info);
ASSERT(sym);
@@ -747,7 +755,16 @@ int32_t getSymSectionNumber ( COFF_HEADER_INFO *info, COFF_symbol* sym )
case COFF_ANON_BIG_OBJ:
return sym->ex.SectionNumber;
default:
- return sym->og.SectionNumber;
+ // Take care to catch reserved values; see #22941.
+ switch (sym->og.SectionNumber) {
+ case IMAGE_SYM_UNDEFINED: return PE_SECTION_UNDEFINED;
+ case IMAGE_SYM_ABSOLUTE : return PE_SECTION_ABSOLUTE;
+ case IMAGE_SYM_DEBUG: return PE_SECTION_DEBUG;
+ default:
+ // Ensure that we catch if SectionNumber is made wider in the future
+ ASSERT(sizeof(sym->og.SectionNumber) == 2);
+ return (uint16_t) sym->og.SectionNumber;
+ }
}
}
@@ -1694,7 +1711,7 @@ ocGetNames_PEi386 ( ObjectCode* oc )
StgWord globalBssSize = 0;
for (unsigned int i=0; i < info->numberOfSymbols; i++) {
COFF_symbol* sym = &oc->info->symbols[i];
- if (getSymSectionNumber (info, sym) == IMAGE_SYM_UNDEFINED
+ if (getSymSectionNumber (info, sym) == PE_SECTION_UNDEFINED
&& getSymValue (info, sym) > 0
&& getSymStorageClass (info, sym) != IMAGE_SYM_CLASS_SECTION) {
globalBssSize += getSymValue (info, sym);
@@ -1727,21 +1744,39 @@ ocGetNames_PEi386 ( ObjectCode* oc )
for (unsigned int i = 0; i < (uint32_t)oc->n_symbols; i++) {
COFF_symbol* sym = &oc->info->symbols[i];
- int32_t secNumber = getSymSectionNumber (info, sym);
uint32_t symValue = getSymValue (info, sym);
uint8_t symStorageClass = getSymStorageClass (info, sym);
-
SymbolAddr *addr = NULL;
bool isWeak = false;
SymbolName *sname = get_sym_name (getSymShortName (info, sym), oc);
- Section *section = secNumber > 0 ? &oc->sections[secNumber-1] : NULL;
+
+ uint32_t secNumber = getSymSectionNumber (info, sym);
+ Section *section;
+ switch (secNumber) {
+ case PE_SECTION_UNDEFINED:
+ // N.B. This may be a weak symbol
+ section = NULL;
+ break;
+ case PE_SECTION_ABSOLUTE:
+ IF_DEBUG(linker, debugBelch("symbol %s is ABSOLUTE, skipping...\n", sname));
+ i += getSymNumberOfAuxSymbols (info, sym);
+ continue;
+ case PE_SECTION_DEBUG:
+ IF_DEBUG(linker, debugBelch("symbol %s is DEBUG, skipping...\n", sname));
+ i += getSymNumberOfAuxSymbols (info, sym);
+ continue;
+ default:
+ CHECK(secNumber < (uint32_t) oc->n_sections);
+ section = &oc->sections[secNumber-1];
+ }
SymType type;
switch (getSymType(oc->info->ch_info, sym)) {
case 0x00: type = SYM_TYPE_DATA; break;
case 0x20: type = SYM_TYPE_CODE; break;
default:
- debugBelch("Invalid symbol type: 0x%x\n", getSymType(oc->info->ch_info, sym));
+ debugBelch("Symbol %s has invalid type 0x%x\n",
+ sname, getSymType(oc->info->ch_info, sym));
return 1;
}
@@ -1772,8 +1807,18 @@ ocGetNames_PEi386 ( ObjectCode* oc )
CHECK(symValue == 0);
COFF_symbol_aux_weak_external *aux = (COFF_symbol_aux_weak_external *) (sym+1);
COFF_symbol* targetSym = &oc->info->symbols[aux->TagIndex];
- int32_t targetSecNumber = getSymSectionNumber (info, targetSym);
- Section *targetSection = targetSecNumber > 0 ? &oc->sections[targetSecNumber-1] : NULL;
+
+ uint32_t targetSecNumber = getSymSectionNumber (info, targetSym);
+ Section *targetSection;
+ switch (targetSecNumber) {
+ case PE_SECTION_UNDEFINED:
+ case PE_SECTION_ABSOLUTE:
+ case PE_SECTION_DEBUG:
+ targetSection = NULL;
+ break;
+ default:
+ targetSection = &oc->sections[targetSecNumber-1];
+ }
addr = (SymbolAddr*) ((size_t) targetSection->start + getSymValue(info, targetSym));
}
else if ( secNumber == IMAGE_SYM_UNDEFINED && symValue > 0) {
@@ -1892,6 +1937,9 @@ ocGetNames_PEi386 ( ObjectCode* oc )
return false;
break;
+ } else if (secNumber == PE_SECTION_UNDEFINED) {
+ IF_DEBUG(linker, debugBelch("symbol %s is UNDEFINED, skipping...\n", sname));
+ i += getSymNumberOfAuxSymbols (info, sym);
}
if ((addr != NULL || isWeak)
@@ -2018,7 +2066,19 @@ ocResolve_PEi386 ( ObjectCode* oc )
debugBelch("'\n" ));
if (getSymStorageClass (info, sym) == IMAGE_SYM_CLASS_STATIC) {
- Section section = oc->sections[getSymSectionNumber (info, sym)-1];
+ uint32_t sect_n = getSymSectionNumber (info, sym);
+ switch (sect_n) {
+ case PE_SECTION_UNDEFINED:
+ case PE_SECTION_ABSOLUTE:
+ case PE_SECTION_DEBUG:
+ errorBelch(" | %" PATH_FMT ": symbol `%s' has invalid section number %02x",
+ oc->fileName, symbol, sect_n);
+ return false;
+ default:
+ break;
+ }
+ CHECK(sect_n < (uint32_t) oc->n_sections);
+ Section section = oc->sections[sect_n - 1];
S = ((size_t)(section.start))
+ ((size_t)(getSymValue (info, sym)));
} else {
=====================================
rts/linker/PEi386.h
=====================================
@@ -143,7 +143,7 @@ struct _Alignments {
COFF_OBJ_TYPE getObjectType ( char* image, pathchar* fileName );
COFF_HEADER_INFO* getHeaderInfo ( ObjectCode* oc );
size_t getSymbolSize ( COFF_HEADER_INFO *info );
-int32_t getSymSectionNumber ( COFF_HEADER_INFO *info, COFF_symbol* sym );
+uint32_t getSymSectionNumber ( COFF_HEADER_INFO *info, COFF_symbol* sym );
uint32_t getSymValue ( COFF_HEADER_INFO *info, COFF_symbol* sym );
uint8_t getSymStorageClass ( COFF_HEADER_INFO *info, COFF_symbol* sym );
uint8_t getSymNumberOfAuxSymbols ( COFF_HEADER_INFO *info, COFF_symbol* sym );
=====================================
rts/win32/ThrIOManager.c
=====================================
@@ -79,7 +79,9 @@ readIOManagerEvent (void)
}
}
} else {
- res = 0;
+ // Making it here after getIOManagerEvent has been called means that we
+ // have hit ioManagerDie, which closed our event object.
+ res = IO_MANAGER_DIE;
}
OS_RELEASE_LOCK(&event_buf_mutex);
=====================================
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, () #)
+
=====================================
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, () #)
+
=====================================
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, () #)
+
=====================================
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
+
=====================================
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, () #)
+
=====================================
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, () #)
+
=====================================
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, () #)
=====================================
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, () #)
+
=====================================
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')
=====================================
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
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -223,3 +223,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', normal, compile_and_run, ['-fcheck-prim-bounds'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a1faa21050b01b5db16413026876016e9fa3e059...73da339e4180944c21acc8de8dc5b95c4cc9e072
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a1faa21050b01b5db16413026876016e9fa3e059...73da339e4180944c21acc8de8dc5b95c4cc9e072
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230803/7625fc5e/attachment-0001.html>
More information about the ghc-commits
mailing list