diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs
index 9972b69eb0fab16706ccc6848790d27e463456a1..72d55f90aaeb2b3f12284bc2f59b9c10e6b002fe 100644
--- a/compiler/GHC/Runtime/Heap/Inspect.hs
+++ b/compiler/GHC/Runtime/Heap/Inspect.hs
@@ -128,6 +128,11 @@ isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t
isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t
isFullyEvaluatedTerm _ = False
+-- | Gives an error if the term doesn't have subterms
+expectSubTerms :: Term -> [Term]
+expectSubTerms (Term { subTerms = subTerms} ) = subTerms
+expectSubTerms _ = panic "expectSubTerms"
+
instance Outputable (Term) where
ppr t | Just doc <- cPprTerm cPprTermBase t = doc
| otherwise = panic "Outputable Term instance"
@@ -332,8 +337,8 @@ cPprTermBase :: forall m. Monad m => CustomTermPrinter m
cPprTermBase y =
[ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma)
. mapM (y (-1))
- . subTerms)
- , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
+ . expectSubTerms)
+ , ifTerm (\t -> isTyCon listTyCon (ty t) && expectSubTerms t `lengthIs` 2)
ppr_list
, ifTerm' (isTyCon intTyCon . ty) ppr_int
, ifTerm' (isTyCon charTyCon . ty) ppr_char
@@ -768,7 +773,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
traceTR (text "Gave up reconstructing a term after" <>
int max_depth <> text " steps")
clos <- trIO $ GHCi.getClosure interp a
- return (Suspension (tipe (info clos)) my_ty a Nothing)
+ return (Suspension (tipe (getClosureInfoTbl clos)) my_ty a Nothing)
go !max_depth my_ty old_ty a = do
let monomorphic = not(isTyVarTy my_ty)
-- This ^^^ is a convention. The ancestor tests for
@@ -864,7 +869,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
_ -> do
traceTR (text "Unknown closure:" <+>
text (show (fmap (const ()) clos)))
- return (Suspension (tipe (info clos)) my_ty a Nothing)
+ return (Suspension (tipe (getClosureInfoTbl clos)) my_ty a Nothing)
-- insert NewtypeWraps around newtypes
expandNewtypes = foldTerm idTermFold { fTerm = worker } where
@@ -918,7 +923,7 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0
go_rep ptr_i arr_i ty rep
| isGcPtrRep rep = do
- t <- recurse ty $ (ptrArgs clos)!!ptr_i
+ t <- recurse ty $ (getClosurePtrArgs clos)!!ptr_i
return (ptr_i + 1, arr_i, t)
| otherwise = do
-- This is a bit involved since we allow packing multiple fields
diff --git a/docs/users_guide/9.14.1-notes.rst b/docs/users_guide/9.14.1-notes.rst
index 0a82afcf4858b98b01289a6292712adf056e88c4..3c3c45e2127b7adc6464ce8cf33aba58b7e8c788 100644
--- a/docs/users_guide/9.14.1-notes.rst
+++ b/docs/users_guide/9.14.1-notes.rst
@@ -50,6 +50,11 @@ Cmm
``ghc-heap`` library
~~~~~~~~~~~~~~~~~~~~
+* The functions `getClosureInfoTbl_maybe`, `getClosureInfoTbl`,
+ `getClosurePtrArgs` and `getClosurePtrArgs_maybe` have been added to allow
+ reading of the relevant Closure attributes without reliance on incomplete
+ selectors.
+
``ghc-experimental`` library
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/libraries/ghc-heap/GHC/Exts/Heap.hs b/libraries/ghc-heap/GHC/Exts/Heap.hs
index e832c68c4e30c69a79df4c45c4a8555b062df81e..0e3c18bb3b183165ac4b5dd6bfde23427e88858f 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap.hs
@@ -29,6 +29,10 @@ module GHC.Exts.Heap (
, WhyBlocked(..)
, TsoFlags(..)
, HasHeapRep(getClosureData)
+ , getClosureInfoTbl
+ , getClosureInfoTbl_maybe
+ , getClosurePtrArgs
+ , getClosurePtrArgs_maybe
, getClosureDataFromHeapRep
, getClosureDataFromHeapRepPrim
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
index 4789b127650bc0b93b2a6f9129d75f0fdc9b023b..936d4a6174f7258d5d8d6d10c05841cc723e57a9 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
@@ -8,12 +8,18 @@
{-# 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.Exts.Heap.Closures (
-- * Closures
Closure
, GenClosure(..)
+ , getClosureInfoTbl
+ , getClosureInfoTbl_maybe
+ , getClosurePtrArgs
+ , getClosurePtrArgs_maybe
, PrimType(..)
, WhatNext(..)
, WhyBlocked(..)
@@ -67,6 +73,7 @@ import Data.Word
import GHC.Exts
import GHC.Generics
import Numeric
+import GHC.Stack (HasCallStack)
------------------------------------------------------------------------
-- Boxes
@@ -382,6 +389,104 @@ data GenClosure b
{ 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