[Git][ghc/ghc][wip/andreask/selectors] ghc-heap: Fix incomplete selector warnings.
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Wed Oct 30 13:22:46 UTC 2024
Andreas Klebinger pushed to branch wip/andreask/selectors at Glasgow Haskell Compiler / GHC
Commits:
5f447f40 by Andreas Klebinger at 2024-10-30T14:03:33+01:00
ghc-heap: Fix incomplete selector warnings.
Use utility functions instead of selectors to read partial attributes.
Part of fixing #25380.
- - - - -
4 changed files:
- compiler/GHC/Runtime/Heap/Inspect.hs
- docs/users_guide/9.14.1-notes.rst
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
Changes:
=====================================
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
=====================================
docs/users_guide/9.14.1-notes.rst
=====================================
@@ -44,6 +44,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
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
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
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5f447f401c117c5bfc1a0f12dfe5e2ce911ac036
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5f447f401c117c5bfc1a0f12dfe5e2ce911ac036
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241030/4196feb7/attachment-0001.html>
More information about the ghc-commits
mailing list