diff options
| author | Ben Gamari <bgamari.foss@gmail.com> | 2017-07-03 19:09:03 -0400 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2017-07-03 19:42:21 -0400 |
| commit | a6f3d1b00e9c37a56cd4db9e519309e94a65d181 (patch) | |
| tree | b2133ecde8fef1e90649a667b20946fde4a62d8a | |
| parent | ef63ff27251a20ff11e58c9303677fa31e609a88 (diff) | |
| download | haskell-a6f3d1b00e9c37a56cd4db9e519309e94a65d181.tar.gz | |
rts: Fix isByteArrayPinned#'s treatment of large arrays
It should respond with True to both BF_PINNED and BF_LARGE byte arrays.
However, previously it would only check the BF_PINNED flag.
Test Plan: Validate
Reviewers: simonmar, austin, erikd
Subscribers: winterland1989, rwbarton, thomie
GHC Trac Issues: #13894
Differential Revision: https://phabricator.haskell.org/D3685
| -rw-r--r-- | rts/PrimOps.cmm | 5 | ||||
| -rw-r--r-- | testsuite/tests/rts/T13894.hs | 18 | ||||
| -rw-r--r-- | testsuite/tests/rts/all.T | 1 |
3 files changed, 22 insertions, 2 deletions
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index dddba396c3..006c9de8c8 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -147,10 +147,11 @@ stg_isByteArrayPinnedzh ( gcptr ba ) { W_ bd, flags; bd = Bdescr(ba); - // pinned byte arrays live in blocks with the BF_PINNED flag set. + // Pinned byte arrays live in blocks with the BF_PINNED flag set. + // We also consider BF_LARGE objects to be unmoveable. See #13894. // See the comment in Storage.c:allocatePinned. flags = TO_W_(bdescr_flags(bd)); - return (flags & BF_PINNED != 0); + return (flags & (BF_PINNED | BF_LARGE) != 0); } stg_isMutableByteArrayPinnedzh ( gcptr mba ) diff --git a/testsuite/tests/rts/T13894.hs b/testsuite/tests/rts/T13894.hs new file mode 100644 index 0000000000..e09e90802c --- /dev/null +++ b/testsuite/tests/rts/T13894.hs @@ -0,0 +1,18 @@ +-- Test that isByteArray# returns True for large but not explicitly pinned byte +-- arrays + +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +import Control.Monad +import GHC.Exts +import GHC.IO + +main :: IO () +main = do + pinned <- IO $ \s0 -> + case newByteArray# 1000000# s0 of + (# s1, arr# #) -> + case isMutableByteArrayPinned# arr# of + n# -> (# s1, isTrue# n# #) + unless pinned $ putStrLn "BAD" diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T index e02f880d7c..e81940479e 100644 --- a/testsuite/tests/rts/all.T +++ b/testsuite/tests/rts/all.T @@ -377,3 +377,4 @@ test('T12497', [ unless(opsys('mingw32'), skip) test('T12903', [when(opsys('mingw32'), skip)], compile_and_run, ['']) test('T13832', exit_code(1), compile_and_run, ['-threaded']) +test('T13894', normal, compile_and_run, ['']) |