diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 13f908e84690e486bef8df30e679b5ca687fd249..5d47fd8908c49d747bc5ff55fb21b68c4d7833c7 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -113,7 +113,8 @@ cgTopRhsClosure dflags rec id ccs _ upd_flag args body =
-- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
; emitDataLits closure_label closure_rep
; let fv_details :: [(NonVoid Id, ByteOff)]
- (_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info) []
+ header = if isLFThunk lf_info then ThunkHeader else StdHeader
+ (_, _, fv_details) = mkVirtHeapOffsets dflags header []
-- Don't drop the non-void args until the closure info has been made
; forkClosureBody (closureCodeBody True id closure_info ccs
(nonVoidIds args) (length args) body fv_details)
@@ -350,9 +351,9 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body
; let name = idName bndr
descr = closureDescription dflags mod_name name
fv_details :: [(NonVoid Id, ByteOff)]
+ header = if isLFThunk lf_info then ThunkHeader else StdHeader
(tot_wds, ptr_wds, fv_details)
- = mkVirtHeapOffsets dflags (isLFThunk lf_info)
- (addIdReps reduced_fvs)
+ = mkVirtHeapOffsets dflags header (addIdReps reduced_fvs)
closure_info = mkClosureInfo dflags False -- Not static
bndr lf_info tot_wds ptr_wds
descr
@@ -395,9 +396,10 @@ cgRhsStdThunk bndr lf_info payload
{ -- LAY OUT THE OBJECT
mod_name <- getModuleName
; dflags <- getDynFlags
- ; let (tot_wds, ptr_wds, payload_w_offsets)
- = mkVirtHeapOffsets dflags (isLFThunk lf_info)
- (addArgReps (nonVoidStgArgs payload))
+ ; let header = if isLFThunk lf_info then ThunkHeader else StdHeader
+ (tot_wds, ptr_wds, payload_w_offsets)
+ = mkVirtHeapOffsets dflags header
+ (addArgReps (nonVoidStgArgs payload))
descr = closureDescription dflags mod_name (idName bndr)
closure_info = mkClosureInfo dflags False -- Not static
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index a38f7bce3737df2b1fc6eeef04f597e04c0bba55..c0a57627c84dbbf06a4a426aa1887b4eb02950a1 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -79,11 +79,10 @@ cgTopRhsCon dflags id con args =
-- LAY IT OUT
; let
- is_thunk = False
(tot_wds, -- #ptr_wds + #nonptr_wds
ptr_wds, -- #ptr_wds
nv_args_w_offsets) =
- mkVirtHeapOffsetsWithPadding dflags is_thunk (addArgReps args)
+ mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args)
mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
mk_payload (FieldOff arg _) = do
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 5111b93bc595ebc01643dfbcd29d0b5b65fb04da..a0a64e5f2a242784736dba7764dfd11c7f2f8ba8 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -19,6 +19,7 @@ module StgCmmLayout (
slowCall, directCall,
FieldOffOrPadding(..),
+ ClosureHeader(..),
mkVirtHeapOffsets,
mkVirtHeapOffsetsWithPadding,
mkVirtConstrOffsets,
@@ -399,9 +400,17 @@ data FieldOffOrPadding a
| Padding ByteOff -- Length of padding in bytes.
ByteOff -- Offset in bytes.
+-- | Used to tell the various @mkVirtHeapOffsets@ functions what kind
+-- of header the object has. This will be accounted for in the
+-- offsets of the fields returned.
+data ClosureHeader
+ = NoHeader
+ | StdHeader
+ | ThunkHeader
+
mkVirtHeapOffsetsWithPadding
:: DynFlags
- -> Bool -- True <=> is a thunk
+ -> ClosureHeader -- What kind of header to account for
-> [NonVoid (PrimRep, a)] -- Things to make offsets for
-> ( WordOff -- Total number of words allocated
, WordOff -- Number of words allocated for *pointers*
@@ -415,15 +424,17 @@ mkVirtHeapOffsetsWithPadding
-- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets
-- than the unboxed things
-mkVirtHeapOffsetsWithPadding dflags is_thunk things =
+mkVirtHeapOffsetsWithPadding dflags header things =
ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))
( tot_wds
, bytesToWordsRoundUp dflags bytes_of_ptrs
, concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad
)
where
- hdr_words | is_thunk = thunkHdrSize dflags
- | otherwise = fixedHdrSizeW dflags
+ hdr_words = case header of
+ NoHeader -> 0
+ StdHeader -> fixedHdrSizeW dflags
+ ThunkHeader -> thunkHdrSize dflags
hdr_bytes = wordsToBytes dflags hdr_words
(ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things
@@ -472,25 +483,25 @@ mkVirtHeapOffsetsWithPadding dflags is_thunk things =
mkVirtHeapOffsets
:: DynFlags
- -> Bool -- True <=> is a thunk
+ -> ClosureHeader -- What kind of header to account for
-> [NonVoid (PrimRep,a)] -- Things to make offsets for
-> (WordOff, -- _Total_ number of words allocated
WordOff, -- Number of words allocated for *pointers*
[(NonVoid a, ByteOff)])
-mkVirtHeapOffsets dflags is_thunk things =
+mkVirtHeapOffsets dflags header things =
( tot_wds
, ptr_wds
, [ (field, offset) | (FieldOff field offset) <- things_offsets ]
)
where
(tot_wds, ptr_wds, things_offsets) =
- mkVirtHeapOffsetsWithPadding dflags is_thunk things
+ mkVirtHeapOffsetsWithPadding dflags header things
-- | Just like mkVirtHeapOffsets, but for constructors
mkVirtConstrOffsets
:: DynFlags -> [NonVoid (PrimRep, a)]
-> (WordOff, WordOff, [(NonVoid a, ByteOff)])
-mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False
+mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags StdHeader
-- | Just like mkVirtConstrOffsets, but used when we don't have the actual
-- arguments. Useful when e.g. generating info tables; we just need to know
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index 13cb83df14b6299ec0481602ec3b41314e18350a..90fcb6d2caf977679703e8c42641d0e5b2cbb989 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -47,9 +47,7 @@ import Unique
import FastString
import Panic
import StgCmmClosure ( NonVoid(..), fromNonVoid, nonVoidIds )
-import StgCmmLayout ( ArgRep(..), FieldOffOrPadding(..),
- toArgRep, argRepSizeW,
- mkVirtHeapOffsetsWithPadding, mkVirtConstrOffsets )
+import StgCmmLayout
import SMRep hiding (WordOff, ByteOff, wordsToBytes)
import Bitmap
import OrdList
@@ -801,9 +799,8 @@ mkConAppCode orig_d _ p con args_r_to_l =
, let prim_rep = atomPrimRep arg
, not (isVoidRep prim_rep)
]
- is_thunk = False
(_, _, args_offsets) =
- mkVirtHeapOffsetsWithPadding dflags is_thunk non_voids
+ mkVirtHeapOffsetsWithPadding dflags StdHeader non_voids
do_pushery !d (arg : args) = do
(push, arg_bytes) <- case arg of
@@ -970,7 +967,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- algebraic alt with some binders
| otherwise =
let (tot_wds, _ptrs_wds, args_offsets) =
- mkVirtConstrOffsets dflags
+ mkVirtHeapOffsets dflags NoHeader
[ NonVoid (bcIdPrimRep id, id)
| NonVoid id <- nonVoidIds real_bndrs
]
@@ -980,7 +977,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- convert offsets from Sp into offsets into the virtual stack
p' = Map.insertList
- [ (arg, stack_bot + wordSize dflags - ByteOff offset)
+ [ (arg, stack_bot - ByteOff offset)
| (NonVoid arg, offset) <- args_offsets ]
p_alts
in do
diff --git a/testsuite/tests/codeGen/should_run/T13825-unit.hs b/testsuite/tests/codeGen/should_run/T13825-unit.hs
index bd3d7fbb3300df04ae648b1b195fe3f4d78e1034..1197dc60fe6f32bc23fdc1e81deb677e1c895fb7 100644
--- a/testsuite/tests/codeGen/should_run/T13825-unit.hs
+++ b/testsuite/tests/codeGen/should_run/T13825-unit.hs
@@ -69,7 +69,7 @@ assert_32_64 actual expected32 expected64 = do
runTest :: [(a, PrimRep)] -> Ghc (WordOff , WordOff, [FieldOffOrPadding a])
runTest prim_reps = do
dflags <- getDynFlags
- return $ mkVirtHeapOffsetsWithPadding dflags False (mkNonVoids prim_reps)
+ return $ mkVirtHeapOffsetsWithPadding dflags StdHeader (mkNonVoids prim_reps)
where
mkNonVoids = map (\(a, prim_rep) -> NonVoid (prim_rep, a))