[Git][ghc/ghc][wip/andreask/selectors] ghc-heap: Fix incomplete selector warnings.
Andreas Klebinger (@AndreasK)
gitlab at gitlab.haskell.org
Mon Oct 28 15:26:12 UTC 2024
Andreas Klebinger pushed to branch wip/andreask/selectors at Glasgow Haskell Compiler / GHC
Commits:
fb277d82 by Andreas Klebinger at 2024-10-28T16:06:57+01:00
ghc-heap: Fix incomplete selector warnings.
Instead of using use to read the info table.
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
=====================================
@@ -86,6 +86,7 @@ import qualified Data.Sequence as Seq
import Data.Sequence (viewl, ViewL(..))
import Foreign hiding (shiftL, shiftR)
import System.IO.Unsafe
+import GHC.Exts.Heap.Closures (getClosureInfoTbl_maybe)
---------------------------------------------
-- * A representation of semi evaluated Terms
@@ -128,6 +129,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 +338,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 +774,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
@@ -862,9 +868,13 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
-- The otherwise case: can be a Thunk,AP,PAP,etc.
_ -> do
+ let info_tbl =
+ case heapClosureInfo_maybe clos of
+ Nothing -> error "cvObtainTerm"
+
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
=====================================
docs/users_guide/9.14.1-notes.rst
=====================================
@@ -44,6 +44,10 @@ Cmm
``ghc-heap`` library
~~~~~~~~~~~~~~~~~~~~
+* The functions `getClosureInfoTbl_maybe`` and `getClosureInfoTbl` have been added
+ to allow reading the info table of a closure without relying on partial selector
+ functions.
+
``ghc-experimental`` library
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -29,6 +29,8 @@ module GHC.Exts.Heap (
, WhyBlocked(..)
, TsoFlags(..)
, HasHeapRep(getClosureData)
+ , getClosureInfoTbl_maybe
+ , getClosureInfoTbl
, getClosureDataFromHeapRep
, getClosureDataFromHeapRepPrim
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -8,12 +8,16 @@
{-# 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_maybe
+ , getClosureInfoTbl
, PrimType(..)
, WhatNext(..)
, WhyBlocked(..)
@@ -67,6 +71,7 @@ import Data.Word
import GHC.Exts
import GHC.Generics
import Numeric
+import GHC.Stack (HasCallStack)
------------------------------------------------------------------------
-- Boxes
@@ -382,6 +387,61 @@ data GenClosure b
{ wordVal :: !Word }
deriving (Show, Generic, Functor, Foldable, Traversable)
+-- Ideally we would refactor GenClosure into two types or a GADT differentiating:
+-- * Heap objects
+-- * Primitive values with no info table.
+
+-- But for now we just do this:
+
+-- | 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"
+
type StgStackClosure = GenStgStackClosure Box
-- | A decoded @StgStack@ with `StackFrame`s
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fb277d822016b34d050456f5d4ce9d0cab0f6e2c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/fb277d822016b34d050456f5d4ce9d0cab0f6e2c
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/20241028/1459306f/attachment-0001.html>
More information about the ghc-commits
mailing list