diff options
Diffstat (limited to 'compiler/codeGen')
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 14 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmCon.hs | 3 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmLayout.hs | 27 |
3 files changed, 28 insertions, 16 deletions
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index cf602ef0b8..9ef552d336 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 197291006b..8dadb4ede7 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 95828ad4c6..78a7cf3f85 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -19,6 +19,7 @@ module StgCmmLayout ( slowCall, directCall, FieldOffOrPadding(..), + ClosureHeader(..), mkVirtHeapOffsets, mkVirtHeapOffsetsWithPadding, mkVirtConstrOffsets, @@ -398,9 +399,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* @@ -414,15 +423,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 @@ -471,25 +482,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 |