[Git][ghc/ghc][wip/fendor/ann-frame] WIP: move iterator based stack decoder to ghc-internal

21 Jul 2025

Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC


Commits:
f2e641b5 by fendor at 2025-07-21T12:28:50+02:00
WIP: move iterator based stack decoder to ghc-internal

- - - - -


19 changed files:

- libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs
- libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs
- + libraries/ghc-internal/cbits/HeapPrim.cmm
- + libraries/ghc-internal/cbits/Stack.cmm
- + libraries/ghc-internal/cbits/Stack_c.c
- libraries/ghc-internal/ghc-internal.cabal.in
- libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
- + libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
- + libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc
- + libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc
- + libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc
- + libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc
- + libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs
- + libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
- + libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc
- + libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs


Changes:

=====================================
libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs
=====================================
@@ -23,28 +23,7 @@ import Data.Typeable
 import GHC.Exts
 import GHC.IO
 import GHC.Internal.Stack
-

--- ----------------------------------------------------------------------------
--- IsStackAnnotation
--- ----------------------------------------------------------------------------
-
-class IsStackAnnotation a where
-  displayStackAnnotation :: a -> String
-
--- ----------------------------------------------------------------------------
--- Annotations
--- ----------------------------------------------------------------------------
-
-{- |
-The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy.
-When the call stack is annotated with a value of type @a@, behind the scenes it is
-encapsulated in a @SomeStackAnnotation@.
--}
-data SomeStackAnnotation where
-  SomeStackAnnotation :: forall a. (Typeable a, IsStackAnnotation a) => a -> SomeStackAnnotation
-
-instance IsStackAnnotation SomeStackAnnotation where
-  displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a
+import GHC.Internal.Stack.Annotation
 
 data StringAnnotation where
   StringAnnotation :: String -> StringAnnotation


=====================================
libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
=====================================
@@ -24,10 +24,10 @@ import Data.Bits
 import Data.Maybe
 import Foreign
 import GHC.Exts
-import GHC.Exts.Heap (Box (..))
 import GHC.Exts.Heap.ClosureTypes
 import GHC.Exts.Heap.Closures
-  ( StackFrame,
+  ( Box (..),
+    StackFrame,
     GenStackFrame (..),
     StgStackClosure,
     GenStgStackClosure (..),


=====================================
libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs
=====================================
@@ -14,7 +14,7 @@ hello x y = annotateShow (x,y) $
 
 {-# NOINLINE decodeAndPrintAnnotationFrames #-}
 decodeAndPrintAnnotationFrames :: a -> a
-decodeAndPrintAnnotationFrames a = unsafePerformIO $ do
+decodeAndPrintAnnotationFrames !a = unsafePerformIO $ do
   stack <- GHC.Stack.CloneStack.cloneMyStack
   decoded <- GHC.Exts.Stack.Decode.decodeStack stack
   print [ displayStackAnnotation a


=====================================
libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs
=====================================
@@ -1,6 +1,4 @@
-
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -ddump-to-file -ddump-stg-final -ddump-simpl -dsuppress-all #-}
 import Control.Monad
 import GHC.Stack.Types
 import Control.Exception
@@ -9,21 +7,8 @@ import GHC.Stack.Annotation.Experimental
 
 main :: IO ()
 main = do
-  setBacktraceMechanismState IPEBacktrace True
-  -- foo baz
   bar
 
-foo :: HasCallStack => IO () -> IO ()
-foo act = annotateCallStackM $ do
-  putStrLn "Start some work"
-  act
-  putStrLn "Finish some work"
-
-baz :: HasCallStack => IO ()
-baz = annotateCallStackM $ do
-  print (fib 20)
-  throwIO $ ErrorCall "baz is interrupted"
-
 bar :: IO ()
 bar = annotateCallStackM $ annotateStringM "bar" $ do
   putStrLn "Some more work in bar"


=====================================
libraries/ghc-internal/cbits/HeapPrim.cmm
=====================================
@@ -0,0 +1,13 @@
+#include "Cmm.h"
+
+aToWordzh (P_ clos)
+{
+    return (clos);
+}
+
+reallyUnsafePtrEqualityUpToTag (W_ clos1, W_  clos2)
+{
+    clos1 = UNTAG(clos1);
+    clos2 = UNTAG(clos2);
+    return (clos1 == clos2);
+}


=====================================
libraries/ghc-internal/cbits/Stack.cmm
=====================================
@@ -0,0 +1,182 @@
+// Uncomment to enable assertions during development
+// #define DEBUG 1
+
+#include "Cmm.h"
+
+// StgStack_marking was not available in the Stage0 compiler at the time of
+// writing. Because, it has been added to derivedConstants when Stack.cmm was
+// developed.
+#if defined(StgStack_marking)
+
+// Returns the next stackframe's StgStack* and offset in it. And, an indicator
+// if this frame is the last one (`hasNext` bit.)
+// (StgStack*, StgWord, StgWord) advanceStackFrameLocationzh(StgStack* stack, StgWord offsetWords)
+advanceStackFrameLocationzh (P_ stack, W_ offsetWords) {
+  W_ frameSize;
+  (frameSize) = ccall stackFrameSize(stack, offsetWords);
+
+  P_ nextClosurePtr;
+  nextClosurePtr = (StgStack_sp(stack) + WDS(offsetWords) + WDS(frameSize));
+
+  P_ stackArrayPtr;
+  stackArrayPtr = stack + SIZEOF_StgHeader + OFFSET_StgStack_stack;
+
+  P_ stackBottom;
+  W_ stackSize, stackSizeInBytes;
+  stackSize = TO_W_(StgStack_stack_size(stack));
+  stackSizeInBytes = WDS(stackSize);
+  stackBottom = stackSizeInBytes + stackArrayPtr;
+
+  P_ newStack;
+  W_ newOffsetWords, hasNext;
+  if(nextClosurePtr < stackBottom) (likely: True) {
+    newStack = stack;
+    newOffsetWords = offsetWords + frameSize;
+    hasNext = 1;
+  } else {
+    P_ underflowFrameStack;
+    (underflowFrameStack) = ccall getUnderflowFrameStack(stack, offsetWords);
+    if (underflowFrameStack == NULL) (likely: True) {
+      newStack = NULL;
+      newOffsetWords = NULL;
+      hasNext = NULL;
+    } else {
+      newStack = underflowFrameStack;
+      newOffsetWords = NULL;
+      hasNext = 1;
+    }
+  }
+
+  return (newStack, newOffsetWords, hasNext);
+}
+
+// (StgWord, StgWord) getSmallBitmapzh(StgStack* stack, StgWord offsetWords)
+getSmallBitmapzh(P_ stack, W_ offsetWords) {
+  P_ c;
+  c = StgStack_sp(stack) + WDS(offsetWords);
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  W_ bitmap, size;
+  (bitmap) = ccall getBitmapWord(c);
+  (size) = ccall getBitmapSize(c);
+
+  return (bitmap, size);
+}
+
+
+// (StgWord, StgWord) getRetFunSmallBitmapzh(StgStack* stack, StgWord offsetWords)
+getRetFunSmallBitmapzh(P_ stack, W_ offsetWords) {
+  P_ c;
+  c = StgStack_sp(stack) + WDS(offsetWords);
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  W_ bitmap, size, specialType;
+  (bitmap) = ccall getRetFunBitmapWord(c);
+  (size) = ccall getRetFunBitmapSize(c);
+
+  return (bitmap, size);
+}
+
+// (StgWord*, StgWord) getLargeBitmapzh(StgStack* stack, StgWord offsetWords)
+getLargeBitmapzh(P_ stack, W_ offsetWords) {
+  P_ c, words;
+  W_ size;
+  c = StgStack_sp(stack) + WDS(offsetWords);
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  (words) = ccall getLargeBitmap(MyCapability(), c);
+  (size) = ccall getLargeBitmapSize(c);
+
+  return (words, size);
+}
+
+// (StgWord*, StgWord) getBCOLargeBitmapzh(StgStack* stack, StgWord offsetWords)
+getBCOLargeBitmapzh(P_ stack, W_ offsetWords) {
+  P_ c, words;
+  W_ size;
+  c = StgStack_sp(stack) + WDS(offsetWords);
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  (words) = ccall getBCOLargeBitmap(MyCapability(), c);
+  (size) = ccall getBCOLargeBitmapSize(c);
+
+  return (words, size);
+}
+
+// (StgWord*, StgWord) getRetFunLargeBitmapzh(StgStack* stack, StgWord offsetWords)
+getRetFunLargeBitmapzh(P_ stack, W_ offsetWords) {
+  P_ c, words;
+  W_ size;
+  c = StgStack_sp(stack) + WDS(offsetWords);
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  (words) = ccall getRetFunLargeBitmap(MyCapability(), c);
+  (size) = ccall getRetFunSize(c);
+
+  return (words, size);
+}
+
+// (StgWord) getWordzh(StgStack* stack, StgWord offsetWords)
+getWordzh(P_ stack, W_ offsetWords) {
+  P_ wordAddr;
+  wordAddr = (StgStack_sp(stack) + WDS(offsetWords));
+  return (W_[wordAddr]);
+}
+
+// (StgStack*) getUnderflowFrameNextChunkzh(StgStack* stack, StgWord offsetWords)
+getUnderflowFrameNextChunkzh(P_ stack, W_ offsetWords) {
+  P_ closurePtr;
+  closurePtr = (StgStack_sp(stack) + WDS(offsetWords));
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(closurePtr));
+
+  P_ next_chunk;
+  (next_chunk) = ccall getUnderflowFrameNextChunk(closurePtr);
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(next_chunk));
+  return (next_chunk);
+}
+
+// (StgWord) getRetFunTypezh(StgStack* stack, StgWord offsetWords)
+isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) {
+  P_ c;
+  c = StgStack_sp(stack) + WDS(offsetWords);
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  W_ type;
+  (type) = ccall isArgGenBigRetFunType(c);
+  return (type);
+}
+
+// (StgInfoTable*, StgInfoTable*) getInfoTableAddrszh(StgStack* stack, StgWord offsetWords)
+getInfoTableAddrszh(P_ stack, W_ offsetWords) {
+  P_ p, info_struct, info_ptr;
+  p = StgStack_sp(stack) + WDS(offsetWords);
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(p));
+  info_struct = %GET_STD_INFO(UNTAG(p));
+  info_ptr = %INFO_PTR(UNTAG(p));
+  return (info_struct, info_ptr);
+}
+
+// (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack)
+getStackInfoTableAddrzh(P_ stack) {
+  P_ info;
+  info = %GET_STD_INFO(UNTAG(stack));
+  return (info);
+}
+
+// (StgClosure*) getStackClosurezh(StgStack* stack, StgWord offsetWords)
+getStackClosurezh(P_ stack, W_ offsetWords) {
+  P_ ptr;
+  ptr = StgStack_sp(stack) + WDS(offsetWords);
+
+  P_ closure;
+  (closure) = ccall getStackClosure(ptr);
+  return (closure);
+}
+
+// (bits32) getStackFieldszh(StgStack* stack)
+getStackFieldszh(P_ stack){
+  bits32 size;
+  size = StgStack_stack_size(stack);
+  return (size);
+}
+#endif


=====================================
libraries/ghc-internal/cbits/Stack_c.c
=====================================
@@ -0,0 +1,151 @@
+#include "MachDeps.h"
+#include "Rts.h"
+#include "RtsAPI.h"
+#include "rts/Messages.h"
+#include "rts/Types.h"
+#include "rts/storage/ClosureTypes.h"
+#include "rts/storage/Closures.h"
+#include "rts/storage/FunTypes.h"
+#include "rts/storage/InfoTables.h"
+
+StgWord stackFrameSize(StgStack *stack, StgWord offset) {
+  StgClosure *c = (StgClosure *)stack->sp + offset;
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+  return stack_frame_sizeW(c);
+}
+
+StgStack *getUnderflowFrameStack(StgStack *stack, StgWord offset) {
+  StgClosure *frame = (StgClosure *)stack->sp + offset;
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(frame));
+  const StgRetInfoTable *info = get_ret_itbl((StgClosure *)frame);
+
+  if (info->i.type == UNDERFLOW_FRAME) {
+    return ((StgUnderflowFrame *)frame)->next_chunk;
+  } else {
+    return NULL;
+  }
+}
+
+// Only exists to make the get_itbl macro available in Haskell code (via FFI).
+const StgInfoTable *getItbl(StgClosure *closure) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
+  return get_itbl(closure);
+};
+
+StgWord getBitmapSize(StgClosure *c) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  const StgInfoTable *info = get_itbl(c);
+  StgWord bitmap = info->layout.bitmap;
+  return BITMAP_SIZE(bitmap);
+}
+
+StgWord getRetFunBitmapSize(StgRetFun *ret_fun) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+  switch (fun_info->f.fun_type) {
+  case ARG_GEN:
+    return BITMAP_SIZE(fun_info->f.b.bitmap);
+  case ARG_GEN_BIG:
+    return GET_FUN_LARGE_BITMAP(fun_info)->size;
+  default:
+    return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
+  }
+}
+
+StgWord getBitmapWord(StgClosure *c) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  const StgInfoTable *info = get_itbl(c);
+  StgWord bitmap = info->layout.bitmap;
+  StgWord bitmapWord = BITMAP_BITS(bitmap);
+  return bitmapWord;
+}
+
+StgWord getRetFunBitmapWord(StgRetFun *ret_fun) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+  fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+  switch (fun_info->f.fun_type) {
+  case ARG_GEN:
+    return BITMAP_BITS(fun_info->f.b.bitmap);
+  case ARG_GEN_BIG:
+    // Cannot do more than warn and exit.
+    errorBelch("Unexpected ARG_GEN_BIG StgRetFun closure %p", ret_fun);
+    stg_exit(EXIT_INTERNAL_ERROR);
+  default:
+    return BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
+  }
+}
+
+StgWord getLargeBitmapSize(StgClosure *c) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  const StgInfoTable *info = get_itbl(c);
+  StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
+  return bitmap->size;
+}
+
+StgWord getRetFunSize(StgRetFun *ret_fun) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+  fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+  switch (fun_info->f.fun_type) {
+  case ARG_GEN:
+    return BITMAP_SIZE(fun_info->f.b.bitmap);
+  case ARG_GEN_BIG:
+    return GET_FUN_LARGE_BITMAP(fun_info)->size;
+  default:
+    return BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]);
+  }
+}
+
+StgWord getBCOLargeBitmapSize(StgClosure *c) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  StgBCO *bco = (StgBCO *)*c->payload;
+
+  return BCO_BITMAP_SIZE(bco);
+}
+
+StgWord *getLargeBitmap(Capability *cap, StgClosure *c) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+  const StgInfoTable *info = get_itbl(c);
+  StgLargeBitmap *bitmap = GET_LARGE_BITMAP(info);
+
+  return bitmap->bitmap;
+}
+
+StgWord *getRetFunLargeBitmap(Capability *cap, StgRetFun *ret_fun) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+  StgLargeBitmap *bitmap = GET_FUN_LARGE_BITMAP(fun_info);
+
+  return bitmap->bitmap;
+}
+
+StgWord *getBCOLargeBitmap(Capability *cap, StgClosure *c) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(c));
+
+  StgBCO *bco = (StgBCO *)*c->payload;
+  StgLargeBitmap *bitmap = BCO_BITMAP(bco);
+
+  return bitmap->bitmap;
+}
+
+StgStack *getUnderflowFrameNextChunk(StgUnderflowFrame *frame) {
+  return frame->next_chunk;
+}
+
+StgWord isArgGenBigRetFunType(StgRetFun *ret_fun) {
+  ASSERT(LOOKS_LIKE_CLOSURE_PTR(ret_fun));
+
+  const StgFunInfoTable *fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
+  return fun_info->f.fun_type == ARG_GEN_BIG;
+}
+
+StgClosure *getStackClosure(StgClosure **c) { return *c; }


=====================================
libraries/ghc-internal/ghc-internal.cabal.in
=====================================
@@ -231,6 +231,12 @@ Library
         GHC.Internal.GHCi
         GHC.Internal.GHCi.Helpers
         GHC.Internal.Generics
+        GHC.Internal.Heap.Closures
+        GHC.Internal.Heap.Constants
+        GHC.Internal.Heap.InfoTable
+        GHC.Internal.Heap.InfoTable.Types
+        GHC.Internal.Heap.InfoTableProf
+        GHC.Internal.Heap.ProfInfo.Types
         GHC.Internal.InfoProv
         GHC.Internal.InfoProv.Types
         GHC.Internal.IO
@@ -283,14 +289,17 @@ Library
         GHC.Internal.RTS.Flags
         GHC.Internal.RTS.Flags.Test
         GHC.Internal.ST
-        GHC.Internal.Stack.CloneStack
         GHC.Internal.StaticPtr
         GHC.Internal.STRef
         GHC.Internal.Show
         GHC.Internal.Stable
         GHC.Internal.StableName
         GHC.Internal.Stack
+        GHC.Internal.Stack.Annotation
         GHC.Internal.Stack.CCS
+        GHC.Internal.Stack.CloneStack
+        GHC.Internal.Stack.Constants
+        GHC.Internal.Stack.Decode
         GHC.Internal.Stack.Types
         GHC.Internal.Stats
         GHC.Internal.Storable
@@ -449,9 +458,12 @@ Library
           cbits/popcnt.c
           cbits/vectorQuotRem.c
           cbits/word2float.c
+          cbits/Stack_c.c
 
       cmm-sources:
           cbits/StackCloningDecoding.cmm
+          cbits/Stack.cmm
+          cbits/HeapPrim.cmm
 
     if arch(javascript)
       js-sources:


=====================================
libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs
=====================================
@@ -7,6 +7,8 @@ module GHC.Internal.Exception.Backtrace where
 
 import GHC.Internal.Base
 import GHC.Internal.Data.OldList
+import GHC.Internal.Data.Functor
+import GHC.Internal.Data.Maybe
 import GHC.Internal.IORef
 import GHC.Internal.IO.Unsafe (unsafePerformIO)
 import GHC.Internal.Exception.Context
@@ -16,6 +18,7 @@ import GHC.Internal.Stack.Types as GHC.Stack (CallStack)
 import qualified GHC.Internal.Stack as HCS
 import qualified GHC.Internal.ExecutionStack.Internal as ExecStack
 import qualified GHC.Internal.Stack.CloneStack as CloneStack
+import qualified GHC.Internal.Stack.Decode as Decode
 import qualified GHC.Internal.Stack.CCS as CCS
 
 -- | How to collect a backtrace when an exception is thrown.
@@ -112,7 +115,7 @@ displayBacktraces bts = concat
     displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames
     -- The unsafePerformIO here is safe as 'StackSnapshot' makes sure neither the stack frames nor
     -- references closures can be garbage collected.
-    displayIpe  = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode
+    displayIpe  = unlines . map (indent 2 . Decode.prettyStackEntry) . unsafePerformIO . CloneStack.decode
     displayHsc  = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack
       where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc
 


=====================================
libraries/ghc-internal/src/GHC/Internal/Heap/Closures.hs
=====================================
@@ -0,0 +1,669 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+-- Late cost centres introduce a thunk in the asBox function, which leads to
+-- an additional wrapper being added to any value placed inside a box.
+-- This can be removed once our boot compiler is no longer affected by #25212
+{-# OPTIONS_GHC -fno-prof-late  #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module GHC.Internal.Heap.Closures (
+    -- * Closures
+      Closure
+    , GenClosure(..)
+    , getClosureInfoTbl
+    , getClosureInfoTbl_maybe
+    , getClosurePtrArgs
+    , getClosurePtrArgs_maybe
+    , PrimType(..)
+    , WhatNext(..)
+    , WhyBlocked(..)
+    , TsoFlags(..)
+    , allClosures
+    , closureSize
+
+    -- * Stack
+    , StgStackClosure
+    , GenStgStackClosure(..)
+    , StackFrame
+    , GenStackFrame(..)
+    , StackField
+    , GenStackField(..)
+
+    -- * Boxes
+    , Box(..)
+    , areBoxesEqual
+    , asBox
+    ) where
+
+import GHC.Internal.Base
+import GHC.Internal.Show
+
+import GHC.Internal.Heap.Constants
+#if defined(PROFILING)
+import GHC.Internal.Heap.InfoTable () -- see Note [No way-dependent imports]
+import GHC.Internal.Heap.InfoTableProf
+#else
+import GHC.Internal.Heap.InfoTable
+import GHC.Internal.Heap.InfoTableProf () -- see Note [No way-dependent imports]
+
+{-
+Note [No way-dependent imports]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+`ghc -M` currently assumes that the imports for a module are the same
+in every way.  This is arguably a bug, but breaking this assumption by
+importing different things in different ways can cause trouble.  For
+example, this module in the profiling way imports and uses
+GHC.Exts.Heap.InfoTableProf.  When it was not also imported in the
+vanilla way, there were intermittent build failures due to this module
+being compiled in the profiling way before GHC.Exts.Heap.InfoTableProf
+in the profiling way. (#15197)
+-}
+#endif
+
+import GHC.Internal.Heap.ProfInfo.Types
+
+import GHC.Internal.Data.Bits
+import GHC.Internal.Data.Foldable (Foldable, toList)
+import GHC.Internal.Data.Traversable (Traversable)
+import GHC.Internal.Int
+import GHC.Internal.Num
+import GHC.Internal.Real
+import GHC.Internal.Word
+import GHC.Internal.Exts
+import GHC.Internal.Generics
+import GHC.Internal.Numeric
+import GHC.Internal.Stack (HasCallStack)
+
+------------------------------------------------------------------------
+-- Boxes
+
+foreign import prim "aToWordzh" aToWord# :: Any -> Word#
+
+foreign import prim "reallyUnsafePtrEqualityUpToTag"
+    reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
+
+-- | An arbitrary Haskell value in a safe Box. The point is that even
+-- unevaluated thunks can safely be moved around inside the Box, and when
+-- required, e.g. in 'getBoxedClosureData', the function knows how far it has
+-- to evaluate the argument.
+data Box = Box Any
+
+instance Show Box where
+-- From libraries/base/GHC/Ptr.lhs
+   showsPrec _ (Box a) rs =
+    -- unsafePerformIO (print "↓" >> pClosure a) `seq`
+    pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs
+     where
+       ptr  = W# (aToWord# a)
+       tag  = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
+       addr = ptr - tag
+       pad_out ls = '0':'x':ls
+
+-- |This takes an arbitrary value and puts it into a box.
+-- Note that calls like
+--
+-- > asBox (head list)
+--
+-- will put the thunk \"head list\" into the box, /not/ the element at the head
+-- of the list. For that, use careful case expressions:
+--
+-- > case list of x:_ -> asBox x
+asBox :: a -> Box
+asBox x = Box (unsafeCoerce# x)
+
+-- | Boxes can be compared, but this is not pure, as different heap objects can,
+-- after garbage collection, become the same object.
+areBoxesEqual :: Box -> Box -> IO Bool
+areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
+    0# -> pure False
+    _  -> pure True
+
+
+------------------------------------------------------------------------
+-- Closures
+type Closure = GenClosure Box
+
+-- | This is the representation of a Haskell value on the heap. It reflects
+-- https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/Closu...
+--
+-- The data type is parametrized by `b`: the type to store references in.
+-- Usually this is a 'Box' with the type synonym 'Closure'.
+--
+-- All Heap objects have the same basic layout. A header containing a pointer to
+-- the info table and a payload with various fields. The @info@ field below
+-- always refers to the info table pointed to by the header. The remaining
+-- fields are the payload.
+--
+-- See
+-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/rts/storage/heap-objects
+-- for more information.
+data GenClosure b
+  = -- | A data constructor
+    ConstrClosure
+        { info       :: !StgInfoTable
+        , ptrArgs    :: ![b]            -- ^ Pointer arguments
+        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
+        , pkg        :: !String         -- ^ Package name
+        , modl       :: !String         -- ^ Module name
+        , name       :: !String         -- ^ Constructor name
+        }
+
+    -- | A function
+  | FunClosure
+        { info       :: !StgInfoTable
+        , ptrArgs    :: ![b]            -- ^ Pointer arguments
+        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
+        }
+
+    -- | A thunk, an expression not obviously in head normal form
+  | ThunkClosure
+        { info       :: !StgInfoTable
+        , ptrArgs    :: ![b]            -- ^ Pointer arguments
+        , dataArgs   :: ![Word]         -- ^ Non-pointer arguments
+        }
+
+    -- | A thunk which performs a simple selection operation
+  | SelectorClosure
+        { info       :: !StgInfoTable
+        , selectee   :: !b              -- ^ Pointer to the object being
+                                        --   selected from
+        }
+
+    -- | An unsaturated function application
+  | PAPClosure
+        { info       :: !StgInfoTable
+        , arity      :: !HalfWord       -- ^ Arity of the partial application
+        , n_args     :: !HalfWord       -- ^ Size of the payload in words
+        , fun        :: !b              -- ^ Pointer to a 'FunClosure'
+        , payload    :: ![b]            -- ^ Sequence of already applied
+                                        --   arguments
+        }
+
+    -- In GHCi, if Linker.h would allow a reverse lookup, we could for exported
+    -- functions fun actually find the name here.
+    -- At least the other direction works via "lookupSymbol
+    -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags)
+    -- | A function application
+  | APClosure
+        { info       :: !StgInfoTable
+        , arity      :: !HalfWord       -- ^ Always 0
+        , n_args     :: !HalfWord       -- ^ Size of payload in words
+        , fun        :: !b              -- ^ Pointer to a 'FunClosure'
+        , payload    :: ![b]            -- ^ Sequence of already applied
+                                        --   arguments
+        }
+
+    -- | A suspended thunk evaluation
+  | APStackClosure
+        { info       :: !StgInfoTable
+        , fun        :: !b              -- ^ Function closure
+        , payload    :: ![b]            -- ^ Stack right before suspension
+        }
+
+    -- | A pointer to another closure, introduced when a thunk is updated
+    -- to point at its value
+  | IndClosure
+        { info       :: !StgInfoTable
+        , indirectee :: !b              -- ^ Target closure
+        }
+
+   -- | A byte-code object (BCO) which can be interpreted by GHC's byte-code
+   -- interpreter (e.g. as used by GHCi)
+  | BCOClosure
+        { info       :: !StgInfoTable
+        , instrs     :: !b              -- ^ A pointer to an ArrWords
+                                        --   of instructions
+        , literals   :: !b              -- ^ A pointer to an ArrWords
+                                        --   of literals
+        , bcoptrs    :: !b              -- ^ A pointer to an ArrWords
+                                        --   of byte code objects
+        , arity      :: !HalfWord       -- ^ The arity of this BCO
+        , size       :: !HalfWord       -- ^ The size of this BCO in words
+        , bitmap     :: ![Word]         -- ^ An StgLargeBitmap describing the
+                                        --   pointerhood of its args/free vars
+        }
+
+    -- | A thunk under evaluation by another thread
+  | BlackholeClosure
+        { info       :: !StgInfoTable
+        , indirectee :: !b              -- ^ The target closure
+        }
+
+    -- | A @ByteArray#@
+  | ArrWordsClosure
+        { info       :: !StgInfoTable
+        , bytes      :: !Word           -- ^ Size of array in bytes
+        , arrWords   :: ![Word]         -- ^ Array payload
+        }
+
+    -- | A @MutableByteArray#@
+  | MutArrClosure
+        { info       :: !StgInfoTable
+        , mccPtrs    :: !Word           -- ^ Number of pointers
+        , mccSize    :: !Word           -- ^ ?? Closures.h vs ClosureMacros.h
+        , mccPayload :: ![b]            -- ^ Array payload
+        -- Card table ignored
+        }
+
+    -- | A @SmallMutableArray#@
+    --
+    -- @since 8.10.1
+  | SmallMutArrClosure
+        { info       :: !StgInfoTable
+        , mccPtrs    :: !Word           -- ^ Number of pointers
+        , mccPayload :: ![b]            -- ^ Array payload
+        }
+
+  -- | An @MVar#@, with a queue of thread state objects blocking on them
+  | MVarClosure
+    { info       :: !StgInfoTable
+    , queueHead  :: !b              -- ^ Pointer to head of queue
+    , queueTail  :: !b              -- ^ Pointer to tail of queue
+    , value      :: !b              -- ^ Pointer to closure
+    }
+
+    -- | An @IOPort#@, with a queue of thread state objects blocking on them
+  | IOPortClosure
+        { info       :: !StgInfoTable
+        , queueHead  :: !b              -- ^ Pointer to head of queue
+        , queueTail  :: !b              -- ^ Pointer to tail of queue
+        , value      :: !b              -- ^ Pointer to closure
+        }
+
+    -- | A @MutVar#@
+  | MutVarClosure
+        { info       :: !StgInfoTable
+        , var        :: !b              -- ^ Pointer to contents
+        }
+
+    -- | An STM blocking queue.
+  | BlockingQueueClosure
+        { info       :: !StgInfoTable
+        , link       :: !b              -- ^ ?? Here so it looks like an IND
+        , blackHole  :: !b              -- ^ The blackhole closure
+        , owner      :: !b              -- ^ The owning thread state object
+        , queue      :: !b              -- ^ ??
+        }
+
+  | WeakClosure
+        { info        :: !StgInfoTable
+        , cfinalizers :: !b
+        , key         :: !b
+        , value       :: !b
+        , finalizer   :: !b
+        , weakLink    :: !(Maybe b) -- ^ next weak pointer for the capability
+        }
+
+  -- | Representation of StgTSO: A Thread State Object. The values for
+  -- 'what_next', 'why_blocked' and 'flags' are defined in @Constants.h@.
+  | TSOClosure
+      { info                :: !StgInfoTable
+      -- pointers
+      , link                :: !b
+      , global_link         :: !b
+      , tsoStack            :: !b -- ^ stackobj from StgTSO
+      , trec                :: !b
+      , blocked_exceptions  :: !b
+      , bq                  :: !b
+      , thread_label        :: !(Maybe b)
+      -- values
+      , what_next           :: !WhatNext
+      , why_blocked         :: !WhyBlocked
+      , flags               :: ![TsoFlags]
+      , threadId            :: !Word64
+      , saved_errno         :: !Word32
+      , tso_dirty           :: !Word32 -- ^ non-zero => dirty
+      , alloc_limit         :: !Int64
+      , tot_stack_size      :: !Word32
+      , prof                :: !(Maybe StgTSOProfInfo)
+      }
+
+  -- | Representation of StgStack: The 'tsoStack ' of a 'TSOClosure'.
+  | StackClosure
+      { info            :: !StgInfoTable
+      , stack_size      :: !Word32 -- ^ stack size in *words*
+      , stack_dirty     :: !Word8 -- ^ non-zero => dirty
+      , stack_marking   :: !Word8
+      }
+
+    ------------------------------------------------------------
+    -- Unboxed unlifted closures
+
+    -- | Primitive Int
+  | IntClosure
+        { ptipe      :: PrimType
+        , intVal     :: !Int }
+
+    -- | Primitive Word
+  | WordClosure
+        { ptipe      :: PrimType
+        , wordVal    :: !Word }
+
+    -- | Primitive Int64
+  | Int64Closure
+        { ptipe      :: PrimType
+        , int64Val   :: !Int64 }
+
+    -- | Primitive Word64
+  | Word64Closure
+        { ptipe      :: PrimType
+        , word64Val  :: !Word64 }
+
+    -- | Primitive Addr
+  | AddrClosure
+        { ptipe      :: PrimType
+        , addrVal    :: !(Ptr ()) }
+
+    -- | Primitive Float
+  | FloatClosure
+        { ptipe      :: PrimType
+        , floatVal   :: !Float }
+
+    -- | Primitive Double
+  | DoubleClosure
+        { ptipe      :: PrimType
+        , doubleVal  :: !Double }
+
+    -----------------------------------------------------------
+    -- Anything else
+
+    -- | Another kind of closure
+  | OtherClosure
+        { info       :: !StgInfoTable
+        , hvalues    :: ![b]
+        , rawWords   :: ![Word]
+        }
+
+  | UnsupportedClosure
+        { info       :: !StgInfoTable
+        }
+
+    -- | A primitive word from a bitmap encoded stack frame payload
+    --
+    -- The type itself cannot be restored (i.e. it might represent a Word8#
+    -- or an Int#).
+  |  UnknownTypeWordSizedPrimitive
+        { wordVal :: !Word }
+  deriving (Show, Generic, Functor, Foldable, Traversable)
+
+-- | Get the info table for a heap closure, or Nothing for a prim value
+--
+-- @since 9.14.1
+getClosureInfoTbl_maybe :: GenClosure b -> Maybe StgInfoTable
+{-# INLINE getClosureInfoTbl_maybe #-} -- Ensure we can get rid of the just box
+getClosureInfoTbl_maybe closure = case closure of
+  ConstrClosure{info} ->Just info
+  FunClosure{info} ->Just info
+  ThunkClosure{info} ->Just info
+  SelectorClosure{info} ->Just info
+  PAPClosure{info} ->Just info
+  APClosure{info} ->Just info
+  APStackClosure{info} ->Just info
+  IndClosure{info} ->Just info
+  BCOClosure{info} ->Just info
+  BlackholeClosure{info} ->Just info
+  ArrWordsClosure{info} ->Just info
+  MutArrClosure{info} ->Just info
+  SmallMutArrClosure{info} ->Just info
+  MVarClosure{info} ->Just info
+  IOPortClosure{info} ->Just info
+  MutVarClosure{info} ->Just info
+  BlockingQueueClosure{info} ->Just info
+  WeakClosure{info} ->Just info
+  TSOClosure{info} ->Just info
+  StackClosure{info} ->Just info
+
+  IntClosure{} -> Nothing
+  WordClosure{} -> Nothing
+  Int64Closure{} -> Nothing
+  Word64Closure{} -> Nothing
+  AddrClosure{} -> Nothing
+  FloatClosure{} -> Nothing
+  DoubleClosure{} -> Nothing
+
+  OtherClosure{info} -> Just info
+  UnsupportedClosure {info} -> Just info
+
+  UnknownTypeWordSizedPrimitive{} -> Nothing
+
+-- | Partial version of getClosureInfoTbl_maybe for when we know we deal with a
+-- heap closure.
+--
+-- @since 9.14.1
+getClosureInfoTbl :: HasCallStack => GenClosure b -> StgInfoTable
+getClosureInfoTbl closure = case getClosureInfoTbl_maybe closure of
+  Just info -> info
+  Nothing -> error "getClosureInfoTbl - Closure without info table"
+
+-- | Get the info table for a heap closure, or Nothing for a prim value
+--
+-- @since 9.14.1
+getClosurePtrArgs_maybe :: GenClosure b -> Maybe [b]
+{-# INLINE getClosurePtrArgs_maybe #-} -- Ensure we can get rid of the just box
+getClosurePtrArgs_maybe closure = case closure of
+  ConstrClosure{ptrArgs} -> Just ptrArgs
+  FunClosure{ptrArgs} -> Just ptrArgs
+  ThunkClosure{ptrArgs} -> Just ptrArgs
+  SelectorClosure{} -> Nothing
+  PAPClosure{} -> Nothing
+  APClosure{} -> Nothing
+  APStackClosure{} -> Nothing
+  IndClosure{} -> Nothing
+  BCOClosure{} -> Nothing
+  BlackholeClosure{} -> Nothing
+  ArrWordsClosure{} -> Nothing
+  MutArrClosure{} -> Nothing
+  SmallMutArrClosure{} -> Nothing
+  MVarClosure{} -> Nothing
+  IOPortClosure{} -> Nothing
+  MutVarClosure{} -> Nothing
+  BlockingQueueClosure{} -> Nothing
+  WeakClosure{} -> Nothing
+  TSOClosure{} -> Nothing
+  StackClosure{} -> Nothing
+
+  IntClosure{} -> Nothing
+  WordClosure{} -> Nothing
+  Int64Closure{} -> Nothing
+  Word64Closure{} -> Nothing
+  AddrClosure{} -> Nothing
+  FloatClosure{} -> Nothing
+  DoubleClosure{} -> Nothing
+
+  OtherClosure{} -> Nothing
+  UnsupportedClosure{} -> Nothing
+
+  UnknownTypeWordSizedPrimitive{} -> Nothing
+
+-- | Partial version of getClosureInfoTbl_maybe for when we know we deal with a
+-- heap closure.
+--
+-- @since 9.14.1
+getClosurePtrArgs :: HasCallStack => GenClosure b -> [b]
+getClosurePtrArgs closure = case getClosurePtrArgs_maybe closure of
+  Just ptrs -> ptrs
+  Nothing -> error "getClosurePtrArgs - Closure without ptrArgs field"
+
+type StgStackClosure = GenStgStackClosure Box
+
+-- | A decoded @StgStack@ with `StackFrame`s
+--
+-- Stack related data structures (`GenStgStackClosure`, `GenStackField`,
+-- `GenStackFrame`) are defined separately from `GenClosure` as their related
+-- functions are very different. Though, both are closures in the sense of RTS
+-- structures, their decoding logic differs: While it's safe to keep a reference
+-- to a heap closure, the garbage collector does not update references to stack
+-- located closures.
+--
+-- Additionally, stack frames don't appear outside of the stack. Thus, keeping
+-- `GenStackFrame` and `GenClosure` separated, makes these types more precise
+-- (in the sense what values to expect.)
+data GenStgStackClosure b = GenStgStackClosure
+      { ssc_info            :: !StgInfoTable
+      , ssc_stack_size      :: !Word32 -- ^ stack size in *words*
+      , ssc_stack           :: ![GenStackFrame b]
+      }
+  deriving (Foldable, Functor, Generic, Show, Traversable)
+
+type StackField = GenStackField Box
+
+-- | Bitmap-encoded payload on the stack
+data GenStackField b
+    -- | A non-pointer field
+    = StackWord !Word
+    -- | A pointer field
+    | StackBox  !b
+  deriving (Foldable, Functor, Generic, Show, Traversable)
+
+type StackFrame = GenStackFrame Box
+
+-- | A single stack frame
+data GenStackFrame b =
+   UpdateFrame
+      { info_tbl           :: !StgInfoTable
+      , updatee            :: !b
+      }
+
+  | CatchFrame
+      { info_tbl            :: !StgInfoTable
+      , handler             :: !b
+      }
+
+  | CatchStmFrame
+      { info_tbl            :: !StgInfoTable
+      , catchFrameCode      :: !b
+      , handler             :: !b
+      }
+
+  | CatchRetryFrame
+      { info_tbl            :: !StgInfoTable
+      , running_alt_code    :: !Word
+      , first_code          :: !b
+      , alt_code            :: !b
+      }
+
+  | AtomicallyFrame
+      { info_tbl            :: !StgInfoTable
+      , atomicallyFrameCode :: !b
+      , result              :: !b
+      }
+
+  | UnderflowFrame
+      { info_tbl            :: !StgInfoTable
+      , nextChunk           :: !(GenStgStackClosure b)
+      }
+
+  | StopFrame
+      { info_tbl            :: !StgInfoTable }
+
+  | RetSmall
+      { info_tbl            :: !StgInfoTable
+      , stack_payload       :: ![GenStackField b]
+      }
+
+  | RetBig
+      { info_tbl            :: !StgInfoTable
+      , stack_payload       :: ![GenStackField b]
+      }
+
+  | RetFun
+      { info_tbl            :: !StgInfoTable
+      , retFunSize          :: !Word
+      , retFunFun           :: !b
+      , retFunPayload       :: ![GenStackField b]
+      }
+
+  | RetBCO
+      { info_tbl            :: !StgInfoTable
+      , bco                 :: !b -- ^ always a BCOClosure
+      , bcoArgs             :: ![GenStackField b]
+      }
+  | AnnFrame
+      { info_tbl            :: !StgInfoTable
+      , annotation          :: !b
+      }
+  deriving (Foldable, Functor, Generic, Show, Traversable)
+
+data PrimType
+  = PInt
+  | PWord
+  | PInt64
+  | PWord64
+  | PAddr
+  | PFloat
+  | PDouble
+  deriving (Eq, Show, Generic, Ord)
+
+data WhatNext
+  = ThreadRunGHC
+  | ThreadInterpret
+  | ThreadKilled
+  | ThreadComplete
+  | WhatNextUnknownValue Word16 -- ^ Please report this as a bug
+  deriving (Eq, Show, Generic, Ord)
+
+data WhyBlocked
+  = NotBlocked
+  | BlockedOnMVar
+  | BlockedOnMVarRead
+  | BlockedOnBlackHole
+  | BlockedOnRead
+  | BlockedOnWrite
+  | BlockedOnDelay
+  | BlockedOnSTM
+  | BlockedOnDoProc
+  | BlockedOnCCall
+  | BlockedOnCCall_Interruptible
+  | BlockedOnMsgThrowTo
+  | ThreadMigrating
+  | WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug
+  deriving (Eq, Show, Generic, Ord)
+
+data TsoFlags
+  = TsoLocked
+  | TsoBlockx
+  | TsoInterruptible
+  | TsoStoppedOnBreakpoint
+  | TsoMarked
+  | TsoSqueezed
+  | TsoAllocLimit
+  | TsoStopNextBreakpoint
+  | TsoStopAfterReturn
+  | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug
+  deriving (Eq, Show, Generic, Ord)
+
+-- | For generic code, this function returns all referenced closures.
+allClosures :: GenClosure b -> [b]
+allClosures (ConstrClosure {..}) = ptrArgs
+allClosures (ThunkClosure {..}) = ptrArgs
+allClosures (SelectorClosure {..}) = [selectee]
+allClosures (IndClosure {..}) = [indirectee]
+allClosures (BlackholeClosure {..}) = [indirectee]
+allClosures (APClosure {..}) = fun:payload
+allClosures (PAPClosure {..}) = fun:payload
+allClosures (APStackClosure {..}) = fun:payload
+allClosures (BCOClosure {..}) = [instrs,literals,bcoptrs]
+allClosures (ArrWordsClosure {}) = []
+allClosures (MutArrClosure {..}) = mccPayload
+allClosures (SmallMutArrClosure {..}) = mccPayload
+allClosures (MutVarClosure {..}) = [var]
+allClosures (MVarClosure {..}) = [queueHead,queueTail,value]
+allClosures (IOPortClosure {..}) = [queueHead,queueTail,value]
+allClosures (FunClosure {..}) = ptrArgs
+allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
+allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer] ++ GHC.Internal.Data.Foldable.toList weakLink
+allClosures (OtherClosure {..}) = hvalues
+allClosures _ = []
+
+-- | Get the size of the top-level closure in words.
+-- Includes header and payload. Does not follow pointers.
+--
+-- @since 8.10.1
+closureSize :: Box -> Int
+closureSize (Box x) = I# (closureSize# x)


=====================================
libraries/ghc-internal/src/GHC/Internal/Heap/Constants.hsc
=====================================
@@ -0,0 +1,18 @@
+{-# LANGUAGE CPP #-}
+
+module GHC.Internal.Heap.Constants
+    ( wORD_SIZE
+    , tAG_MASK
+    , wORD_SIZE_IN_BITS
+    ) where
+
+#include "MachDeps.h"
+
+import GHC.Internal.Data.Bits
+import GHC.Internal.Int
+import GHC.Internal.Num
+
+wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS :: Int
+wORD_SIZE = #const SIZEOF_HSWORD
+wORD_SIZE_IN_BITS = #const WORD_SIZE_IN_BITS
+tAG_MASK = (1 `shift` #const TAG_BITS) - 1


=====================================
libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable.hsc
=====================================
@@ -0,0 +1,79 @@
+module GHC.Internal.Heap.InfoTable
+    ( module GHC.Internal.Heap.InfoTable.Types
+    , itblSize
+    , peekItbl
+    , pokeItbl
+    ) where
+
+#include "Rts.h"
+
+import GHC.Internal.Base
+import GHC.Internal.Data.Either
+import GHC.Internal.Real
+import GHC.Internal.Enum
+
+import GHC.Internal.Heap.InfoTable.Types
+#if !defined(TABLES_NEXT_TO_CODE)
+import GHC.Internal.Heap.Constants
+import GHC.Internal.Data.Maybe
+#endif
+import GHC.Internal.Foreign.Ptr
+import GHC.Internal.Foreign.Storable
+import GHC.Internal.Foreign.Marshal.Array
+
+-------------------------------------------------------------------------
+-- Profiling specific code
+--
+-- The functions that follow all rely on PROFILING. They are duplicated in
+-- ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc where PROFILING is defined. This
+-- allows hsc2hs to generate values for both profiling and non-profiling builds.
+
+-- | Read an InfoTable from the heap into a haskell type.
+-- WARNING: This code assumes it is passed a pointer to a "standard" info
+-- table. If tables_next_to_code is disabled, it will look 1 word before the
+-- start for the entry field.
+peekItbl :: Ptr StgInfoTable -> IO StgInfoTable
+peekItbl a0 = do
+#if !defined(TABLES_NEXT_TO_CODE)
+  let ptr = a0 `plusPtr` (negate wORD_SIZE)
+  entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr
+#else
+  let ptr = a0
+      entry' = Nothing
+#endif
+  ptrs'   <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr
+  nptrs'  <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr
+  tipe'   <- (#peek struct StgInfoTable_, type) ptr
+  srtlen' <- (#peek struct StgInfoTable_, srt) a0
+  return StgInfoTable
+    { entry  = entry'
+    , ptrs   = ptrs'
+    , nptrs  = nptrs'
+    , tipe   = toEnum (fromIntegral (tipe' :: HalfWord))
+    , srtlen = srtlen'
+    , code   = Nothing
+    }
+
+pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()
+pokeItbl a0 itbl = do
+#if !defined(TABLES_NEXT_TO_CODE)
+  (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))
+#endif
+  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)
+  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)
+  (#poke StgInfoTable, type) a0 (toHalfWord (fromEnum (tipe itbl)))
+  (#poke StgInfoTable, srt) a0 (srtlen itbl)
+#if defined(TABLES_NEXT_TO_CODE)
+  let code_offset = a0 `plusPtr` (#offset StgInfoTable, code)
+  case code itbl of
+    Nothing -> return ()
+    Just (Left xs) -> pokeArray code_offset xs
+    Just (Right xs) -> pokeArray code_offset xs
+#endif
+  where
+    toHalfWord :: Int -> HalfWord
+    toHalfWord i = fromIntegral i
+
+-- | Size in bytes of a standard InfoTable
+itblSize :: Int
+itblSize = (#size struct StgInfoTable_)


=====================================
libraries/ghc-internal/src/GHC/Internal/Heap/InfoTable/Types.hsc
=====================================
@@ -0,0 +1,53 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module GHC.Internal.Heap.InfoTable.Types
+    ( StgInfoTable(..)
+    , EntryFunPtr
+    , HalfWord(..)
+    , ItblCodes
+    ) where
+
+#include "Rts.h"
+
+import GHC.Internal.Base
+import GHC.Internal.Generics
+import GHC.Internal.ClosureTypes
+import GHC.Internal.Foreign.Ptr
+import GHC.Internal.Foreign.Storable
+import GHC.Internal.Enum
+import GHC.Internal.Num
+import GHC.Internal.Word
+import GHC.Internal.Show
+import GHC.Internal.Real
+import GHC.Internal.Data.Either
+
+type ItblCodes = Either [Word8] [Word32]
+
+#include "ghcautoconf.h"
+-- Ultra-minimalist version specially for constructors
+#if SIZEOF_VOID_P == 8
+type HalfWord' = Word32
+#elif SIZEOF_VOID_P == 4
+type HalfWord' = Word16
+#else
+#error Unknown SIZEOF_VOID_P
+#endif
+
+newtype HalfWord = HalfWord HalfWord'
+    deriving newtype (Enum, Eq, Integral, Num, Ord, Real, Show, Storable)
+
+type EntryFunPtr = FunPtr (Ptr () -> IO (Ptr ()))
+
+-- | This is a somewhat faithful representation of an info table. See
+-- https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/InfoT...
+-- for more details on this data structure.
+data StgInfoTable = StgInfoTable {
+   entry  :: Maybe EntryFunPtr, -- Just <=> not TABLES_NEXT_TO_CODE
+   ptrs   :: HalfWord,
+   nptrs  :: HalfWord,
+   tipe   :: ClosureType,
+   srtlen :: HalfWord,
+   code   :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE
+  } deriving (Eq, Show, Generic)


=====================================
libraries/ghc-internal/src/GHC/Internal/Heap/InfoTableProf.hsc
=====================================
@@ -0,0 +1,72 @@
+module GHC.Internal.Heap.InfoTableProf
+    ( module GHC.Internal.Heap.InfoTable.Types
+    , itblSize
+    , peekItbl
+    , pokeItbl
+    ) where
+
+-- This file overrides InfoTable.hsc's implementation of peekItbl and pokeItbl.
+-- Manually defining PROFILING gives the #peek and #poke macros an accurate
+-- representation of StgInfoTable_ when hsc2hs runs.
+#define PROFILING
+#include "Rts.h"
+
+import GHC.Internal.Base
+import GHC.Internal.Data.Either
+import GHC.Internal.Real
+import GHC.Internal.Enum
+
+import GHC.Internal.Heap.InfoTable.Types
+#if !defined(TABLES_NEXT_TO_CODE)
+import GHC.Internal.Heap.Constants
+import GHC.Internal.Data.Maybe
+#endif
+import GHC.Internal.Foreign.Ptr
+import GHC.Internal.Foreign.Storable
+import GHC.Internal.Foreign.Marshal.Array
+
+-- | Read an InfoTable from the heap into a haskell type.
+-- WARNING: This code assumes it is passed a pointer to a "standard" info
+-- table. If tables_next_to_code is enabled, it will look 1 byte before the
+-- start for the entry field.
+peekItbl :: Ptr StgInfoTable -> IO StgInfoTable
+peekItbl a0 = do
+#if !defined(TABLES_NEXT_TO_CODE)
+  let ptr = a0 `plusPtr` (negate wORD_SIZE)
+  entry' <- Just <$> (#peek struct StgInfoTable_, entry) ptr
+#else
+  let ptr = a0
+      entry' = Nothing
+#endif
+  ptrs'   <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr
+  nptrs'  <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr
+  tipe'   <- (#peek struct StgInfoTable_, type) ptr
+  srtlen' <- (#peek struct StgInfoTable_, srt) a0
+  return StgInfoTable
+    { entry  = entry'
+    , ptrs   = ptrs'
+    , nptrs  = nptrs'
+    , tipe   = toEnum (fromIntegral (tipe' :: HalfWord))
+    , srtlen = srtlen'
+    , code   = Nothing
+    }
+
+pokeItbl :: Ptr StgInfoTable -> StgInfoTable -> IO ()
+pokeItbl a0 itbl = do
+#if !defined(TABLES_NEXT_TO_CODE)
+  (#poke StgInfoTable, entry) a0 (fromJust (entry itbl))
+#endif
+  (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)
+  (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)
+  (#poke StgInfoTable, type) a0 (fromEnum (tipe itbl))
+  (#poke StgInfoTable, srt) a0 (srtlen itbl)
+#if defined(TABLES_NEXT_TO_CODE)
+  let code_offset = a0 `plusPtr` (#offset StgInfoTable, code)
+  case code itbl of
+    Nothing -> return ()
+    Just (Left xs) -> pokeArray code_offset xs
+    Just (Right xs) -> pokeArray code_offset xs
+#endif
+
+itblSize :: Int
+itblSize = (#size struct StgInfoTable_)


=====================================
libraries/ghc-internal/src/GHC/Internal/Heap/ProfInfo/Types.hs
=====================================
@@ -0,0 +1,57 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module GHC.Internal.Heap.ProfInfo.Types where
+
+import GHC.Internal.Base
+import GHC.Internal.Word
+import GHC.Internal.Generics
+import GHC.Internal.Show
+
+-- | This is a somewhat faithful representation of StgTSOProfInfo. See
+-- https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/storage/TSO.h
+-- for more details on this data structure.
+newtype StgTSOProfInfo = StgTSOProfInfo {
+    cccs :: Maybe CostCentreStack
+} deriving (Show, Generic, Eq, Ord)
+
+-- | This is a somewhat faithful representation of CostCentreStack. See
+-- https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h
+-- for more details on this data structure.
+data CostCentreStack = CostCentreStack {
+    ccs_ccsID :: Int,
+    ccs_cc :: CostCentre,
+    ccs_prevStack :: Maybe CostCentreStack,
+    ccs_indexTable :: Maybe IndexTable,
+    ccs_root :: Maybe CostCentreStack,
+    ccs_depth :: Word,
+    ccs_scc_count :: Word64,
+    ccs_selected :: Word,
+    ccs_time_ticks :: Word,
+    ccs_mem_alloc :: Word64,
+    ccs_inherited_alloc :: Word64,
+    ccs_inherited_ticks :: Word
+} deriving (Show, Generic, Eq, Ord)
+
+-- | This is a somewhat faithful representation of CostCentre. See
+-- https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h
+-- for more details on this data structure.
+data CostCentre = CostCentre {
+    cc_ccID :: Int,
+    cc_label :: String,
+    cc_module :: String,
+    cc_srcloc :: Maybe String,
+    cc_mem_alloc :: Word64,
+    cc_time_ticks :: Word,
+    cc_is_caf :: Bool,
+    cc_link :: Maybe CostCentre
+} deriving (Show, Generic, Eq, Ord)
+
+-- | This is a somewhat faithful representation of IndexTable. See
+-- https://gitlab.haskell.org/ghc/ghc/blob/master/rts/include/rts/prof/CCS.h
+-- for more details on this data structure.
+data IndexTable = IndexTable {
+    it_cc :: CostCentre,
+    it_ccs :: Maybe CostCentreStack,
+    it_next :: Maybe IndexTable,
+    it_back_edge :: Bool
+} deriving (Show, Generic, Eq, Ord)


=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/Annotation.hs
=====================================
@@ -0,0 +1,32 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module GHC.Internal.Stack.Annotation (
+  IsStackAnnotation(..),
+  SomeStackAnnotation(..),
+  )
+  where
+
+import GHC.Internal.Base
+import GHC.Internal.Data.Typeable
+
+-- ----------------------------------------------------------------------------
+-- IsStackAnnotation
+-- ----------------------------------------------------------------------------
+
+class IsStackAnnotation a where
+  displayStackAnnotation :: a -> String
+
+-- ----------------------------------------------------------------------------
+-- Annotations
+-- ----------------------------------------------------------------------------
+
+{- |
+The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy.
+When the call stack is annotated with a value of type @a@, behind the scenes it is
+encapsulated in a @SomeStackAnnotation@.
+-}
+data SomeStackAnnotation where
+  SomeStackAnnotation :: forall a. (Typeable a, IsStackAnnotation a) => a -> SomeStackAnnotation
+
+instance IsStackAnnotation SomeStackAnnotation where
+  displayStackAnnotation (SomeStackAnnotation a) = displayStackAnnotation a


=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/CloneStack.hs
=====================================
@@ -18,8 +18,8 @@ module GHC.Internal.Stack.CloneStack (
   StackEntry(..),
   cloneMyStack,
   cloneThreadStack,
-  decode,
-  prettyStackEntry
+  decode, -- TODO @fendor: deprecate
+  toStackEntry, -- TODO @fendor: deprecate
   ) where
 
 import GHC.Internal.MVar
@@ -40,7 +40,7 @@ import GHC.Internal.ClosureTypes
 --
 -- @since base-4.17.0.0
 data StackSnapshot = StackSnapshot !StackSnapshot#
-
+-- TODO @fendor: deprecate
 foreign import prim "stg_decodeStackzh" decodeStack# :: StackSnapshot# -> State# RealWorld -> (# State# RealWorld, ByteArray# #)
 
 foreign import prim "stg_cloneMyStackzh" cloneMyStack# :: State# RealWorld -> (# State# RealWorld, StackSnapshot# #)
@@ -208,6 +208,7 @@ cloneThreadStack (ThreadId tid#) = do
 
 -- | Representation for the source location where a return frame was pushed on the stack.
 -- This happens every time when a @case ... of@ scrutinee is evaluated.
+-- TODO @fendor: deprecate
 data StackEntry = StackEntry
   { functionName :: String,
     moduleName :: String,
@@ -232,9 +233,11 @@ data StackEntry = StackEntry
 --     is evaluated.)
 --
 -- @since base-4.17.0.0
+-- TODO @fendor: deprecate
 decode :: StackSnapshot -> IO [StackEntry]
 decode stackSnapshot = catMaybes `fmap` getDecodedStackArray stackSnapshot
 
+-- TODO @fendor: deprecate
 toStackEntry :: InfoProv -> StackEntry
 toStackEntry infoProv =
   StackEntry
@@ -244,6 +247,7 @@ toStackEntry infoProv =
     closureType = ipDesc infoProv
   }
 
+-- TODO @fendor: deprecate
 getDecodedStackArray :: StackSnapshot -> IO [Maybe StackEntry]
 getDecodedStackArray (StackSnapshot s) =
   IO $ \s0 -> case decodeStack# s s0 of
@@ -263,6 +267,7 @@ getDecodedStackArray (StackSnapshot s) =
 
     wordSize = sizeOf (nullPtr :: Ptr ())
 
+-- TODO @fendor: deprecate
 prettyStackEntry :: StackEntry -> String
 prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =
     "  " ++ mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")"


=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/Constants.hsc
=====================================
@@ -0,0 +1,135 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+module GHC.Internal.Stack.Constants where
+
+import GHC.Internal.Base
+import GHC.Internal.Enum
+import GHC.Internal.Num
+import GHC.Internal.Show
+import GHC.Internal.Real
+
+#include "Rts.h"
+#undef BLOCK_SIZE
+#undef MBLOCK_SIZE
+#undef BLOCKS_PER_MBLOCK
+#include "DerivedConstants.h"
+
+newtype ByteOffset = ByteOffset { offsetInBytes :: Int }
+  deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord)
+
+newtype WordOffset = WordOffset { offsetInWords :: Int }
+  deriving newtype (Eq, Show, Integral, Real, Num, Enum, Ord)
+
+offsetStgCatchFrameHandler :: WordOffset
+offsetStgCatchFrameHandler = byteOffsetToWordOffset $
+  (#const OFFSET_StgCatchFrame_handler) + (#size StgHeader)
+
+sizeStgCatchFrame :: Int
+sizeStgCatchFrame = bytesToWords $
+  (#const SIZEOF_StgCatchFrame_NoHdr) + (#size StgHeader)
+
+offsetStgCatchSTMFrameCode :: WordOffset
+offsetStgCatchSTMFrameCode = byteOffsetToWordOffset $
+  (#const OFFSET_StgCatchSTMFrame_code) + (#size StgHeader)
+
+offsetStgCatchSTMFrameHandler :: WordOffset
+offsetStgCatchSTMFrameHandler = byteOffsetToWordOffset $
+  (#const OFFSET_StgCatchSTMFrame_handler) + (#size StgHeader)
+
+sizeStgCatchSTMFrame :: Int
+sizeStgCatchSTMFrame = bytesToWords $
+  (#const SIZEOF_StgCatchSTMFrame_NoHdr) + (#size StgHeader)
+
+offsetStgUpdateFrameUpdatee :: WordOffset
+offsetStgUpdateFrameUpdatee = byteOffsetToWordOffset $
+  (#const OFFSET_StgUpdateFrame_updatee) + (#size StgHeader)
+
+sizeStgUpdateFrame :: Int
+sizeStgUpdateFrame = bytesToWords $
+  (#const SIZEOF_StgUpdateFrame_NoHdr) + (#size StgHeader)
+
+offsetStgAtomicallyFrameCode :: WordOffset
+offsetStgAtomicallyFrameCode = byteOffsetToWordOffset $
+  (#const OFFSET_StgAtomicallyFrame_code) + (#size StgHeader)
+
+offsetStgAtomicallyFrameResult :: WordOffset
+offsetStgAtomicallyFrameResult = byteOffsetToWordOffset $
+  (#const OFFSET_StgAtomicallyFrame_result) + (#size StgHeader)
+
+sizeStgAtomicallyFrame :: Int
+sizeStgAtomicallyFrame = bytesToWords $
+  (#const SIZEOF_StgAtomicallyFrame_NoHdr) + (#size StgHeader)
+
+offsetStgCatchRetryFrameRunningAltCode :: WordOffset
+offsetStgCatchRetryFrameRunningAltCode = byteOffsetToWordOffset $
+  (#const OFFSET_StgCatchRetryFrame_running_alt_code) + (#size StgHeader)
+
+offsetStgCatchRetryFrameRunningFirstCode :: WordOffset
+offsetStgCatchRetryFrameRunningFirstCode = byteOffsetToWordOffset $
+  (#const OFFSET_StgCatchRetryFrame_first_code) + (#size StgHeader)
+
+offsetStgCatchRetryFrameAltCode :: WordOffset
+offsetStgCatchRetryFrameAltCode = byteOffsetToWordOffset $
+  (#const OFFSET_StgCatchRetryFrame_alt_code) + (#size StgHeader)
+
+sizeStgCatchRetryFrame :: Int
+sizeStgCatchRetryFrame = bytesToWords $
+  (#const SIZEOF_StgCatchRetryFrame_NoHdr) + (#size StgHeader)
+
+offsetStgRetFunFrameSize :: WordOffset
+-- StgRetFun has no header, but only a pointer to the info table at the beginning.
+offsetStgRetFunFrameSize = byteOffsetToWordOffset (#const OFFSET_StgRetFun_size)
+
+offsetStgRetFunFrameFun :: WordOffset
+offsetStgRetFunFrameFun = byteOffsetToWordOffset (#const OFFSET_StgRetFun_fun)
+
+offsetStgRetFunFramePayload :: WordOffset
+offsetStgRetFunFramePayload = byteOffsetToWordOffset (#const OFFSET_StgRetFun_payload)
+
+sizeStgRetFunFrame :: Int
+sizeStgRetFunFrame = bytesToWords (#const SIZEOF_StgRetFun)
+
+sizeStgAnnFrame :: Int
+sizeStgAnnFrame = bytesToWords $
+  (#const SIZEOF_StgAnnFrame_NoHdr) + (#size StgHeader)
+
+offsetStgAnnFrameAnn :: WordOffset
+offsetStgAnnFrameAnn = byteOffsetToWordOffset $
+  (#const OFFSET_StgAnnFrame_ann) + (#size StgHeader)
+
+offsetStgBCOFrameInstrs :: ByteOffset
+offsetStgBCOFrameInstrs = (#const OFFSET_StgBCO_instrs) + (#size StgHeader)
+
+offsetStgBCOFrameLiterals :: ByteOffset
+offsetStgBCOFrameLiterals = (#const OFFSET_StgBCO_literals) + (#size StgHeader)
+
+offsetStgBCOFramePtrs :: ByteOffset
+offsetStgBCOFramePtrs = (#const OFFSET_StgBCO_ptrs) + (#size StgHeader)
+
+offsetStgBCOFrameArity :: ByteOffset
+offsetStgBCOFrameArity = (#const OFFSET_StgBCO_arity) + (#size StgHeader)
+
+offsetStgBCOFrameSize :: ByteOffset
+offsetStgBCOFrameSize = (#const OFFSET_StgBCO_size) + (#size StgHeader)
+
+offsetStgClosurePayload :: WordOffset
+offsetStgClosurePayload = byteOffsetToWordOffset $
+  (#const OFFSET_StgClosure_payload) + (#size StgHeader)
+
+sizeStgClosure :: Int
+sizeStgClosure = bytesToWords (#size StgHeader)
+
+byteOffsetToWordOffset :: ByteOffset -> WordOffset
+byteOffsetToWordOffset = WordOffset . bytesToWords . fromInteger . toInteger
+
+bytesToWords :: Int -> Int
+bytesToWords b =
+  if b `mod` bytesInWord == 0 then
+      fromIntegral $ b `div` bytesInWord
+    else
+      error "Unexpected struct alignment!"
+
+bytesInWord :: Int
+bytesInWord = (#const SIZEOF_VOID_P)
+


=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs
=====================================
@@ -0,0 +1,499 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+module GHC.Internal.Stack.Decode (
+  decodeStack,
+  decodeStackWithIpe,
+  prettyStackFrameWithIpe,
+  -- * StackEntry
+  StackEntry(..),
+  prettyStackEntry,
+  decode,
+  )
+where
+
+import GHC.Internal.Base
+import GHC.Internal.Show
+import GHC.Internal.Real
+import GHC.Internal.Word
+import GHC.Internal.Num
+import GHC.Internal.Data.Bits
+import GHC.Internal.Data.Functor
+import GHC.Internal.Data.List
+import GHC.Internal.Data.Tuple
+import GHC.Internal.Foreign.Ptr
+import GHC.Internal.Foreign.Storable
+import GHC.Internal.Exts
+import GHC.Internal.Unsafe.Coerce
+
+import GHC.Internal.ClosureTypes
+import GHC.Internal.Heap.Closures
+  ( Box (..),
+    StackFrame,
+    GenStackFrame (..),
+    StgStackClosure,
+    GenStgStackClosure (..),
+    StackField,
+    GenStackField(..)
+  )
+import GHC.Internal.Heap.Constants (wORD_SIZE_IN_BITS)
+import GHC.Internal.Heap.InfoTable
+import GHC.Internal.Stack.Annotation
+import GHC.Internal.Stack.Constants
+import GHC.Internal.Stack.CloneStack
+import GHC.Internal.InfoProv.Types (InfoProv (..), lookupIPE)
+
+{- Note [Decoding the stack]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The stack is represented by a chain of StgStack closures. Each of these closures
+is subject to garbage collection. I.e. they can be moved in memory (in a
+simplified perspective) at any time.
+
+The array of closures inside an StgStack (that makeup the execution stack; the
+stack frames) is moved as bare memory by the garbage collector. References
+(pointers) to stack frames are not updated by the garbage collector.
+
+As the StgStack closure is moved as whole, the relative offsets inside it stay
+the same. (Though, the absolute addresses change!)
+
+Decoding
+========
+
+Stack frames are defined by their `StackSnapshot#` (`StgStack*` in RTS) and
+their relative offset. This tuple is described by `StackFrameLocation`.
+
+`StackFrame` is an ADT for decoded stack frames. Regarding payload and fields we
+have to deal with three cases:
+
+- If the payload can only be a closure, we put it in a `Box` for later decoding
+  by the heap closure functions.
+
+- If the payload can either be a closure or a word-sized value (this happens for
+  bitmap-encoded payloads), we use a `StackField` which is a sum type to
+  represent either a `Word` or a `Box`.
+
+- Fields that are just simple (i.e. non-closure) values are decoded as such.
+
+The decoding happens in two phases:
+
+1. The whole stack is decoded into `StackFrameLocation`s.
+
+2. All `StackFrameLocation`s are decoded into `StackFrame`s.
+
+`StackSnapshot#` parameters are updated by the garbage collector and thus safe
+to hand around.
+
+The head of the stack frame array has offset (index) 0. To traverse the stack
+frames the latest stack frame's offset is incremented by the closure size. The
+unit of the offset is machine words (32bit or 64bit.)
+
+IO
+==
+
+Unfortunately, ghc-heap decodes `Closure`s in `IO`. This leads to `StackFrames`
+also being decoded in `IO`, due to references to `Closure`s.
+
+Technical details
+=================
+
+- All access to StgStack/StackSnapshot# closures is made through Cmm code. This
+  keeps the closure from being moved by the garbage collector during the
+  operation.
+
+- As StgStacks are mainly used in Cmm and C code, much of the decoding logic is
+  implemented in Cmm and C. It's just easier to reuse existing helper macros and
+  functions, than reinventing them in Haskell.
+
+- Offsets and sizes of closures are imported from DerivedConstants.h via HSC.
+  This keeps the code very portable.
+-}
+
+foreign import prim "getUnderflowFrameNextChunkzh"
+  getUnderflowFrameNextChunk# ::
+    StackSnapshot# -> Word# -> StackSnapshot#
+
+getUnderflowFrameNextChunk :: StackSnapshot# -> WordOffset -> StackSnapshot
+getUnderflowFrameNextChunk stackSnapshot# index =
+  StackSnapshot (getUnderflowFrameNextChunk# stackSnapshot# (wordOffsetToWord# index))
+
+foreign import prim "getWordzh"
+  getWord# ::
+    StackSnapshot# -> Word# -> Word#
+
+getWord :: StackSnapshot# -> WordOffset -> Word
+getWord stackSnapshot# index =
+  W# (getWord# stackSnapshot# (wordOffsetToWord# index))
+
+foreign import prim "isArgGenBigRetFunTypezh" isArgGenBigRetFunType# :: StackSnapshot# -> Word# -> Int#
+
+isArgGenBigRetFunType :: StackSnapshot# -> WordOffset -> Bool
+isArgGenBigRetFunType stackSnapshot# index =
+  I# (isArgGenBigRetFunType# stackSnapshot# (wordOffsetToWord# index)) > 0
+
+-- | Gets contents of a `LargeBitmap` (@StgLargeBitmap@)
+--
+-- The first two arguments identify the location of the frame on the stack.
+-- Returned is the `Addr#` of the @StgWord[]@ (bitmap) and it's size.
+type LargeBitmapGetter = StackSnapshot# -> Word# -> (# Addr#, Word# #)
+
+foreign import prim "getLargeBitmapzh" getLargeBitmap# :: LargeBitmapGetter
+
+foreign import prim "getBCOLargeBitmapzh" getBCOLargeBitmap# :: LargeBitmapGetter
+
+foreign import prim "getRetFunLargeBitmapzh" getRetFunLargeBitmap# :: LargeBitmapGetter
+
+-- | Gets contents of a small bitmap (fitting in one @StgWord@)
+--
+-- The first two arguments identify the location of the frame on the stack.
+-- Returned is the bitmap and it's size.
+type SmallBitmapGetter = StackSnapshot# -> Word# -> (# Word#, Word# #)
+
+foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter
+
+foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter
+
+foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #)
+
+foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr#
+
+-- | Get the 'StgInfoTable' of the stack frame.
+-- Additionally, provides 'InfoProv' for the 'StgInfoTable' if there is any.
+getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe InfoProv)
+getInfoTableOnStack stackSnapshot# index =
+  let !(# itbl_struct#, itbl_ptr# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index)
+   in
+    (,) <$> peekItbl (Ptr itbl_struct#) <*> lookupIPE (Ptr itbl_ptr#)
+
+getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable
+getInfoTableForStack stackSnapshot# =
+  peekItbl $
+    Ptr (getStackInfoTableAddr# stackSnapshot#)
+
+foreign import prim "getStackClosurezh"
+  getStackClosure# ::
+    StackSnapshot# -> Word# ->  Any
+
+foreign import prim "getStackFieldszh"
+  getStackFields# ::
+    StackSnapshot# -> Word32#
+
+getStackFields :: StackSnapshot# -> Word32
+getStackFields stackSnapshot# =
+  case getStackFields# stackSnapshot# of
+    sSize# -> W32# sSize#
+
+-- | `StackFrameLocation` of the top-most stack frame
+stackHead :: StackSnapshot# -> StackFrameLocation
+stackHead s# = (StackSnapshot s#, 0) -- GHC stacks are never empty
+
+-- | Advance to the next stack frame (if any)
+--
+-- The last `Int#` in the result tuple is meant to be treated as bool
+-- (has_next).
+foreign import prim "advanceStackFrameLocationzh"
+  advanceStackFrameLocation# ::
+    StackSnapshot# -> Word# -> (# StackSnapshot#, Word#, Int# #)
+
+-- | Advance to the next stack frame (if any)
+advanceStackFrameLocation :: StackFrameLocation -> Maybe StackFrameLocation
+advanceStackFrameLocation ((StackSnapshot stackSnapshot#), index) =
+  let !(# s', i', hasNext #) = advanceStackFrameLocation# stackSnapshot# (wordOffsetToWord# index)
+   in if I# hasNext > 0
+        then Just (StackSnapshot s', primWordToWordOffset i')
+        else Nothing
+  where
+    primWordToWordOffset :: Word# -> WordOffset
+    primWordToWordOffset w# = fromIntegral (W# w#)
+
+getClosureBox :: StackSnapshot# -> WordOffset -> Box
+getClosureBox stackSnapshot# index =
+        case getStackClosure# stackSnapshot# (wordOffsetToWord# index) of
+          -- c needs to be strictly evaluated, otherwise a thunk gets boxed (and
+          -- will later be decoded as such)
+          !c -> Box c
+
+-- | Representation of @StgLargeBitmap@ (RTS)
+data LargeBitmap = LargeBitmap
+  { largeBitmapSize :: Word,
+    largebitmapWords :: Ptr Word
+  }
+
+-- | Is a bitmap entry a closure pointer or a primitive non-pointer?
+data Pointerness = Pointer | NonPointer
+  deriving (Show)
+
+decodeLargeBitmap :: LargeBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [StackField]
+decodeLargeBitmap getterFun# stackSnapshot# index relativePayloadOffset = do
+  let largeBitmap = case getterFun# stackSnapshot# (wordOffsetToWord# index) of
+        (# wordsAddr#, size# #) -> LargeBitmap (W# size#) (Ptr wordsAddr#)
+  bitmapWords <- largeBitmapToList largeBitmap
+  pure $ decodeBitmaps
+          stackSnapshot#
+          (index + relativePayloadOffset)
+          (bitmapWordsPointerness (largeBitmapSize largeBitmap) bitmapWords)
+  where
+    largeBitmapToList :: LargeBitmap -> IO [Word]
+    largeBitmapToList LargeBitmap {..} =
+      cWordArrayToList largebitmapWords $
+        (usedBitmapWords . fromIntegral) largeBitmapSize
+
+    cWordArrayToList :: Ptr Word -> Int -> IO [Word]
+    cWordArrayToList ptr size = mapM (peekElemOff ptr) [0 .. (size - 1)]
+
+    usedBitmapWords :: Int -> Int
+    usedBitmapWords 0 = error "Invalid large bitmap size 0."
+    usedBitmapWords size = (size `div` fromIntegral wORD_SIZE_IN_BITS) + 1
+
+    bitmapWordsPointerness :: Word -> [Word] -> [Pointerness]
+    bitmapWordsPointerness size _ | size <= 0 = []
+    bitmapWordsPointerness _ [] = []
+    bitmapWordsPointerness size (w : wds) =
+      bitmapWordPointerness (min size (fromIntegral wORD_SIZE_IN_BITS)) w
+        ++ bitmapWordsPointerness (size - fromIntegral wORD_SIZE_IN_BITS) wds
+
+bitmapWordPointerness :: Word -> Word -> [Pointerness]
+bitmapWordPointerness 0 _ = []
+bitmapWordPointerness bSize bitmapWord =
+  ( if (bitmapWord .&. 1) /= 0
+      then NonPointer
+      else Pointer
+  )
+    : bitmapWordPointerness
+      (bSize - 1)
+      (bitmapWord `shiftR` 1)
+
+decodeBitmaps :: StackSnapshot# -> WordOffset -> [Pointerness] -> [StackField]
+decodeBitmaps stack# index ps =
+  zipWith toPayload ps [index ..]
+  where
+    toPayload :: Pointerness -> WordOffset -> StackField
+    toPayload p i = case p of
+      NonPointer -> StackWord (getWord stack# i)
+      Pointer -> StackBox (getClosureBox stack# i)
+
+decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> [StackField]
+decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset =
+  let (bitmap, size) = case getterFun# stackSnapshot# (wordOffsetToWord# index) of
+        (# b#, s# #) -> (W# b#, W# s#)
+  in decodeBitmaps
+      stackSnapshot#
+      (index + relativePayloadOffset)
+      (bitmapWordPointerness size bitmap)
+
+unpackStackFrame :: StackFrameLocation -> IO StackFrame
+unpackStackFrame stackFrameLoc = do
+  unpackStackFrameTo stackFrameLoc
+    (\ info nextChunk -> do
+      stackClosure <- decodeStack nextChunk
+      pure $
+        UnderflowFrame
+          { info_tbl = info,
+            nextChunk = stackClosure
+          }
+    )
+    (\ frame _ -> pure frame)
+
+unpackStackFrameWithIpe :: StackFrameLocation -> IO [(StackFrame, Maybe InfoProv)]
+unpackStackFrameWithIpe stackFrameLoc = do
+  unpackStackFrameTo stackFrameLoc
+    (\ _ nextChunk -> do
+      decodeStackWithIpe nextChunk
+    )
+    (\ frame mIpe -> pure [(frame, mIpe)])
+
+unpackStackFrameTo ::
+  forall a .
+  StackFrameLocation ->
+  (StgInfoTable -> StackSnapshot -> IO a) ->
+  (StackFrame -> Maybe InfoProv -> IO a) ->
+  IO a
+unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do
+  (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index
+  unpackStackFrame' info
+    (`finaliseStackFrame` m_info_prov)
+  where
+    unpackStackFrame' ::
+      StgInfoTable ->
+      (StackFrame -> IO a) ->
+      IO a
+    unpackStackFrame' info mkStackFrameResult =
+      case tipe info of
+        RET_BCO -> do
+          let bco' = getClosureBox stackSnapshot# (index + offsetStgClosurePayload)
+          -- The arguments begin directly after the payload's one element
+          bcoArgs' <- decodeLargeBitmap getBCOLargeBitmap# stackSnapshot# index (offsetStgClosurePayload + 1)
+          mkStackFrameResult
+            RetBCO
+              { info_tbl = info,
+                bco = bco',
+                bcoArgs = bcoArgs'
+              }
+        RET_SMALL ->
+          let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload
+          in
+            mkStackFrameResult $
+              RetSmall
+                { info_tbl = info,
+                  stack_payload = payload'
+                }
+        RET_BIG -> do
+          payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload
+          mkStackFrameResult $
+            RetBig
+              { info_tbl = info,
+                stack_payload = payload'
+              }
+        RET_FUN -> do
+          let retFunSize' = getWord stackSnapshot# (index + offsetStgRetFunFrameSize)
+              retFunFun' = getClosureBox stackSnapshot# (index + offsetStgRetFunFrameFun)
+          retFunPayload' <-
+            if isArgGenBigRetFunType stackSnapshot# index == True
+              then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload
+              else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload
+          mkStackFrameResult $
+            RetFun
+              { info_tbl = info,
+                retFunSize = retFunSize',
+                retFunFun = retFunFun',
+                retFunPayload = retFunPayload'
+              }
+        UPDATE_FRAME ->
+          let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee)
+          in
+            mkStackFrameResult $
+              UpdateFrame
+                { info_tbl = info,
+                  updatee = updatee'
+                }
+        CATCH_FRAME -> do
+          let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler)
+          mkStackFrameResult $
+            CatchFrame
+              { info_tbl = info,
+                handler = handler'
+              }
+        UNDERFLOW_FRAME -> do
+          let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index
+          unpackUnderflowFrame info nextChunk'
+        STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info}
+        ATOMICALLY_FRAME -> do
+          let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode)
+              result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult)
+          mkStackFrameResult $
+            AtomicallyFrame
+              { info_tbl = info,
+                atomicallyFrameCode = atomicallyFrameCode',
+                result = result'
+              }
+        CATCH_RETRY_FRAME ->
+          let running_alt_code' = getWord stackSnapshot# (index + offsetStgCatchRetryFrameRunningAltCode)
+              first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode)
+              alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode)
+          in
+            mkStackFrameResult $
+              CatchRetryFrame
+                { info_tbl = info,
+                  running_alt_code = running_alt_code',
+                  first_code = first_code',
+                  alt_code = alt_code'
+                }
+        CATCH_STM_FRAME ->
+          let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode)
+              handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler)
+          in
+            mkStackFrameResult $
+              CatchStmFrame
+                { info_tbl = info,
+                  catchFrameCode = catchFrameCode',
+                  handler = handler'
+                }
+        ANN_FRAME ->
+          let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn)
+           in
+             mkStackFrameResult $
+               AnnFrame
+                { info_tbl = info,
+                  annotation = annotation
+                }
+        x -> error $ "Unexpected closure type on stack: " ++ show x
+
+-- | Unbox 'Int#' from 'Int'
+toInt# :: Int -> Int#
+toInt# (I# i) = i
+
+-- | Convert `Int` to `Word#`
+intToWord# :: Int -> Word#
+intToWord# i = int2Word# (toInt# i)
+
+wordOffsetToWord# :: WordOffset -> Word#
+wordOffsetToWord# wo = intToWord# (fromIntegral wo)
+
+-- | Location of a stackframe on the stack
+--
+-- It's defined by the `StackSnapshot` (@StgStack@) and the offset to the bottom
+-- of the stack.
+type StackFrameLocation = (StackSnapshot, WordOffset)
+
+-- | Decode `StackSnapshot` to a `StgStackClosure`
+--
+-- The return value is the representation of the @StgStack@ itself.
+--
+-- See /Note [Decoding the stack]/.
+decodeStack :: StackSnapshot -> IO StgStackClosure
+decodeStack snapshot@(StackSnapshot stack#) = do
+  (stackInfo, ssc_stack) <- decodeStackWithFrameUnpack unpackStackFrame snapshot
+  pure
+    GenStgStackClosure
+      { ssc_info = stackInfo,
+        ssc_stack_size = getStackFields stack#,
+        ssc_stack = ssc_stack
+      }
+
+decodeStackWithIpe :: StackSnapshot -> IO [(StackFrame, Maybe InfoProv)]
+decodeStackWithIpe snapshot =
+  concat . snd <$> decodeStackWithFrameUnpack unpackStackFrameWithIpe snapshot
+
+decodeStackWithFrameUnpack :: (StackFrameLocation -> IO a) -> StackSnapshot -> IO (StgInfoTable, [a])
+decodeStackWithFrameUnpack unpackFrame (StackSnapshot stack#) = do
+  info <- getInfoTableForStack stack#
+  case tipe info of
+    STACK -> do
+      let sfls = stackFrameLocations stack#
+      stack' <- mapM unpackFrame sfls
+      pure (info, stack')
+    _ -> error $ "Expected STACK closure, got " ++ show info
+  where
+    stackFrameLocations :: StackSnapshot# -> [StackFrameLocation]
+    stackFrameLocations s# =
+      stackHead s#
+        : go (advanceStackFrameLocation (stackHead s#))
+      where
+        go :: Maybe StackFrameLocation -> [StackFrameLocation]
+        go Nothing = []
+        go (Just r) = r : go (advanceStackFrameLocation r)
+
+prettyStackFrameWithIpe :: (StackFrame, Maybe InfoProv) -> Maybe String
+prettyStackFrameWithIpe (frame, mipe) =
+  case frame of
+    AnnFrame _ (Box ann) ->
+      Just $ displayStackAnnotation (unsafeCoerce ann :: SomeStackAnnotation)
+    _ ->
+      (prettyStackEntry . toStackEntry) <$> mipe
+
+
+-- TODO @fendor: deprecate
+prettyStackEntry :: StackEntry -> String
+prettyStackEntry (StackEntry {moduleName=mod_nm, functionName=fun_nm, srcLoc=loc}) =
+  mod_nm ++ "." ++ fun_nm ++ " (" ++ loc ++ ")"



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f2e641b5e405ab10c684bb955e54819a...

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f2e641b5e405ab10c684bb955e54819a...
You're receiving this email because of your account on gitlab.haskell.org.

    

Hannes Siebenhandl (＠fendor)

tags

participants (1)