testsuite: Add test for #21390

6 files changed, 44 insertions, 0 deletions

diff --git a/testsuite/tests/ghci/T21390/GetTy.hs b/testsuite/tests/ghci/T21390/GetTy.hs
new file mode 100644
index 0000000000..e52fbd95f5
--- /dev/null
+++ b/testsuite/tests/ghci/T21390/GetTy.hs
@@ -0,0 +1,9 @@
+{-# OPTIONS_GHC -fobject-code #-}
+
+module GetTy (getTy) where
+
+import Lib
+
+getTy :: Ty -> Int
+getTy (Ty (Just n)) = n
+getTy (Ty Nothing) = error "uh oh"
diff --git a/testsuite/tests/ghci/T21390/Lib.hs b/testsuite/tests/ghci/T21390/Lib.hs
new file mode 100644
index 0000000000..5969de3c55
--- /dev/null
+++ b/testsuite/tests/ghci/T21390/Lib.hs
@@ -0,0 +1,7 @@
+{-# OPTIONS_GHC -O0 -fobject-code #-}
+
+module Lib (Ty(..)) where
+
+-- We need to ensure that this *isn't* unpacked.
+data Ty = Ty {-# NOUNPACK #-} !(Maybe Int)
+
diff --git a/testsuite/tests/ghci/T21390/T21390.script b/testsuite/tests/ghci/T21390/T21390.script
new file mode 100644
index 0000000000..2d84180c54
--- /dev/null
+++ b/testsuite/tests/ghci/T21390/T21390.script
@@ -0,0 +1,4 @@
+:load Test.hs GetTy.hs
+import GetTy
+import Test
+getTy (mkTy 1)
diff --git a/testsuite/tests/ghci/T21390/T21390.stdout b/testsuite/tests/ghci/T21390/T21390.stdout
new file mode 100644
index 0000000000..9a7456b54d
--- /dev/null
+++ b/testsuite/tests/ghci/T21390/T21390.stdout
@@ -0,0 +1,2 @@
+2
+
diff --git a/testsuite/tests/ghci/T21390/Test.hs b/testsuite/tests/ghci/T21390/Test.hs
new file mode 100644
index 0000000000..692eac1555
--- /dev/null
+++ b/testsuite/tests/ghci/T21390/Test.hs
@@ -0,0 +1,8 @@
+module Test (mkTy) where
+
+import Lib
+
+-- The bytecode interpreter will fail to tag the Just correctly here.
+mkTy :: Int -> Ty
+mkTy n = Ty (Just (n+1))
+
diff --git a/testsuite/tests/ghci/T21390/all.T b/testsuite/tests/ghci/T21390/all.T
new file mode 100644
index 0000000000..9f62cc8715
--- /dev/null
+++ b/testsuite/tests/ghci/T21390/all.T
@@ -0,0 +1,14 @@
+# This tests #21390, where data constructors constructed by the interpreter
+# would contain untagged values in strict fields.
+#
+# The test is structured as follows:
+#
+#  * `Lib.hs` defines a type defining `Ty`, a type with a strict Maybe field;
+#    this should be compiled to object code
+#  * `GetTy.hs` defines a function, `getTy`, which scrutinizes a `Ty` value and
+#    its field. This too should be compiled to object code.
+#  * `Test.hs` defines `mkTy` which constructs a `Ty`. This should be
+#    interpreted.
+
+test('T21390', extra_files(['Lib.hs', 'Test.hs', 'GetTy.hs']), ghci_script, ['T21390.script'])
+