.gitlab-ci.yml

@@ -659,22 +659,6 @@ validate-x86_64-linux-deb9-debug:
     when: always
     expire_in: 2 week
 
-# Disabled to alleviate CI load
-.validate-x86_64-linux-deb9-llvm:
-  extends: .build-x86_64-linux-deb9
-  stage: full-build
-  variables:
-    BUILD_FLAVOUR: perf-llvm
-    TEST_ENV: "x86_64-linux-deb9-llvm"
-
-nightly-x86_64-linux-deb9-llvm:
-  <<: *nightly
-  extends: .build-x86_64-linux-deb9
-  stage: full-build
-  variables:
-    BUILD_FLAVOUR: perf-llvm
-    TEST_ENV: "x86_64-linux-deb9-llvm"
-
 validate-x86_64-linux-deb9-integer-simple:
   extends: .build-x86_64-linux-deb9
   stage: full-build
@@ -759,6 +743,23 @@ release-x86_64-linux-deb10-dwarf:
     TEST_ENV: "x86_64-linux-deb10-dwarf"
     BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-deb10-linux-dwarf.tar.xz"
 
+validate-x86_64-linux-deb10-llvm:
+  extends: .build-x86_64-linux-deb10
+  stage: full-build
+  rules:
+    - if: '$CI_MERGE_REQUEST_LABELS =~ /.*LLVM backend.*/'
+  variables:
+    BUILD_FLAVOUR: perf-llvm
+    TEST_ENV: "x86_64-linux-deb10-llvm"
+
+nightly-x86_64-linux-deb10-llvm:
+  <<: *nightly
+  extends: .build-x86_64-linux-deb10
+  stage: full-build
+  variables:
+    BUILD_FLAVOUR: perf-llvm
+    TEST_ENV: "x86_64-linux-deb10-llvm"
+
 #################################
 # x86_64-linux-ubuntu 20.04
 #################################

compiler/GHC/ByteCode/Types.hs

@@ -37,7 +37,7 @@ import Data.ByteString (ByteString)
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
 import Data.Maybe (catMaybes)
-import GHC.Exts.Heap
+import qualified GHC.Exts.Heap as Heap
 import GHC.Stack.CCS
 
 -- -----------------------------------------------------------------------------
@@ -72,7 +72,7 @@ type ItblEnv = NameEnv (Name, ItblPtr)
         -- We need the Name in the range so we know which
         -- elements to filter out when unloading a module
 
-newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable)
+newtype ItblPtr = ItblPtr (RemotePtr Heap.StgInfoTable)
   deriving (Show, NFData)
 
 data UnlinkedBCO

compiler/GHC/CmmToLlvm/Base.hs

@@ -476,13 +476,15 @@ ghcInternalFunctions :: LlvmM ()
 ghcInternalFunctions = do
     platform <- getPlatform
     let w = llvmWord platform
+        cint = LMInt $ widthInBits $ cIntWidth platform
+    mk "memcmp" cint [i8Ptr, i8Ptr, w]
     mk "memcpy" i8Ptr [i8Ptr, i8Ptr, w]
     mk "memmove" i8Ptr [i8Ptr, i8Ptr, w]
     mk "memset" i8Ptr [i8Ptr, w, w]
     mk "newSpark" w [i8Ptr, i8Ptr]
   where
     mk n ret args = do
-      let n' = llvmDefLabel $ fsLit n
+      let n' = fsLit n
           decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
                                  FixedArgs (tysToParams args) Nothing
       renderLlvm $ ppLlvmFunctionDecl decl
@@ -516,7 +518,10 @@ getGlobalPtr llvmLbl = do
   let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing
   case m_ty of
     -- Directly reference if we have seen it already
-    Just ty -> return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global
+    Just ty -> do
+      if llvmLbl `elem` (map fsLit ["newSpark", "memmove", "memcpy", "memcmp", "memset"])
+        then return $ mkGlbVar (llvmLbl) ty Global
+        else return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global
     -- Otherwise use a forward alias of it
     Nothing -> do
       saveAlias llvmLbl

compiler/GHC/Runtime/Interpreter.hs

@@ -103,7 +103,7 @@ import qualified Data.ByteString.Lazy as LB
 import Data.Array ((!))
 import Data.IORef
 import Foreign hiding (void)
-import GHC.Exts.Heap
+import qualified GHC.Exts.Heap as Heap
 import GHC.Stack.CCS (CostCentre,CostCentreStack)
 import System.Exit
 import GHC.IO.Handle.Types (Handle)
@@ -395,7 +395,7 @@ getBreakpointVar hsc_env ref ix =
     mb <- iservCmd hsc_env (GetBreakpointVar apStack ix)
     mapM (mkFinalizedHValue hsc_env) mb
 
-getClosure :: HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
+getClosure :: HscEnv -> ForeignHValue -> IO (Heap.GenClosure ForeignHValue)
 getClosure hsc_env ref =
   withForeignRef ref $ \hval -> do
     mb <- iservCmd hsc_env (GetClosure hval)

docs/users_guide/conf.py

@@ -101,6 +101,9 @@ latex_elements = {
 \setmonofont{DejaVu Sans Mono}
 \setlength{\tymin}{45pt}
 
+% Dynamic section number spacing. Fixes #18554
+\renewcommand{\numberline}[1]{#1~}
+
 % Avoid a torrent of over-full \hbox warnings
 \usepackage{microtype}
 \hbadness=99999

includes/Rts.h

@@ -37,12 +37,17 @@ extern "C" {
 #include "HsFFI.h"
 #include "RtsAPI.h"
 
-// Turn off inlining when debugging - it obfuscates things
+// Disencourage gcc from inlining when debugging - it obfuscates things
 #if defined(DEBUG)
 # undef  STATIC_INLINE
 # define STATIC_INLINE static
 #endif
 
+// Fine grained inlining control helpers.
+#define ATTR_ALWAYS_INLINE __attribute__((always_inline))
+#define ATTR_NOINLINE      __attribute__((noinline))
+
+
 #include "rts/Types.h"
 #include "rts/Time.h"
 

includes/RtsAPI.h

@@ -18,8 +18,6 @@ extern "C" {
 #include "HsFFI.h"
 #include "rts/Time.h"
 #include "rts/Types.h"
-#include "rts/EventLogWriter.h"
-
 
 /*
  * Running the scheduler
@@ -60,6 +58,9 @@ typedef struct CapabilityPublic_ {
     StgRegTable r;
 } CapabilityPublic;
 
+/* N.B. this needs the Capability declaration above. */
+#include "rts/EventLogWriter.h"
+
 /* ----------------------------------------------------------------------------
    RTS configuration settings, for passing to hs_init_ghc()
    ------------------------------------------------------------------------- */

includes/rts/EventLogWriter.h

@@ -68,3 +68,8 @@ bool startEventLogging(const EventLogWriter *writer);
  * Stop event logging and destroy the current EventLogWriter.
  */
 void endEventLogging(void);
+
+/*
+ * Flush the eventlog. cap can be NULL if one is not held.
+ */
+void flushEventLog(Capability **cap);

libraries/base/Debug/Trace.hs

@@ -37,6 +37,7 @@ module Debug.Trace (
         -- $eventlog_tracing
         traceEvent,
         traceEventIO,
+        flushEventLog,
 
         -- * Execution phase markers
         -- $markers
@@ -319,3 +320,11 @@ traceMarkerIO :: String -> IO ()
 traceMarkerIO msg =
   GHC.Foreign.withCString utf8 msg $ \(Ptr p) -> IO $ \s ->
     case traceMarker# p s of s' -> (# s', () #)
+
+-- | Immediately flush the event log, if enabled.
+--
+-- @since 4.15.0.0
+flushEventLog :: IO ()
+flushEventLog = c_flushEventLog nullPtr
+
+foreign import ccall "flushEventLog" c_flushEventLog :: Ptr () -> IO ()

libraries/ghc-boot/GHC/Data/ShortText.hs

-{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, GeneralizedNewtypeDeriving, DerivingStrategies #-}
+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, GeneralizedNewtypeDeriving, DerivingStrategies, CPP #-}
 {-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
-
+-- gross hack: we manuvered ourselves into a position where we can't boot GHC with a LLVM based GHC anymore.
+-- LLVM based GHC's fail to compile memcmp ffi calls.  These end up as memcmp$def in the llvm ir, however we
+-- don't have any prototypes and subsequently the llvm toolchain chokes on them.  Since 7fdcce6d, we use
+-- ShortText for the package database.  This however introduces this very module; which through inlining ends
+-- up bringing memcmp_ByteArray from bytestring:Data.ByteString.Short.Internal into scope, which results in
+-- the memcmp call we choke on.
+--
+-- The solution thusly is to force late binding via the linker instead of inlining when comping with the
+-- bootstrap compiler.  This will produce a slower (slightly less optimised) stage1 compiler only.
+--
+-- See issue 18857. hsyl20 deserves credit for coming up with the idea for the soltuion.
+--
+-- This can be removed when we exit the boot compiler window. Thus once we drop GHC-9.2 as boot compiler,
+-- we can drop this code as well.
+#if GHC_STAGE < 1
+{-# OPTIONS_GHC -fignore-interface-pragmas #-}
+#endif
 -- |
 -- An Unicode string for internal GHC use. Meant to replace String
 -- in places where being a lazy linked is not very useful and a more

libraries/ghc-heap/GHC/Exts/Heap.hs

@@ -27,6 +27,9 @@ module GHC.Exts.Heap (
     , GenClosure(..)
     , ClosureType(..)
     , PrimType(..)
+    , WhatNext(..)
+    , WhyBlocked(..)
+    , TsoFlags(..)
     , HasHeapRep(getClosureData)
     , getClosureDataFromHeapRep
 
@@ -39,6 +42,12 @@ module GHC.Exts.Heap (
     , peekItbl
     , pokeItbl
 
+    -- * Cost Centre (profiling) types
+    , StgTSOProfInfo(..)
+    , IndexTable(..)
+    , CostCentre(..)
+    , CostCentreStack(..)
+
      -- * Closure inspection
     , getBoxedClosureData
     , allClosures
@@ -53,12 +62,14 @@ import Prelude
 import GHC.Exts.Heap.Closures
 import GHC.Exts.Heap.ClosureTypes
 import GHC.Exts.Heap.Constants
+import GHC.Exts.Heap.ProfInfo.Types
 #if defined(PROFILING)
 import GHC.Exts.Heap.InfoTableProf
 #else
 import GHC.Exts.Heap.InfoTable
 #endif
 import GHC.Exts.Heap.Utils
+import qualified GHC.Exts.Heap.FFIClosures as FFIClosures
 
 import Control.Monad
 import Data.Bits
@@ -323,6 +334,45 @@ getClosureDataFromHeapRep heapRep infoTablePtr pts = do
                 , finalizer = pts !! 3
                 , link = pts !! 4
                 }
+        TSO | [ u_lnk, u_gbl_lnk, tso_stack, u_trec, u_blk_ex, u_bq] <- pts
+                -> withArray rawHeapWords (\ptr -> do
+                    fields <- FFIClosures.peekTSOFields ptr
+                    pure $ TSOClosure
+                        { info = itbl
+                        , link = u_lnk
+                        , global_link = u_gbl_lnk
+                        , tsoStack = tso_stack
+                        , trec = u_trec
+                        , blocked_exceptions = u_blk_ex
+                        , bq = u_bq
+                        , what_next = FFIClosures.tso_what_next fields
+                        , why_blocked = FFIClosures.tso_why_blocked fields
+                        , flags = FFIClosures.tso_flags fields
+                        , threadId = FFIClosures.tso_threadId fields
+                        , saved_errno = FFIClosures.tso_saved_errno fields
+                        , tso_dirty = FFIClosures.tso_dirty fields
+                        , alloc_limit = FFIClosures.tso_alloc_limit fields
+                        , tot_stack_size = FFIClosures.tso_tot_stack_size fields
+                        , prof = FFIClosures.tso_prof fields
+                        })
+            | otherwise
+                -> fail $ "Expected 6 ptr arguments to TSO, found "
+                        ++ show (length pts)
+        STACK
+            | [] <- pts
+            -> withArray rawHeapWords (\ptr -> do
+                            fields <- FFIClosures.peekStackFields ptr
+                            pure $ StackClosure
+                                { info = itbl
+                                , stack_size = FFIClosures.stack_size fields
+                                , stack_dirty = FFIClosures.stack_dirty fields
+#if __GLASGOW_HASKELL__ >= 811
+                                , stack_marking = FFIClosures.stack_marking fields
+#endif
+                                })
+            | otherwise
+                -> fail $ "Expected 0 ptr argument to STACK, found "
+                    ++ show (length pts)
 
         _ ->
             pure $ UnsupportedClosure itbl

libraries/ghc-heap/GHC/Exts/Heap/Closures.hs

@@ -12,6 +12,9 @@ module GHC.Exts.Heap.Closures (
       Closure
     , GenClosure(..)
     , PrimType(..)
+    , WhatNext(..)
+    , WhyBlocked(..)
+    , TsoFlags(..)
     , allClosures
 #if __GLASGOW_HASKELL__ >= 809
     -- The closureSize# primop is unsupported on earlier GHC releases but we
@@ -40,6 +43,8 @@ import GHC.Exts.Heap.InfoTable
 import GHC.Exts.Heap.InfoTableProf ()
 #endif
 
+import GHC.Exts.Heap.ProfInfo.Types
+
 import Data.Bits
 import Data.Int
 import Data.Word
@@ -100,11 +105,11 @@ 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/includes/rts/storage/Closures.h>
 --
--- The data type is parametrized by the type to store references in. Usually
--- this is a 'Box' with the type synonym 'Closure'.
+-- 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
+-- 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.
 --
@@ -268,6 +273,39 @@ data GenClosure b
         , link        :: !b -- ^ next weak pointer for the capability, can be NULL.
         }
 
+  -- | 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
+      -- 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
+#if __GLASGOW_HASKELL__ >= 811
+      , stack_marking   :: !Word8
+#endif
+      }
+
     ------------------------------------------------------------
     -- Unboxed unlifted closures
 
@@ -332,6 +370,43 @@ data PrimType
   | PDouble
   deriving (Eq, Show, Generic)
 
+data WhatNext
+  = ThreadRunGHC
+  | ThreadInterpret
+  | ThreadKilled
+  | ThreadComplete
+  | WhatNextUnknownValue Word16 -- ^ Please report this as a bug
+  deriving (Eq, Show, Generic)
+
+data WhyBlocked
+  = NotBlocked
+  | BlockedOnMVar
+  | BlockedOnMVarRead
+  | BlockedOnBlackHole
+  | BlockedOnRead
+  | BlockedOnWrite
+  | BlockedOnDelay
+  | BlockedOnSTM
+  | BlockedOnDoProc
+  | BlockedOnCCall
+  | BlockedOnCCall_Interruptible
+  | BlockedOnMsgThrowTo
+  | ThreadMigrating
+  | BlockedOnIOCompletion
+  | WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug
+  deriving (Eq, Show, Generic)
+
+data TsoFlags
+  = TsoLocked
+  | TsoBlockx
+  | TsoInterruptible
+  | TsoStoppedOnBreakpoint
+  | TsoMarked
+  | TsoSqueezed
+  | TsoAllocLimit
+  | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug
+  deriving (Eq, Show, Generic)
+
 -- | For generic code, this function returns all referenced closures.
 allClosures :: GenClosure b -> [b]
 allClosures (ConstrClosure {..}) = ptrArgs

libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hs

+{-# LANGUAGE CPP #-}
+
+module GHC.Exts.Heap.FFIClosures (module Reexport) where
+
+-- NOTE [hsc and CPP workaround]
+--
+-- # Problem
+--
+-- Often, .hsc files are used to get the correct offsets of C struct fields.
+-- Those structs may be affected by CPP directives e.g. profiled vs not profiled
+-- closure headers is affected by the PROFILED cpp define. Since we are building
+-- multiple variants of the RTS, we must support all possible offsets e.g. by
+-- running hsc2hs with cpp defines corresponding to each RTS flavour. The
+-- problem is that GHC's build system runs hsc2hs *only once* per .hsc file
+-- without properly setting cpp defines. This results in the same (probably
+-- incorrect) offsets into our C structs.
+--
+--
+-- # Workaround
+--
+-- To work around this issue, we create multiple .hsc files each manually
+-- defining thir cpp defines (see e.g. FFIClosures_ProfilingDisabled.hsc and
+-- FFIClosures_ProfilingEnabled.hsc). Then we rely on cpp defines working
+-- correctly in .hs files and use CPP to switch on which .hsc module to
+-- re-export (see below). In each case we import the desired .hsc module as
+-- `Reexport` and we import `()` (i.e. nothing) from all other .hsc variants
+-- just so that the build system sees all .hsc file as dependencies.
+--
+--
+-- # Future Work
+--
+-- * Duplication of the code in the .hsc files could be reduced simply by
+--   placing the code in a single .hsc.in file and `#include`ing it from each
+--   .hsc file. The .hsc files would only be responsible for setting the correct
+--   cpp defines. This currently doesn't work as hadrian doesn't know to copy
+--   the .hsc.in file to the build directory.
+-- * The correct solution would be for the build system to run `hsc2hs` with the
+--   correct cpp defines once per RTS flavour.
+--
+
+#if defined(PROFILING)
+import GHC.Exts.Heap.FFIClosures_ProfilingEnabled as Reexport
+import GHC.Exts.Heap.FFIClosures_ProfilingDisabled ()
+#else
+import GHC.Exts.Heap.FFIClosures_ProfilingDisabled as Reexport
+import GHC.Exts.Heap.FFIClosures_ProfilingEnabled ()
+#endif

libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingDisabled.hsc

+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+
+module GHC.Exts.Heap.FFIClosures_ProfilingDisabled where
+
+-- See [hsc and CPP workaround]
+
+#undef PROFILING
+#include "Rts.h"
+
+import Prelude
+import Foreign
+import GHC.Exts
+import GHC.Exts.Heap.ProfInfo.PeekProfInfo
+import GHC.Exts.Heap.ProfInfo.Types
+import GHC.Exts.Heap.Closures(WhatNext(..), WhyBlocked(..), TsoFlags(..))
+
+data TSOFields = TSOFields {
+    tso_what_next :: WhatNext,
+    tso_why_blocked :: WhyBlocked,
+    tso_flags :: [TsoFlags],
+-- Unfortunately block_info is a union without clear discriminator.
+--    block_info :: TDB,
+    tso_threadId :: Word64,
+    tso_saved_errno :: Word32,
+    tso_dirty:: Word32,
+    tso_alloc_limit :: Int64,
+    tso_tot_stack_size :: Word32,
+    tso_prof :: Maybe StgTSOProfInfo
+}
+
+-- | Get non-pointer fields from @StgTSO_@ (@TSO.h@)
+peekTSOFields :: Ptr tsoPtr -> IO TSOFields
+peekTSOFields ptr = do
+    what_next' <- (#peek struct StgTSO_, what_next) ptr
+    why_blocked' <- (#peek struct StgTSO_, why_blocked) ptr
+    flags' <- (#peek struct StgTSO_, flags) ptr
+    threadId' <- (#peek struct StgTSO_, id) ptr
+    saved_errno' <- (#peek struct StgTSO_, saved_errno) ptr
+    dirty' <- (#peek struct StgTSO_, dirty) ptr
+    alloc_limit' <- (#peek struct StgTSO_, alloc_limit) ptr
+    tot_stack_size' <- (#peek struct StgTSO_, tot_stack_size) ptr
+    tso_prof' <- peekStgTSOProfInfo ptr
+
+    return TSOFields {
+        tso_what_next = parseWhatNext what_next',
+        tso_why_blocked = parseWhyBlocked why_blocked',
+        tso_flags = parseTsoFlags flags',
+        tso_threadId = threadId',
+        tso_saved_errno = saved_errno',
+        tso_dirty = dirty',
+        tso_alloc_limit = alloc_limit',
+        tso_tot_stack_size = tot_stack_size',
+        tso_prof = tso_prof'
+    }
+
+parseWhatNext :: Word16 -> WhatNext
+parseWhatNext w = case w of
+                    (#const ThreadRunGHC) -> ThreadRunGHC
+                    (#const ThreadInterpret) -> ThreadInterpret
+                    (#const ThreadKilled) -> ThreadKilled
+                    (#const ThreadComplete) -> ThreadComplete
+                    _ -> WhatNextUnknownValue w
+
+parseWhyBlocked :: Word16 -> WhyBlocked
+parseWhyBlocked w = case w of
+                        (#const NotBlocked) -> NotBlocked
+                        (#const BlockedOnMVar) -> BlockedOnMVar
+                        (#const BlockedOnMVarRead) -> BlockedOnMVarRead
+                        (#const BlockedOnBlackHole) -> BlockedOnBlackHole
+                        (#const BlockedOnRead) -> BlockedOnRead
+                        (#const BlockedOnWrite) -> BlockedOnWrite
+                        (#const BlockedOnDelay) -> BlockedOnDelay
+                        (#const BlockedOnSTM) -> BlockedOnSTM
+                        (#const BlockedOnDoProc) -> BlockedOnDoProc
+                        (#const BlockedOnCCall) -> BlockedOnCCall
+                        (#const BlockedOnCCall_Interruptible) -> BlockedOnCCall_Interruptible
+                        (#const BlockedOnMsgThrowTo) -> BlockedOnMsgThrowTo
+                        (#const ThreadMigrating) -> ThreadMigrating
+#if __GLASGOW_HASKELL__ >= 811
+                        (#const BlockedOnIOCompletion) -> BlockedOnIOCompletion
+#endif
+                        _ -> WhyBlockedUnknownValue w
+
+parseTsoFlags :: Word32 -> [TsoFlags]
+parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset (#const TSO_LOCKED) w)
+                | isSet (#const TSO_BLOCKEX) w = TsoBlockx : parseTsoFlags (unset (#const TSO_BLOCKEX) w)
+                | isSet (#const TSO_INTERRUPTIBLE) w = TsoInterruptible : parseTsoFlags (unset (#const TSO_INTERRUPTIBLE) w)
+                | isSet (#const TSO_STOPPED_ON_BREAKPOINT) w = TsoStoppedOnBreakpoint : parseTsoFlags (unset (#const TSO_STOPPED_ON_BREAKPOINT) w)
+                | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w)
+                | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w)
+                | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w)
+parseTsoFlags 0 = []
+parseTsoFlags w = [TsoFlagsUnknownValue w]
+
+isSet :: Word32 -> Word32 -> Bool
+isSet bitMask w = w .&. bitMask /= 0
+
+unset :: Word32 -> Word32 -> Word32
+unset bitMask w = w `xor` bitMask
+
+data StackFields = StackFields {
+    stack_size :: Word32,
+    stack_dirty :: Word8,
+#if __GLASGOW_HASKELL__ >= 811
+    stack_marking :: Word8,
+#endif
+    stack_sp :: Addr##
+}
+
+-- | Get non-closure fields from @StgStack_@ (@TSO.h@)
+peekStackFields :: Ptr a -> IO StackFields
+peekStackFields ptr = do
+    stack_size' <- (#peek struct StgStack_, stack_size) ptr ::IO Word32
+    dirty' <- (#peek struct StgStack_, dirty) ptr
+#if __GLASGOW_HASKELL__ >= 811
+    marking' <- (#peek struct StgStack_, marking) ptr
+#endif
+    Ptr sp' <- (#peek struct StgStack_, sp) ptr
+
+    -- TODO decode the stack.
+
+    return StackFields {
+        stack_size = stack_size',
+        stack_dirty = dirty',
+#if __GLASGOW_HASKELL__ >= 811
+        stack_marking = marking',
+#endif
+        stack_sp = sp'
+    }
+

libraries/ghc-heap/GHC/Exts/Heap/FFIClosures_ProfilingEnabled.hsc

+{-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+
+module GHC.Exts.Heap.FFIClosures_ProfilingEnabled where
+
+-- See [hsc and CPP workaround]
+
+#define PROFILING
+#include "Rts.h"
+
+import Prelude
+import Foreign
+import GHC.Exts
+import GHC.Exts.Heap.ProfInfo.PeekProfInfo
+import GHC.Exts.Heap.ProfInfo.Types
+import GHC.Exts.Heap.Closures(WhatNext(..), WhyBlocked(..), TsoFlags(..))
+
+data TSOFields = TSOFields {
+    tso_what_next :: WhatNext,
+    tso_why_blocked :: WhyBlocked,
+    tso_flags :: [TsoFlags],
+-- Unfortunately block_info is a union without clear discriminator.
+--    block_info :: TDB,
+    tso_threadId :: Word64,
+    tso_saved_errno :: Word32,
+    tso_dirty:: Word32,
+    tso_alloc_limit :: Int64,
+    tso_tot_stack_size :: Word32,
+    tso_prof :: Maybe StgTSOProfInfo
+}
+
+-- | Get non-pointer fields from @StgTSO_@ (@TSO.h@)
+peekTSOFields :: Ptr tsoPtr -> IO TSOFields
+peekTSOFields ptr = do
+    what_next' <- (#peek struct StgTSO_, what_next) ptr
+    why_blocked' <- (#peek struct StgTSO_, why_blocked) ptr
+    flags' <- (#peek struct StgTSO_, flags) ptr
+    threadId' <- (#peek struct StgTSO_, id) ptr
+    saved_errno' <- (#peek struct StgTSO_, saved_errno) ptr
+    dirty' <- (#peek struct StgTSO_, dirty) ptr
+    alloc_limit' <- (#peek struct StgTSO_, alloc_limit) ptr
+    tot_stack_size' <- (#peek struct StgTSO_, tot_stack_size) ptr
+    tso_prof' <- peekStgTSOProfInfo ptr
+
+    return TSOFields {
+        tso_what_next = parseWhatNext what_next',
+        tso_why_blocked = parseWhyBlocked why_blocked',
+        tso_flags = parseTsoFlags flags',
+        tso_threadId = threadId',
+        tso_saved_errno = saved_errno',
+        tso_dirty = dirty',
+        tso_alloc_limit = alloc_limit',
+        tso_tot_stack_size = tot_stack_size',
+        tso_prof = tso_prof'
+    }
+
+parseWhatNext :: Word16 -> WhatNext
+parseWhatNext w = case w of
+                    (#const ThreadRunGHC) -> ThreadRunGHC
+                    (#const ThreadInterpret) -> ThreadInterpret
+                    (#const ThreadKilled) -> ThreadKilled
+                    (#const ThreadComplete) -> ThreadComplete
+                    _ -> WhatNextUnknownValue w
+
+parseWhyBlocked :: Word16 -> WhyBlocked
+parseWhyBlocked w = case w of
+                        (#const NotBlocked) -> NotBlocked
+                        (#const BlockedOnMVar) -> BlockedOnMVar
+                        (#const BlockedOnMVarRead) -> BlockedOnMVarRead
+                        (#const BlockedOnBlackHole) -> BlockedOnBlackHole
+                        (#const BlockedOnRead) -> BlockedOnRead
+                        (#const BlockedOnWrite) -> BlockedOnWrite
+                        (#const BlockedOnDelay) -> BlockedOnDelay
+                        (#const BlockedOnSTM) -> BlockedOnSTM
+                        (#const BlockedOnDoProc) -> BlockedOnDoProc
+                        (#const BlockedOnCCall) -> BlockedOnCCall
+                        (#const BlockedOnCCall_Interruptible) -> BlockedOnCCall_Interruptible
+                        (#const BlockedOnMsgThrowTo) -> BlockedOnMsgThrowTo
+                        (#const ThreadMigrating) -> ThreadMigrating
+#if __GLASGOW_HASKELL__ >= 811
+                        (#const BlockedOnIOCompletion) -> BlockedOnIOCompletion
+#endif
+                        _ -> WhyBlockedUnknownValue w
+
+parseTsoFlags :: Word32 -> [TsoFlags]
+parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset (#const TSO_LOCKED) w)
+                | isSet (#const TSO_BLOCKEX) w = TsoBlockx : parseTsoFlags (unset (#const TSO_BLOCKEX) w)
+                | isSet (#const TSO_INTERRUPTIBLE) w = TsoInterruptible : parseTsoFlags (unset (#const TSO_INTERRUPTIBLE) w)
+                | isSet (#const TSO_STOPPED_ON_BREAKPOINT) w = TsoStoppedOnBreakpoint : parseTsoFlags (unset (#const TSO_STOPPED_ON_BREAKPOINT) w)
+                | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w)
+                | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w)
+                | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w)
+parseTsoFlags 0 = []
+parseTsoFlags w = [TsoFlagsUnknownValue w]
+
+isSet :: Word32 -> Word32 -> Bool
+isSet bitMask w = w .&. bitMask /= 0
+
+unset :: Word32 -> Word32 -> Word32
+unset bitMask w = w `xor` bitMask
+
+data StackFields = StackFields {
+    stack_size :: Word32,
+    stack_dirty :: Word8,
+#if __GLASGOW_HASKELL__ >= 811
+    stack_marking :: Word8,
+#endif
+    stack_sp :: Addr##
+}
+
+-- | Get non-closure fields from @StgStack_@ (@TSO.h@)
+peekStackFields :: Ptr a -> IO StackFields
+peekStackFields ptr = do
+    stack_size' <- (#peek struct StgStack_, stack_size) ptr ::IO Word32
+    dirty' <- (#peek struct StgStack_, dirty) ptr
+#if __GLASGOW_HASKELL__ >= 811
+    marking' <- (#peek struct StgStack_, marking) ptr
+#endif
+    Ptr sp' <- (#peek struct StgStack_, sp) ptr
+
+    -- TODO decode the stack.
+
+    return StackFields {
+        stack_size = stack_size',
+        stack_dirty = dirty',
+#if __GLASGOW_HASKELL__ >= 811
+        stack_marking = marking',
+#endif
+        stack_sp = sp'
+    }

libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo.hs

+{-# LANGUAGE CPP #-}
+
+module GHC.Exts.Heap.ProfInfo.PeekProfInfo (module Reexport) where
+
+-- See [hsc and CPP workaround]
+
+#if defined(PROFILING)
+import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled as Reexport
+import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled ()
+#else
+import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled as Reexport
+import GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled ()
+#endif

libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingDisabled.hsc

+module GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled(
+    peekStgTSOProfInfo
+) where
+
+import Prelude
+import Foreign
+import GHC.Exts.Heap.ProfInfo.Types
+
+-- | This implementation is used when PROFILING is undefined.
+-- It always returns 'Nothing', because there is no profiling info available.
+peekStgTSOProfInfo :: Ptr tsoPtr -> IO (Maybe StgTSOProfInfo)
+peekStgTSOProfInfo _ = return Nothing

libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/PeekProfInfo_ProfilingEnabled.hsc

+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE MagicHash #-}
+
+module GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled(
+    peekStgTSOProfInfo
+) where
+
+#if __GLASGOW_HASKELL__ >= 811
+
+-- See [hsc and CPP workaround]
+
+#define PROFILING
+
+#include "Rts.h"
+#undef BLOCK_SIZE
+#undef MBLOCK_SIZE
+#undef BLOCKS_PER_MBLOCK
+#include "DerivedConstants.h"
+
+import           Data.IntSet (IntSet)
+import qualified Data.IntSet as IntSet
+import           Data.IntMap.Strict (IntMap)
+import qualified Data.IntMap.Strict as IntMap
+import           Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import           Foreign
+import           Foreign.C.String
+import           GHC.Exts
+import           GHC.Exts.Heap.ProfInfo.Types
+import           Prelude
+
+-- Use Int based containers for pointers (addresses) for better performance.
+-- These will be queried a lot!
+type AddressSet = IntSet
+type AddressMap = IntMap
+
+peekStgTSOProfInfo :: Ptr a -> IO (Maybe StgTSOProfInfo)
+peekStgTSOProfInfo tsoPtr = do
+    cccs_ptr <- peekByteOff tsoPtr cccsOffset
+    costCenterCacheRef <- newIORef IntMap.empty
+    cccs' <- peekCostCentreStack IntSet.empty costCenterCacheRef cccs_ptr
+
+    return $ Just StgTSOProfInfo {
+        cccs = cccs'
+    }
+
+cccsOffset :: Int
+cccsOffset = (#const OFFSET_StgTSO_cccs) + (#size StgHeader)
+
+peekCostCentreStack
+    :: AddressSet
+    -> IORef (AddressMap CostCentre)
+    -> Ptr costCentreStack
+    -> IO (Maybe CostCentreStack)
+peekCostCentreStack _ _ ptr | ptr == nullPtr = return Nothing
+peekCostCentreStack loopBreakers _ ptr | IntSet.member (ptrToInt ptr) loopBreakers = return Nothing
+peekCostCentreStack loopBreakers costCenterCacheRef ptr = do
+        ccs_ccsID' <- (#peek struct CostCentreStack_, ccsID) ptr
+        ccs_cc_ptr <- (#peek struct CostCentreStack_, cc) ptr
+        ccs_cc' <- peekCostCentre costCenterCacheRef ccs_cc_ptr
+        ccs_prevStack_ptr <- (#peek struct CostCentreStack_, prevStack) ptr
+        let loopBreakers' = (IntSet.insert ptrAsInt loopBreakers)
+        ccs_prevStack' <- peekCostCentreStack loopBreakers' costCenterCacheRef ccs_prevStack_ptr
+        ccs_indexTable_ptr <- (#peek struct CostCentreStack_, indexTable) ptr
+        ccs_indexTable' <- peekIndexTable loopBreakers' costCenterCacheRef ccs_indexTable_ptr
+        ccs_root_ptr <- (#peek struct CostCentreStack_, root) ptr
+        ccs_root' <- peekCostCentreStack loopBreakers' costCenterCacheRef ccs_root_ptr
+        ccs_depth' <- (#peek struct CostCentreStack_, depth) ptr
+        ccs_scc_count' <- (#peek struct CostCentreStack_, scc_count) ptr
+        ccs_selected' <- (#peek struct CostCentreStack_, selected) ptr
+        ccs_time_ticks' <- (#peek struct CostCentreStack_, time_ticks) ptr
+        ccs_mem_alloc' <- (#peek struct CostCentreStack_, mem_alloc) ptr
+        ccs_inherited_alloc' <- (#peek struct CostCentreStack_, inherited_alloc) ptr
+        ccs_inherited_ticks' <- (#peek struct CostCentreStack_, inherited_ticks) ptr
+
+        return $ Just CostCentreStack {
+            ccs_ccsID = ccs_ccsID',
+            ccs_cc = ccs_cc',
+            ccs_prevStack = ccs_prevStack',
+            ccs_indexTable = ccs_indexTable',
+            ccs_root = ccs_root',
+            ccs_depth = ccs_depth',
+            ccs_scc_count = ccs_scc_count',
+            ccs_selected = ccs_selected',
+            ccs_time_ticks = ccs_time_ticks',
+            ccs_mem_alloc = ccs_mem_alloc',
+            ccs_inherited_alloc = ccs_inherited_alloc',
+            ccs_inherited_ticks = ccs_inherited_ticks'
+        }
+    where
+        ptrAsInt = ptrToInt ptr
+
+peekCostCentre :: IORef (AddressMap CostCentre) -> Ptr costCentre -> IO CostCentre
+peekCostCentre costCenterCacheRef ptr = do
+    costCenterCache <- readIORef costCenterCacheRef
+    case IntMap.lookup ptrAsInt costCenterCache of
+        (Just a) -> return a
+        Nothing -> do
+                    cc_ccID' <- (#peek struct CostCentre_, ccID) ptr
+                    cc_label_ptr <- (#peek struct CostCentre_, label) ptr
+                    cc_label' <- peekCString cc_label_ptr
+                    cc_module_ptr <- (#peek struct CostCentre_, module) ptr
+                    cc_module' <- peekCString cc_module_ptr
+                    cc_srcloc_ptr <- (#peek struct CostCentre_, srcloc) ptr
+                    cc_srcloc' <- do
+                        if cc_srcloc_ptr == nullPtr then
+                            return Nothing
+                        else
+                            fmap Just (peekCString cc_srcloc_ptr)
+                    cc_mem_alloc' <- (#peek struct CostCentre_, mem_alloc) ptr
+                    cc_time_ticks' <- (#peek struct CostCentre_, time_ticks) ptr
+                    cc_is_caf' <- (#peek struct CostCentre_, is_caf) ptr
+                    cc_link_ptr <- (#peek struct CostCentre_, link) ptr
+                    cc_link' <- if cc_link_ptr == nullPtr then
+                        return Nothing
+                    else
+                        fmap Just (peekCostCentre costCenterCacheRef cc_link_ptr)
+
+                    let result = CostCentre {
+                        cc_ccID = cc_ccID',
+                        cc_label = cc_label',
+                        cc_module = cc_module',
+                        cc_srcloc = cc_srcloc',
+                        cc_mem_alloc = cc_mem_alloc',
+                        cc_time_ticks = cc_time_ticks',
+                        cc_is_caf = cc_is_caf',
+                        cc_link = cc_link'
+                    }
+
+                    writeIORef costCenterCacheRef (IntMap.insert ptrAsInt result costCenterCache)
+
+                    return result
+    where
+        ptrAsInt = ptrToInt ptr
+
+peekIndexTable :: AddressSet -> IORef (AddressMap CostCentre) -> Ptr indexTable -> IO (Maybe IndexTable)
+peekIndexTable _ _ ptr | ptr == nullPtr = return Nothing
+peekIndexTable loopBreakers costCenterCacheRef ptr = do
+        it_cc_ptr <- (#peek struct IndexTable_, cc) ptr
+        it_cc' <- peekCostCentre costCenterCacheRef it_cc_ptr
+        it_ccs_ptr <- (#peek struct IndexTable_, ccs) ptr
+        it_ccs' <- peekCostCentreStack loopBreakers costCenterCacheRef it_ccs_ptr
+        it_next_ptr <- (#peek struct IndexTable_, next) ptr
+        it_next' <- peekIndexTable loopBreakers costCenterCacheRef it_next_ptr
+        it_back_edge' <- (#peek struct IndexTable_, back_edge) ptr
+
+        return $ Just IndexTable {
+            it_cc = it_cc',
+            it_ccs = it_ccs',
+            it_next = it_next',
+            it_back_edge = it_back_edge'
+        }
+
+-- | casts a @Ptr@ to an @Int@
+ptrToInt :: Ptr a -> Int
+ptrToInt (Ptr a##) = I## (addr2Int## a##)
+
+#else
+import Prelude
+import Foreign
+
+import GHC.Exts.Heap.ProfInfo.Types
+
+peekStgTSOProfInfo :: Ptr a -> IO (Maybe StgTSOProfInfo)
+peekStgTSOProfInfo _ = return Nothing
+#endif

libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs

+{-# LANGUAGE DeriveGeneric #-}
+
+module GHC.Exts.Heap.ProfInfo.Types where
+
+import Prelude
+import Data.Word
+import GHC.Generics
+
+-- | This is a somewhat faithful representation of StgTSOProfInfo. See
+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/TSO.h>
+-- for more details on this data structure.
+data StgTSOProfInfo = StgTSOProfInfo {
+    cccs :: Maybe CostCentreStack
+} deriving (Show, Generic)
+
+-- | This is a somewhat faithful representation of CostCentreStack. See
+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/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)
+
+-- | This is a somewhat faithful representation of CostCentre. See
+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/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)
+
+-- | This is a somewhat faithful representation of IndexTable. See
+-- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/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)

libraries/ghc-heap/ghc-heap.cabal.in

@@ -25,6 +25,7 @@ library
   build-depends:    base             >= 4.9.0 && < 5.0
                   , ghc-prim         > 0.2 && < 0.8
                   , rts              == 1.0.*
+                  , containers       >= 0.6.2.1 && < 0.7
 
   ghc-options:      -Wall
   cmm-sources:      cbits/HeapPrim.cmm
@@ -39,3 +40,10 @@ library
                     GHC.Exts.Heap.InfoTable.Types
                     GHC.Exts.Heap.InfoTableProf
                     GHC.Exts.Heap.Utils
+                    GHC.Exts.Heap.FFIClosures
+                    GHC.Exts.Heap.FFIClosures_ProfilingDisabled
+                    GHC.Exts.Heap.FFIClosures_ProfilingEnabled
+                    GHC.Exts.Heap.ProfInfo.Types
+                    GHC.Exts.Heap.ProfInfo.PeekProfInfo
+                    GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled
+                    GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled