From 5ff47ff5bb815e18e03fab42ffae7d735ea70976 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Tue, 7 Dec 2021 08:47:16 -0500
Subject: 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.
---
 .../codeGen/should_fail/CheckBoundsCopyByteArray.hs  | 20 ++++++++++++++++++++
 .../codeGen/should_fail/CheckBoundsIndexArray.hs     | 18 ++++++++++++++++++
 .../codeGen/should_fail/CheckBoundsReadInt8Array.hs  | 16 ++++++++++++++++
 .../should_fail/CheckBoundsReadWord8ArrayAsInt32.hs  | 16 ++++++++++++++++
 .../codeGen/should_fail/CheckBoundsWriteArray.hs     | 16 ++++++++++++++++
 testsuite/tests/codeGen/should_fail/all.T            | 12 ++++++++++++
 6 files changed, 98 insertions(+)
 create mode 100644 testsuite/tests/codeGen/should_fail/CheckBoundsCopyByteArray.hs
 create mode 100644 testsuite/tests/codeGen/should_fail/CheckBoundsIndexArray.hs
 create mode 100644 testsuite/tests/codeGen/should_fail/CheckBoundsReadInt8Array.hs
 create mode 100644 testsuite/tests/codeGen/should_fail/CheckBoundsReadWord8ArrayAsInt32.hs
 create mode 100644 testsuite/tests/codeGen/should_fail/CheckBoundsWriteArray.hs

(limited to 'testsuite/tests/codeGen')

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')
+
-- 
cgit v1.2.1