Commit 488d63d6 authored by Simon Marlow's avatar Simon Marlow Committed by Ben Gamari

Fix interpreter with profiling

This was broken by D3746 and/or D3809, but unfortunately we didn't
notice because CI at the time wasn't building the profiling way.

Test Plan:
```
cd testsuite/test/profiling/should_run
make WAY=ghci-ext-prof
```

Reviewers: bgamari, michalt, hvr, erikd

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #14705

Differential Revision: https://phabricator.haskell.org/D4437
parent 1488591a
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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))
......
......@@ -39,7 +39,7 @@ test('T3001-2', [only_ways(['prof_hb']), extra_ways(['prof_hb'])],
# As with ioprof001, the unoptimised profile is different but
# not badly wrong (CAF attribution is different).
test('scc001',
[expect_broken_for_10037, expect_broken_for(14705, ['ghci-ext-prof'])],
[expect_broken_for_10037],
compile_and_run,
['-fno-state-hack -fno-full-laziness']) # Note [consistent stacks]
......@@ -108,9 +108,7 @@ test('callstack002',
['-fprof-auto-calls -fno-full-laziness -fno-state-hack'])
# Should not stack overflow with -prof -fprof-auto
test('T5363',
[expect_broken_for(14705, ['ghci-ext-prof'])],
compile_and_run, [''])
test('T5363', [], compile_and_run, [''])
test('profinline001', [], compile_and_run, [''])
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment