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

6 files changed, 35 insertions, 28 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
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index 13cb83df14..90fcb6d2ca 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 bd3d7fbb33..1197dc60fe 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))
 
diff --git a/testsuite/tests/profiling/should_run/all.T b/testsuite/tests/profiling/should_run/all.T
index 4c4822c526..03332f6097 100644
--- a/testsuite/tests/profiling/should_run/all.T
+++ b/testsuite/tests/profiling/should_run/all.T
@@ -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, [''])