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 = ...@@ -113,7 +113,8 @@ cgTopRhsClosure dflags rec id ccs _ upd_flag args body =
-- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
; emitDataLits closure_label closure_rep ; emitDataLits closure_label closure_rep
; let fv_details :: [(NonVoid Id, ByteOff)] ; 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 -- Don't drop the non-void args until the closure info has been made
; forkClosureBody (closureCodeBody True id closure_info ccs ; forkClosureBody (closureCodeBody True id closure_info ccs
(nonVoidIds args) (length args) body fv_details) (nonVoidIds args) (length args) body fv_details)
...@@ -350,9 +351,9 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body ...@@ -350,9 +351,9 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body
; let name = idName bndr ; let name = idName bndr
descr = closureDescription dflags mod_name name descr = closureDescription dflags mod_name name
fv_details :: [(NonVoid Id, ByteOff)] fv_details :: [(NonVoid Id, ByteOff)]
header = if isLFThunk lf_info then ThunkHeader else StdHeader
(tot_wds, ptr_wds, fv_details) (tot_wds, ptr_wds, fv_details)
= mkVirtHeapOffsets dflags (isLFThunk lf_info) = mkVirtHeapOffsets dflags header (addIdReps reduced_fvs)
(addIdReps reduced_fvs)
closure_info = mkClosureInfo dflags False -- Not static closure_info = mkClosureInfo dflags False -- Not static
bndr lf_info tot_wds ptr_wds bndr lf_info tot_wds ptr_wds
descr descr
...@@ -395,9 +396,10 @@ cgRhsStdThunk bndr lf_info payload ...@@ -395,9 +396,10 @@ cgRhsStdThunk bndr lf_info payload
{ -- LAY OUT THE OBJECT { -- LAY OUT THE OBJECT
mod_name <- getModuleName mod_name <- getModuleName
; dflags <- getDynFlags ; dflags <- getDynFlags
; let (tot_wds, ptr_wds, payload_w_offsets) ; let header = if isLFThunk lf_info then ThunkHeader else StdHeader
= mkVirtHeapOffsets dflags (isLFThunk lf_info) (tot_wds, ptr_wds, payload_w_offsets)
(addArgReps (nonVoidStgArgs payload)) = mkVirtHeapOffsets dflags header
(addArgReps (nonVoidStgArgs payload))
descr = closureDescription dflags mod_name (idName bndr) descr = closureDescription dflags mod_name (idName bndr)
closure_info = mkClosureInfo dflags False -- Not static closure_info = mkClosureInfo dflags False -- Not static
......
...@@ -79,11 +79,10 @@ cgTopRhsCon dflags id con args = ...@@ -79,11 +79,10 @@ cgTopRhsCon dflags id con args =
-- LAY IT OUT -- LAY IT OUT
; let ; let
is_thunk = False
(tot_wds, -- #ptr_wds + #nonptr_wds (tot_wds, -- #ptr_wds + #nonptr_wds
ptr_wds, -- #ptr_wds ptr_wds, -- #ptr_wds
nv_args_w_offsets) = 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 (Padding len _) = return (CmmInt 0 (widthFromBytes len))
mk_payload (FieldOff arg _) = do mk_payload (FieldOff arg _) = do
......
...@@ -19,6 +19,7 @@ module StgCmmLayout ( ...@@ -19,6 +19,7 @@ module StgCmmLayout (
slowCall, directCall, slowCall, directCall,
FieldOffOrPadding(..), FieldOffOrPadding(..),
ClosureHeader(..),
mkVirtHeapOffsets, mkVirtHeapOffsets,
mkVirtHeapOffsetsWithPadding, mkVirtHeapOffsetsWithPadding,
mkVirtConstrOffsets, mkVirtConstrOffsets,
...@@ -398,9 +399,17 @@ data FieldOffOrPadding a ...@@ -398,9 +399,17 @@ data FieldOffOrPadding a
| Padding ByteOff -- Length of padding in bytes. | Padding ByteOff -- Length of padding in bytes.
ByteOff -- Offset 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 mkVirtHeapOffsetsWithPadding
:: DynFlags :: DynFlags
-> Bool -- True <=> is a thunk -> ClosureHeader -- What kind of header to account for
-> [NonVoid (PrimRep, a)] -- Things to make offsets for -> [NonVoid (PrimRep, a)] -- Things to make offsets for
-> ( WordOff -- Total number of words allocated -> ( WordOff -- Total number of words allocated
, WordOff -- Number of words allocated for *pointers* , WordOff -- Number of words allocated for *pointers*
...@@ -414,15 +423,17 @@ mkVirtHeapOffsetsWithPadding ...@@ -414,15 +423,17 @@ mkVirtHeapOffsetsWithPadding
-- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets -- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets
-- than the unboxed things -- than the unboxed things
mkVirtHeapOffsetsWithPadding dflags is_thunk things = mkVirtHeapOffsetsWithPadding dflags header things =
ASSERT(not (any (isVoidRep . fst . fromNonVoid) things)) ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))
( tot_wds ( tot_wds
, bytesToWordsRoundUp dflags bytes_of_ptrs , bytesToWordsRoundUp dflags bytes_of_ptrs
, concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad
) )
where where
hdr_words | is_thunk = thunkHdrSize dflags hdr_words = case header of
| otherwise = fixedHdrSizeW dflags NoHeader -> 0
StdHeader -> fixedHdrSizeW dflags
ThunkHeader -> thunkHdrSize dflags
hdr_bytes = wordsToBytes dflags hdr_words hdr_bytes = wordsToBytes dflags hdr_words
(ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things
...@@ -471,25 +482,25 @@ mkVirtHeapOffsetsWithPadding dflags is_thunk things = ...@@ -471,25 +482,25 @@ mkVirtHeapOffsetsWithPadding dflags is_thunk things =
mkVirtHeapOffsets mkVirtHeapOffsets
:: DynFlags :: DynFlags
-> Bool -- True <=> is a thunk -> ClosureHeader -- What kind of header to account for
-> [NonVoid (PrimRep,a)] -- Things to make offsets for -> [NonVoid (PrimRep,a)] -- Things to make offsets for
-> (WordOff, -- _Total_ number of words allocated -> (WordOff, -- _Total_ number of words allocated
WordOff, -- Number of words allocated for *pointers* WordOff, -- Number of words allocated for *pointers*
[(NonVoid a, ByteOff)]) [(NonVoid a, ByteOff)])
mkVirtHeapOffsets dflags is_thunk things = mkVirtHeapOffsets dflags header things =
( tot_wds ( tot_wds
, ptr_wds , ptr_wds
, [ (field, offset) | (FieldOff field offset) <- things_offsets ] , [ (field, offset) | (FieldOff field offset) <- things_offsets ]
) )
where where
(tot_wds, ptr_wds, things_offsets) = (tot_wds, ptr_wds, things_offsets) =
mkVirtHeapOffsetsWithPadding dflags is_thunk things mkVirtHeapOffsetsWithPadding dflags header things
-- | Just like mkVirtHeapOffsets, but for constructors -- | Just like mkVirtHeapOffsets, but for constructors
mkVirtConstrOffsets mkVirtConstrOffsets
:: DynFlags -> [NonVoid (PrimRep, a)] :: DynFlags -> [NonVoid (PrimRep, a)]
-> (WordOff, WordOff, [(NonVoid a, ByteOff)]) -> (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 -- | 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 -- arguments. Useful when e.g. generating info tables; we just need to know
......
...@@ -47,9 +47,7 @@ import Unique ...@@ -47,9 +47,7 @@ import Unique
import FastString import FastString
import Panic import Panic
import StgCmmClosure ( NonVoid(..), fromNonVoid, nonVoidIds ) import StgCmmClosure ( NonVoid(..), fromNonVoid, nonVoidIds )
import StgCmmLayout ( ArgRep(..), FieldOffOrPadding(..), import StgCmmLayout
toArgRep, argRepSizeW,
mkVirtHeapOffsetsWithPadding, mkVirtConstrOffsets )
import SMRep hiding (WordOff, ByteOff, wordsToBytes) import SMRep hiding (WordOff, ByteOff, wordsToBytes)
import Bitmap import Bitmap
import OrdList import OrdList
...@@ -801,9 +799,8 @@ mkConAppCode orig_d _ p con args_r_to_l = ...@@ -801,9 +799,8 @@ mkConAppCode orig_d _ p con args_r_to_l =
, let prim_rep = atomPrimRep arg , let prim_rep = atomPrimRep arg
, not (isVoidRep prim_rep) , not (isVoidRep prim_rep)
] ]
is_thunk = False
(_, _, args_offsets) = (_, _, args_offsets) =
mkVirtHeapOffsetsWithPadding dflags is_thunk non_voids mkVirtHeapOffsetsWithPadding dflags StdHeader non_voids
do_pushery !d (arg : args) = do do_pushery !d (arg : args) = do
(push, arg_bytes) <- case arg of (push, arg_bytes) <- case arg of
...@@ -970,7 +967,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple ...@@ -970,7 +967,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- algebraic alt with some binders -- algebraic alt with some binders
| otherwise = | otherwise =
let (tot_wds, _ptrs_wds, args_offsets) = let (tot_wds, _ptrs_wds, args_offsets) =
mkVirtConstrOffsets dflags mkVirtHeapOffsets dflags NoHeader
[ NonVoid (bcIdPrimRep id, id) [ NonVoid (bcIdPrimRep id, id)
| NonVoid id <- nonVoidIds real_bndrs | NonVoid id <- nonVoidIds real_bndrs
] ]
...@@ -980,7 +977,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple ...@@ -980,7 +977,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
-- convert offsets from Sp into offsets into the virtual stack -- convert offsets from Sp into offsets into the virtual stack
p' = Map.insertList p' = Map.insertList
[ (arg, stack_bot + wordSize dflags - ByteOff offset) [ (arg, stack_bot - ByteOff offset)
| (NonVoid arg, offset) <- args_offsets ] | (NonVoid arg, offset) <- args_offsets ]
p_alts p_alts
in do in do
......
...@@ -69,7 +69,7 @@ assert_32_64 actual expected32 expected64 = do ...@@ -69,7 +69,7 @@ assert_32_64 actual expected32 expected64 = do
runTest :: [(a, PrimRep)] -> Ghc (WordOff , WordOff, [FieldOffOrPadding a]) runTest :: [(a, PrimRep)] -> Ghc (WordOff , WordOff, [FieldOffOrPadding a])
runTest prim_reps = do runTest prim_reps = do
dflags <- getDynFlags dflags <- getDynFlags
return $ mkVirtHeapOffsetsWithPadding dflags False (mkNonVoids prim_reps) return $ mkVirtHeapOffsetsWithPadding dflags StdHeader (mkNonVoids prim_reps)
where where
mkNonVoids = map (\(a, prim_rep) -> NonVoid (prim_rep, a)) mkNonVoids = map (\(a, prim_rep) -> NonVoid (prim_rep, a))
......
...@@ -39,7 +39,7 @@ test('T3001-2', [only_ways(['prof_hb']), extra_ways(['prof_hb'])], ...@@ -39,7 +39,7 @@ test('T3001-2', [only_ways(['prof_hb']), extra_ways(['prof_hb'])],
# As with ioprof001, the unoptimised profile is different but # As with ioprof001, the unoptimised profile is different but
# not badly wrong (CAF attribution is different). # not badly wrong (CAF attribution is different).
test('scc001', test('scc001',
[expect_broken_for_10037, expect_broken_for(14705, ['ghci-ext-prof'])], [expect_broken_for_10037],
compile_and_run, compile_and_run,
['-fno-state-hack -fno-full-laziness']) # Note [consistent stacks] ['-fno-state-hack -fno-full-laziness']) # Note [consistent stacks]
...@@ -108,9 +108,7 @@ test('callstack002', ...@@ -108,9 +108,7 @@ test('callstack002',
['-fprof-auto-calls -fno-full-laziness -fno-state-hack']) ['-fprof-auto-calls -fno-full-laziness -fno-state-hack'])
# Should not stack overflow with -prof -fprof-auto # Should not stack overflow with -prof -fprof-auto
test('T5363', test('T5363', [], compile_and_run, [''])
[expect_broken_for(14705, ['ghci-ext-prof'])],
compile_and_run, [''])
test('profinline001', [], 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