Allow packing constructor fields

This is another step for fixing #13825 and is based on D38 by Simon
Marlow.

The change allows storing multiple constructor fields within the same
word. This currently applies only to `Float`s, e.g.,
```
data Foo = Foo {-# UNPACK #-} !Float {-# UNPACK #-} !Float
```
on 64-bit arch, will now store both fields within the same constructor
word. For `WordX/IntX` we'll need to introduce new primop types.

Main changes:

- We now use sizes in bytes when we compute the offsets for
  constructor fields in `StgCmmLayout` and introduce padding if
  necessary (word-sized fields are still word-aligned)

- `ByteCodeGen` had to be updated to correctly construct the data
  types. This required some new bytecode instructions to allow pushing
  things that are not full words onto the stack (and updating
  `Interpreter.c`). Note that we only use the packed stuff when
  constructing data types (i.e., for `PACK`), in all other cases the
  behavior should not change.

- `RtClosureInspect` was changed to handle the new layout when
  extracting subterms. This seems to be used by things like `:print`.
  I've also added a test for this.

- I deviated slightly from Simon's approach and use `PrimRep` instead
  of `ArgRep` for computing the size of fields.  This seemed more
  natural and in the future we'll probably want to introduce new
  primitive types (e.g., `Int8#`) and `PrimRep` seems like a better
  place to do that (where we already have `Int64Rep` for example).
  `ArgRep` on the other hand seems to be more focused on calling
  functions.

Signed-off-by: Michal Terepeta <michal.terepeta@gmail.com>

Test Plan: ./validate

Reviewers: bgamari, simonmar, austin, hvr, goldfire, erikd

Reviewed By: bgamari

Subscribers: maoe, rwbarton, thomie

GHC Trac Issues: #13825

Differential Revision: https://phabricator.haskell.org/D3809

13 files changed, 257 insertions, 0 deletions

diff --git a/testsuite/tests/codeGen/should_run/T13825-unit.hs b/testsuite/tests/codeGen/should_run/T13825-unit.hs
new file mode 100644
index 0000000000..bd3d7fbb33
--- /dev/null
+++ b/testsuite/tests/codeGen/should_run/T13825-unit.hs
@@ -0,0 +1,78 @@
+module Main where
+
+import DynFlags
+import RepType
+import SMRep
+import StgCmmLayout
+import StgCmmClosure
+import GHC
+import GhcMonad
+import System.Environment
+import Platform
+
+main :: IO ()
+main = do
+    [libdir] <- getArgs
+    runGhc (Just libdir) tests
+
+
+-- How to read tests:
+--   F(a,8) = field a at offset 8
+--   P(4,8) = 4 bytes of padding at offset 8
+tests :: Ghc ()
+tests = do
+      (_, _, off) <- runTest [("a", FloatRep), ("b", DoubleRep)]
+      assert_32_64 (map fmt off)
+          ["F(a,4)", "F(b,8)"]
+          ["F(a,8)", "P(4,12)", "F(b,16)"]
+
+      (_, _, off) <- runTest [("a", FloatRep), ("b", FloatRep)]
+      assert_32_64 (map fmt off)
+          ["F(a,4)", "F(b,8)"]
+          ["F(a,8)", "F(b,12)"]
+
+      (_, _, off) <- runTest [("a", FloatRep), ("b", FloatRep), ("c", FloatRep)]
+      assert_32_64 (map fmt off)
+          ["F(a,4)", "F(b,8)", "F(c,12)"]
+          ["F(a,8)", "F(b,12)", "F(c,16)", "P(4,20)"]
+
+      (_, _, off) <- runTest [("a", FloatRep), ("b", FloatRep), ("c", Int64Rep)]
+      assert_32_64 (map fmt off)
+          ["F(a,4)", "F(b,8)", "F(c,12)"]
+          ["F(a,8)", "F(b,12)", "F(c,16)"]
+
+      (_, _, off) <- runTest [("a", Int64Rep), ("b", FloatRep), ("c", FloatRep)]
+      assert_32_64 (map fmt off)
+          ["F(a,4)", "F(b,12)", "F(c,16)"]
+          ["F(a,8)", "F(b,16)", "F(c,20)"]
+
+      (_, _, off) <- runTest [("a", Int64Rep), ("b", FloatRep), ("c", Int64Rep)]
+      assert_32_64 (map fmt off)
+          ["F(a,4)", "F(b,12)", "F(c,16)"]
+          ["F(a,8)", "F(b,16)", "P(4,20)", "F(c,24)"]
+
+
+assert_32_64 :: (Eq a, Show a) => a -> a -> a -> Ghc ()
+assert_32_64 actual expected32 expected64 = do
+    dflags <- getDynFlags
+    let
+      expected
+          | word_size == 4 = expected32
+          | word_size == 8 = expected64
+      word_size = wORD_SIZE dflags
+    case actual == expected of
+        True -> return ()
+        False ->
+            error $ "Expected:\n" ++ show expected
+                 ++ "\nBut got:\n" ++ show actual
+
+runTest :: [(a, PrimRep)] -> Ghc (WordOff , WordOff, [FieldOffOrPadding a])
+runTest prim_reps = do
+    dflags <- getDynFlags
+    return $ mkVirtHeapOffsetsWithPadding dflags False (mkNonVoids prim_reps)
+  where
+    mkNonVoids = map (\(a, prim_rep) -> NonVoid (prim_rep, a))
+
+fmt :: FieldOffOrPadding String -> String
+fmt (FieldOff (NonVoid id) off) = "F(" ++ id ++ "," ++ show off ++ ")"
+fmt (Padding len off) = "P(" ++ show len ++ "," ++ show off ++ ")"
diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T
index 6aacea5fa3..214a9d5704 100644
--- a/testsuite/tests/codeGen/should_run/all.T
+++ b/testsuite/tests/codeGen/should_run/all.T
@@ -159,3 +159,7 @@ test('T9577', [ unless(arch('x86_64') or arch('i386'),skip),
 
 test('T13425', normal, compile_and_run, ['-O'])
 test('castFloatWord', normal, compile_and_run, ['-dcmm-lint'])
+test('T13825-unit',
+     extra_run_opts('"' + config.libdir + '"'),
+     compile_and_run,
+     ['-package ghc'])
diff --git a/testsuite/tests/ghci.debugger/scripts/T13825-debugger.hs b/testsuite/tests/ghci.debugger/scripts/T13825-debugger.hs
new file mode 100644
index 0000000000..0c3a1de219
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/T13825-debugger.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE MagicHash #-}
+module T13825 where
+
+import GHC.Exts
+import Data.Word
+import Data.Int
+
+data Packed1 = Packed1 Float# Float# Int# Float#
+    deriving Show
+
+data Packed2 =
+    Packed2
+        {-# UNPACK #-} !Float
+        {-# UNPACK #-} !Float
+        {-# UNPACK #-} !Int
+        {-# UNPACK #-} !Float
+    deriving Show
+
+data Packed3 =
+    Packed3
+        {-# UNPACK #-} !Word8
+        {-# UNPACK #-} !Int8
+        {-# UNPACK #-} !Int64
+        {-# UNPACK #-} !Word16
+        {-# UNPACK #-} !Word64
+        {-# UNPACK #-} !Word32
+        {-# UNPACK #-} !Float
+        {-# UNPACK #-} !Double
+    deriving Show
+
+packed1 = Packed1 12.34# 56.78# 42# 99.99#
+packed2 = Packed2 12.34 56.78 42 99.99
+packed3 = Packed3 1 2 3 4 5 6 7.8 9.0
diff --git a/testsuite/tests/ghci.debugger/scripts/T13825-debugger.script b/testsuite/tests/ghci.debugger/scripts/T13825-debugger.script
new file mode 100644
index 0000000000..fc55ffc5dd
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/T13825-debugger.script
@@ -0,0 +1,7 @@
+:l T13825-debugger.hs
+packed1
+:print packed1
+packed2
+:print packed2
+packed3
+:print packed3
diff --git a/testsuite/tests/ghci.debugger/scripts/T13825-debugger.stdout b/testsuite/tests/ghci.debugger/scripts/T13825-debugger.stdout
new file mode 100644
index 0000000000..6d3dc2f560
--- /dev/null
+++ b/testsuite/tests/ghci.debugger/scripts/T13825-debugger.stdout
@@ -0,0 +1,8 @@
+Packed1 12.34# 56.78# 42# 99.99#
+packed1 = Packed1 12.34 56.78 42 99.99
+Packed2 12.34 56.78 42 99.99
+packed2 = Packed2 12.34 56.78 42 99.99
+Packed3 1 2 3 4 5 6 7.8 9.0
+packed3 = Packed3
+            (GHC.Word.W8# 1) (GHC.Int.I8# 2) (GHC.Int.I64# 3) (GHC.Word.W16# 4)
+            (GHC.Word.W64# 5) (GHC.Word.W32# 6) 7.8 9.0
diff --git a/testsuite/tests/ghci.debugger/scripts/all.T b/testsuite/tests/ghci.debugger/scripts/all.T
index 00a39d704e..de3e7e37b2 100644
--- a/testsuite/tests/ghci.debugger/scripts/all.T
+++ b/testsuite/tests/ghci.debugger/scripts/all.T
@@ -95,3 +95,4 @@ test('getargs', extra_files(['../getargs.hs']), ghci_script, ['getargs.script'])
 test('T7386', normal, ghci_script, ['T7386.script'])
 test('T8557', normal, ghci_script, ['T8557.script'])
 test('T12458', normal, ghci_script, ['T12458.script'])
+test('T13825-debugger', normal, ghci_script, ['T13825-debugger.script'])
diff --git a/testsuite/tests/ghci/should_run/T13825-ghci.hs b/testsuite/tests/ghci/should_run/T13825-ghci.hs
new file mode 100644
index 0000000000..959cc7dc5b
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T13825-ghci.hs
@@ -0,0 +1,38 @@
+module T13825 where
+
+import Data.Int
+import Data.Word
+
+data Packed =
+    Packed
+      {-# UNPACK #-} !Float
+      {-# UNPACK #-} !Float
+      {-# UNPACK #-} !Int8
+      {-# UNPACK #-} !Word16
+      {-# UNPACK #-} !Float
+      {-# UNPACK #-} !Int
+  deriving (Show)
+
+-- Test a top-level constant
+packed :: Packed
+packed = Packed 1.0 2.0 3 4 5 6
+
+packedAll :: [Packed]
+packedAll =
+    packed :
+    [ Packed
+        (fromIntegral i)
+        (fromIntegral (i + 1))
+        (fromIntegral (i + 2))
+        (fromIntegral (i + 3))
+        (fromIntegral (i + 3))
+        (fromIntegral (i + 4))
+    | i <- [1.. 4]
+    ]
+
+addOne :: Packed -> Packed
+addOne (Packed a b c d e f) =
+    Packed (a + 1.0) (b + 1.0) (c + 1) (d + 1) (e + 1.0) (f + 1)
+
+mapAddOne :: [Packed] -> [Packed]
+mapAddOne = map addOne
diff --git a/testsuite/tests/ghci/should_run/T13825-ghci.script b/testsuite/tests/ghci/should_run/T13825-ghci.script
new file mode 100644
index 0000000000..6cd22d9a1c
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T13825-ghci.script
@@ -0,0 +1,13 @@
+:l T13825-ghci
+let ghciPacked = Packed 1.0 2.0 3 4 5 6
+map addOne (ghciPacked : packedAll)
+let ghciAddOne (Packed a b c d e f) = Packed (a + 1.0) (b + 1.0) (c + 1) (d + 1) (e + 1.0) (f + 1)
+map ghciAddOne (ghciPacked : packedAll)
+
+:set -fobject-code
+:l T13825-ghci
+:set -fbyte-code
+let ghciPacked = Packed 1.0 2.0 3 4 5 6
+map addOne (ghciPacked : packedAll)
+let ghciAddOne (Packed a b c d e f) = Packed (a + 1.0) (b + 1.0) (c + 1) (d + 1) (e + 1.0) (f + 1)
+map ghciAddOne (ghciPacked : packedAll)
diff --git a/testsuite/tests/ghci/should_run/T13825-ghci.stdout b/testsuite/tests/ghci/should_run/T13825-ghci.stdout
new file mode 100644
index 0000000000..4edee56c11
--- /dev/null
+++ b/testsuite/tests/ghci/should_run/T13825-ghci.stdout
@@ -0,0 +1,4 @@
+[Packed 2.0 3.0 4 5 6.0 7,Packed 2.0 3.0 4 5 6.0 7,Packed 2.0 3.0 4 5 5.0 6,Packed 3.0 4.0 5 6 6.0 7,Packed 4.0 5.0 6 7 7.0 8,Packed 5.0 6.0 7 8 8.0 9]
+[Packed 2.0 3.0 4 5 6.0 7,Packed 2.0 3.0 4 5 6.0 7,Packed 2.0 3.0 4 5 5.0 6,Packed 3.0 4.0 5 6 6.0 7,Packed 4.0 5.0 6 7 7.0 8,Packed 5.0 6.0 7 8 8.0 9]
+[Packed 2.0 3.0 4 5 6.0 7,Packed 2.0 3.0 4 5 6.0 7,Packed 2.0 3.0 4 5 5.0 6,Packed 3.0 4.0 5 6 6.0 7,Packed 4.0 5.0 6 7 7.0 8,Packed 5.0 6.0 7 8 8.0 9]
+[Packed 2.0 3.0 4 5 6.0 7,Packed 2.0 3.0 4 5 6.0 7,Packed 2.0 3.0 4 5 5.0 6,Packed 3.0 4.0 5 6 6.0 7,Packed 4.0 5.0 6 7 7.0 8,Packed 5.0 6.0 7 8 8.0 9]
diff --git a/testsuite/tests/ghci/should_run/all.T b/testsuite/tests/ghci/should_run/all.T
index da20149b56..c64b0e7026 100644
--- a/testsuite/tests/ghci/should_run/all.T
+++ b/testsuite/tests/ghci/should_run/all.T
@@ -29,3 +29,4 @@ test('T12456',     just_ghci, ghci_script, ['T12456.script'])
 test('T12549',     just_ghci, ghci_script, ['T12549.script'])
 test('BinaryArray', normal, compile_and_run, [''])
 test('T14125a',    just_ghci, ghci_script, ['T14125a.script'])
+test('T13825-ghci',just_ghci, ghci_script, ['T13825-ghci.script'])
diff --git a/testsuite/tests/primops/should_run/T13825-compile.hs b/testsuite/tests/primops/should_run/T13825-compile.hs
new file mode 100644
index 0000000000..04a72b38e9
--- /dev/null
+++ b/testsuite/tests/primops/should_run/T13825-compile.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE MagicHash #-}
+module Main where
+
+import GHC.Exts
+import Data.Word
+import Data.Int
+
+data Packed1 = Packed1 Float# Float# Int# Float#
+    deriving Show
+
+data Packed2 =
+    Packed2
+        {-# UNPACK #-} !Float
+        {-# UNPACK #-} !Float
+        {-# UNPACK #-} !Int
+        {-# UNPACK #-} !Float
+    deriving Show
+
+data Packed3 =
+    Packed3
+        {-# UNPACK #-} !Word8
+        {-# UNPACK #-} !Int8
+        {-# UNPACK #-} !Int64
+        {-# UNPACK #-} !Float
+        {-# UNPACK #-} !Word64
+        {-# UNPACK #-} !Word32
+        {-# UNPACK #-} !Float
+        {-# UNPACK #-} !Double
+    deriving Show
+
+packed1 = go 0.0# 1.0# 2# 3.0#
+  where
+    go a b c d =
+        Packed1 a b c d
+            : go (a `plusFloat#` 1.0#)
+                 (b `plusFloat#` 1.0#)
+               (c +# 1#)
+               (d `plusFloat#` 1.0#)
+
+packed2 =
+    [ Packed2
+        (fromIntegral i)
+        (fromIntegral (i + 1))
+        (fromIntegral (i + 2))
+        (fromIntegral (i + 3))
+    | i <- [0..]
+    ]
+
+packed3 =
+    [ Packed3
+        (fromIntegral i)
+        (fromIntegral (i + 1))
+        (fromIntegral (i + 2))
+        (fromIntegral (i + 3))
+        (fromIntegral (i + 4))
+        (fromIntegral (i + 5))
+        (fromIntegral (i + 6))
+        (fromIntegral (i + 6))
+    | i <- [0..]
+    ]
+
+main :: IO ()
+main = do
+    print (take 3 packed1)
+    print (take 3 packed2)
+    print (take 3 packed3)
diff --git a/testsuite/tests/primops/should_run/T13825-compile.stdout b/testsuite/tests/primops/should_run/T13825-compile.stdout
new file mode 100644
index 0000000000..41a5fb1368
--- /dev/null
+++ b/testsuite/tests/primops/should_run/T13825-compile.stdout
@@ -0,0 +1,3 @@
+[Packed1 0.0# 1.0# 2# 3.0#,Packed1 1.0# 2.0# 3# 4.0#,Packed1 2.0# 3.0# 4# 5.0#]
+[Packed2 0.0 1.0 2 3.0,Packed2 1.0 2.0 3 4.0,Packed2 2.0 3.0 4 5.0]
+[Packed3 0 1 2 3.0 4 5 6.0 6.0,Packed3 1 2 3 4.0 5 6 7.0 7.0,Packed3 2 3 4 5.0 6 7 8.0 8.0]
diff --git a/testsuite/tests/primops/should_run/all.T b/testsuite/tests/primops/should_run/all.T
index 68a2d5609f..30e871ac11 100644
--- a/testsuite/tests/primops/should_run/all.T
+++ b/testsuite/tests/primops/should_run/all.T
@@ -13,3 +13,4 @@ test('T10678',
      ],
      compile_and_run, ['-O'])
 test('T11296', normal, compile_and_run, [''])
+test('T13825-compile', normal, compile_and_run, [''])