Generate GHCi bytecode from STG instead of Core and support unboxed

tuples and sums.

fixes #1257

8 files changed, 646 insertions, 0 deletions

diff --git a/testsuite/tests/ghci/T16670/T16670_unboxed.hs b/testsuite/tests/ghci/T16670/T16670_unboxed.hs
index 2e903959bb..93816795e0 100644
--- a/testsuite/tests/ghci/T16670/T16670_unboxed.hs
+++ b/testsuite/tests/ghci/T16670/T16670_unboxed.hs
@@ -1,5 +1,13 @@
 {-# LANGUAGE UnboxedTuples #-}
+
 {-# OPTIONS_GHC -fwrite-interface #-}
+{-
+  GHCi doesn't automatically switch to object code anymore now that
+  UnboxedTuples are supported in bytecode. But we test for the
+  existence of the file.
+ -}
+{-# OPTIONS_GHC -fobject-code #-}
+
 module T16670_unboxed where
 
 data UnboxedTupleData = MkUTD (# (),() #)
diff --git a/testsuite/tests/ghci/prog014/prog014.T b/testsuite/tests/ghci/prog014/prog014.T
index d9dee7eac7..1b583e8c19 100644
--- a/testsuite/tests/ghci/prog014/prog014.T
+++ b/testsuite/tests/ghci/prog014/prog014.T
@@ -1,5 +1,6 @@
 test('prog014',
      [extra_files(['Primop.hs', 'dummy.c']),
+      expect_fail, # bytecode compiler doesn't support foreign import prim
       extra_run_opts('dummy.o'),
       pre_cmd('$MAKE -s --no-print-directory prog014')],
      ghci_script, ['prog014.script'])
diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/ByteCode.hs b/testsuite/tests/ghci/should_run/UnboxedTuples/ByteCode.hs
new file mode 100644
index 0000000000..a1bce35ad0
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/ByteCode.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE CPP, UnboxedTuples, MagicHash, ScopedTypeVariables, PolyKinds #-}
+{-# OPTIONS_GHC -fbyte-code #-}
+
+#include "MachDeps.h"
+
+#if WORD_SIZE_IN_BITS < 64
+#define WW Word64
+#else
+#define WW Word
+#endif
+
+module ByteCode where
+
+import GHC.Exts
+import GHC.Word
+
+#include "Common.hs-incl"
diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/Common.hs-incl b/testsuite/tests/ghci/should_run/UnboxedTuples/Common.hs-incl
new file mode 100644
index 0000000000..6931397f09
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/Common.hs-incl
@@ -0,0 +1,368 @@
+swap :: (# a, b #) -> (# b, a #)
+swap (# x, y #) = (# y, x #)
+
+type T1 a = a -> (# a #)
+tuple1 :: T1 a
+tuple1 x = (# x #)
+
+tuple1_a :: T1 a -> a -> a
+tuple1_a f x = case f x of (# y #) -> y
+
+tuple1_b :: T1 a -> a -> String -> IO ()
+tuple1_b f x msg = case f x of (# _ #) -> putStrLn msg
+
+-- can still be returned in registers, pointers
+type T2p a = a -> a -> a -> a -> (# a, a, a, a #)
+
+tuple2p :: T2p a
+tuple2p x1 x2 x3 x4 = (# x1, x2, x3, x4 #)
+
+tuple2p_a :: T2p a -> a -> a -> a -> a -> (a, a, a, a)
+tuple2p_a f x1 x2 x3 x4 =
+    case f x1 x2 x3 x4 of (# y1, y2, y3, y4 #) -> (y1, y2, y3, y4)
+
+-- can still be returned in registers, non-pointers
+type T2n = Int -> Int -> Int -> Int -> (# Int#, Int#, Int#, Int# #)
+
+tuple2n :: T2n
+tuple2n (I# x1) (I# x2) (I# x3) (I# x4) = (# x1, x2, x3, x4 #)
+
+tuple2n_a :: T2n -> Int -> Int -> Int -> Int -> (Int, Int, Int, Int)
+tuple2n_a f x1 x2 x3 x4 =
+    case f x1 x2 x3 x4 of
+        (# y1, y2, y3, y4 #) -> (I# y1, I# y2, I# y3, I# y4)
+
+
+-- too big to fit in registers
+type T3 a = a -> a -> a -> a
+        -> a -> a -> a -> a
+        -> a -> a -> a -> a
+        -> (# a, a, a, a
+            , a, a, a, a
+            , a, a, a, a #)
+tuple3 :: T3 a
+tuple3 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 =
+    (# x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12 #)
+
+tuple3_a :: T3 a
+        -> a -> a -> a -> a
+        -> a -> a -> a -> a
+        -> a -> a -> a -> a
+        -> ( a, a, a, a
+           , a, a, a, a
+           , a, a, a, a
+           )
+tuple3_a f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 =
+    case f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 of
+            (# y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12 #) ->
+                (y1, y2, y3, y4, y5, y6, y7, y8, y9, y10, y11, y12)
+
+type T4a = Float -> Double -> Float -> Double
+        -> (# Float#, Double#, Float#, Double# #)
+
+tuple4a :: T4a
+tuple4a (F# f1) (D# d1) (F# f2) (D# d2) = (# f1, d1, f2, d2 #)
+
+tuple4a_a :: T4a
+         -> Float -> Double -> Float -> Double
+         -> (Float, Double, Float, Double)
+tuple4a_a h f1 d1 f2 d2 =
+  case h f1 d1 f2 d2 of (# g1, e1, g2, e2 #) -> (F# g1, D# e1, F# g2, D# e2 )
+
+
+-- this should fill the floating point registers
+type T4b = Float -> Double -> Float -> Double
+       -> Float -> Double -> Float -> Double
+       -> Float -> Double -> Float -> Double
+       -> Float -> Double -> Float -> Double
+       -> Float -> Double -> Float -> Double
+       -> (# Float#, Double#, Float#, Double#
+           , Float#, Double#, Float#, Double#
+           , Float#, Double#, Float#, Double#
+           , Float#, Double#, Float#, Double#
+           , Float#, Double#, Float#, Double# #)
+tuple4b :: T4b
+tuple4b (F# f1) (D# d1) (F# f2) (D# d2)
+       (F# f3) (D# d3) (F# f4) (D# d4)
+       (F# f5) (D# d5) (F# f6) (D# d6)
+       (F# f7) (D# d7) (F# f8) (D# d8)
+       (F# f9) (D# d9) (F# f10) (D# d10) =
+    (# f1, d1, f2, d2
+     , f3, d3, f4, d4
+     , f5, d5, f6, d6
+     , f7, d7, f8, d8
+     , f9, d9, f10, d10
+     #)
+
+tuple4b_a :: T4b
+         -> Float -> Double -> Float -> Double
+         -> Float -> Double -> Float -> Double
+         -> Float -> Double -> Float -> Double
+         -> Float -> Double -> Float -> Double
+         -> Float -> Double -> Float -> Double
+         -> ( (Float, Double, Float, Double)
+            , (Float, Double, Float, Double)
+            , (Float, Double, Float, Double)
+            , (Float, Double, Float, Double)
+            , (Float, Double, Float, Double)
+            )
+tuple4b_a h f1 d1 f2 d2
+           f3 d3 f4 d4
+           f5 d5 f6 d6
+           f7 d7 f8 d8
+           f9 d9 f10 d10 =
+    case h f1 d1 f2 d2
+           f3 d3 f4 d4
+           f5 d5 f6 d6
+           f7 d7 f8 d8
+           f9 d9 f10 d10 of
+      (# g1, e1, g2, e2
+       , g3, e3, g4, e4
+       , g5, e5, g6, e6
+       , g7, e7, g8, e8
+       , g9, e9, g10, e10 #) ->
+        ( (F# g1, D# e1, F# g2, D# e2)
+        , (F# g3, D# e3, F# g4, D# e4)
+        , (F# g5, D# e5, F# g6, D# e6)
+        , (F# g7, D# e7, F# g8, D# e8)
+        , (F# g9, D# e9, F# g10, D# e10))
+
+type T4c = Float -> Double -> Word64 -> Integer
+        -> Float -> Double -> Word64 -> Integer
+        -> Float -> Double -> Word64 -> Integer
+        -> Float -> Double -> Word64 -> Integer
+        -> (# Float#, Double#, WW#, Integer
+            , Float#, Double#, WW#, Integer
+            , Float#, Double#, WW#, Integer
+            , Float#, Double#, WW#, Integer
+            #)
+tuple4c :: T4c
+tuple4c (F# f1) (D# d1) (W64# w1) i1
+        (F# f2) (D# d2) (W64# w2) i2
+        (F# f3) (D# d3) (W64# w3) i3
+        (F# f4) (D# d4) (W64# w4) i4 =
+     (# f1, d1, w1, i1
+      , f2, d2, w2, i2
+      , f3, d3, w3, i3
+      , f4, d4, w4, i4
+      #)
+
+tuple4c_a :: T4c
+          -> Float -> Double -> Word64 -> Integer
+          -> Float -> Double -> Word64 -> Integer
+          -> Float -> Double -> Word64 -> Integer
+          -> Float -> Double -> Word64 -> Integer
+          -> ( ( Float, Double, Word64, Integer)
+            , ( Float, Double, Word64, Integer)
+            , ( Float, Double, Word64, Integer)
+            ,  ( Float, Double, Word64, Integer)
+             )
+tuple4c_a h f1 d1 w1 i1
+            f2 d2 w2 i2
+            f3 d3 w3 i3
+            f4 d4 w4 i4 =
+    case h f1 d1 w1 i1
+            f2 d2 w2 i2
+            f3 d3 w3 i3
+            f4 d4 w4 i4 of
+      (# f1', d1', w1', i1'
+       , f2', d2', w2', i2'
+       , f3', d3', w3', i3'
+       , f4', d4', w4', i4' #) ->
+       ( (F# f1', D# d1', W64# w1', i1')
+       , (F# f2', D# d2', W64# w2', i2')
+       , (F# f3', D# d3', W64# w3', i3')
+       , (F# f4', D# d4', W64# w4', i4')
+       )
+
+type T5 = Int -> Word64 -> Int -> Word64
+       -> Int -> Word64 -> Int -> Word64
+       -> Int -> Word64 -> Int -> Word64
+       -> Int -> Word64 -> Int -> Word64
+       -> (# Int, WW#, Int, WW#
+           , Int, WW#, Int, WW#
+           , Int, WW#, Int, WW#
+           , Int, WW#, Int, WW#
+           #)
+
+tuple5 :: T5
+tuple5 i1 (W64# w1) i2 (W64# w2)
+       i3 (W64# w3) i4 (W64# w4)
+       i5 (W64# w5) i6 (W64# w6)
+       i7 (W64# w7) i8 (W64# w8) =
+    (# i1, w1, i2, w2
+     , i3, w3, i4, w4
+     , i5, w5, i6, w6
+     , i7, w7, i8, w8 #)
+
+tuple5_a :: T5
+         -> Int -> Word64 -> Int -> Word64
+         -> Int -> Word64 -> Int -> Word64
+         -> Int -> Word64 -> Int -> Word64
+         -> Int -> Word64 -> Int -> Word64
+         -> ( (Int, Word64, Int, Word64)
+            , (Int, Word64, Int, Word64)
+            , (Int, Word64, Int, Word64)
+            , (Int, Word64, Int, Word64)
+            )
+tuple5_a f i1 w1 i2 w2
+           i3 w3 i4 w4
+           i5 w5 i6 w6
+           i7 w7 i8 w8 =
+    case f i1 w1 i2 w2
+           i3 w3 i4 w4
+           i5 w5 i6 w6
+           i7 w7 i8 w8 of
+      (# j1, x1, j2, x2
+       , j3, x3, j4, x4
+       , j5, x5, j6, x6
+       , j7, x7, j8, x8
+       #) ->
+       ( (j1, W64# x1, j2, W64# x2)
+       , (j3, W64# x3, j4, W64# x4)
+       , (j5, W64# x5, j6, W64# x6)
+       , (j7, W64# x7, j8, W64# x8)
+       )
+
+type T6 = Int ->
+        (# Int#, (# Int, (# Int#, (# #) #) #) #)
+tuple6 :: T6
+tuple6 x@(I# x#) = (# x#, (# x, (# x#, (# #) #) #) #)
+
+tuple6_a :: T6 -> Int -> String
+tuple6_a f x =
+  case f x of
+    (# x1, (# x2, (# x3, (# #) #) #) #) -> show (I# x1, (x2, (I# x3, ())))
+
+-- empty tuples and tuples with void
+
+type TV1 = Bool -> (# #)
+
+{-# NOINLINE tuple_v1 #-}
+tuple_v1 :: TV1
+tuple_v1 _ = (# #)
+
+{-# NOINLINE tuple_v1_a #-}
+tuple_v1_a :: TV1 -> Bool -> Bool
+tuple_v1_a f x = case f x of (# #) -> True
+
+
+type TV2 = Bool -> (# (# #) #)
+
+{-# NOINLINE tuple_v2 #-}
+tuple_v2 :: TV2
+tuple_v2 _ = (# (# #) #)
+
+{-# NOINLINE tuple_v2_a #-}
+tuple_v2_a :: TV2 -> Bool -> Bool
+tuple_v2_a f x = case f x of (# _ #) -> True
+
+
+type TV3 a = a -> (# (# #), a #)
+
+{-# NOINLINE tuple_v3 #-}
+tuple_v3 :: TV3 a
+tuple_v3 x = (# (# #), x #)
+
+{-# NOINLINE tuple_v3_a #-}
+tuple_v3_a :: TV3 a -> a -> a
+tuple_v3_a f x = case f x of (# _, y #) -> y
+
+
+type TV4 a = a -> (# a, (# #) #)
+
+{-# NOINLINE tuple_v4 #-}
+tuple_v4 :: TV4 a
+tuple_v4 x = (# x, (# #) #)
+
+{-# NOINLINE tuple_v4_a #-}
+tuple_v4_a :: TV4 a -> a -> a
+tuple_v4_a f x = case f x of (# y, _ #) -> y
+
+
+type TV5 a = a -> (# (# #), a, (# #) #)
+
+{-# NOINLINE tuple_v5 #-}
+tuple_v5 :: TV5 a
+tuple_v5 x = (# (# #), x, (# #) #)
+
+{-# NOINLINE tuple_v5_a #-}
+tuple_v5_a :: TV5 a -> a -> a
+tuple_v5_a f x = case f x of (# _, x, _ #) -> x
+
+
+type TV6 = Int -> Double -> Int -> Double
+         -> (# Int#, (# #), Double#, (# #)
+            ,  Int#, (# #), Double#, (# #) #)
+
+{-# NOINLINE tuple_v6 #-}
+tuple_v6 :: TV6
+tuple_v6 (I# x) (D# y) (I# z) (D# w) = (# x, (# #), y, (# #), z, (# #), w, (# #) #)
+
+{-# NOINLINE tuple_v6_a #-}
+tuple_v6_a :: TV6 -> Int -> Double -> Int -> Double
+           -> (Int, Double, Int, Double)
+tuple_v6_a f x y z w = case f x y z w of (# x', _, y', _, z', _, w', _ #) ->
+                                           (I# x', D# y', I# z', D# w')
+
+-- some levity polymorphic things
+{-# NOINLINE lev_poly #-}
+lev_poly :: forall r a (b :: TYPE r).
+            (a -> a -> a -> a ->
+             a -> a -> a -> a ->
+             a -> a -> a -> a -> b) -> a -> b
+lev_poly f x = f x x x x x x x x x x x x
+
+{-# NOINLINE lev_poly_a #-}
+lev_poly_a :: (t1
+                -> t2 -> (# a, b, c, d, e, f, g, h, i, j, k, l #))
+            -> t1 -> t2 -> (a, b, c, d, e, f, g, h, i, j, k, l)
+lev_poly_a lp t x =
+  case lp t x of (# x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12 #) ->
+                   (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12)
+
+{-# NOINLINE lev_poly_boxed #-}
+lev_poly_boxed x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12
+  = (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12)
+
+{-# NOINLINE lev_poly_b #-}
+lev_poly_b lp t x =
+  case lp t x of (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12)
+                   -> (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12)
+
+-- some unboxed sums
+type S1 = (# (# Int#, String #) | Bool #)
+
+{-# NOINLINE sum1 #-}
+sum1 :: Int -> Int -> String -> Bool -> S1
+sum1 0 (I# x) y _ = (# (# x, y #) | #)
+sum1 _ _      _ b = (# | b #)
+
+{-# NOINLINE sum1_a #-}
+sum1_a :: (Int -> Int -> String -> Bool -> S1) -> Int -> Int -> String -> Bool -> Either (Int, String) Bool
+sum1_a f n x y b =
+  case f n x y b of
+    (# (# x, y #) | #) -> Left (I# x, y)
+    (# | b #)          -> Right b
+
+
+type S2 a = (# (# a, a, a, a #) | (# a, a #) | (# #) | Int# | Int #)
+
+{-# NOINLINE sum2 #-}
+sum2 :: Int -> a -> S2 a
+sum2 0 x = (# (# x, x, x, x #) | | | | #)
+sum2 1 x = (# | (# x, x #) | | | #)
+sum2 2 _ = (# | | (# #) | | #)
+sum2 n@(I# n#) _
+  | even n = (# | | | n# | #)
+  | otherwise = (# | | | | n #)
+
+{-# NOINLINE sum2_a #-}
+sum2_a :: Show a => (Int -> a -> S2 a) -> Int -> a -> String
+sum2_a f n x =
+  case f n x of
+    (# (# x1, x2, x3, x4 #) | | | | #) -> show (x1, x2, x3, x4)
+    (# | (# x1, x2 #) | | | #)         -> show (x1, x2)
+    (# | | (# #) | | #)                -> "(# #)"
+    (# | | | x# | #)                   -> show (I# x#) ++ "#"
+    (# | | | | x #)                    -> show x
diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/Obj.hs b/testsuite/tests/ghci/should_run/UnboxedTuples/Obj.hs
new file mode 100644
index 0000000000..190b8f1683
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/Obj.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE CPP, UnboxedTuples, MagicHash, ScopedTypeVariables, PolyKinds #-}
+{-# OPTIONS_GHC -fobject-code #-}
+
+#include "MachDeps.h"
+
+#if WORD_SIZE_IN_BITS < 64
+#define WW Word64
+#else
+#define WW Word
+#endif
+
+module Obj where
+
+import GHC.Exts
+import GHC.Word
+
+#include "Common.hs-incl"
diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.hs b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.hs
new file mode 100644
index 0000000000..1daec7f207
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.hs
@@ -0,0 +1,182 @@
+{-# LANGUAGE UnboxedTuples, MagicHash #-}
+{-# OPTIONS_GHC -fbyte-code #-}
+
+{-
+  Test unboxed tuples and sums in the bytecode interpreter.
+
+  The bytecode interpreter uses the stack for everything, while
+  compiled code uses STG registers for arguments and return values.
+ -}
+
+module Main where
+
+import qualified Obj      as O
+import qualified ByteCode as B
+
+import GHC.Exts
+import GHC.Word
+
+main :: IO ()
+main = do
+
+    case B.swap (O.swap (B.swap (O.swap (# "x", 1 #)))) of
+      (# y1, y2 #) -> print (y1, y2)
+
+    -- one-tuples
+    testX "tuple1"
+          B.tuple1_a O.tuple1_a
+          B.tuple1   O.tuple1
+          (\f -> f 90053)
+
+    -- check that the contents of a one-tuple aren't evaluated
+    B.tuple1_b B.tuple1 (error "error tuple1_b") "tuple1_b"
+    B.tuple1_b O.tuple1 (error "error tuple1_b") "tuple1_b"
+    O.tuple1_b B.tuple1 (error "error tuple1_b") "tuple1_b"
+    O.tuple1_b O.tuple1 (error "error tuple1_b") "tuple1_b"
+
+    -- various size tuples with boxed/unboxed elements
+    testX "tuple2p"
+          B.tuple2p_a O.tuple2p_a
+          B.tuple2p   O.tuple2p
+          (\f -> f (1234::Integer) 1235 1236 1237)
+
+    testX "tuple2n"
+          B.tuple2n_a O.tuple2n_a
+          B.tuple2n   O.tuple2n
+          (\f -> f 7654 7653 7652 7651)
+
+    testX "tuple3"
+          B.tuple3_a O.tuple3_a
+          B.tuple3   O.tuple3
+          (\f -> f (1000::Integer) 1001 1002 1003
+                   1004 1005 1006 1007
+                   1008 1009 1010 1011)
+
+    testX "tuple4a"
+          B.tuple4a_a O.tuple4a_a
+          B.tuple4a   O.tuple4a
+          (\f -> f 2000 2001 2002 2003)
+
+    testX "tuple4b"
+          B.tuple4b_a O.tuple4b_a
+          B.tuple4b   O.tuple4b
+          (\f -> f 3000 3001 3002 3003
+                   3004 3005 3006 3007
+                   3008 3009 3010 3011
+                   3012 3013 3014 3015
+                   3016 3017 3018 3019)
+
+    testX "tuple4c"
+          B.tuple4c_a O.tuple4c_a
+          B.tuple4c   O.tuple4c
+          (\f -> f 3000 3001 3002 3003
+                   3004 3005 3006 3007
+                   3008 3009 3010 3011
+                   3012 3013 3014 3015)
+
+    testX "tuple5"
+          B.tuple5_a O.tuple5_a
+          B.tuple5   O.tuple5
+          (\f -> f 4000 4001 4002 4003
+                   4004 4005 4006 4007
+                   4008 4009 4010 4011
+                   4012 4013 4014 4015)
+
+    testX "tuple6"
+          B.tuple6_a O.tuple6_a
+          B.tuple6   O.tuple6
+          (\f -> f 6006)
+
+    -- tuples with void and empty tuples
+    testX "tuplev1"
+          B.tuple_v1_a O.tuple_v1_a
+          B.tuple_v1   O.tuple_v1
+          (\f -> f False)
+
+    testX "tuplev2"
+          B.tuple_v2_a O.tuple_v2_a
+          B.tuple_v2   O.tuple_v2
+          (\f -> f False)
+
+    testX "tuplev3"
+          B.tuple_v3_a O.tuple_v3_a
+          B.tuple_v3   O.tuple_v3
+          (\f -> f 30001)
+
+    testX "tuplev4"
+          B.tuple_v4_a O.tuple_v4_a
+          B.tuple_v4   O.tuple_v4
+          (\f -> f 40001)
+
+    testX "tuplev5"
+          B.tuple_v5_a O.tuple_v5_a
+          B.tuple_v5   O.tuple_v5
+          (\f -> f 50001)
+
+    testX "tuplev6"
+          B.tuple_v6_a O.tuple_v6_a
+          B.tuple_v6   O.tuple_v6
+          (\f -> f 601 602 603 604)
+
+    -- levity polymorphic
+    print $ B.lev_poly_a B.lev_poly B.tuple3 991
+    print $ B.lev_poly_a B.lev_poly O.tuple3 992
+    print $ B.lev_poly_a O.lev_poly B.tuple3 993
+    print $ B.lev_poly_a O.lev_poly O.tuple3 994
+    print $ O.lev_poly_a B.lev_poly B.tuple3 995
+    print $ O.lev_poly_a B.lev_poly O.tuple3 996
+    print $ O.lev_poly_a O.lev_poly B.tuple3 997
+    print $ O.lev_poly_a O.lev_poly O.tuple3 998
+
+    print $ B.lev_poly_b B.lev_poly B.lev_poly_boxed 981
+    print $ B.lev_poly_b B.lev_poly O.lev_poly_boxed 982
+    print $ B.lev_poly_b O.lev_poly B.lev_poly_boxed 983
+    print $ B.lev_poly_b O.lev_poly O.lev_poly_boxed 984
+    print $ O.lev_poly_b B.lev_poly B.lev_poly_boxed 985
+    print $ O.lev_poly_b B.lev_poly O.lev_poly_boxed 986
+    print $ O.lev_poly_b O.lev_poly B.lev_poly_boxed 987
+    print $ O.lev_poly_b O.lev_poly O.lev_poly_boxed 988
+
+    -- sums
+    testX "sum1a"
+          B.sum1_a O.sum1_a
+          B.sum1   O.sum1
+          (\f -> f 0 1 "23" True)
+
+    testX "sum1b"
+          B.sum1_a O.sum1_a
+          B.sum1   O.sum1
+          (\f -> f 1 1 "23" True)
+
+    testX "sum2a"
+          B.sum2_a O.sum2_a
+          B.sum2   O.sum2
+          (\f -> f 0 "sum2")
+
+    testX "sum2b"
+          B.sum2_a O.sum2_a
+          B.sum2   O.sum2
+          (\f -> f 1 "sum2")
+
+    testX "sum2c"
+          B.sum2_a O.sum2_a
+          B.sum2   O.sum2
+          (\f -> f 2 "sum2")
+
+    testX "sum2d"
+          B.sum2_a O.sum2_a
+          B.sum2   O.sum2
+          (\f -> f 3 "sum2")
+
+    testX "sum2e"
+          B.sum2_a O.sum2_a
+          B.sum2   O.sum2
+          (\f -> f 4 "sum2")
+
+
+
+testX :: (Eq a, Show a)
+      => String -> (p -> t) -> (p -> t) -> p -> p -> (t -> a) -> IO ()
+testX msg a1 a2 b1 b2 ap =
+    let (r:rs) = [ap (f g) | f <- [a1,a2], g <- [b1,b2]]
+    in putStrLn (msg ++ " " ++ (show $ all (==r) rs) ++ " " ++ show r)
diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.stdout b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.stdout
new file mode 100644
index 0000000000..82619b86fc
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/UnboxedTuples.stdout
@@ -0,0 +1,43 @@
+("x",1)
+tuple1 True 90053
+tuple1_b
+tuple1_b
+tuple1_b
+tuple1_b
+tuple2p True (1234,1235,1236,1237)
+tuple2n True (7654,7653,7652,7651)
+tuple3 True (1000,1001,1002,1003,1004,1005,1006,1007,1008,1009,1010,1011)
+tuple4a True (2000.0,2001.0,2002.0,2003.0)
+tuple4b True ((3000.0,3001.0,3002.0,3003.0),(3004.0,3005.0,3006.0,3007.0),(3008.0,3009.0,3010.0,3011.0),(3012.0,3013.0,3014.0,3015.0),(3016.0,3017.0,3018.0,3019.0))
+tuple4c True ((3000.0,3001.0,3002,3003),(3004.0,3005.0,3006,3007),(3008.0,3009.0,3010,3011),(3012.0,3013.0,3014,3015))
+tuple5 True ((4000,4001,4002,4003),(4004,4005,4006,4007),(4008,4009,4010,4011),(4012,4013,4014,4015))
+tuple6 True "(6006,(6006,(6006,())))"
+tuplev1 True True
+tuplev2 True True
+tuplev3 True 30001
+tuplev4 True 40001
+tuplev5 True 50001
+tuplev6 True (601,602.0,603,604.0)
+(991,991,991,991,991,991,991,991,991,991,991,991)
+(992,992,992,992,992,992,992,992,992,992,992,992)
+(993,993,993,993,993,993,993,993,993,993,993,993)
+(994,994,994,994,994,994,994,994,994,994,994,994)
+(995,995,995,995,995,995,995,995,995,995,995,995)
+(996,996,996,996,996,996,996,996,996,996,996,996)
+(997,997,997,997,997,997,997,997,997,997,997,997)
+(998,998,998,998,998,998,998,998,998,998,998,998)
+(981,981,981,981,981,981,981,981,981,981,981,981)
+(982,982,982,982,982,982,982,982,982,982,982,982)
+(983,983,983,983,983,983,983,983,983,983,983,983)
+(984,984,984,984,984,984,984,984,984,984,984,984)
+(985,985,985,985,985,985,985,985,985,985,985,985)
+(986,986,986,986,986,986,986,986,986,986,986,986)
+(987,987,987,987,987,987,987,987,987,987,987,987)
+(988,988,988,988,988,988,988,988,988,988,988,988)
+sum1a True Left (1,"23")
+sum1b True Right True
+sum2a True "(\"sum2\",\"sum2\",\"sum2\",\"sum2\")"
+sum2b True "(\"sum2\",\"sum2\")"
+sum2c True "(# #)"
+sum2d True "3"
+sum2e True "4#"
diff --git a/testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T b/testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T
new file mode 100644
index 0000000000..4166c82f7f
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/UnboxedTuples/unboxedtuples.T
@@ -0,0 +1,10 @@
+test('UnboxedTuples',
+     [ extra_files(['Obj.hs', 'ByteCode.hs', 'Common.hs-incl']),
+       req_interp,
+       extra_ways(['ghci']),
+       when(config.have_ext_interp, extra_ways(['ghci', 'ghci-ext'])),
+       when(config.have_ext_interp and config.have_profiling, extra_ways(['ghci', 'ghci-ext', 'ghci-ext-prof']))
+     ],
+     compile_and_run,
+     ['']
+    )