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

4 files changed, 192 insertions, 48 deletions

diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
index edb18df382..920bc4ac2b 100644
--- a/compiler/ghci/ByteCodeAsm.hs
+++ b/compiler/ghci/ByteCodeAsm.hs
@@ -351,6 +351,12 @@ assembleI dflags i = case i of
   PUSH_L o1                -> emit bci_PUSH_L [SmallOp o1]
   PUSH_LL o1 o2            -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2]
   PUSH_LLL o1 o2 o3        -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3]
+  PUSH8 o1                 -> emit bci_PUSH8 [SmallOp o1]
+  PUSH16 o1                -> emit bci_PUSH16 [SmallOp o1]
+  PUSH32 o1                -> emit bci_PUSH32 [SmallOp o1]
+  PUSH8_W o1               -> emit bci_PUSH8_W [SmallOp o1]
+  PUSH16_W o1              -> emit bci_PUSH16_W [SmallOp o1]
+  PUSH32_W o1              -> emit bci_PUSH32_W [SmallOp o1]
   PUSH_G nm                -> do p <- ptr (BCOPtrName nm)
                                  emit bci_PUSH_G [Op p]
   PUSH_PRIMOP op           -> do p <- ptr (BCOPtrPrimOp op)
@@ -365,6 +371,15 @@ assembleI dflags i = case i of
                            -> do let ul_bco = assembleBCO dflags proto
                                  p <- ioptr (liftM BCOPtrBCO ul_bco)
                                  emit (push_alts pk) [Op p]
+  PUSH_PAD8                -> emit bci_PUSH_PAD8 []
+  PUSH_PAD16               -> emit bci_PUSH_PAD16 []
+  PUSH_PAD32               -> emit bci_PUSH_PAD32 []
+  PUSH_UBX8 lit            -> do np <- literal lit
+                                 emit bci_PUSH_UBX8 [Op np]
+  PUSH_UBX16 lit           -> do np <- literal lit
+                                 emit bci_PUSH_UBX16 [Op np]
+  PUSH_UBX32 lit           -> do np <- literal lit
+                                 emit bci_PUSH_UBX32 [Op np]
   PUSH_UBX lit nws         -> do np <- literal lit
                                  emit bci_PUSH_UBX [Op np, SmallOp nws]
 
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index c7b96a83a0..697dc63b43 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -47,8 +47,9 @@ import Unique
 import FastString
 import Panic
 import StgCmmClosure    ( NonVoid(..), fromNonVoid, nonVoidIds )
-import StgCmmLayout     ( ArgRep(..), toArgRep, argRepSizeW,
-                          mkVirtHeapOffsets, mkVirtConstrOffsets )
+import StgCmmLayout     ( ArgRep(..), FieldOffOrPadding(..),
+                          toArgRep, argRepSizeW,
+                          mkVirtHeapOffsetsWithPadding, mkVirtConstrOffsets )
 import SMRep hiding (WordOff, ByteOff, wordsToBytes)
 import Bitmap
 import OrdList
@@ -455,6 +456,9 @@ truncIntegral16 w
     | otherwise
     = fromIntegral w
 
+trunc16B :: ByteOff -> Word16
+trunc16B = truncIntegral16
+
 trunc16W :: WordOff -> Word16
 trunc16W = truncIntegral16
 
@@ -798,10 +802,13 @@ mkConAppCode orig_d _ p con args_r_to_l =
                 , not (isVoidRep prim_rep)
                 ]
             is_thunk = False
-            (_, _, args_offsets) = mkVirtHeapOffsets dflags is_thunk non_voids
+            (_, _, args_offsets) =
+                mkVirtHeapOffsetsWithPadding dflags is_thunk non_voids
 
-            do_pushery !d ((arg, _) : args) = do
-                (push, arg_bytes) <- pushAtom d p (fromNonVoid arg)
+            do_pushery !d (arg : args) = do
+                (push, arg_bytes) <- case arg of
+                    (Padding l _) -> pushPadding l
+                    (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a)
                 more_push_code <- do_pushery (d + arg_bytes) args
                 return (push `appOL` more_push_code)
             do_pushery !d [] = do
@@ -926,7 +933,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
                             | otherwise = wordSize dflags
 
         -- depth of stack after the return value has been pushed
-        d_bndr = d + ret_frame_size_b + idSizeB dflags bndr
+        d_bndr =
+            d + ret_frame_size_b + wordsToBytes dflags (idSizeW dflags bndr)
 
         -- depth of stack after the extra info table for an unboxed return
         -- has been pushed, if any.  This is the stack depth at the
@@ -1127,8 +1135,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
      code_n_reps <- pargs d0 args_r_to_l
      let
          (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
-         a_reps_sizeW =
-             WordOff (sum (map (primRepSizeW dflags) a_reps_pushed_r_to_l))
+         a_reps_sizeW = sum (map (repSizeWords dflags) a_reps_pushed_r_to_l)
 
          push_args    = concatOL pushs_arg
          !d_after_args = d0 + wordsToBytes dflags a_reps_sizeW
@@ -1218,7 +1225,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
 
          -- Push the return placeholder.  For a call returning nothing,
          -- this is a V (tag).
-         r_sizeW   = WordOff (primRepSizeW dflags r_rep)
+         r_sizeW   = repSizeWords dflags r_rep
          d_after_r = d_after_Addr + wordsToBytes dflags r_sizeW
          push_r =
              if returns_void
@@ -1472,12 +1479,20 @@ pushAtom d p (AnnVar var)
 
    | Just d_v <- lookupBCEnv_maybe var p  -- var is a local variable
    = do dflags <- getDynFlags
-        -- Currently this code assumes that @szb@ is a multiple of full words.
-        -- It'll need to change to support, e.g., sub-word constructor fields.
-        let !szb = idSizeB dflags var
-            !szw = bytesToWords dflags szb -- szb is a multiple of words
-            l = trunc16W $ bytesToWords dflags (d - d_v) + szw - 1
-        return (toOL (genericReplicate szw (PUSH_L l)), szb)
+
+        let !szb = idSizeCon dflags var
+            with_instr instr = do
+                let !off_b = trunc16B $ d - d_v
+                return (unitOL (instr off_b), wordSize dflags)
+
+        case szb of
+            1 -> with_instr PUSH8_W
+            2 -> with_instr PUSH16_W
+            4 -> with_instr PUSH32_W
+            _ -> do
+                let !szw = bytesToWords dflags szb
+                    !off_w = trunc16W $ bytesToWords dflags (d - d_v) + szw - 1
+                return (toOL (genericReplicate szw (PUSH_L off_w)), szb)
         -- 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
@@ -1492,7 +1507,7 @@ pushAtom d p (AnnVar var)
               ptrToWordPtr $ fromRemotePtr ptr
             Nothing -> do
                 dflags <- getDynFlags
-                let sz = idSizeB dflags var
+                let sz = idSizeCon dflags var
                 MASSERT( sz == wordSize dflags )
                 return (unitOL (PUSH_G (getName var)), sz)
 
@@ -1525,6 +1540,36 @@ pushAtom _ _ expr
               (pprCoreExpr (deAnnotate' expr))
 
 
+-- | Push an atom for constructor (i.e., PACK instruction) onto the stack.
+-- This is slightly different to @pushAtom@ due to the fact that we allow
+-- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.
+pushConstrAtom
+    :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)
+
+pushConstrAtom _ _ (AnnLit lit@(MachFloat _)) =
+    return (unitOL (PUSH_UBX32 lit), 4)
+
+pushConstrAtom d p (AnnVar v)
+    | Just d_v <- lookupBCEnv_maybe v p = do  -- v is a local variable
+        dflags <- getDynFlags
+        let !szb = idSizeCon dflags v
+            done instr = do
+                let !off = trunc16B $ d - d_v
+                return (unitOL (instr off), szb)
+        case szb of
+            1 -> done PUSH8
+            2 -> done PUSH16
+            4 -> done PUSH32
+            _ -> pushAtom d p (AnnVar v)
+
+pushConstrAtom d p expr = pushAtom d p expr
+
+pushPadding :: Int -> BcM (BCInstrList, ByteOff)
+pushPadding 1 = return (unitOL (PUSH_PAD8), 1)
+pushPadding 2 = return (unitOL (PUSH_PAD16), 2)
+pushPadding 4 = return (unitOL (PUSH_PAD32), 4)
+pushPadding x = panic $ "pushPadding x=" ++ show x
+
 -- -----------------------------------------------------------------------------
 -- Given a bunch of alts code and their discrs, do the donkey work
 -- of making a multiway branch using a switch tree.
@@ -1669,8 +1714,8 @@ lookupBCEnv_maybe = Map.lookup
 idSizeW :: DynFlags -> Id -> WordOff
 idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep
 
-idSizeB :: DynFlags -> Id -> ByteOff
-idSizeB dflags = wordsToBytes dflags . idSizeW dflags
+idSizeCon :: DynFlags -> Id -> ByteOff
+idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep
 
 bcIdArgRep :: Id -> ArgRep
 bcIdArgRep = toArgRep . bcIdPrimRep
@@ -1682,6 +1727,9 @@ bcIdPrimRep id
   | otherwise
   = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))
 
+repSizeWords :: DynFlags -> PrimRep -> WordOff
+repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep)
+
 isFollowableArg :: ArgRep -> Bool
 isFollowableArg P = True
 isFollowableArg _ = False
diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs
index 7ef82206cb..07dcd2222a 100644
--- a/compiler/ghci/ByteCodeInstr.hs
+++ b/compiler/ghci/ByteCodeInstr.hs
@@ -62,6 +62,23 @@ data BCInstr
    | PUSH_LL   !Word16 !Word16{-2 offsets-}
    | PUSH_LLL  !Word16 !Word16 !Word16{-3 offsets-}
 
+   -- Push the specified local as a 8, 16, 32 bit value onto the stack. (i.e.,
+   -- the stack will grow by 8, 16 or 32 bits)
+   | PUSH8  !Word16
+   | PUSH16 !Word16
+   | PUSH32 !Word16
+
+   -- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the
+   -- value will take the whole word on the stack (i.e., the stack will gorw by
+   -- a word)
+   -- This is useful when extracting a packed constructor field for further use.
+   -- Currently we expect all values on the stack to take full words, except for
+   -- the ones used for PACK (i.e., actually constracting new data types, in
+   -- which case we use PUSH{8,16,32})
+   | PUSH8_W  !Word16
+   | PUSH16_W !Word16
+   | PUSH32_W !Word16
+
    -- Push a ptr  (these all map to PUSH_G really)
    | PUSH_G       Name
    | PUSH_PRIMOP  PrimOp
@@ -71,8 +88,16 @@ data BCInstr
    | PUSH_ALTS          (ProtoBCO Name)
    | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep
 
+   -- Pushing 8, 16 and 32 bits of padding (for constructors).
+   | PUSH_PAD8
+   | PUSH_PAD16
+   | PUSH_PAD32
+
    -- Pushing literals
-   | PUSH_UBX  Literal Word16
+   | PUSH_UBX8  Literal
+   | PUSH_UBX16 Literal
+   | PUSH_UBX32 Literal
+   | PUSH_UBX   Literal Word16
         -- push this int/float/double/addr, on the stack. Word16
         -- is # of words to copy from literal pool.  Eitherness reflects
         -- the difficulty of dealing with MachAddr here, mostly due to
@@ -194,6 +219,12 @@ instance Outputable BCInstr where
    ppr (PUSH_L offset)       = text "PUSH_L  " <+> ppr offset
    ppr (PUSH_LL o1 o2)       = text "PUSH_LL " <+> ppr o1 <+> ppr o2
    ppr (PUSH_LLL o1 o2 o3)   = text "PUSH_LLL" <+> ppr o1 <+> ppr o2 <+> ppr o3
+   ppr (PUSH8  offset)       = text "PUSH8  " <+> ppr offset
+   ppr (PUSH16 offset)       = text "PUSH16  " <+> ppr offset
+   ppr (PUSH32 offset)       = text "PUSH32  " <+> ppr offset
+   ppr (PUSH8_W  offset)     = text "PUSH8_W  " <+> ppr offset
+   ppr (PUSH16_W offset)     = text "PUSH16_W  " <+> ppr offset
+   ppr (PUSH32_W offset)     = text "PUSH32_W  " <+> ppr offset
    ppr (PUSH_G nm)           = text "PUSH_G  " <+> ppr nm
    ppr (PUSH_PRIMOP op)      = text "PUSH_G  " <+> text "GHC.PrimopWrappers."
                                                <> ppr op
@@ -201,6 +232,13 @@ instance Outputable BCInstr where
    ppr (PUSH_ALTS bco)       = hang (text "PUSH_ALTS") 2 (ppr bco)
    ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)
 
+   ppr PUSH_PAD8             = text "PUSH_PAD8"
+   ppr PUSH_PAD16            = text "PUSH_PAD16"
+   ppr PUSH_PAD32            = text "PUSH_PAD32"
+
+   ppr (PUSH_UBX8  lit)      = text "PUSH_UBX8" <+> ppr lit
+   ppr (PUSH_UBX16 lit)      = text "PUSH_UBX16" <+> ppr lit
+   ppr (PUSH_UBX32 lit)      = text "PUSH_UBX32" <+> ppr lit
    ppr (PUSH_UBX lit nw)     = text "PUSH_UBX" <+> parens (ppr nw) <+> ppr lit
    ppr PUSH_APPLY_N          = text "PUSH_APPLY_N"
    ppr PUSH_APPLY_V          = text "PUSH_APPLY_V"
@@ -269,11 +307,23 @@ bciStackUse STKCHECK{}            = 0
 bciStackUse PUSH_L{}              = 1
 bciStackUse PUSH_LL{}             = 2
 bciStackUse PUSH_LLL{}            = 3
+bciStackUse PUSH8{}               = 1  -- overapproximation
+bciStackUse PUSH16{}              = 1  -- overapproximation
+bciStackUse PUSH32{}              = 1  -- overapproximation on 64bit arch
+bciStackUse PUSH8_W{}             = 1  -- takes exactly 1 word
+bciStackUse PUSH16_W{}            = 1  -- takes exactly 1 word
+bciStackUse PUSH32_W{}            = 1  -- takes exactly 1 word
 bciStackUse PUSH_G{}              = 1
 bciStackUse PUSH_PRIMOP{}         = 1
 bciStackUse PUSH_BCO{}            = 1
 bciStackUse (PUSH_ALTS bco)       = 2 + protoBCOStackUse bco
 bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco
+bciStackUse (PUSH_PAD8)           = 1  -- overapproximation
+bciStackUse (PUSH_PAD16)          = 1  -- overapproximation
+bciStackUse (PUSH_PAD32)          = 1  -- overapproximation on 64bit arch
+bciStackUse (PUSH_UBX8 _)         = 1  -- overapproximation
+bciStackUse (PUSH_UBX16 _)        = 1  -- overapproximation
+bciStackUse (PUSH_UBX32 _)        = 1  -- overapproximation on 64bit arch
 bciStackUse (PUSH_UBX _ nw)       = fromIntegral nw
 bciStackUse PUSH_APPLY_N{}        = 1
 bciStackUse PUSH_APPLY_V{}        = 1
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 63d1886b4d..b85322d60e 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -60,6 +60,7 @@ import GHC.Arr          ( Array(..) )
 import GHC.Char
 import GHC.Exts
 import GHC.IO ( IO(..) )
+import SMRep ( roundUpTo )
 
 import Control.Monad
 import Data.Maybe
@@ -71,6 +72,7 @@ import Data.Sequence (viewl, ViewL(..))
 import Foreign
 import System.IO.Unsafe
 
+
 ---------------------------------------------
 -- * A representation of semi evaluated Terms
 ---------------------------------------------
@@ -148,11 +150,13 @@ data ClosureType = Constr
                  | Other  Int
  deriving (Show, Eq)
 
+data ClosureNonPtrs = ClosureNonPtrs ByteArray#
+
 data Closure = Closure { tipe         :: ClosureType
                        , infoPtr      :: Ptr ()
                        , infoTable    :: StgInfoTable
                        , ptrs         :: Array Int HValue
-                       , nonPtrs      :: [Word]
+                       , nonPtrs      :: ClosureNonPtrs
                        }
 
 instance Outputable ClosureType where
@@ -184,8 +188,7 @@ getClosureData dflags a =
            let tipe = readCType (InfoTable.tipe itbl)
                elems = fromIntegral (InfoTable.ptrs itbl)
                ptrsList = Array 0 (elems - 1) elems ptrs
-               nptrs_data = [W# (indexWordArray# nptrs i)
-                            | I# i <- [0.. fromIntegral (InfoTable.nptrs itbl)-1] ]
+               nptrs_data = ClosureNonPtrs nptrs
            ASSERT(elems >= 0) return ()
            ptrsList `seq`
             return (Closure tipe iptr0 itbl ptrsList nptrs_data)
@@ -793,47 +796,75 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
 
 extractSubTerms :: (Type -> HValue -> TcM Term)
                 -> Closure -> [Type] -> TcM [Term]
-extractSubTerms recurse clos = liftM thdOf3 . go 0 (nonPtrs clos)
+extractSubTerms recurse clos = liftM thdOf3 . go 0 0
   where
-    go ptr_i ws [] = return (ptr_i, ws, [])
-    go ptr_i ws (ty:tys)
+    !(ClosureNonPtrs array) = nonPtrs clos
+
+    go ptr_i arr_i [] = return (ptr_i, arr_i, [])
+    go ptr_i arr_i (ty:tys)
       | Just (tc, elem_tys) <- tcSplitTyConApp_maybe ty
       , isUnboxedTupleTyCon tc
                 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
-      = do (ptr_i, ws, terms0) <- go ptr_i ws (dropRuntimeRepArgs elem_tys)
-           (ptr_i, ws, terms1) <- go ptr_i ws tys
-           return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
+      = do (ptr_i, arr_i, terms0) <-
+               go ptr_i arr_i (dropRuntimeRepArgs elem_tys)
+           (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
+           return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
       | otherwise
       = case typePrimRepArgs ty of
           [rep_ty] ->  do
-            (ptr_i, ws, term0)  <- go_rep ptr_i ws ty rep_ty
-            (ptr_i, ws, terms1) <- go ptr_i ws tys
-            return (ptr_i, ws, term0 : terms1)
+            (ptr_i, arr_i, term0)  <- go_rep ptr_i arr_i ty rep_ty
+            (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
+            return (ptr_i, arr_i, term0 : terms1)
           rep_tys -> do
-           (ptr_i, ws, terms0) <- go_unary_types ptr_i ws rep_tys
-           (ptr_i, ws, terms1) <- go ptr_i ws tys
-           return (ptr_i, ws, unboxedTupleTerm ty terms0 : terms1)
+           (ptr_i, arr_i, terms0) <- go_unary_types ptr_i arr_i rep_tys
+           (ptr_i, arr_i, terms1) <- go ptr_i arr_i tys
+           return (ptr_i, arr_i, unboxedTupleTerm ty terms0 : terms1)
 
-    go_unary_types ptr_i ws [] = return (ptr_i, ws, [])
-    go_unary_types ptr_i ws (rep_ty:rep_tys) = do
+    go_unary_types ptr_i arr_i [] = return (ptr_i, arr_i, [])
+    go_unary_types ptr_i arr_i (rep_ty:rep_tys) = do
       tv <- newVar liftedTypeKind
-      (ptr_i, ws, term0)  <- go_rep ptr_i ws tv rep_ty
-      (ptr_i, ws, terms1) <- go_unary_types ptr_i ws rep_tys
-      return (ptr_i, ws, term0 : terms1)
-
-    go_rep ptr_i ws ty rep
-      | isGcPtrRep rep
-      = do t <- appArr (recurse ty) (ptrs clos) ptr_i
-           return (ptr_i + 1, ws, t)
-      | otherwise
-      = do dflags <- getDynFlags
-           let (ws0, ws1) = splitAt (primRepSizeW dflags rep) ws
-           return (ptr_i, ws1, Prim ty ws0)
+      (ptr_i, arr_i, term0)  <- go_rep ptr_i arr_i tv rep_ty
+      (ptr_i, arr_i, terms1) <- go_unary_types ptr_i arr_i rep_tys
+      return (ptr_i, arr_i, term0 : terms1)
+
+    go_rep ptr_i arr_i ty rep
+      | isGcPtrRep rep = do
+          t <- appArr (recurse ty) (ptrs clos) ptr_i
+          return (ptr_i + 1, arr_i, t)
+      | otherwise = do
+          -- This is a bit involved since we allow packing multiple fields
+          -- within a single word. See also
+          -- StgCmmLayout.mkVirtHeapOffsetsWithPadding
+          dflags <- getDynFlags
+          let word_size = wORD_SIZE dflags
+              size_b = primRepSizeB dflags rep
+              -- Fields are always aligned.
+              !aligned_idx = roundUpTo arr_i size_b
+              !new_arr_i = aligned_idx + size_b
+              ws
+                  | size_b < word_size = [index size_b array aligned_idx]
+                  | otherwise =
+                      let (q, r) = size_b `quotRem` word_size
+                      in ASSERT( r == 0 )
+                         [ W# (indexWordArray# array i)
+                         | o <- [0.. q - 1]
+                         , let !(I# i) = (aligned_idx + o) `quot` word_size
+                         ]
+          return (ptr_i, new_arr_i, Prim ty ws)
 
     unboxedTupleTerm ty terms
       = Term ty (Right (tupleDataCon Unboxed (length terms)))
                 (error "unboxedTupleTerm: no HValue for unboxed tuple") terms
 
+    index item_size_b  array (I# index_b) =
+        case item_size_b of
+            -- indexWord*Array# functions take offsets dependent not in bytes,
+            -- but in multiples of an element's size.
+            1 -> W# (indexWord8Array# array index_b)
+            2 -> W# (indexWord16Array# array (index_b `quotInt#` 2#))
+            4 -> W# (indexWord32Array# array (index_b `quotInt#` 4#))
+            _ -> panic ("Weird byte-index: " ++ show (I# index_b))
+
 
 -- Fast, breadth-first Type reconstruction
 ------------------------------------------