fix sub-word literals in GHCi

8 files changed, 299 insertions, 9 deletions

diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs
index b2743ece43..4d9dc0b4e1 100644
--- a/compiler/GHC/StgToByteCode.hs
+++ b/compiler/GHC/StgToByteCode.hs
@@ -327,7 +327,8 @@ bytesToWords platform (ByteOff bytes) =
     let (q, r) = bytes `quotRem` (platformWordSizeInBytes platform)
     in if r == 0
            then fromIntegral q
-           else panic $ "GHC.StgToByteCode.bytesToWords: bytes=" ++ show bytes
+           else pprPanic "GHC.StgToByteCode.bytesToWords"
+                         (text "bytes=" <> ppr bytes)
 
 wordSize :: Platform -> ByteOff
 wordSize platform = ByteOff (platformWordSizeInBytes platform)
@@ -922,7 +923,7 @@ mkConAppCode orig_d _ p con args = app_code
 
             do_pushery !d (arg : args) = do
                 (push, arg_bytes) <- case arg of
-                    (Padding l _) -> return $! pushPadding l
+                    (Padding l _) -> return $! pushPadding (ByteOff l)
                     (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a)
                 more_push_code <- do_pushery (d + arg_bytes) args
                 return (push `appOL` more_push_code)
@@ -1845,7 +1846,8 @@ pushAtom d p (StgVarArg var)
             _ -> do
                 let !szw = bytesToWords platform szb
                     !off_w = trunc16W $ bytesToWords platform (d - d_v) + szw - 1
-                return (toOL (genericReplicate szw (PUSH_L off_w)), szb)
+                return (toOL (genericReplicate szw (PUSH_L off_w)),
+                              wordsToBytes platform szw)
         -- d - d_v           offset from TOS to the first slot of the object
         --
         -- d - d_v + sz - 1  offset from the TOS of the last slot of the object
@@ -1864,15 +1866,31 @@ pushAtom d p (StgVarArg var)
                 MASSERT( sz == wordSize platform )
                 return (unitOL (PUSH_G (getName var)), sz)
 
-pushAtom _ _ (StgLitArg lit) = do
+
+pushAtom _ _ (StgLitArg lit) = pushLiteral True lit
+
+pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff)
+pushLiteral padded lit =
+  do
      platform <- targetPlatform <$> getDynFlags
      let code :: PrimRep -> BcM (BCInstrList, ByteOff)
          code rep =
-            return (unitOL instr, size_bytes)
+            return (padding_instr `snocOL` instr, size_bytes + padding_bytes)
           where
             size_bytes = ByteOff $ primRepSizeB platform rep
+
             -- Here we handle the non-word-width cases specifically since we
             -- must emit different bytecode for them.
+
+            round_to_words (ByteOff bytes) =
+              ByteOff (roundUpToWords platform bytes)
+
+            padding_bytes
+                | padded    = round_to_words size_bytes - size_bytes
+                | otherwise = 0
+
+            (padding_instr, _) = pushPadding padding_bytes
+
             instr =
               case size_bytes of
                 1  -> PUSH_UBX8 lit
@@ -1910,8 +1928,7 @@ pushAtom _ _ (StgLitArg lit) = do
 -- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.
 pushConstrAtom
     :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)
-pushConstrAtom _ _ (StgLitArg lit@(LitFloat _)) =
-    return (unitOL (PUSH_UBX32 lit), 4)
+pushConstrAtom _ _ (StgLitArg lit) = pushLiteral False lit
 
 pushConstrAtom d p va@(StgVarArg v)
     | Just d_v <- lookupBCEnv_maybe v p = do  -- v is a local variable
@@ -1928,8 +1945,8 @@ pushConstrAtom d p va@(StgVarArg v)
 
 pushConstrAtom d p expr = pushAtom d p expr
 
-pushPadding :: Int -> (BCInstrList, ByteOff)
-pushPadding !n = go n (nilOL, 0)
+pushPadding :: ByteOff -> (BCInstrList, ByteOff)
+pushPadding (ByteOff n) = go n (nilOL, 0)
   where
     go n acc@(!instrs, !off) = case n of
         0 -> acc
diff --git a/testsuite/tests/ghci/should_run/PackedDataCon/ByteCode.hs b/testsuite/tests/ghci/should_run/PackedDataCon/ByteCode.hs
new file mode 100644
index 0000000000..7d1d78324a
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/PackedDataCon/ByteCode.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
+{-# OPTIONS_GHC -fbyte-code #-}
+
+module ByteCode where
+
+import GHC.Exts
+import GHC.Word
+import GHC.Int
+import Types
+
+#include "Common.hs-incl"
diff --git a/testsuite/tests/ghci/should_run/PackedDataCon/Common.hs-incl b/testsuite/tests/ghci/should_run/PackedDataCon/Common.hs-incl
new file mode 100644
index 0000000000..fdce7ec7db
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/PackedDataCon/Common.hs-incl
@@ -0,0 +1,117 @@
+
+
+d1w8 :: Word8 -> D1
+d1w8 (W8# x) = D1w8 x
+
+d1i8 :: Int8 -> D1
+d1i8 (I8# x) = D1i8 x
+
+d1w16 :: Word16 -> D1
+d1w16 (W16# x) = D1w16 x
+
+d1i16 :: Int16 -> D1
+d1i16 (I16# x) = D1i16 x
+
+d1w32 :: Word32 -> D1
+d1w32 (W32# x) = D1w32 x
+
+d1i32 :: Int32 -> D1
+d1i32 (I32# x) = D1i32 x
+
+showD1 :: D1 -> String
+showD1 (D1w8 x) = show (W8# x)
+showD1 (D1i8 x) = show (I8# x)
+showD1 (D1w16 x) = show (W16# x)
+showD1 (D1i16 x) = show (I16# x)
+showD1 (D1w32 x) = show (W32# x)
+showD1 (D1i32 x) = show (I32# x)
+
+d2a :: Word8 -> Word8 -> D2
+d2a (W8# x1) (W8# x2) = D2a x1 x2
+
+d2b :: Word8 -> Word16 -> D2
+d2b (W8# x1) (W16# x2) = D2b x1 x2
+
+d2c :: Word8 -> Word16 -> Word8 -> D2
+d2c (W8# x1) (W16# x2) (W8# x3)= D2c x1 x2 x3
+
+d2d :: Word -> Word8 -> Word -> D2
+d2d (W# x1) (W8# x2) (W# x3) = D2d x1 x2 x3
+
+d2e :: Word -> Int8 -> Double -> Float -> Word8 -> D2
+d2e (W# x1) (I8# x2) (D# x3) (F# x4) (W8# x5) = D2e x1 x2 x3 x4 x5
+
+d2l :: Int -> D2
+d2l 0 = D2a (wordToWord8# 44##) (wordToWord8# 55##)
+d2l 1 = D2b (wordToWord8# 44##) (wordToWord16# 55##)
+d2l 2 = D2c (wordToWord8# 44##) (wordToWord16# 5555##) (wordToWord8# 66##)
+d2l 3 = D2d 5555## (wordToWord8# 66##) 7777##
+d2l _ = D2e 7777## (intToInt8# 66#) 55.55## 44.44# (wordToWord8# 33##)
+
+showD2 :: D2 -> String
+showD2 (D2a x1 x2) = show (W8# x1, W8# x2)
+showD2 (D2b x1 x2) = show (W8# x1, W16# x2)
+showD2 (D2c x1 x2 x3) = show (W8# x1, W16# x2, W8# x3)
+showD2 (D2d x1 x2 x3) = show (W# x1, W8# x2, W# x3)
+showD2 (D2e x1 x2 x3 x4 x5) = show (W# x1, I8# x2, D# x3, F# x4, W8# x5)
+
+-- unboxed function arguments
+
+type F1 = Int8# -> Float# -> Word16# -> Double# -> Word32# -> Word8# -> (Int8, Float, Word16, Double, Word32, Word8)
+
+f1 :: F1
+f1 x1 x2 x3 x4 x5 x6 = (I8# x1, F# x2, W16# x3, D# x4, W32# x5, W8# x6)
+
+f1a :: Word8# -> F1
+f1a x0 x1 x2 x3 x4 x5 x6 = (I8# x1, F# x2, W16# x3, D# x4, W32# x5, W8# x0)
+
+f1a_app :: (Word8# -> F1) -> F1
+f1a_app f = f (wordToWord8# 77##)
+
+f1_show :: F1 -> String
+f1_show f = show $ f (intToInt8# 123#)
+                     456.789#
+                     (wordToWord16# 8765##)
+                     123.456##
+                     (wordToWord32# 12345678##)
+                     (wordToWord8# 33##)
+
+
+-- unboxed return values of various sizes
+
+type U1 = Int8 -> Int8#
+unboxed1 :: U1
+unboxed1 0 = intToInt8# 11#
+unboxed1 _ = intToInt8# 13#
+
+unboxed1_a :: U1 -> Int8 -> Int8
+unboxed1_a f x = case f x of x1 -> I8# x1
+
+
+type U2 = Word16 -> Word16#
+unboxed2 :: U2
+unboxed2 0 = wordToWord16# 1111##
+unboxed2 _ = wordToWord16# 1333##
+
+unboxed2_a :: U2 -> Word16 -> Word16
+unboxed2_a f x = case f x of x1 -> W16# x1
+
+
+type U3 = Word16 -> Float#
+unboxed3 :: U3
+unboxed3 0 = 55.55#
+unboxed3 _ = 77.77#
+
+unboxed3_a :: U3 -> Word16 -> Float
+unboxed3_a f x = case f x of x1 -> F# x1
+
+-- unboxed tuple
+
+type T1 = Int -> (# Int8#, Word16#, Float#, Int #)
+
+tuple1 :: T1
+tuple1 x = (# intToInt8# 66#, wordToWord16# 7777##, 99.99#, x #)
+
+tuple1_a :: T1 -> Int -> (Int8, Word16, Float, Int)
+tuple1_a f x  =
+  case f x of (# x1, x2, x3, x4 #) -> (I8# x1, W16# x2, F# x3, x4)
diff --git a/testsuite/tests/ghci/should_run/PackedDataCon/Obj.hs b/testsuite/tests/ghci/should_run/PackedDataCon/Obj.hs
new file mode 100644
index 0000000000..54edad5075
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/PackedDataCon/Obj.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
+{-# OPTIONS_GHC -fobject-code #-}
+
+module Obj where
+
+import GHC.Exts
+import GHC.Word
+import GHC.Int
+import Types
+
+#include "Common.hs-incl"
diff --git a/testsuite/tests/ghci/should_run/PackedDataCon/PackedDataCon.hs b/testsuite/tests/ghci/should_run/PackedDataCon/PackedDataCon.hs
new file mode 100644
index 0000000000..898ced4b90
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/PackedDataCon/PackedDataCon.hs
@@ -0,0 +1,75 @@
+{-# OPTIONS_GHC -fbyte-code #-}
+
+{-
+  Test constructor packing in GHCi with unboxed fields of various sizes
+ -}
+
+module Main where
+
+import qualified Obj      as O
+import qualified ByteCode as B
+
+import GHC.Exts
+import GHC.Word
+
+main :: IO ()
+main = do
+
+    -- pack a single field
+    testX "D1w8"  B.showD1 O.showD1 B.d1w8  O.d1w8  (\f -> f 33)
+    testX "D1i8"  B.showD1 O.showD1 B.d1i8  O.d1i8  (\f -> f 33)
+    testX "D1w16" B.showD1 O.showD1 B.d1w16 O.d1w16 (\f -> f 3333)
+    testX "D1i16" B.showD1 O.showD1 B.d1i16 O.d1i16 (\f -> f 3333)
+    testX "D1w32" B.showD1 O.showD1 B.d1w32 O.d1w32 (\f -> f 33333333)
+    testX "D1i32" B.showD1 O.showD1 B.d1i32 O.d1i32 (\f -> f 33333333)
+
+    -- pack multiple fields
+    testX "D2a" B.showD2 O.showD2 B.d2a O.d2a (\f -> f 44 55)
+    testX "D2b" B.showD2 O.showD2 B.d2b O.d2b (\f -> f 44 55)
+    testX "D2c" B.showD2 O.showD2 B.d2c O.d2c (\f -> f 44 5555 66)
+    testX "D2d" B.showD2 O.showD2 B.d2d O.d2d (\f -> f 5555 66 7777)
+    testX "D2e" B.showD2 O.showD2 B.d2e O.d2e (\f -> f 7777 66 55.55 44.44 33)
+
+    -- pack multiple fields from literals
+    testX "D2l 0" B.showD2 O.showD2 B.d2l O.d2l (\f -> f 0)
+    testX "D2l 1" B.showD2 O.showD2 B.d2l O.d2l (\f -> f 1)
+    testX "D2l 2" B.showD2 O.showD2 B.d2l O.d2l (\f -> f 2)
+    testX "D2l 3" B.showD2 O.showD2 B.d2l O.d2l (\f -> f 3)
+    testX "D2l 4" B.showD2 O.showD2 B.d2l O.d2l (\f -> f 4)
+
+    -- function arguments, not packed
+    testX' "f1 "  B.f1_show O.f1_show B.f1 O.f1
+    testX' "f1a"  B.f1_show O.f1_show (B.f1a_app B.f1a) (B.f1a_app B.f1a)
+    testX' "f1b"  B.f1_show O.f1_show (B.f1a_app O.f1a) (B.f1a_app B.f1a)
+    testX' "f1c"  B.f1_show O.f1_show (O.f1a_app B.f1a) (B.f1a_app B.f1a)
+    testX' "f1d"  B.f1_show O.f1_show (O.f1a_app O.f1a) (B.f1a_app B.f1a)
+
+    -- unboxed return values and tuples
+    testX'' "unboxed1 0" B.unboxed1_a O.unboxed1_a B.unboxed1 O.unboxed1 (\f -> f 0)
+    testX'' "unboxed1 1" B.unboxed1_a O.unboxed1_a B.unboxed1 O.unboxed1 (\f -> f 1)
+
+    testX'' "unboxed2 0" B.unboxed2_a O.unboxed2_a B.unboxed2 O.unboxed2 (\f -> f 0)
+    testX'' "unboxed2 1" B.unboxed2_a O.unboxed2_a B.unboxed2 O.unboxed2 (\f -> f 1)
+
+    testX'' "unboxed3 0" B.unboxed3_a O.unboxed3_a B.unboxed3 O.unboxed3 (\f -> f 0)
+    testX'' "unboxed3 1" B.unboxed3_a O.unboxed3_a B.unboxed3 O.unboxed3 (\f -> f 1)
+
+    testX'' "tuple1"   B.tuple1_a O.tuple1_a B.tuple1 O.tuple1 (\f -> f 3)
+
+
+testX :: (Eq a, Show a)
+      => String -> (p -> a) -> (p -> a) -> f -> f -> (f -> p) -> IO ()
+testX msg a1 a2 b1 b2 ap =
+    let (r:rs) = [f (ap g) | f <- [a1,a2], g <- [b1,b2]]
+    in putStrLn (msg ++ " " ++ (show $ all (==r) rs) ++ " " ++ show r)
+
+testX' :: String -> (f -> String) -> (f -> String) -> f -> f -> IO ()
+testX' msg a1 a2 b1 b2 =
+    let (r:rs) = [f g | f <- [a1,a2], g <- [b1,b2]]
+    in putStrLn (msg ++ " " ++ (show $ all (==r) rs) ++ " " ++ show r)
+
+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/PackedDataCon/PackedDataCon.stdout b/testsuite/tests/ghci/should_run/PackedDataCon/PackedDataCon.stdout
new file mode 100644
index 0000000000..533ef77cd2
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/PackedDataCon/PackedDataCon.stdout
@@ -0,0 +1,28 @@
+D1w8 True "33"
+D1i8 True "33"
+D1w16 True "3333"
+D1i16 True "3333"
+D1w32 True "33333333"
+D1i32 True "33333333"
+D2a True "(44,55)"
+D2b True "(44,55)"
+D2c True "(44,5555,66)"
+D2d True "(5555,66,7777)"
+D2e True "(7777,66,55.55,44.44,33)"
+D2l 0 True "(44,55)"
+D2l 1 True "(44,55)"
+D2l 2 True "(44,5555,66)"
+D2l 3 True "(5555,66,7777)"
+D2l 4 True "(7777,66,55.55,44.44,33)"
+f1  True "(123,456.789,8765,123.456,12345678,33)"
+f1a True "(123,456.789,8765,123.456,12345678,77)"
+f1b True "(123,456.789,8765,123.456,12345678,77)"
+f1c True "(123,456.789,8765,123.456,12345678,77)"
+f1d True "(123,456.789,8765,123.456,12345678,77)"
+unboxed1 0 True 11
+unboxed1 1 True 13
+unboxed2 0 True 1111
+unboxed2 1 True 1333
+unboxed3 0 True 55.55
+unboxed3 1 True 77.77
+tuple1 True (66,7777,99.99,3)
\ No newline at end of file
diff --git a/testsuite/tests/ghci/should_run/PackedDataCon/Types.hs b/testsuite/tests/ghci/should_run/PackedDataCon/Types.hs
new file mode 100644
index 0000000000..9b1f1f5a9e
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/PackedDataCon/Types.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE MagicHash #-}
+{-# OPTIONS_GHC -fobject-code #-}
+
+module Types where
+
+import GHC.Exts
+import GHC.Int
+import GHC.Word
+
+data D1 = D1w8 Word8#
+        | D1i8 Int8#
+        | D1w16 Word16#
+        | D1i16 Int16#
+        | D1w32 Word32#
+        | D1i32 Int32#
+
+data D2 = D2a Word8# Word8#
+        | D2b Word8# Word16#
+        | D2c Word8# Word16# Word8#
+        | D2d Word# Word8# Word#
+        | D2e Word# Int8# Double# Float# Word8#
diff --git a/testsuite/tests/ghci/should_run/PackedDataCon/packeddatacon.T b/testsuite/tests/ghci/should_run/PackedDataCon/packeddatacon.T
new file mode 100644
index 0000000000..4bf55043fc
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/PackedDataCon/packeddatacon.T
@@ -0,0 +1,10 @@
+test('PackedDataCon',
+     [ extra_files(['Obj.hs', 'ByteCode.hs', 'Types.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,
+     ['']
+    )