Represent offsets into heap objects with byte, not word, offsets

I'd like to be able to pack together non-pointer fields that are less
than a word in size, and this is a necessary prerequisite.

5 files changed, 40 insertions, 29 deletions

diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 4531903228..c29f47c7f4 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -286,7 +286,8 @@ mkRhsClosure    dflags bndr _cc _bi
                                -- Just want the layout
     maybe_offset          = assocMaybe params_w_offsets (NonVoid selectee)
     Just the_offset       = maybe_offset
-    offset_into_int       = the_offset - fixedHdrSize dflags
+    offset_into_int       = bytesToWordsRoundUp dflags the_offset
+                             - fixedHdrSize dflags
 
 ---------- Note [Ap thunks] ------------------
 mkRhsClosure    dflags bndr _cc _bi
@@ -341,7 +342,7 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body
         ; dflags <- getDynFlags
         ; let   name  = idName bndr
                 descr = closureDescription dflags mod_name name
-                fv_details :: [(NonVoid Id, VirtualHpOffset)]
+                fv_details :: [(NonVoid Id, ByteOff)]
                 (tot_wds, ptr_wds, fv_details)
                    = mkVirtHeapOffsets dflags (isLFThunk lf_info)
                                        (addIdReps (map unsafe_stripNV reduced_fvs))
@@ -434,7 +435,7 @@ closureCodeBody :: Bool            -- whether this is a top-level binding
                 -> [NonVoid Id]    -- incoming args to the closure
                 -> Int             -- arity, including void args
                 -> StgExpr
-                -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free vars
+                -> [(NonVoid Id, ByteOff)] -- the closure's free vars
                 -> FCode ()
 
 {- There are two main cases for the code for closures.
@@ -514,10 +515,10 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
 
 -- A function closure pointer may be tagged, so we
 -- must take it into account when accessing the free variables.
-bind_fv :: (NonVoid Id, VirtualHpOffset) -> FCode (LocalReg, WordOff)
+bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
 bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
 
-load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode ()
+load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
 load_fvs node lf_info = mapM_ (\ (reg, off) ->
    do dflags <- getDynFlags
       let tag = lfDynTag dflags lf_info
@@ -551,7 +552,7 @@ mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
   | otherwise = return ()
 
 -----------------------------------------
-thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack
+thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack
           -> LocalReg -> Int -> StgExpr -> FCode ()
 thunkCode cl_info fv_details _cc node arity body
   = do { dflags <- getDynFlags
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index eb00bbf0c0..b6bcf6912b 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -21,6 +21,7 @@ import CoreSyn  ( AltCon(..) )
 import StgCmmMonad
 import StgCmmEnv
 import StgCmmHeap
+import StgCmmLayout
 import StgCmmUtils
 import StgCmmClosure
 import StgCmmProf ( curCCS )
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 077b7809b5..75ad8b40f4 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -14,7 +14,6 @@ module StgCmmHeap (
         heapStackCheckGen,
         entryHeapCheck',
 
-        mkVirtHeapOffsets, mkVirtConstrOffsets,
         mkStaticClosureFields, mkStaticClosure,
 
         allocDynClosure, allocDynClosureCmm,
@@ -68,7 +67,7 @@ allocDynClosure
 
 allocDynClosureCmm
         :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
-        -> [(CmmExpr, VirtualHpOffset)]
+        -> [(CmmExpr, ByteOff)]
         -> FCode CmmExpr -- returns Hp+n
 
 -- allocDynClosure allocates the thing in the heap,
@@ -130,18 +129,18 @@ allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets
 emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
 emitSetDynHdr base info_ptr ccs
   = do dflags <- getDynFlags
-       hpStore base (header dflags) [0..]
+       hpStore base (header dflags) [0, wORD_SIZE dflags ..]
   where
     header :: DynFlags -> [CmmExpr]
     header dflags = [info_ptr] ++ dynProfHdr dflags ccs
         -- ToDof: Parallel stuff
         -- No ticky header
 
-hpStore :: CmmExpr -> [CmmExpr] -> [VirtualHpOffset] -> FCode ()
+hpStore :: CmmExpr -> [CmmExpr] -> [ByteOff] -> FCode ()
 -- Store the item (expr,off) in base[off]
 hpStore base vals offs
   = do dflags <- getDynFlags
-       let mk_store val off = mkStore (cmmOffsetW dflags base off) val
+       let mk_store val off = mkStore (cmmOffsetB dflags base off) val
        emit (catAGraphs (zipWith mk_store vals offs))
 
 
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 54e2e920f9..7fbcbced81 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -384,7 +384,7 @@ mkVirtHeapOffsets
   -> [(PrimRep,a)]        -- Things to make offsets for
   -> (WordOff,                -- _Total_ number of words allocated
       WordOff,                -- Number of words allocated for *pointers*
-      [(NonVoid a, VirtualHpOffset)])
+      [(NonVoid a, ByteOff)])
 
 -- Things with their offsets from start of object in order of
 -- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER
@@ -397,22 +397,31 @@ mkVirtHeapOffsets
 -- than the unboxed things
 
 mkVirtHeapOffsets dflags is_thunk things
-  = let non_void_things               = filterOut (isVoidRep . fst)  things
-        (ptrs, non_ptrs)              = partition (isGcPtrRep . fst) non_void_things
-        (wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
-        (tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
-    in
-    (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
+  = ( bytesToWordsRoundUp dflags tot_bytes
+    , bytesToWordsRoundUp dflags bytes_of_ptrs
+    , ptrs_w_offsets ++ non_ptrs_w_offsets
+    )
   where
-    hdr_size | is_thunk   = thunkHdrSize dflags
-             | otherwise  = fixedHdrSize dflags
-
-    computeOffset wds_so_far (rep, thing)
-      = (wds_so_far + argRepSizeW dflags (toArgRep rep),
-         (NonVoid thing, hdr_size + wds_so_far))
-
-mkVirtConstrOffsets :: DynFlags -> [(PrimRep,a)] -> (WordOff, WordOff, [(NonVoid a, VirtualHpOffset)])
--- Just like mkVirtHeapOffsets, but for constructors
+    hdr_words | is_thunk   = thunkHdrSize dflags
+              | otherwise  = fixedHdrSize dflags
+    hdr_bytes = wordsToBytes dflags hdr_words
+
+    non_void_things    = filterOut (isVoidRep . fst)  things
+    (ptrs, non_ptrs)   = partition (isGcPtrRep . fst) non_void_things
+
+    (bytes_of_ptrs, ptrs_w_offsets) =
+       mapAccumL computeOffset 0 ptrs
+    (tot_bytes, non_ptrs_w_offsets) =
+       mapAccumL computeOffset bytes_of_ptrs non_ptrs
+
+    computeOffset bytes_so_far (rep, thing)
+      = (bytes_so_far + wordsToBytes dflags (argRepSizeW dflags (toArgRep rep)),
+         (NonVoid thing, hdr_bytes + bytes_so_far))
+
+-- | Just like mkVirtHeapOffsets, but for constructors
+mkVirtConstrOffsets
+  :: DynFlags -> [(PrimRep,a)]
+  -> (WordOff, WordOff, [(NonVoid a, ByteOff)])
 mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False
 
 
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 45b0f0c785..1c6c3f2eae 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -142,7 +142,8 @@ addToMemE rep ptr n
 --
 -------------------------------------------------------------------------
 
-mkTaggedObjectLoad :: DynFlags -> LocalReg -> LocalReg -> WordOff -> DynTag -> CmmAGraph
+mkTaggedObjectLoad
+  :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
 -- (loadTaggedObjectField reg base off tag) generates assignment
 --      reg = bitsK[ base + off - tag ]
 -- where K is fixed by 'reg'
@@ -150,7 +151,7 @@ mkTaggedObjectLoad dflags reg base offset tag
   = mkAssign (CmmLocal reg)
              (CmmLoad (cmmOffsetB dflags
                                   (CmmReg (CmmLocal base))
-                                  (wORD_SIZE dflags * offset - tag))
+                                  (offset - tag))
                       (localRegType reg))
 
 -------------------------------------------------------------------------