diff options
author | Ben Gamari <ben@smart-cactus.org> | 2021-12-07 08:47:16 -0500 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-12-21 01:46:00 -0500 |
commit | 5ff47ff5bb815e18e03fab42ffae7d735ea70976 (patch) | |
tree | a866f6b824ff746bc3837cfb5b74d0636ace6ae7 /testsuite/tests | |
parent | 887d8b4c409c06257a63751e4e84c86ddf5cc874 (diff) | |
download | haskell-5ff47ff5bb815e18e03fab42ffae7d735ea70976.tar.gz |
codeGen: Introduce flag to bounds-check array accesses
Here we introduce code generator support for instrument array primops
with bounds checking, enabled with the `-fcheck-prim-bounds` flag.
Introduced to debug #20769.
Diffstat (limited to 'testsuite/tests')
6 files changed, 98 insertions, 0 deletions
diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsCopyByteArray.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsCopyByteArray.hs new file mode 100644 index 0000000000..d5e5e6b65f --- /dev/null +++ b/testsuite/tests/codeGen/should_fail/CheckBoundsCopyByteArray.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import GHC.Exts +import GHC.IO + +main :: IO () +main = do + IO $ \s0 -> + case newByteArray# 4# s0 of + (# s1, src_marr #) -> + case newByteArray# 4# s1 of + (# s2, dst_marr #) -> + case unsafeFreezeByteArray# src_marr s2 of + (# s3, src_arr #) -> + case copyByteArray# src_arr 0# dst_marr 1# 4# s3 of + s4 -> (# s4, () #) + diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsIndexArray.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsIndexArray.hs new file mode 100644 index 0000000000..12712e49cc --- /dev/null +++ b/testsuite/tests/codeGen/should_fail/CheckBoundsIndexArray.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import GHC.Exts +import GHC.IO + +main :: IO () +main = do + IO $ \s0 -> + case newArray# 4# () s0 of + (# s1, marr #) -> + case unsafeFreezeArray# marr s1 of + (# s2, arr #) -> + case indexArray# arr 5# of + (# () #) -> (# s2, () #) + diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsReadInt8Array.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsReadInt8Array.hs new file mode 100644 index 0000000000..ee0a302431 --- /dev/null +++ b/testsuite/tests/codeGen/should_fail/CheckBoundsReadInt8Array.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import GHC.Exts +import GHC.IO + +main :: IO () +main = do + IO $ \s0 -> + case newByteArray# 5# s0 of + (# s1, marr #) -> + case readInt8Array# marr 5# s1 of + (# s2, _n #) -> (# s2, () #) + diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsReadWord8ArrayAsInt32.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsReadWord8ArrayAsInt32.hs new file mode 100644 index 0000000000..f756fb1f65 --- /dev/null +++ b/testsuite/tests/codeGen/should_fail/CheckBoundsReadWord8ArrayAsInt32.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import GHC.Exts +import GHC.IO + +main :: IO () +main = do + IO $ \s0 -> + case newByteArray# 7# s0 of + (# s1, marr #) -> + case readWord8ArrayAsInt32# marr 4# s1 of + (# s2, _n #) -> (# s2, () #) + diff --git a/testsuite/tests/codeGen/should_fail/CheckBoundsWriteArray.hs b/testsuite/tests/codeGen/should_fail/CheckBoundsWriteArray.hs new file mode 100644 index 0000000000..f2ec9246f8 --- /dev/null +++ b/testsuite/tests/codeGen/should_fail/CheckBoundsWriteArray.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} + +module Main where + +import GHC.Exts +import GHC.IO + +main :: IO () +main = do + IO $ \s0 -> + case newArray# 5# () s0 of + (# s1, marr #) -> + case writeArray# marr 5# () s1 of + s2 -> (# s2, () #) + diff --git a/testsuite/tests/codeGen/should_fail/all.T b/testsuite/tests/codeGen/should_fail/all.T index 67015e46a8..01a4802d09 100644 --- a/testsuite/tests/codeGen/should_fail/all.T +++ b/testsuite/tests/codeGen/should_fail/all.T @@ -4,3 +4,15 @@ # memcpy operations test('T8131', [cmm_src, only_ways(llvm_ways)], compile_fail, ['-no-hs-main']) +def check_bounds_test(name): + """ A -fcheck-prim-bounds test that is expected to fail. """ + test(name, + [ignore_stderr, exit_code(3 if opsys('mingw32') else 134)], + compile_and_run, ['-fcheck-prim-bounds']) + +check_bounds_test('CheckBoundsWriteArray') +check_bounds_test('CheckBoundsIndexArray') +check_bounds_test('CheckBoundsReadInt8Array') +check_bounds_test('CheckBoundsReadWord8ArrayAsInt32') +check_bounds_test('CheckBoundsCopyByteArray') + |