- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/T25944] CprAnal: Detect recursive newtypes (#25944)
by Sebastian Graf (＠sgraf812) 17 Jul '25

17 Jul '25

Sebastian Graf pushed to branch wip/T25944 at Glasgow Haskell Compiler / GHC Commits: 9e8a00b7 by Sebastian Graf at 2025-07-17T20:00:19+02:00 CprAnal: Detect recursive newtypes (#25944) While `cprTransformDataConWork` handles recursive data con workers, it did not detect the case when a newtype is responsible for the recursion. This is now detected in the `Cast` case of `cprAnal`. The same reproducer made it clear that `isRecDataCon` lacked congruent handling for `AppTy` and `CastTy`, now fixed. Furthermore, the new repro case T25944 triggered this bug via an infinite loop in `cprFix`, caused by the infelicity in `isRecDataCon`. While it should be much less likely to trigger such an infinite loop now that `isRecDataCon` has been fixed, I made sure to abort the loop after 10 iterations and emitting a warning instead. Fixes #25944. - - - - - 5 changed files: - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - + testsuite/tests/cpranal/sigs/T25944.hs - + testsuite/tests/cpranal/sigs/T25944.stderr - testsuite/tests/cpranal/sigs/all.T Changes: ===================================== compiler/GHC/Core/Opt/CprAnal.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiWayIf #-} -- | Constructed Product Result analysis. Identifies functions that surely -- return heap-allocated records on every code path, so that we can eliminate @@ -22,12 +23,15 @@ import GHC.Types.Demand import GHC.Types.Cpr import GHC.Types.Unique.MemoFun +import GHC.Core import GHC.Core.FamInstEnv import GHC.Core.DataCon import GHC.Core.Type import GHC.Core.Utils -import GHC.Core +import GHC.Core.Coercion +import GHC.Core.Reduction import GHC.Core.Seq +import GHC.Core.TyCon import GHC.Core.Opt.WorkWrap.Utils import GHC.Data.Graph.UnVar -- for UnVarSet @@ -216,9 +220,13 @@ cprAnal' _ (Type ty) = (topCprType, Type ty) -- Doesn't happen, in fact cprAnal' _ (Coercion co) = (topCprType, Coercion co) cprAnal' env (Cast e co) - = (cpr_ty, Cast e' co) + = (cpr_ty', Cast e' co) where (cpr_ty, e') = cprAnal env e + cpr_ty' + | cpr_ty == topCprType = topCprType -- cheap case first + | isRecNewTyConApp env (coercionRKind co) = topCprType -- See Note [CPR for recursive data constructors] + | otherwise = cpr_ty cprAnal' env (Tick t e) = (cpr_ty, Tick t e') @@ -391,6 +399,19 @@ cprTransformDataConWork env con args mAX_CPR_SIZE :: Arity mAX_CPR_SIZE = 10 +isRecNewTyConApp :: AnalEnv -> Type -> Bool +-- See Note [CPR for recursive newtype constructors] +isRecNewTyConApp env ty + --- | pprTrace "isRecNewTyConApp" (ppr ty) False = undefined + | Just (tc, tc_args) <- splitTyConApp_maybe ty = + if | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe (ae_fam_envs env) tc tc_args + -> isRecNewTyConApp env rhs + | Just dc <- newTyConDataCon_maybe tc + -> ae_rec_dc env dc == DefinitelyRecursive + | otherwise + -> False + | otherwise = False + -- -- * Bindings -- @@ -414,12 +435,18 @@ cprFix orig_env orig_pairs | otherwise = orig_pairs init_env = extendSigEnvFromIds orig_env (map fst init_pairs) + -- If fixed-point iteration does not yield a result we use this instead + -- See Note [Safe abortion in the fixed-point iteration] + abort :: (AnalEnv, [(Id,CoreExpr)]) + abort = step (nonVirgin orig_env) [(setIdCprSig id topCprSig, rhs) | (id, rhs) <- orig_pairs ] + -- The fixed-point varies the idCprSig field of the binders and and their -- entries in the AnalEnv, and terminates if that annotation does not change -- any more. loop :: Int -> AnalEnv -> [(Id,CoreExpr)] -> (AnalEnv, [(Id,CoreExpr)]) loop n env pairs | found_fixpoint = (reset_env', pairs') + | n == 10 = pprTraceUserWarning (text "cprFix aborts. This is not terrible, but worth reporting a GHC issue." <+> ppr (map fst pairs)) $ abort | otherwise = loop (n+1) env' pairs' where -- In all but the first iteration, delete the virgin flag @@ -519,8 +546,9 @@ cprAnalBind env id rhs -- possibly trim thunk CPR info rhs_ty' -- See Note [CPR for thunks] - | stays_thunk = trimCprTy rhs_ty - | otherwise = rhs_ty + | rhs_ty == topCprType = topCprType -- cheap case first + | stays_thunk = trimCprTy rhs_ty + | otherwise = rhs_ty -- See Note [Arity trimming for CPR signatures] sig = mkCprSigForArity (idArity id) rhs_ty' -- See Note [OPAQUE pragma] @@ -639,7 +667,7 @@ data AnalEnv , ae_fam_envs :: FamInstEnvs -- ^ Needed when expanding type families and synonyms of product types. , ae_rec_dc :: DataCon -> IsRecDataConResult - -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon' + -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataType } instance Outputable AnalEnv where @@ -1042,10 +1070,11 @@ Eliminating the shared 'c' binding in the process. And then What can we do about it? - A. Don't CPR functions that return a *recursive data type* (the list in this - case). This is the solution we adopt. Rationale: the benefit of CPR on - recursive data structures is slight, because it only affects the outer layer - of a potentially massive data structure. + A. Don't give recursive data constructors or casts representing recursive newtype constructors + the CPR property (the list in this case). This is the solution we adopt. + Rationale: the benefit of CPR on recursive data structures is slight, + because it only affects the outer layer of a potentially massive data + structure. B. Don't CPR any *recursive function*. That would be quite conservative, as it would also affect e.g. the factorial function. C. Flat CPR only for recursive functions. This prevents the asymptotic @@ -1055,10 +1084,15 @@ What can we do about it? `c` in the second eqn of `replicateC`). But we'd need to know which paths were hot. We want such static branch frequency estimates in #20378. -We adopt solution (A) It is ad-hoc, but appears to work reasonably well. -Deciding what a "recursive data constructor" is is quite tricky and ad-hoc, too: -See Note [Detecting recursive data constructors]. We don't have to be perfect -and can simply keep on unboxing if unsure. +We adopt solution (A). It is ad-hoc, but appears to work reasonably well. +Specifically: + +* For data constructors, in `cprTransformDataConWork` we check for a recursive + data constructor by calling `ae_rec_dc env`, which is just a memoised version + of `isRecDataCon`. See Note [Detecting recursive data constructors] +* For newtypes, in the `Cast` case of `cprAnal`, we check for a recursive newtype + by calling `isRecNewTyConApp`, which in turn calls `ae_rec_dc env`. + See Note [CPR for recursive newtype constructors] Note [Detecting recursive data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1075,12 +1109,15 @@ looks inside the following class of types, represented by `ty` (and responds types of its data constructors and check `tc_args` for recursion. C. If `ty = F tc_args`, `F` is a `FamTyCon` and we can reduce `F tc_args` to `rhs`, look into the `rhs` type. + D. If `ty = f a`, then look into `f` and `a` + E. If `ty = ty' |> co`, then look into `ty'` A few perhaps surprising points: 1. It deems any function type as non-recursive, because it's unlikely that a recursion through a function type builds up a recursive data structure. - 2. It doesn't look into kinds or coercion types because there's nothing to unbox. + 2. It doesn't look into kinds, literals or coercion types because we are + ultimately looking for value-level recursion. Same for promoted data constructors. 3. We don't care whether an AlgTyCon app `T tc_args` is fully saturated or not; we simply look at its definition/DataCons and its field tys and look for @@ -1153,6 +1190,22 @@ I've played with the idea to make points (1) through (3) of 'isRecDataCon' configurable like (4) to enable more re-use throughout the compiler, but haven't found a killer app for that yet, so ultimately didn't do that. +Note [CPR for recursive newtype constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A newtype constructor is considered recursive iff the data constructor of the +equivalent datatype definition is recursive. +See Note [CPR for recursive data constructors]. +Detection is a bit complicated by the fact that newtype constructor applications +reflect as Casts in Core: + + newtype List a = C (Maybe (a, List a)) + xs = C (Just (0, C Nothing)) + ==> {desugar to Core} + xs = Just (0, Nothing |> sym N:List) |> sym N:List + +So the check for `isRecNewTyConApp` is in the Cast case of `cprAnal` rather than +in `cprTransformDataConWork` as for data constructors. + Note [CPR examples] ~~~~~~~~~~~~~~~~~~~ Here are some examples (stranal/should_compile/T10482a) of the ===================================== compiler/GHC/Core/Opt/WorkWrap/Utils.hs ===================================== @@ -63,6 +63,7 @@ import Data.List ( unzip4 ) import GHC.Types.RepType import GHC.Unit.Types +import GHC.Core.TyCo.Rep {- ************************************************************************ @@ -1426,23 +1427,29 @@ isRecDataCon fam_envs fuel orig_dc | arg_ty <- map scaledThing (dataConRepArgTys dc) ] go_arg_ty :: IntWithInf -> TyConSet -> Type -> IsRecDataConResult - go_arg_ty fuel visited_tcs ty - --- | pprTrace "arg_ty" (ppr ty) False = undefined + go_arg_ty fuel visited_tcs ty = -- pprTrace "arg_ty" (ppr ty) $ + case coreFullView ty of + TyConApp tc tc_args -> go_tc_app fuel visited_tcs tc tc_args + -- See Note [Detecting recursive data constructors], points (B) and (C) - | Just (_tcv, ty') <- splitForAllTyCoVar_maybe ty - = go_arg_ty fuel visited_tcs ty' + ForAllTy _ ty' -> go_arg_ty fuel visited_tcs ty' -- See Note [Detecting recursive data constructors], point (A) - | Just (tc, tc_args) <- splitTyConApp_maybe ty - = go_tc_app fuel visited_tcs tc tc_args + CastTy ty' _ -> go_arg_ty fuel visited_tcs ty' - | otherwise - = NonRecursiveOrUnsure + AppTy f a -> go_arg_ty fuel visited_tcs f `combineIRDCR` go_arg_ty fuel visited_tcs a + -- See Note [Detecting recursive data constructors], point (D) + + FunTy{} -> NonRecursiveOrUnsure + -- See Note [Detecting recursive data constructors], point (1) + + -- (TyVarTy{} | LitTy{} | CastTy{}) + _ -> NonRecursiveOrUnsure go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Type] -> IsRecDataConResult go_tc_app fuel visited_tcs tc tc_args = case tyConDataCons_maybe tc of - --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined + ---_ | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False -> undefined _ | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args -- This is the only place where we look at tc_args, which might have -- See Note [Detecting recursive data constructors], point (C) and (5) ===================================== testsuite/tests/cpranal/sigs/T25944.hs ===================================== @@ -0,0 +1,114 @@ +{-# LANGUAGE UndecidableInstances, LambdaCase #-} + +-- | This file starts with a small reproducer for #25944 that is easy to debug +-- and then continues with a much larger MWE that is faithful to the original +-- issue. +module T25944 (foo, bar, popMinOneT, popMinOne) where + +import Data.Functor.Identity ( Identity(..) ) +import Data.Coerce + +data ListCons a b = Nil | a :- !b +newtype Fix f = Fix (f (Fix f)) -- Rec + +foo :: Fix (ListCons a) -> Fix (ListCons a) -> Fix (ListCons a) +foo a b = go a + where + -- The outer loop arranges it so that the base case `go as` of `go2` is + -- bottom on the first iteration of the loop. + go (Fix Nil) = Fix Nil + go (Fix (a :- as)) = Fix (a :- go2 b) + where + go2 (Fix Nil) = go as + go2 (Fix (b :- bs)) = Fix (b :- go2 bs) + +bar :: Int -> (Fix (ListCons Int), Int) +bar n = (foo (Fix Nil) (Fix Nil), n) -- should still have CPR property + +-- Now the actual reproducer from #25944: + +newtype ListT m a = ListT { runListT :: m (ListCons a (ListT m a)) } + +cons :: Applicative m => a -> ListT m a -> ListT m a +cons x xs = ListT (pure (x :- xs)) + +nil :: Applicative m => ListT m a +nil = ListT (pure Nil) + +instance Functor m => Functor (ListT m) where + fmap f (ListT m) = ListT (go <$> m) + where + go Nil = Nil + go (a :- m) = f a :- (f <$> m) + +foldListT :: ((ListCons a (ListT m a) -> c) -> m (ListCons a (ListT m a)) -> b) + -> (a -> b -> c) + -> c + -> ListT m a -> b +foldListT r c n = r h . runListT + where + h Nil = n + h (x :- ListT xs) = c x (r h xs) +{-# INLINE foldListT #-} + +mapListT :: forall a m b. Monad m => (a -> ListT m b -> ListT m b) -> ListT m b -> ListT m a -> ListT m b +mapListT = + foldListT + ((coerce :: + ((ListCons a (ListT m a) -> m (ListCons b (ListT m b))) -> m (ListCons a (ListT m a)) -> m (ListCons b (ListT m b))) -> + ((ListCons a (ListT m a) -> ListT m b) -> m (ListCons a (ListT m a)) -> ListT m b)) + (=<<)) +{-# INLINE mapListT #-} + +instance Monad m => Applicative (ListT m) where + pure x = cons x nil + {-# INLINE pure #-} + liftA2 f xs ys = mapListT (\x zs -> mapListT (cons . f x) zs ys) nil xs + {-# INLINE liftA2 #-} + +instance Monad m => Monad (ListT m) where + xs >>= f = mapListT (flip (mapListT cons) . f) nil xs + {-# INLINE (>>=) #-} + +infixr 5 :< +data Node w a b = Leaf a | !w :< b + deriving (Functor) + +bimapNode f g (Leaf x) = Leaf (f x) +bimapNode f g (x :< xs) = x :< g xs + +newtype HeapT w m a = HeapT { runHeapT :: ListT m (Node w a (HeapT w m a)) } + +-- | The 'Heap' type, specialised to the 'Identity' monad. +type Heap w = HeapT w Identity + +instance Functor m => Functor (HeapT w m) where + fmap f = HeapT . fmap (bimapNode f (fmap f)) . runHeapT + +instance Monad m => Applicative (HeapT w m) where + pure = HeapT . pure . Leaf + (<*>) = liftA2 id + +instance Monad m => Monad (HeapT w m) where + HeapT m >>= f = HeapT (m >>= g) + where + g (Leaf x) = runHeapT (f x) + g (w :< xs) = pure (w :< (xs >>= f)) + +popMinOneT :: forall w m a. (Monoid w, Monad m) => HeapT w m a -> m (Maybe ((a, w), HeapT w m a)) +popMinOneT = go mempty [] . runHeapT + where + go' :: w -> Maybe (w, HeapT w m a) -> m (Maybe ((a, w), HeapT w m a)) + go' a Nothing = pure Nothing + go' a (Just (w, HeapT xs)) = go (a <> w) [] xs + + go :: w -> [(w, HeapT w m a)] -> ListT m (Node w a (HeapT w m a)) -> m (Maybe ((a, w), HeapT w m a)) + go w a (ListT xs) = xs >>= \case + Nil -> go' w (undefined) + Leaf x :- xs -> pure (Just ((x, w), undefined >> HeapT (foldl (\ys (yw,y) -> ListT (pure ((yw :< y) :- ys))) xs a))) + (u :< x) :- xs -> go w ((u,x) : a) xs +{-# INLINE popMinOneT #-} + +popMinOne :: Monoid w => Heap w a -> Maybe ((a, w), Heap w a) +popMinOne = runIdentity . popMinOneT +{-# INLINE popMinOne #-} ===================================== testsuite/tests/cpranal/sigs/T25944.stderr ===================================== @@ -0,0 +1,17 @@ + +==================== Cpr signatures ==================== +T25944.$fApplicativeHeapT: +T25944.$fApplicativeListT: +T25944.$fFunctorHeapT: +T25944.$fFunctorListT: +T25944.$fFunctorNode: +T25944.$fMonadHeapT: +T25944.$fMonadListT: +T25944.bar: 1 +T25944.foo: +T25944.popMinOne: 2(1(1,)) +T25944.popMinOneT: +T25944.runHeapT: +T25944.runListT: + + ===================================== testsuite/tests/cpranal/sigs/all.T ===================================== @@ -12,3 +12,4 @@ test('T16040', normal, compile, ['']) test('T19232', normal, compile, ['']) test('T19398', normal, compile, ['']) test('T19822', normal, compile, ['']) +test('T25944', normal, compile, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9e8a00b7ebc5e28d20d0d30f9cf9d62… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9e8a00b7ebc5e28d20d0d30f9cf9d62… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/backtraces-decoders] Extend Backtraces to allow configuration of stack decoders
by Hannes Siebenhandl (＠fendor) 17 Jul '25

17 Jul '25

Hannes Siebenhandl pushed to branch wip/fendor/backtraces-decoders at Glasgow Haskell Compiler / GHC Commits: 42c8f304 by fendor at 2025-07-17T19:11:12+02:00 Extend Backtraces to allow configuration of stack decoders Allow the user to overwrite the default stack-decoders in `Backtraces`. Users can then experiment with custom stack decoders, or tweak the output of the stack trace to their liking. We store the stack decoders for each of the supported backtraces in `DisplayBacktraceMechanisms` in a global `IORef`. When collecting `Backtraces`, we also ask for the currently configured stack decoders (specified via `DisplayBacktraceMechanisms`) and use them for printing the `Backtraces`. - - - - - 2 changed files: - libraries/base/src/Control/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs Changes: ===================================== libraries/base/src/Control/Exception/Backtrace.hs ===================================== @@ -50,6 +50,10 @@ module Control.Exception.Backtrace BacktraceMechanism(..) , getBacktraceMechanismState , setBacktraceMechanismState + -- * Display Backtrace mechanisms + , DisplayBacktraceMechanisms(..) + , getDisplayBacktraceMechanisms + , setDisplayBacktraceMechanismsState -- * Collecting backtraces , Backtraces(..) , displayBacktraces ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs ===================================== @@ -11,9 +11,9 @@ import GHC.Internal.IORef import GHC.Internal.IO.Unsafe (unsafePerformIO) import GHC.Internal.Exception.Context import GHC.Internal.Ptr +import GHC.Internal.Data.Maybe (fromMaybe) import GHC.Internal.Stack.Types as GHC.Stack (CallStack) import qualified GHC.Internal.Stack as HCS -import qualified GHC.Internal.ExecutionStack as ExecStack import qualified GHC.Internal.ExecutionStack.Internal as ExecStack import qualified GHC.Internal.Stack.CloneStack as CloneStack import qualified GHC.Internal.Stack.CCS as CCS @@ -86,37 +86,69 @@ setBacktraceMechanismState bm enabled = do _ <- atomicModifyIORef'_ enabledBacktraceMechanismsRef (setBacktraceMechanismEnabled bm enabled) return () --- | A collection of backtraces. +-- | How to display a backtrace when an exception is thrown. +data DisplayBacktraceMechanisms = + DisplayBacktraceMechanisms + { displayCostCentreBacktrace :: Ptr CCS.CostCentreStack -> String + , displayHasCallStackBacktrace :: HCS.CallStack -> String + , displayExecutionBacktrace :: ExecStack.StackTrace -> String + , displayIpeBacktrace :: CloneStack.StackSnapshot -> String + } + +defaultDisplayBacktraceMechanisms :: DisplayBacktraceMechanisms +defaultDisplayBacktraceMechanisms = DisplayBacktraceMechanisms + { displayCostCentreBacktrace = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings + , displayHasCallStackBacktrace = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack + , displayExecutionBacktrace = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames + , displayIpeBacktrace = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode + } + where + indent :: Int -> String -> String + indent n s = replicate n ' ' ++ s + + prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc + + +displayBacktraceMechanismsRef :: IORef DisplayBacktraceMechanisms +displayBacktraceMechanismsRef = + unsafePerformIO $ newIORef defaultDisplayBacktraceMechanisms +{-# NOINLINE displayBacktraceMechanismsRef #-} + +-- | How are the 'Backtraces' going to be displayed? +getDisplayBacktraceMechanisms :: IO DisplayBacktraceMechanisms +getDisplayBacktraceMechanisms = readIORef displayBacktraceMechanismsRef + +-- | Specify how the 'Backtraces' are displayed. +setDisplayBacktraceMechanismsState :: DisplayBacktraceMechanisms -> IO () +setDisplayBacktraceMechanismsState dbm = do + _ <- atomicModifyIORef'_ displayBacktraceMechanismsRef (const dbm) + return () + +-- | A collection of backtraces, paired with a way to display each respective backtrace. data Backtraces = Backtraces { btrCostCentre :: Maybe (Ptr CCS.CostCentreStack), + btrDisplayCostCentre :: Ptr CCS.CostCentreStack -> String, btrHasCallStack :: Maybe HCS.CallStack, - btrExecutionStack :: Maybe [ExecStack.Location], - btrIpe :: Maybe [CloneStack.StackEntry] + btrDisplayHasCallStack :: HCS.CallStack -> String, + btrExecutionStack :: Maybe ExecStack.StackTrace, + btrDisplayExecutionStack :: ExecStack.StackTrace -> String, + btrIpe :: Maybe CloneStack.StackSnapshot, + btrDisplayIpe :: CloneStack.StackSnapshot -> String } -- | Render a set of backtraces to a human-readable string. displayBacktraces :: Backtraces -> String displayBacktraces bts = concat - [ displayOne "Cost-centre stack backtrace" btrCostCentre displayCc - , displayOne "Native stack backtrace" btrExecutionStack displayExec - , displayOne "IPE backtrace" btrIpe displayIpe - , displayOne "HasCallStack backtrace" btrHasCallStack displayHsc + [ displayOne "Cost-centre stack backtrace" btrCostCentre btrDisplayCostCentre + , displayOne "Native stack backtrace" btrExecutionStack btrDisplayExecutionStack + , displayOne "IPE backtrace" btrIpe btrDisplayIpe + , displayOne "HasCallStack backtrace" btrHasCallStack btrDisplayHasCallStack ] where - indent :: Int -> String -> String - indent n s = replicate n ' ' ++ s - - -- The unsafePerformIO here is safe as we don't currently unload cost-centres. - displayCc = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings - displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") - displayIpe = unlines . map (indent 2 . CloneStack.prettyStackEntry) - displayHsc = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack - where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc - - displayOne :: String -> (Backtraces -> Maybe rep) -> (rep -> String) -> String + displayOne :: String -> (Backtraces -> Maybe rep) -> (Backtraces -> rep -> String) -> String displayOne label getBt displ - | Just bt <- getBt bts = concat [label, ":\n", displ bt] + | Just bt <- getBt bts = concat [label, ":\n", displ bts bt] | otherwise = "" instance ExceptionAnnotation Backtraces where @@ -125,12 +157,14 @@ instance ExceptionAnnotation Backtraces where -- | Collect a set of 'Backtraces'. collectBacktraces :: (?callStack :: CallStack) => IO Backtraces collectBacktraces = HCS.withFrozenCallStack $ do - getEnabledBacktraceMechanisms >>= collectBacktraces' + bm <- getEnabledBacktraceMechanisms + dpm <- getDisplayBacktraceMechanisms + collectBacktraces' bm dpm collectBacktraces' :: (?callStack :: CallStack) - => EnabledBacktraceMechanisms -> IO Backtraces -collectBacktraces' enabled = HCS.withFrozenCallStack $ do + => EnabledBacktraceMechanisms -> DisplayBacktraceMechanisms -> IO Backtraces +collectBacktraces' enabled renderers = HCS.withFrozenCallStack $ do let collect :: BacktraceMechanism -> IO (Maybe a) -> IO (Maybe a) collect mech f | backtraceMechanismEnabled mech enabled = f @@ -140,18 +174,21 @@ collectBacktraces' enabled = HCS.withFrozenCallStack $ do Just `fmap` CCS.getCurrentCCS () exec <- collect ExecutionBacktrace $ do - ExecStack.getStackTrace + ExecStack.collectStackTrace ipe <- collect IPEBacktrace $ do stack <- CloneStack.cloneMyStack - stackEntries <- CloneStack.decode stack - return (Just stackEntries) + return (Just stack) hcs <- collect HasCallStackBacktrace $ do return (Just ?callStack) return (Backtraces { btrCostCentre = ccs + , btrDisplayCostCentre = displayCostCentreBacktrace renderers , btrHasCallStack = hcs + , btrDisplayHasCallStack = displayHasCallStackBacktrace renderers , btrExecutionStack = exec + , btrDisplayExecutionStack = displayExecutionBacktrace renderers , btrIpe = ipe + , btrDisplayIpe = displayIpeBacktrace renderers }) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/42c8f3046d06e4b5f0d8ef913a6b5fe… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/42c8f3046d06e4b5f0d8ef913a6b5fe… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] EPA: Update exact printing based on GHC 9.14 tests
by Marge Bot (＠marge-bot) 17 Jul '25

17 Jul '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: f4e8466c by Alan Zimmerman at 2025-07-17T12:31:55-04:00 EPA: Update exact printing based on GHC 9.14 tests As a result of migrating the GHC ghc-9.14 branch tests to ghc-exactprint in https://github.com/alanz/ghc-exactprint/tree/ghc-9.14, a couple of discrepancies were picked up - The opening paren for a DefaultDecl was printed in the wrong place - The import declaration level specifiers were not printed. This commit adds those fixes, and some tests for them. The tests brought to light that the ImportDecl ppr instance had not been updated for level specifiers, so it updates that too. - - - - - 7 changed files: - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Parser.y - testsuite/tests/printer/Makefile - + testsuite/tests/printer/TestLevelImports.hs - + testsuite/tests/printer/TestNamedDefaults.hs - testsuite/tests/printer/all.T - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Hs/ImpExp.hs ===================================== @@ -149,10 +149,14 @@ instance (OutputableBndrId p ppr (ImportDecl { ideclExt = impExt, ideclName = mod' , ideclPkgQual = pkg , ideclSource = from, ideclSafe = safe + , ideclLevelSpec = level , ideclQualified = qual , ideclAs = as, ideclImportList = spec }) - = hang (hsep [text "import", ppr_imp impExt from, pp_implicit impExt, pp_safe safe, - pp_qual qual False, ppr pkg, ppr mod', pp_qual qual True, pp_as as]) + = hang (hsep [text "import", ppr_imp impExt from, pp_implicit impExt, + pp_level level False, pp_safe safe, pp_qual qual False, + ppr pkg, ppr mod', + pp_level level True, pp_qual qual True, + pp_as as]) 4 (pp_spec spec) where pp_implicit ext = @@ -169,6 +173,15 @@ instance (OutputableBndrId p pp_qual QualifiedPost False = empty -- Postpositive qualifier/prepositive position. pp_qual NotQualified _ = empty + pp_level (LevelStylePre sty) False = pp_level_style sty + pp_level (LevelStylePost _) False = empty + pp_level (LevelStylePre _) True = empty + pp_level (LevelStylePost sty) True = pp_level_style sty + pp_level NotLevelled _ = empty + + pp_level_style ImportDeclQuote = text "quote" + pp_level_style ImportDeclSplice = text "splice" + pp_safe False = empty pp_safe True = text "safe" ===================================== compiler/GHC/Parser.y ===================================== @@ -1123,7 +1123,7 @@ importdecls_semi | {- empty -} { [] } importdecl :: { LImportDecl GhcPs } - : 'import' maybe_src maybe_splice maybe_safe optqualified maybe_pkg modid maybe_splice optqualified maybeas maybeimpspec + : 'import' maybe_src maybe_level maybe_safe optqualified maybe_pkg modid maybe_level optqualified maybeas maybeimpspec {% do { ; let { ; mPreQual = $5 ; mPostQual = $9 @@ -1163,7 +1163,7 @@ maybe_safe :: { (Maybe (EpToken "safe"),Bool) } : 'safe' { (Just (epTok $1),True) } | {- empty -} { (Nothing, False) } -maybe_splice :: { (Maybe EpAnnLevel) } +maybe_level :: { (Maybe EpAnnLevel) } : 'splice' { (Just (EpAnnLevelSplice (epTok $1))) } | 'quote' { (Just (EpAnnLevelQuote (epTok $1))) } | {- empty -} { (Nothing) } ===================================== testsuite/tests/printer/Makefile ===================================== @@ -901,3 +901,14 @@ Test25467: Test25885: $(CHECK_PPR) $(LIBDIR) Test25885.hs $(CHECK_EXACT) $(LIBDIR) Test25885.hs + +.PHONY: TestLevelImports +TestLevelImports: + $(CHECK_PPR) $(LIBDIR) TestLevelImports.hs + $(CHECK_EXACT) $(LIBDIR) TestLevelImports.hs + + +.PHONY: TestNamedDefaults +TestNamedDefaults: + $(CHECK_PPR) $(LIBDIR) TestNamedDefaults.hs + $(CHECK_EXACT) $(LIBDIR) TestNamedDefaults.hs ===================================== testsuite/tests/printer/TestLevelImports.hs ===================================== @@ -0,0 +1,42 @@ + +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ExplicitLevelImports #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +module TestLevelImports where +-- Based on test SI26 and SI01 + +------------------------------------------------ +-- SI26 + +-- Test using 'quote' as a post-qualifier in imports +import Prelude quote +import Prelude quote qualified as P +import quote Prelude qualified as P2 +import quote qualified Prelude as P3 + +-- Test using 'splice' as a post-qualifier in imports +import Language.Haskell.TH.Syntax splice + +import splice Language.Haskell.TH.Syntax qualified as TH +import Language.Haskell.TH.Syntax splice qualified as TH2 + +-- Using a splice imported thing, inside an untyped and typed splice works +import splice SI01A + +-- Use the imported modules +testQuote = [| id |] +testQuote2 = [| P.id |] +testQuote3 = [| P2.id |] + +testSplice = $(lift "Hello from splice") +testSplice2 = $(TH.lift "Hello from splice2") +testSplice3 = $(TH2.lift "Hello from splice3") + +------------------------------------------------ +-- SI01 + +main :: IO () +main = $( sid [| pure () |]) >> $$( sid [|| pure () ||]) ===================================== testsuite/tests/printer/TestNamedDefaults.hs ===================================== @@ -0,0 +1,35 @@ +{-# LANGUAGE NamedDefaults #-} +module NamedDefaults ( + Stringify(..), + default Stringify, + Bingify(..), + default Bingify + ) where + +class Stringify a where + stringify :: a -> String + +instance Stringify Int where + stringify n = "Int" + +instance Stringify Bool where + stringify b = "Bool" + +instance Stringify [Char] where + stringify s = "String" + +class Bingify a where + bingify :: a -> String + +instance Bingify Int where + bingify n = "Int" + +instance Bingify Bool where + bingify b = "Bool" + +instance Bingify [Char] where + bingify s = "String" + +default Stringify (Int) +default Bingify (Int) + ===================================== testsuite/tests/printer/all.T ===================================== @@ -215,4 +215,7 @@ test('Test25467', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25467']) test('T24237', normal, compile_fail, ['']) test('Test25454', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25454']) -test('Test25885', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25885']) \ No newline at end of file +test('Test25885', [ignore_stderr, req_ppr_deps], makefile_test, ['Test25885']) + +test('TestLevelImports', [ignore_stderr, req_ppr_deps], makefile_test, ['TestLevelImports']) +test('TestNamedDefaults', [ignore_stderr, req_ppr_deps], makefile_test, ['TestNamedDefaults']) \ No newline at end of file ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -802,6 +802,7 @@ markLensBracketsC' a l = c' <- markEpUniToken c return (set l (ListBanana o c') a) ListNone -> return (set l ListNone a) + -- ------------------------------------- markEpToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) @@ -937,6 +938,7 @@ lam_where k annsModule = fmap (\newAnns -> annsModule { am_where = newAnns }) -- { importDeclAnnImport :: EpToken "import" -- ^ The location of the @import@ keyword -- , importDeclAnnPragma :: Maybe (EpaLocation, EpToken "#-}") -- ^ The locations of @{-# SOURCE@ and @#-}@ respectively -- , importDeclAnnSafe :: Maybe (EpToken "safe") -- ^ The location of the @safe@ keyword +-- , importDeclAnnLevel :: Maybe EpAnnLevel -- ^ The location of the @splice@ or @quote@ keyword -- , importDeclAnnQualified :: Maybe (EpToken "qualified") -- ^ The location of the @qualified@ keyword -- , importDeclAnnPackage :: Maybe EpaLocation -- ^ The location of the package name (when using @-XPackageImports@) -- , importDeclAnnAs :: Maybe (EpToken "as") -- ^ The location of the @as@ keyword @@ -954,6 +956,10 @@ limportDeclAnnSafe :: Lens EpAnnImportDecl (Maybe (EpToken "safe")) limportDeclAnnSafe k annImp = fmap (\new -> annImp { importDeclAnnSafe = new }) (k (importDeclAnnSafe annImp)) +limportDeclAnnLevel :: Lens EpAnnImportDecl (Maybe EpAnnLevel) +limportDeclAnnLevel k annImp = fmap (\new -> annImp { importDeclAnnLevel = new }) + (k (importDeclAnnLevel annImp)) + limportDeclAnnQualified :: Lens EpAnnImportDecl (Maybe (EpToken "qualified")) limportDeclAnnQualified k annImp = fmap (\new -> annImp { importDeclAnnQualified = new }) (k (importDeclAnnQualified annImp)) @@ -1625,9 +1631,15 @@ instance ExactPrint (ImportDecl GhcPs) where printStringAtLsDelta (SameLine 1) "#-}" return Nothing NoSourceText -> return (importDeclAnnPragma an) + -- pre level + ann0' <- case st of + LevelStylePre _ -> markLensFun' ann0 limportDeclAnnLevel (\mt -> mapM markEpAnnLevel mt) + _ -> return ann0 + + ann1 <- if safeflag - then markLensFun' ann0 limportDeclAnnSafe (\mt -> mapM markEpToken mt) - else return ann0 + then markLensFun' ann0' limportDeclAnnSafe (\mt -> mapM markEpToken mt) + else return ann0' ann2 <- case qualFlag of QualifiedPre -- 'qualified' appears in prepositive position. @@ -1640,11 +1652,16 @@ instance ExactPrint (ImportDecl GhcPs) where _ -> return ann2 modname' <- markAnnotated modname + -- post level + ann3' <- case st of + LevelStylePost _ -> markLensFun' ann3 limportDeclAnnLevel (\mt -> mapM markEpAnnLevel mt) + _ -> return ann3 + ann4 <- case qualFlag of QualifiedPost -- 'qualified' appears in postpositive position. - -> markLensFun' ann3 limportDeclAnnQualified (\ml -> mapM markEpToken ml) - _ -> return ann3 + -> markLensFun' ann3' limportDeclAnnQualified (\ml -> mapM markEpToken ml) + _ -> return ann3' (importDeclAnnAs', mAs') <- case mAs of @@ -1669,6 +1686,9 @@ instance ExactPrint (ImportDecl GhcPs) where return (ImportDecl (XImportDeclPass (EpAnn anc' an2 cs') msrc impl) modname' mpkg src st safeflag qualFlag mAs' hiding') +markEpAnnLevel :: (Monad m, Monoid w) => EpAnnLevel -> EP w m EpAnnLevel +markEpAnnLevel (EpAnnLevelSplice tok) = EpAnnLevelSplice <$> markEpToken tok +markEpAnnLevel (EpAnnLevelQuote tok) = EpAnnLevelQuote <$> markEpToken tok -- --------------------------------------------------------------------- @@ -2717,8 +2737,8 @@ instance ExactPrint (DefaultDecl GhcPs) where exact (DefaultDecl (d,op,cp) cl tys) = do d' <- markEpToken d - op' <- markEpToken op cl' <- markAnnotated cl + op' <- markEpToken op tys' <- markAnnotated tys cp' <- markEpToken cp return (DefaultDecl (d',op',cp') cl' tys') View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f4e8466cf2164fd9ecf8d02d8cb417c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f4e8466cf2164fd9ecf8d02d8cb417c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] base: Deprecate GHC.Weak.Finalize.runFinalizerBatch
by Marge Bot (＠marge-bot) 17 Jul '25

17 Jul '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 360fa82c by Duncan Coutts at 2025-07-17T12:31:14-04:00 base: Deprecate GHC.Weak.Finalize.runFinalizerBatch https://github.com/haskell/core-libraries-committee/issues/342 - - - - - 2 changed files: - libraries/base/changelog.md - libraries/base/src/GHC/Weak/Finalize.hs Changes: ===================================== libraries/base/changelog.md ===================================== @@ -4,6 +4,8 @@ * Add `Data.List.NonEmpty.mapMaybe`. ([CLC proposal #337](https://github.com/haskell/core-libraries-committee/issues/337)) ## 4.22.0.0 *TBA* + * Shipped with GHC 9.14.1 + * The internal `GHC.Weak.Finalize.runFinalizerBatch` function has been deprecated ([CLC proposal #342](https://github.com/haskell/core-libraries-committee/issues/342)) * Define `displayException` of `SomeAsyncException` to unwrap the exception. ([CLC proposal #309](https://github.com/haskell/core-libraries-committee/issues/309)) * Restrict `Data.List.NonEmpty.unzip` to `NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)`. ([CLC proposal #86](https://github.com/haskell/core-libraries-committee/issues/86)) ===================================== libraries/base/src/GHC/Weak/Finalize.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} module GHC.Weak.Finalize ( -- * Handling exceptions -- | When an exception is thrown by a finalizer called by the @@ -8,7 +9,30 @@ module GHC.Weak.Finalize , getFinalizerExceptionHandler , printToHandleFinalizerExceptionHandler -- * Internal - , runFinalizerBatch + , GHC.Weak.Finalize.runFinalizerBatch ) where import GHC.Internal.Weak.Finalize + +-- These imports can be removed once runFinalizerBatch is removed, +-- as can MagicHash above. +import GHC.Internal.Base (Int, Array#, IO, State#, RealWorld) + + +{-# DEPRECATED runFinalizerBatch + "This function is internal to GHC. It will not be exported in future." #-} +-- | Run a batch of finalizers from the garbage collector. Given an +-- array of finalizers and the length of the array, just call each one +-- in turn. +-- +-- This is an internal detail of the GHC RTS weak pointer finaliser +-- mechanism. It should no longer be exported from base. There is no +-- good reason to use it. It will be removed in the next major version +-- of base (4.23.*). +-- +-- See <https://github.com/haskell/core-libraries-committee/issues/342> +-- +runFinalizerBatch :: Int + -> Array# (State# RealWorld -> State# RealWorld) + -> IO () +runFinalizerBatch = GHC.Internal.Weak.Finalize.runFinalizerBatch View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/360fa82cc0e06163c7d712a22e7a33c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/360fa82cc0e06163c7d712a22e7a33c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Add Data.List.NonEmpty.mapMaybe
by Marge Bot (＠marge-bot) 17 Jul '25

17 Jul '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: cc650b4b by Andrew Lelechenko at 2025-07-17T12:30:24-04:00 Add Data.List.NonEmpty.mapMaybe As per https://github.com/haskell/core-libraries-committee/issues/337 - - - - - 6 changed files: - libraries/base/changelog.md - libraries/base/src/Data/List/NonEmpty.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 Changes: ===================================== libraries/base/changelog.md ===================================== @@ -1,5 +1,8 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) +## 4.23.0.0 *TBA* + * Add `Data.List.NonEmpty.mapMaybe`. ([CLC proposal #337](https://github.com/haskell/core-libraries-committee/issues/337)) + ## 4.22.0.0 *TBA* * Define `displayException` of `SomeAsyncException` to unwrap the exception. ([CLC proposal #309](https://github.com/haskell/core-libraries-committee/issues/309)) ===================================== libraries/base/src/Data/List/NonEmpty.hs ===================================== @@ -78,6 +78,7 @@ module Data.List.NonEmpty ( , span -- :: (a -> Bool) -> NonEmpty a -> ([a], [a]) , break -- :: (a -> Bool) -> NonEmpty a -> ([a], [a]) , filter -- :: (a -> Bool) -> NonEmpty a -> [a] + , mapMaybe -- :: (a -> Maybe b) -> NonEmpty a -> [b] , partition -- :: (a -> Bool) -> NonEmpty a -> ([a],[a]) , group -- :: (Foldable f, Eq a) => f a -> [NonEmpty a] , groupBy -- :: Foldable f => (a -> a -> Bool) -> f a -> [NonEmpty a] @@ -118,6 +119,7 @@ import qualified Prelude import Control.Applicative (Applicative (..), Alternative (many)) import qualified Data.List as List +import qualified Data.Maybe as List (mapMaybe) import GHC.Internal.Data.Foldable hiding (length, toList) import qualified GHC.Internal.Data.Foldable as Foldable import GHC.Internal.Data.Function (on) @@ -442,6 +444,14 @@ break p = span (not . p) filter :: (a -> Bool) -> NonEmpty a -> [a] filter p = List.filter p . toList +-- | The 'mapMaybe' function is a version of 'map' which can throw +-- out elements. In particular, the functional argument returns +-- something of type @'Maybe' b@. If this is 'Nothing', no element +-- is added on to the result list. If it is @'Just' b@, then @b@ is +-- included in the result list. +mapMaybe :: (a -> Maybe b) -> NonEmpty a -> [b] +mapMaybe f (x :| xs) = maybe id (:) (f x) $ List.mapMaybe f xs + -- | The 'partition' function takes a predicate @p@ and a stream -- @xs@, and returns a pair of lists. The first list corresponds to the -- elements of @xs@ for which @p@ holds; the second corresponds to the ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -1467,6 +1467,7 @@ module Data.List.NonEmpty where last :: forall a. NonEmpty a -> a length :: forall a. NonEmpty a -> GHC.Internal.Types.Int map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b + mapMaybe :: forall a b. (a -> GHC.Internal.Maybe.Maybe b) -> NonEmpty a -> [b] nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -1467,6 +1467,7 @@ module Data.List.NonEmpty where last :: forall a. NonEmpty a -> a length :: forall a. NonEmpty a -> GHC.Internal.Types.Int map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b + mapMaybe :: forall a b. (a -> GHC.Internal.Maybe.Maybe b) -> NonEmpty a -> [b] nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -1467,6 +1467,7 @@ module Data.List.NonEmpty where last :: forall a. NonEmpty a -> a length :: forall a. NonEmpty a -> GHC.Internal.Types.Int map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b + mapMaybe :: forall a b. (a -> GHC.Internal.Maybe.Maybe b) -> NonEmpty a -> [b] nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -1467,6 +1467,7 @@ module Data.List.NonEmpty where last :: forall a. NonEmpty a -> a length :: forall a. NonEmpty a -> GHC.Internal.Types.Int map :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b + mapMaybe :: forall a b. (a -> GHC.Internal.Maybe.Maybe b) -> NonEmpty a -> [b] nonEmpty :: forall a. [a] -> GHC.Internal.Maybe.Maybe (NonEmpty a) nub :: forall a. GHC.Internal.Classes.Eq a => NonEmpty a -> NonEmpty a nubBy :: forall a. (a -> a -> GHC.Internal.Types.Bool) -> NonEmpty a -> NonEmpty a View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cc650b4be2aea55ec0277d1ae8ffd28… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cc650b4be2aea55ec0277d1ae8ffd28… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26115] 3 commits: Error message changes
by Simon Peyton Jones (＠simonpj) 17 Jul '25

17 Jul '25

Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: 553b9080 by Simon Peyton Jones at 2025-07-17T17:09:47+01:00 Error message changes - - - - - 91333dbb by Simon Peyton Jones at 2025-07-17T17:09:47+01:00 Document use of TrySolveImplication (SF6) - - - - - 3a32ba49 by Simon Peyton Jones at 2025-07-17T17:09:47+01:00 Improve solveOneFromTheOther ...to account for rewriter sets - - - - - 10 changed files: - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/InertSet.hs - testsuite/tests/deriving/should_fail/T12768.stderr - testsuite/tests/deriving/should_fail/T1496.stderr - testsuite/tests/deriving/should_fail/T5498.stderr - testsuite/tests/deriving/should_fail/T7148.stderr - testsuite/tests/deriving/should_fail/T7148a.stderr - testsuite/tests/roles/should_fail/RolesIArray.stderr - + testsuite/tests/simplCore/should_compile/T2117.hs - + testsuite/tests/simplCore/should_compile/T26117.stderr Changes: ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -532,6 +532,8 @@ can_eq_nc_forall ev eq_rel s1 s2 unifyForAllBody ev (eqRelRole eq_rel) $ \uenv -> go uenv skol_tvs init_subst2 bndrs1 bndrs2 + -- Solve the implication right away, using `trySolveImplication` + -- See (SF6) in Note [Solving forall equalities] ; traceTcS "Trying to solve the implication" (ppr s1 $$ ppr s2 $$ ppr wanteds) ; ev_binds_var <- newNoTcEvBinds ; solved <- trySolveImplication $ @@ -620,6 +622,21 @@ There are lots of wrinkles of course: especially Refl ones. We use the `unifyForAllBody` wrapper for `uType`, because we want to /gather/ the equality constraint (to put in the implication) rather than /emit/ them into the monad, as `wrapUnifierTcS` does. + +(SF6) We solve the implication on the spot, using `trySolveImplication`. In + the past we instead generated an `Implication` to be solved later. Nice in + some ways but it added complexity: + - We needed a `wl_implics` field of `WorkList` to collect + these emitted implications + - The types of `solveSimpleWanteds` and friends were more complicated + - Trickily, an `EvFun` had to contain an `EvBindsVar` ref-cell, which made + `evVarsOfTerm` harder. Now an `EvFun` just contains the bindings. + The disadvantage of solve-on-the-spot is that if we fail we are simply + left with an unsolved (forall a. blah) ~ (forall b. blah), and it may + not be clear /why we couldn't solve it. But on balance the error messages + improve: it is easier to undertand that + (forall a. a->a) ~ (forall b. b->Int) + is insoluble than it is to understand a message about matching `a` with `Int`. -} {- Note [Unwrap newtypes first] @@ -2706,7 +2723,7 @@ tryInertEqs :: EqCt -> SolverStage () tryInertEqs work_item@(EqCt { eq_ev = ev, eq_eq_rel = eq_rel }) = Stage $ do { inerts <- getInertCans - ; if | Just (ev_i, swapped) <- inertsCanDischarge inerts work_item + ; if | Just (ev_i, swapped) <- inertsEqsCanDischarge inerts work_item -> do { setEvBindIfWanted ev EvCanonical $ evCoercion (maybeSymCo swapped $ downgradeRole (eqRelRole eq_rel) @@ -2717,10 +2734,10 @@ tryInertEqs work_item@(EqCt { eq_ev = ev, eq_eq_rel = eq_rel }) | otherwise -> continueWith () } -inertsCanDischarge :: InertCans -> EqCt - -> Maybe ( CtEvidence -- The evidence for the inert - , SwapFlag ) -- Whether we need mkSymCo -inertsCanDischarge inerts (EqCt { eq_lhs = lhs_w, eq_rhs = rhs_w +inertsEqsCanDischarge :: InertCans -> EqCt + -> Maybe ( CtEvidence -- The evidence for the inert + , SwapFlag ) -- Whether we need mkSymCo +inertsEqsCanDischarge inerts (EqCt { eq_lhs = lhs_w, eq_rhs = rhs_w , eq_ev = ev_w, eq_eq_rel = eq_rel }) | (ev_i : _) <- [ ev_i | EqCt { eq_ev = ev_i, eq_rhs = rhs_i , eq_eq_rel = eq_rel } @@ -2766,7 +2783,7 @@ inertsCanDischarge inerts (EqCt { eq_lhs = lhs_w, eq_rhs = rhs_w -- Prefer the one that has no rewriters -- See (CE4) in Note [Combining equalities] -inertsCanDischarge _ _ = Nothing +inertsEqsCanDischarge _ _ = Nothing ===================================== compiler/GHC/Tc/Solver/InertSet.hs ===================================== @@ -1960,6 +1960,9 @@ solveOneFromTheOther :: Ct -- Inert (Dict or Irred) -- We can always solve one from the other: even if both are wanted, -- although we don't rewrite wanteds with wanteds, we can combine -- two wanteds into one by solving one from the other +-- +-- Compare the corresponding function for equalities: +-- GHC.Tc.Solver.Equality.inertEqsCanDischarge solveOneFromTheOther ct_i ct_w | CtWanted {} <- ev_w @@ -1968,32 +1971,37 @@ solveOneFromTheOther ct_i ct_w = -- Inert must be Given KeepWork - | CtWanted {} <- ev_w + | CtWanted (WantedCt { ctev_rewriters = rw_w }) <- ev_w = -- Inert is Given or Wanted case ev_i of CtGiven {} -> KeepInert -- work is Wanted; inert is Given: easy choice. - CtWanted {} -- Both are Wanted + CtWanted (WantedCt { ctev_rewriters = rw_i }) -- Both are Wanted -- If only one has no pending superclasses, use it -- Otherwise we can get infinite superclass expansion (#22516) -- in silly cases like class C T b => C a b where ... - | not is_psc_i, is_psc_w -> KeepInert - | is_psc_i, not is_psc_w -> KeepWork + | Just res <- better (not is_psc_i) (not is_psc_w) + -> res + + -- If only one has an empty rewriter set, use it + | Just res <- better (isEmptyRewriterSet rw_i) (isEmptyRewriterSet rw_w) + -> res -- If only one is a WantedSuperclassOrigin (arising from expanding -- a Wanted class constraint), keep the other: wanted superclasses -- may be unexpected by users - | not is_wsc_orig_i, is_wsc_orig_w -> KeepInert - | is_wsc_orig_i, not is_wsc_orig_w -> KeepWork + | Just res <- better (not is_wsc_orig_i) (not is_wsc_orig_w) + -> res - -- otherwise, just choose the lower span + -- Otherwise, just choose the lower span -- reason: if we have something like (abs 1) (where the -- Num constraint cannot be satisfied), it's better to -- get an error about abs than about 1. -- This test might become more elaborate if we see an -- opportunity to improve the error messages | ((<) `on` ctLocSpan) loc_i loc_w -> KeepInert + | otherwise -> KeepWork -- From here on the work-item is Given @@ -2016,6 +2024,15 @@ solveOneFromTheOther ct_i ct_w | otherwise -- Both are Given, levels differ = different_level_strategy where + better :: Bool -> Bool -> Maybe InteractResult + -- (better inert-is-good wanted-is-good) returns + -- Just KeepWork if wanted is strictly better than inert + -- Just KeepInert if inert is strictly better than wanted + -- Nothing if they are the same + better True False = Just KeepInert + better False True = Just KeepWork + better _ _ = Nothing + ev_i = ctEvidence ct_i ev_w = ctEvidence ct_w ===================================== testsuite/tests/deriving/should_fail/T12768.stderr ===================================== @@ -1,10 +1,9 @@ -T12768.hs:9:33: error: [GHC-39999] - • Could not deduce ‘D [a]’ - arising from the head of a quantified constraint +T12768.hs:9:33: error: [GHC-05617] + • Could not deduce ‘D (N a) => + (Coercible ([a] -> [a]) (N a -> N a), D [a])’ arising from the coercion of the method ‘op’ from type ‘D [a] => [a] -> [a]’ to type ‘D (N a) => N a -> N a’ from the context: C a bound by the deriving clause for ‘C (N a)’ at T12768.hs:9:33 - or from: D (N a) bound by a quantified context at T12768.hs:9:33 • When deriving the instance for (C (N a)) ===================================== testsuite/tests/deriving/should_fail/T1496.stderr ===================================== @@ -1,11 +1,8 @@ -T1496.hs:10:32: error: [GHC-18872] - • Couldn't match representation of type: c Int - with that of: c Moo - arising from the head of a quantified constraint +T1496.hs:10:32: error: [GHC-05617] + • Could not solve: ‘forall (c :: * -> *). + Coercible (c Int -> c Int) (c Int -> c Moo)’ arising from the coercion of the method ‘isInt’ from type ‘forall (c :: * -> *). c Int -> c Int’ to type ‘forall (c :: * -> *). c Int -> c Moo’ - Note: We cannot know what roles the parameters to ‘c’ have; - we must assume that the role is nominal. • When deriving the instance for (IsInt Moo) ===================================== testsuite/tests/deriving/should_fail/T5498.stderr ===================================== @@ -1,11 +1,11 @@ -T5498.hs:30:39: error: [GHC-18872] - • Couldn't match representation of type: c a - with that of: c (Down a) - arising from the head of a quantified constraint +T5498.hs:30:39: error: [GHC-05617] + • Could not deduce ‘forall (c :: * -> *). + Coercible (c a -> c Int) (c (Down a) -> c Int)’ arising from the coercion of the method ‘intIso’ from type ‘forall (c :: * -> *). c a -> c Int’ to type ‘forall (c :: * -> *). c (Down a) -> c Int’ - Note: We cannot know what roles the parameters to ‘c’ have; - we must assume that the role is nominal. + from the context: IntIso a + bound by the deriving clause for ‘IntIso (Down a)’ + at T5498.hs:30:39-44 • When deriving the instance for (IntIso (Down a)) ===================================== testsuite/tests/deriving/should_fail/T7148.stderr ===================================== @@ -1,22 +1,13 @@ -T7148.hs:27:40: error: [GHC-25897] - • Couldn't match type ‘b’ with ‘Tagged a b’ - arising from the head of a quantified constraint - arising from the coercion of the method ‘iso2’ - from type ‘forall b1. SameType b1 () -> SameType b1 b’ - to type ‘forall b1. SameType b1 () -> SameType b1 (Tagged a b)’ - ‘b’ is a rigid type variable bound by - the deriving clause for ‘IsoUnit (Tagged a b)’ - at T7148.hs:27:40-46 - • When deriving the instance for (IsoUnit (Tagged a b)) - -T7148.hs:27:40: error: [GHC-25897] - • Couldn't match type ‘b’ with ‘Tagged a b’ - arising from the head of a quantified constraint +T7148.hs:27:40: error: [GHC-05617] + • Could not deduce ‘forall b1. + Coercible + (SameType () b1 -> SameType b b1) + (SameType () b1 -> SameType (Tagged a b) b1)’ arising from the coercion of the method ‘iso1’ from type ‘forall b1. SameType () b1 -> SameType b b1’ to type ‘forall b1. SameType () b1 -> SameType (Tagged a b) b1’ - ‘b’ is a rigid type variable bound by - the deriving clause for ‘IsoUnit (Tagged a b)’ + from the context: IsoUnit b + bound by the deriving clause for ‘IsoUnit (Tagged a b)’ at T7148.hs:27:40-46 • When deriving the instance for (IsoUnit (Tagged a b)) ===================================== testsuite/tests/deriving/should_fail/T7148a.stderr ===================================== @@ -1,13 +1,13 @@ -T7148a.hs:19:50: error: [GHC-10283] - • Couldn't match representation of type ‘b’ - with that of ‘Result a b’ - arising from the head of a quantified constraint +T7148a.hs:19:50: error: [GHC-05617] + • Could not deduce ‘forall b. + Coercible + (Proxy b -> a -> Result a b) (Proxy b -> IS_NO_LONGER a -> b)’ arising from the coercion of the method ‘coerce’ from type ‘forall b. Proxy b -> a -> Result a b’ to type ‘forall b. Proxy b -> IS_NO_LONGER a -> Result (IS_NO_LONGER a) b’ - ‘b’ is a rigid type variable bound by - a quantified context + from the context: Convert a + bound by the deriving clause for ‘Convert (IS_NO_LONGER a)’ at T7148a.hs:19:50-56 • When deriving the instance for (Convert (IS_NO_LONGER a)) ===================================== testsuite/tests/roles/should_fail/RolesIArray.stderr ===================================== @@ -1,68 +1,8 @@ -RolesIArray.hs:10:13: error: [GHC-18872] - • Couldn't match type ‘Word64’ with ‘N’ - arising from the head of a quantified constraint - arising from the coercion of the method ‘Data.Array.Base.unsafeAccumArray’ - from type ‘forall i e'. - Ix i => - (Word64 -> e' -> Word64) - -> Word64 -> (i, i) -> [(Int, e')] -> UArray i Word64’ - to type ‘forall i e'. - Ix i => - (N -> e' -> N) -> N -> (i, i) -> [(Int, e')] -> UArray i N’ - • When deriving the instance for (IArray UArray N) - -RolesIArray.hs:10:13: error: [GHC-18872] - • Couldn't match type ‘Word64’ with ‘N’ - arising from the head of a quantified constraint - arising from the coercion of the method ‘Data.Array.Base.unsafeAccum’ - from type ‘forall i e'. - Ix i => - (Word64 -> e' -> Word64) - -> UArray i Word64 -> [(Int, e')] -> UArray i Word64’ - to type ‘forall i e'. - Ix i => - (N -> e' -> N) -> UArray i N -> [(Int, e')] -> UArray i N’ - • When deriving the instance for (IArray UArray N) - -RolesIArray.hs:10:13: error: [GHC-18872] - • Couldn't match type ‘Word64’ with ‘N’ - arising from the head of a quantified constraint - arising from the coercion of the method ‘Data.Array.Base.unsafeReplace’ - from type ‘forall i. - Ix i => - UArray i Word64 -> [(Int, Word64)] -> UArray i Word64’ - to type ‘forall i. Ix i => UArray i N -> [(Int, N)] -> UArray i N’ - • When deriving the instance for (IArray UArray N) - -RolesIArray.hs:10:13: error: [GHC-18872] - • Couldn't match type ‘Word64’ with ‘N’ - arising from the head of a quantified constraint - arising from the coercion of the method ‘Data.Array.Base.unsafeAt’ - from type ‘forall i. Ix i => UArray i Word64 -> Int -> Word64’ - to type ‘forall i. Ix i => UArray i N -> Int -> N’ - • When deriving the instance for (IArray UArray N) - -RolesIArray.hs:10:13: error: [GHC-18872] - • Couldn't match type ‘Word64’ with ‘N’ - arising from the head of a quantified constraint - arising from the coercion of the method ‘Data.Array.Base.unsafeArray’ - from type ‘forall i. - Ix i => - (i, i) -> [(Int, Word64)] -> UArray i Word64’ - to type ‘forall i. Ix i => (i, i) -> [(Int, N)] -> UArray i N’ - • When deriving the instance for (IArray UArray N) - -RolesIArray.hs:10:13: error: [GHC-18872] - • Couldn't match type ‘Word64’ with ‘N’ - arising from the head of a quantified constraint - arising from the coercion of the method ‘Data.Array.Base.numElements’ - from type ‘forall i. Ix i => UArray i Word64 -> Int’ - to type ‘forall i. Ix i => UArray i N -> Int’ - • When deriving the instance for (IArray UArray N) - -RolesIArray.hs:10:13: error: [GHC-18872] - • Couldn't match type ‘Word64’ with ‘N’ - arising from the head of a quantified constraint +RolesIArray.hs:10:13: error: [GHC-05617] + • Could not solve: ‘forall i. + Ix i => + (Coercible (UArray i Word64 -> (i, i)) (UArray i N -> (i, i)), + Ix i)’ arising from the coercion of the method ‘bounds’ from type ‘forall i. Ix i => UArray i Word64 -> (i, i)’ to type ‘forall i. Ix i => UArray i N -> (i, i)’ ===================================== testsuite/tests/simplCore/should_compile/T2117.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE UndecidableInstances, TypeFamilies #-} + +module T26117 where + +type family F a +type instance F Int = Bool + +class Eq (F a) => D a b where { dop1, dop2 :: a -> b -> b } + +class C a b where { op1,op2 :: F a -> a -> b -> Int } + +instance (Eq (F a), D a b) => C a [b] where + op1 x _ _ | x==x = 3 + | otherwise = 4 + {-# SPECIALISE instance D Int b => C Int [b] #-} ===================================== testsuite/tests/simplCore/should_compile/T26117.stderr ===================================== @@ -0,0 +1,433 @@ +T26117.hs:17:10: warning: [GHC-06201] [-Wmissing-methods (in -Wdefault)] + • No explicit implementation for + ‘op2’ + • In the instance declaration for ‘C a [b]’ + + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 196, types: 296, coercions: 2, joins: 0/0} + +-- RHS size: {terms: 7, types: 18, coercions: 0, joins: 0/0} +op1 [InlPrag=[~]] :: forall a b. C a b => F a -> a -> b -> Int +[GblId[ClassOp], + Arity=1, + Str=<S!P(SL,A)>, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) + Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: C a b) -> + case v of { T26117.C:C v2 [Occ=Once1] _ [Occ=Dead] -> v2 }}] +op1 + = \ (@a) (@b) (v :: C a b) -> + case v of v1 { T26117.C:C v2 v3 -> v2 } + +-- RHS size: {terms: 7, types: 18, coercions: 0, joins: 0/0} +op2 [InlPrag=[~]] :: forall a b. C a b => F a -> a -> b -> Int +[GblId[ClassOp], + Arity=1, + Str=<S!P(A,SL)>, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) + Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: C a b) -> + case v of { T26117.C:C _ [Occ=Dead] v3 [Occ=Once1] -> v3 }}] +op2 + = \ (@a) (@b) (v :: C a b) -> + case v of v1 { T26117.C:C v2 v3 -> v3 } + +-- RHS size: {terms: 7, types: 17, coercions: 0, joins: 0/0} +T26117.$p1D [InlPrag=[~]] :: forall a b. D a b => Eq (F a) +[GblId[ClassOp], + Arity=1, + Str=<S!P(SL,A,A)>, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) + Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: D a b) -> + case v of { T26117.C:D v2 [Occ=Once1] _ [Occ=Dead] _ [Occ=Dead] -> + v2 + }}] +T26117.$p1D + = \ (@a) (@b) (v :: D a b) -> + case v of v1 { T26117.C:D v2 v3 v4 -> v2 } + +-- RHS size: {terms: 7, types: 17, coercions: 0, joins: 0/0} +dop1 [InlPrag=[~]] :: forall a b. D a b => a -> b -> b +[GblId[ClassOp], + Arity=1, + Str=<S!P(A,SL,A)>, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) + Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: D a b) -> + case v of { T26117.C:D _ [Occ=Dead] v3 [Occ=Once1] _ [Occ=Dead] -> + v3 + }}] +dop1 + = \ (@a) (@b) (v :: D a b) -> + case v of v1 { T26117.C:D v2 v3 v4 -> v3 } + +-- RHS size: {terms: 7, types: 17, coercions: 0, joins: 0/0} +dop2 [InlPrag=[~]] :: forall a b. D a b => a -> b -> b +[GblId[ClassOp], + Arity=1, + Str=<S!P(A,A,SL)>, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=False) + Tmpl= \ (@a) (@b) (v [Occ=Once1!] :: D a b) -> + case v of { T26117.C:D _ [Occ=Dead] _ [Occ=Dead] v4 [Occ=Once1] -> + v4 + }}] +dop2 + = \ (@a) (@b) (v :: D a b) -> + case v of v1 { T26117.C:D v2 v3 v4 -> v4 } + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T26117.$fCaList1 :: GHC.Internal.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 70 0}] +T26117.$fCaList1 = "T26117.hs:17:10-37|\CANop2\EM"# + +-- RHS size: {terms: 6, types: 15, coercions: 0, joins: 0/0} +T26117.$fCaList_$cop2 [InlPrag=[2]] + :: forall a b. (Eq (F a), D a b) => F a -> a -> [b] -> Int +[GblId, + Arity=2, + Str=<B><B>b, + Cpr=b, + Unf=Unf{Src=StableSystem, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=True) + Tmpl= \ (@a) (@b) _ [Occ=Dead] _ [Occ=Dead] -> + GHC.Internal.Control.Exception.Base.noMethodBindingError + @GHC.Internal.Types.LiftedRep + @(F a -> a -> [b] -> Int) + T26117.$fCaList1}] +T26117.$fCaList_$cop2 + = \ (@a) (@b) _ [Occ=Dead] _ [Occ=Dead] -> + GHC.Internal.Control.Exception.Base.noMethodBindingError + @GHC.Internal.Types.LiftedRep + @(F a -> a -> [b] -> Int) + T26117.$fCaList1 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T26117.$fCaList3 :: Int +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$fCaList3 = GHC.Internal.Types.I# 4# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T26117.$fCaList2 :: Int +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$fCaList2 = GHC.Internal.Types.I# 3# + +-- RHS size: {terms: 8, types: 7, coercions: 2, joins: 0/0} +lvl :: forall b. F Int -> Int -> [b] -> Int +[GblId, Arity=3, Str=<1A><A><A>, Cpr=1, Unf=OtherCon []] +lvl + = \ (@b) (x :: F Int) _ [Occ=Dead] _ [Occ=Dead] -> + case x `cast` (Sub T26117.D:R:FInt :: F Int ~R# Bool) of lwild + { __DEFAULT -> + T26117.$fCaList2 + } + +-- RHS size: {terms: 3, types: 8, coercions: 0, joins: 0/0} +lvl1 :: forall b. F Int -> Int -> [b] -> Int +[GblId, Str=b, Cpr=b] +lvl1 + = \ (@b) -> + GHC.Internal.Control.Exception.Base.noMethodBindingError + @GHC.Internal.Types.LiftedRep + @(F Int -> Int -> [b] -> Int) + T26117.$fCaList1 + +-- RHS size: {terms: 4, types: 6, coercions: 0, joins: 0/0} +lvl2 :: forall b. C Int [b] +[GblId, Unf=OtherCon []] +lvl2 = \ (@b) -> T26117.C:C @Int @[b] (lvl @b) (lvl1 @b) + +-- RHS size: {terms: 3, types: 5, coercions: 0, joins: 0/0} +T26117.$fCaList_$s$fCaList [InlPrag=CONLIKE] + :: forall b. D Int b => C Int [b] +[GblId[DFunId], + Arity=1, + Str=<A>, + Unf=DFun: \ (@b) ($dD :: D Int b) -> + T26117.C:C TYPE: Int + TYPE: [b] + \ (x :: F Int) _ [Occ=Dead] _ [Occ=Dead] -> + case GHC.Internal.Prim.dataToTagSmall# + @GHC.Internal.Types.Lifted + @Bool + (x `cast` (Sub T26117.D:R:FInt :: F Int ~R# Bool)) + of a# [Occ=Once1] + { __DEFAULT -> + case GHC.Internal.Prim.dataToTagSmall# + @GHC.Internal.Types.Lifted + @Bool + (x `cast` (Sub T26117.D:R:FInt :: F Int ~R# Bool)) + of b# [Occ=Once1] + { __DEFAULT -> + case GHC.Internal.Prim.==# a# b# of { + __DEFAULT -> GHC.Internal.Types.I# 4#; + 1# -> GHC.Internal.Types.I# 3# + } + } + } + GHC.Internal.Control.Exception.Base.noMethodBindingError + @GHC.Internal.Types.LiftedRep + @(F Int -> Int -> [b] -> Int) + "T26117.hs:17:10-37|\CANop2\EM"#] +T26117.$fCaList_$s$fCaList = \ (@b) _ [Occ=Dead] -> lvl2 @b + +-- RHS size: {terms: 4, types: 9, coercions: 0, joins: 0/0} +lvl3 :: forall b a. F a -> a -> [b] -> Int +[GblId, Str=b, Cpr=b] +lvl3 + = \ (@b) (@a) -> + GHC.Internal.Control.Exception.Base.noMethodBindingError + @GHC.Internal.Types.LiftedRep + @(F a -> a -> [b] -> Int) + T26117.$fCaList1 + +-- RHS size: {terms: 18, types: 21, coercions: 0, joins: 0/0} +T26117.$fCaList [InlPrag=CONLIKE] + :: forall a b. (Eq (F a), D a b) => C a [b] +[GblId[DFunId], + Arity=2, + Str=<LP(SC(S,C(1,L)),A)><A>, + Unf=DFun: \ (@a) (@b) (v :: Eq (F a)) (v1 :: D a b) -> + T26117.C:C TYPE: a + TYPE: [b] + \ (x :: F a) _ [Occ=Dead] _ [Occ=Dead] -> + case == @(F a) v x x of { + False -> T26117.$fCaList3; + True -> T26117.$fCaList2 + } + T26117.$fCaList_$cop2 @a @b v v1] +T26117.$fCaList + = \ (@a) (@b) ($dEq :: Eq (F a)) _ [Occ=Dead] -> + T26117.C:C + @a + @[b] + (\ (x :: F a) _ [Occ=Dead] _ [Occ=Dead] -> + case == @(F a) $dEq x x of { + False -> T26117.$fCaList3; + True -> T26117.$fCaList2 + }) + (lvl3 @b @a) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T26117.$trModule4 :: GHC.Internal.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 20 0}] +T26117.$trModule4 = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T26117.$trModule3 :: GHC.Internal.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$trModule3 = GHC.Internal.Types.TrNameS T26117.$trModule4 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T26117.$trModule2 :: GHC.Internal.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 30 0}] +T26117.$trModule2 = "T26117"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T26117.$trModule1 :: GHC.Internal.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$trModule1 = GHC.Internal.Types.TrNameS T26117.$trModule2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T26117.$trModule :: GHC.Internal.Types.Module +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$trModule + = GHC.Internal.Types.Module T26117.$trModule3 T26117.$trModule1 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +$krep + = GHC.Internal.Types.KindRepFun + GHC.Internal.Types.krep$* GHC.Internal.Types.krep$Constraint + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T26117.$tcC1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +T26117.$tcC1 + = GHC.Internal.Types.KindRepFun GHC.Internal.Types.krep$* $krep + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$krep1 :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +$krep1 = GHC.Internal.Types.KindRepVar 1# + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep2 :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +$krep2 = GHC.Internal.Types.KindRepFun $krep1 $krep1 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$krep3 :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +$krep3 = GHC.Internal.Types.KindRepVar 0# + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep4 :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +$krep4 = GHC.Internal.Types.KindRepFun $krep3 $krep2 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T26117.$tcD2 :: GHC.Internal.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 20 0}] +T26117.$tcD2 = "D"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T26117.$tcD1 :: GHC.Internal.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$tcD1 = GHC.Internal.Types.TrNameS T26117.$tcD2 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T26117.$tcD :: GHC.Internal.Types.TyCon +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$tcD + = GHC.Internal.Types.TyCon + 18427868686024955676#Word64 + 4087453451394481638#Word64 + T26117.$trModule + T26117.$tcD1 + 0# + T26117.$tcC1 + +-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} +$krep5 :: [GHC.Internal.Types.KindRep] +[GblId, Unf=OtherCon []] +$krep5 + = GHC.Internal.Types.: + @GHC.Internal.Types.KindRep + $krep1 + (GHC.Internal.Types.[] @GHC.Internal.Types.KindRep) + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep6 :: [GHC.Internal.Types.KindRep] +[GblId, Unf=OtherCon []] +$krep6 + = GHC.Internal.Types.: @GHC.Internal.Types.KindRep $krep3 $krep5 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep7 :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +$krep7 = GHC.Internal.Types.KindRepTyConApp T26117.$tcD $krep6 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep8 :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +$krep8 = GHC.Internal.Types.KindRepFun $krep4 $krep7 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T26117.$tc'C:D1 [InlPrag=[~]] :: GHC.Internal.Types.KindRep +[GblId, Unf=OtherCon []] +T26117.$tc'C:D1 = GHC.Internal.Types.KindRepFun $krep4 $krep8 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T26117.$tc'C:D3 :: GHC.Internal.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 20 0}] +T26117.$tc'C:D3 = "'C:D"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T26117.$tc'C:D2 :: GHC.Internal.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$tc'C:D2 = GHC.Internal.Types.TrNameS T26117.$tc'C:D3 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T26117.$tc'C:D :: GHC.Internal.Types.TyCon +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$tc'C:D + = GHC.Internal.Types.TyCon + 14714477993590114477#Word64 + 17388374250742016296#Word64 + T26117.$trModule + T26117.$tc'C:D2 + 2# + T26117.$tc'C:D1 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +T26117.$tcC3 :: GHC.Internal.Prim.Addr# +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 20 0}] +T26117.$tcC3 = "C"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T26117.$tcC2 :: GHC.Internal.Types.TrName +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$tcC2 = GHC.Internal.Types.TrNameS T26117.$tcC3 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T26117.$tcC :: GHC.Internal.Types.TyCon +[GblId, + Unf=Unf{Src=<vanilla>, TopLvl=True, + Value=True, ConLike=True, WorkFree=True, Expandable=True, + Guidance=IF_ARGS [] 10 10}] +T26117.$tcC + = GHC.Internal.Types.TyCon + 6116531860557468422#Word64 + 17953227584944457497#Word64 + T26117.$trModule + T26117.$tcC2 + 0# + T26117.$tcC1 + + +------ Local rules for imported ids -------- +"USPEC $fCaList @Int @_" + forall (@b) ($dD :: D Int b) ($dEq :: Eq (F Int)). + T26117.$fCaList @Int @b $dEq $dD + = T26117.$fCaList_$s$fCaList @b $dD + + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8241b8a27c5682347d3923453996a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c8241b8a27c5682347d3923453996a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/fendor/backtraces-decoders
by Hannes Siebenhandl (＠fendor) 17 Jul '25

17 Jul '25

Hannes Siebenhandl pushed new branch wip/fendor/backtraces-decoders at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fendor/backtraces-decoders You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/andreask/llvm-check
by Andreas Klebinger (＠AndreasK) 17 Jul '25

17 Jul '25

Andreas Klebinger pushed new branch wip/andreask/llvm-check at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/andreask/llvm-check You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/ann-frame] 3 commits: WIP: Introduce stack frame annotation helpers and extend ghc-heap stack decoder
by Hannes Siebenhandl (＠fendor) 17 Jul '25

17 Jul '25

Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC Commits: d4002865 by fendor at 2025-07-17T15:24:57+02:00 WIP: Introduce stack frame annotation helpers and extend ghc-heap stack decoder - - - - - bf1f28d0 by fendor at 2025-07-17T15:25:01+02:00 WIP: base: extend Backtraces to allow configuration of stack decoders - - - - - 7235ceab by fendor at 2025-07-17T15:25:02+02:00 WIP: move iterator based stack decoder to ghc-internal - - - - - 25 changed files: - libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs - libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc - libraries/ghc-heap/GHC/Exts/Stack/Decode.hs - libraries/ghc-heap/cbits/Stack.cmm - libraries/ghc-heap/tests/stack-annotation/all.T - libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout - + libraries/ghc-heap/tests/stack-annotation/ann_frame003.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 ===================================== @@ -3,65 +3,93 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ImplicitParams #-} -module GHC.Stack.Annotation.Experimental where +module GHC.Stack.Annotation.Experimental ( + IsStackAnnotation(..), + SomeStackAnnotation(..), + -- * Source Location annotations + SrcLocAnnotation, + UnknownSrcLocAnnotation, + -- * Stack annotations + annotateStack, + annotateShow, + annotateCallStack, + annotateStackM, + annotateStringM, + annotateStackShowM, + annotateCallStackM, + ) where import Data.Typeable import GHC.Exts import GHC.IO -import GHC.Internal.Stack.Types +import GHC.Internal.Stack +import GHC.Internal.Stack.Annotation -data StackAnnotation where - StackAnnotation :: forall a. (Typeable a, Show a) => a -> StackAnnotation +data StringAnnotation where + StringAnnotation :: String -> StringAnnotation -class IsStackAnnotation a where - display :: a -> String +instance IsStackAnnotation StringAnnotation where + displayStackAnnotation (StringAnnotation str) = str -instance IsStackAnnotation StackAnnotation where - display (StackAnnotation a) = show a +-- ---------------------------------------------------------------------------- +-- Source location annotations +-- ---------------------------------------------------------------------------- -newtype SrcLocAnno = MkSrcLocAnno SrcLoc +newtype SrcLocAnnotation = SrcLocAnnotation SrcLoc -data UnknownSrcLocAnno = UnknownSrcLocAnno +data UnknownSrcLocAnnotation = UnknownSrcLocAnnotation deriving Show -instance Show SrcLocAnno where - show (MkSrcLocAnno l) = - concat - [ srcLocPackage l - , ":" - , srcLocModule l - , " " - , srcLocFile l - , ":" - , show $ srcLocStartLine l - , "-" - , show $ srcLocStartCol l - , ":" - , show $ srcLocEndLine l - , "-" - , show $ srcLocEndCol l - ] - -instance IsStackAnnotation SrcLocAnno where - display = show - -instance IsStackAnnotation UnknownSrcLocAnno where - display UnknownSrcLocAnno = "UnknownSrcLocAnno" +instance Show SrcLocAnnotation where + show (SrcLocAnnotation l) = prettySrcLoc l + +instance IsStackAnnotation SrcLocAnnotation where + displayStackAnnotation = show + +instance IsStackAnnotation UnknownSrcLocAnnotation where + displayStackAnnotation UnknownSrcLocAnnotation = "<no location info>" + +-- ---------------------------------------------------------------------------- +-- Annotate the CallStack! +-- ---------------------------------------------------------------------------- {-# NOINLINE annotateStack #-} -annotateStack :: forall a b. (Typeable a, Show a) => a -> b -> b +-- TODO @fendor: it seems the pure interface doesnt work, +-- investigate more and then decide what to do +annotateStack :: forall a b. (Typeable a, IsStackAnnotation a) => a -> b -> b annotateStack ann b = unsafePerformIO $ annotateStackM ann (pure b) -annotateStackM :: forall a b . (Typeable a, Show a) => a -> IO b -> IO b +{-# NOINLINE annotateCallStack #-} +-- TODO @fendor: it seems the pure interface doesnt work, +-- investigate more and then decide what to do +annotateCallStack :: HasCallStack => b -> b +annotateCallStack b = unsafePerformIO $ + annotateCallStackM (pure b) + +-- TODO @fendor: it seems the pure interface doesnt work, +-- investigate more and then decide what to do +annotateShow :: forall a b . (Typeable a, Show a) => a -> b -> b +annotateShow ann = + annotateStack (StringAnnotation $ show ann) + +annotateStackM :: forall a b . (Typeable a, IsStackAnnotation a) => a -> IO b -> IO b annotateStackM ann (IO act) = - IO $ \s -> annotateStack# (StackAnnotation ann) act s + IO $ \s -> annotateStack# (SomeStackAnnotation ann) act s + +annotateStringM :: forall b . String -> IO b -> IO b +annotateStringM ann = + annotateStackM (StringAnnotation ann) + +annotateStackShowM :: forall a b . (Typeable a, Show a) => a -> IO b -> IO b +annotateStackShowM ann = + annotateStringM (show ann) annotateCallStackM :: HasCallStack => IO a -> IO a annotateCallStackM act = let cs = getCallStack ?callStack in case cs of - [] -> annotateStackM UnknownSrcLocAnno act - [(_, srcLoc)] -> annotateStackM (MkSrcLocAnno srcLoc) act - (_:(_, srcLoc):_) -> annotateStackM (MkSrcLocAnno srcLoc) act + [] -> annotateStackM UnknownSrcLocAnnotation act + [(_, srcLoc)] -> annotateStackM (SrcLocAnnotation srcLoc) act + (_:(_, srcLoc):_) -> annotateStackM (SrcLocAnnotation srcLoc) act ===================================== libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc ===================================== @@ -24,7 +24,7 @@ import Foreign -- | 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 +-- 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 ===================================== libraries/ghc-heap/GHC/Exts/Stack/Decode.hs ===================================== @@ -15,6 +15,7 @@ module GHC.Exts.Stack.Decode ( decodeStack, + decodeStackWithIpe, ) where @@ -23,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 (..), @@ -36,6 +37,7 @@ import GHC.Exts.Heap.Closures import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS) import GHC.Exts.Heap.InfoTable import GHC.Exts.Stack.Constants +import qualified GHC.Internal.InfoProv.Types as IPE import GHC.Stack.CloneStack import GHC.Word import Prelude @@ -150,14 +152,17 @@ foreign import prim "getSmallBitmapzh" getSmallBitmap# :: SmallBitmapGetter foreign import prim "getRetFunSmallBitmapzh" getRetFunSmallBitmap# :: SmallBitmapGetter -foreign import prim "getInfoTableAddrzh" getInfoTableAddr# :: StackSnapshot# -> Word# -> Addr# +foreign import prim "getInfoTableAddrszh" getInfoTableAddrs# :: StackSnapshot# -> Word# -> (# Addr#, Addr# #) foreign import prim "getStackInfoTableAddrzh" getStackInfoTableAddr# :: StackSnapshot# -> Addr# -getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO StgInfoTable +-- | Get the 'StgInfoTable' of the stack frame. +-- Additionally, provides 'IPE.InfoProv' for the 'StgInfoTable' if there is any. +getInfoTableOnStack :: StackSnapshot# -> WordOffset -> IO (StgInfoTable, Maybe IPE.InfoProv) getInfoTableOnStack stackSnapshot# index = - let infoTablePtr = Ptr (getInfoTableAddr# stackSnapshot# (wordOffsetToWord# index)) - in peekItbl infoTablePtr + let !(# itbl_struct#, itbl_ptr# #) = getInfoTableAddrs# stackSnapshot# (wordOffsetToWord# index) + in + (,) <$> peekItbl (Ptr itbl_struct#) <*> IPE.lookupIPE (Ptr itbl_ptr#) getInfoTableForStack :: StackSnapshot# -> IO StgInfoTable getInfoTableForStack stackSnapshot# = @@ -276,18 +281,49 @@ decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset = (bitmapWordPointerness size bitmap) unpackStackFrame :: StackFrameLocation -> IO StackFrame -unpackStackFrame (StackSnapshot stackSnapshot#, index) = do - info <- getInfoTableOnStack stackSnapshot# index +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 IPE.InfoProv)] +unpackStackFrameWithIpe stackFrameLoc = do + unpackStackFrameTo stackFrameLoc + (\ _ nextChunk -> do + decodeStackWithIpe nextChunk + ) + (\ frame mIpe -> pure [(frame, mIpe)]) + +unpackStackFrameTo :: + StackFrameLocation -> + (StgInfoTable -> StackSnapshot -> IO a) -> + (StackFrame -> Maybe IPE.InfoProv -> IO a) -> + IO a +unpackStackFrameTo (StackSnapshot stackSnapshot#, index) unpackUnderflowFrame finaliseStackFrame = do + (info, m_info_prov) <- getInfoTableOnStack stackSnapshot# index unpackStackFrame' info + unpackUnderflowFrame + (`finaliseStackFrame` m_info_prov) where - unpackStackFrame' :: StgInfoTable -> IO StackFrame - unpackStackFrame' info = + unpackStackFrame' :: + StgInfoTable -> + (StgInfoTable -> StackSnapshot -> IO a) -> + (StackFrame -> IO a) -> + IO a + unpackStackFrame' info unpackUnderflowFrame 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) - pure + mkStackFrameResult RetBCO { info_tbl = info, bco = bco', @@ -296,14 +332,14 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do RET_SMALL -> let payload' = decodeSmallBitmap getSmallBitmap# stackSnapshot# index offsetStgClosurePayload in - pure $ + mkStackFrameResult $ RetSmall { info_tbl = info, stack_payload = payload' } RET_BIG -> do payload' <- decodeLargeBitmap getLargeBitmap# stackSnapshot# index offsetStgClosurePayload - pure $ + mkStackFrameResult $ RetBig { info_tbl = info, stack_payload = payload' @@ -315,7 +351,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do if isArgGenBigRetFunType stackSnapshot# index == True then decodeLargeBitmap getRetFunLargeBitmap# stackSnapshot# index offsetStgRetFunFramePayload else pure $ decodeSmallBitmap getRetFunSmallBitmap# stackSnapshot# index offsetStgRetFunFramePayload - pure $ + mkStackFrameResult $ RetFun { info_tbl = info, retFunSize = retFunSize', @@ -325,31 +361,26 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do UPDATE_FRAME -> let updatee' = getClosureBox stackSnapshot# (index + offsetStgUpdateFrameUpdatee) in - pure $ + mkStackFrameResult $ UpdateFrame { info_tbl = info, updatee = updatee' } CATCH_FRAME -> do let handler' = getClosureBox stackSnapshot# (index + offsetStgCatchFrameHandler) - pure $ + mkStackFrameResult $ CatchFrame { info_tbl = info, handler = handler' } UNDERFLOW_FRAME -> do let nextChunk' = getUnderflowFrameNextChunk stackSnapshot# index - stackClosure <- decodeStack nextChunk' - pure $ - UnderflowFrame - { info_tbl = info, - nextChunk = stackClosure - } - STOP_FRAME -> pure $ StopFrame {info_tbl = info} + unpackUnderflowFrame info nextChunk' + STOP_FRAME -> mkStackFrameResult $ StopFrame {info_tbl = info} ATOMICALLY_FRAME -> do let atomicallyFrameCode' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameCode) result' = getClosureBox stackSnapshot# (index + offsetStgAtomicallyFrameResult) - pure $ + mkStackFrameResult $ AtomicallyFrame { info_tbl = info, atomicallyFrameCode = atomicallyFrameCode', @@ -360,7 +391,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do first_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameRunningFirstCode) alt_code' = getClosureBox stackSnapshot# (index + offsetStgCatchRetryFrameAltCode) in - pure $ + mkStackFrameResult $ CatchRetryFrame { info_tbl = info, running_alt_code = running_alt_code', @@ -371,7 +402,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do let catchFrameCode' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameCode) handler' = getClosureBox stackSnapshot# (index + offsetStgCatchSTMFrameHandler) in - pure $ + mkStackFrameResult $ CatchStmFrame { info_tbl = info, catchFrameCode = catchFrameCode', @@ -380,7 +411,7 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do ANN_FRAME -> let annotation = getClosureBox stackSnapshot# (index + offsetStgAnnFrameAnn) in - pure $ + mkStackFrameResult $ AnnFrame { info_tbl = info, annotation = annotation @@ -410,19 +441,27 @@ type StackFrameLocation = (StackSnapshot, WordOffset) -- -- See /Note [Decoding the stack]/. decodeStack :: StackSnapshot -> IO StgStackClosure -decodeStack (StackSnapshot stack#) = do +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 IPE.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 stack_size' = getStackFields stack# - sfls = stackFrameLocations stack# - stack' <- mapM unpackStackFrame sfls - pure $ - GenStgStackClosure - { ssc_info = info, - ssc_stack_size = stack_size', - ssc_stack = stack' - } + let sfls = stackFrameLocations stack# + stack' <- mapM unpackFrame sfls + pure (info, stack') _ -> error $ "Expected STACK closure, got " ++ show info where stackFrameLocations :: StackSnapshot# -> [StackFrameLocation] ===================================== libraries/ghc-heap/cbits/Stack.cmm ===================================== @@ -146,14 +146,14 @@ isArgGenBigRetFunTypezh(P_ stack, W_ offsetWords) { return (type); } -// (StgInfoTable*) getInfoTableAddrzh(StgStack* stack, StgWord offsetWords) -getInfoTableAddrzh(P_ stack, W_ offsetWords) { - P_ p, info; +// (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 = %GET_STD_INFO(UNTAG(p)); - - return (info); + info_struct = %GET_STD_INFO(UNTAG(p)); + info_ptr = %INFO_PTR(UNTAG(p)); + return (info_struct, info_ptr); } // (StgInfoTable*) getStackInfoTableAddrzh(StgStack* stack) ===================================== libraries/ghc-heap/tests/stack-annotation/all.T ===================================== @@ -1,2 +1,4 @@ test('ann_frame001', normal, compile_and_run, ['']) test('ann_frame002', normal, compile_and_run, ['']) +test('ann_frame003', normal, compile_and_run, ['']) +test('ann_frame004', normal, compile_and_run, ['']) ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs ===================================== @@ -7,7 +7,7 @@ import System.IO.Unsafe import Unsafe.Coerce hello :: Int -> Int -> Int -hello x y = annotateStack (x,y) $ +hello x y = annotateShow (x,y) $ decodeAndPrintAnnotationFrames $! x + y + 42 {-# OPAQUE hello #-} @@ -17,9 +17,9 @@ decodeAndPrintAnnotationFrames :: a -> a decodeAndPrintAnnotationFrames a = unsafePerformIO $ do stack <- GHC.Stack.CloneStack.cloneMyStack decoded <- GHC.Exts.Stack.Decode.decodeStack stack - print [ show a + print [ displayStackAnnotation a | Closures.AnnFrame _ (Box ann) <- Closures.ssc_stack decoded - , StackAnnotation a <- pure $ unsafeCoerce ann + , SomeStackAnnotation a <- pure $ unsafeCoerce ann ] pure a @@ -30,13 +30,13 @@ main = do {-# INLINE tailCallEx #-} tailCallEx :: Int -> Int -> Int -tailCallEx a b = annotateStack "tailCallEx" $ foo a b +tailCallEx a b = annotateShow "tailCallEx" $ foo a b {-# INLINE foo #-} foo :: Int -> Int -> Int -foo a b = annotateStack "foo" $ bar $ a * b +foo a b = annotateShow "foo" $ bar $ a * b -bar c = annotateStack "bar" $ +bar c = annotateShow "bar" $ decodeAndPrintAnnotationFrames $ c + c ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame002.hs ===================================== @@ -12,17 +12,7 @@ import qualified GHC.Internal.Stack.CloneStack as CloneStack import System.IO.Unsafe import Unsafe.Coerce - -{-# NOINLINE decodeAnnotationFrames #-} -decodeAnnotationFrames :: IO [String] -decodeAnnotationFrames = do - stack <- CloneStack.cloneMyStack - decoded <- Decode.decodeStack stack - pure - [ show a - | AnnFrame _ (Box ann) <- ssc_stack decoded - , StackAnnotation a <- [unsafeCoerce ann] - ] +import GHC.Exts.Heap.Closures (GenStgStackClosure) {-# NOINLINE printAnnotationStack #-} printAnnotationStack :: [String] -> IO () @@ -47,8 +37,8 @@ baz = annotateCallStackM $ do decodeAnnotationFrames >>= printAnnotationStack bar :: IO () -bar = annotateCallStackM $ annotateStackM "bar" $ do - putStrLn "Some more ork in bar" +bar = annotateCallStackM $ annotateStringM "bar" $ do + putStrLn "Some more work in bar" print (fib 21) decodeAnnotationFrames >>= printAnnotationStack @@ -56,3 +46,23 @@ fib :: Int -> Int fib n | n <= 1 = 1 | otherwise = fib (n - 1) + fib (n - 2) + +{-# NOINLINE decodeAnnotationFrames #-} +decodeAnnotationFrames :: IO [String] +decodeAnnotationFrames = do + stack <- CloneStack.cloneMyStack + decoded <- Decode.decodeStack stack + pure $ unwindStack decoded + +unwindStack :: GenStgStackClosure Box -> [String] +unwindStack stack_closure = + [ ann + | a <- ssc_stack stack_closure + , ann <- case a of + AnnFrame _ (Box ann) -> + [ displayStackAnnotation a + | SomeStackAnnotation a <- [unsafeCoerce ann] + ] + UnderflowFrame _ underflow_stack_closure -> unwindStack underflow_stack_closure + _ -> [] + ] ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame002.stdout ===================================== @@ -1,11 +1,11 @@ Start some work 10946 Annotation stack: -main:Main ann_frame002.hs:35-7:35-10 -main:Main ann_frame002.hs:35-3:35-6 +ann_frame002.hs:25:7 in main:Main +ann_frame002.hs:25:3 in main:Main Finish some work Some more ork in bar 17711 Annotation stack: -"bar" -main:Main ann_frame002.hs:50-7:50-25 +bar +ann_frame002.hs:40:7 in main:Main ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame003.hs ===================================== @@ -0,0 +1,28 @@ + +import GHC.Stack.Annotation.Experimental +import Control.Exception.Backtrace + +hello :: Int -> Int -> Int +hello x y = annotateShow (x,y) $ + x + y + 42 +{-# OPAQUE hello #-} + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + print $ hello 2 3 + print $ tailCallEx 4 5 + +{-# INLINE tailCallEx #-} +tailCallEx :: Int -> Int -> Int +tailCallEx a b = annotateShow "tailCallEx" $ + foo a b + +{-# INLINE foo #-} +foo :: Int -> Int -> Int +foo a b = annotateShow "foo" $ + bar $ a * b + +bar c = annotateShow "bar" $ + error $ show $ c + c + ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs ===================================== @@ -0,0 +1,36 @@ + +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -ddump-to-file -ddump-stg-final -ddump-simpl -dsuppress-all #-} +import Control.Monad +import GHC.Stack.Types +import Control.Exception +import Control.Exception.Backtrace +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" + print (annotateCallStack $ fib 21) + +fib :: Int -> Int +fib n + | n <= 1 = 1 + | n >= 21 = throw $ ErrorCall "This fib implementation supports only up to the 21st fibonacci number" + | otherwise = fib (n - 1) + fib (n - 2) ===================================== 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 qualified GHC.Internal.Stack as HCS import qualified GHC.Internal.ExecutionStack as ExecStack 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. @@ -37,6 +40,14 @@ data EnabledBacktraceMechanisms = , ipeBacktraceEnabled :: !Bool } +data DisplayBacktraceMechanisms = + DisplayBacktraceMechanisms + { displayCostCentreBacktrace :: Ptr CCS.CostCentreStack -> String + , displayHasCallStackBacktrace :: HCS.CallStack -> String + , displayExecutionBacktrace :: [ExecStack.Location] -> String + , displayIpeBacktrace :: CloneStack.StackSnapshot -> String + } + defaultEnabledBacktraceMechanisms :: EnabledBacktraceMechanisms defaultEnabledBacktraceMechanisms = EnabledBacktraceMechanisms { costCentreBacktraceEnabled = False @@ -45,6 +56,19 @@ defaultEnabledBacktraceMechanisms = EnabledBacktraceMechanisms , ipeBacktraceEnabled = False } +defaultDisplayBacktraceMechanisms :: DisplayBacktraceMechanisms +defaultDisplayBacktraceMechanisms = DisplayBacktraceMechanisms + { displayCostCentreBacktrace = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings + , displayHasCallStackBacktrace = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack + , displayExecutionBacktrace = unlines . map (indent 2 . flip ExecStack.showLocation "") + , displayIpeBacktrace = unlines . mapMaybe (fmap (indent 2) . Decode.prettyStackFrameWithIpe) . unsafePerformIO . Decode.decodeStackWithIpe + } + where + indent :: Int -> String -> String + indent n s = replicate n ' ' ++ s + + prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc + backtraceMechanismEnabled :: BacktraceMechanism -> EnabledBacktraceMechanisms -> Bool backtraceMechanismEnabled bm = case bm of @@ -69,6 +93,11 @@ enabledBacktraceMechanismsRef = unsafePerformIO $ newIORef defaultEnabledBacktraceMechanisms {-# NOINLINE enabledBacktraceMechanismsRef #-} +displayBacktraceMechanismsRef :: IORef DisplayBacktraceMechanisms +displayBacktraceMechanismsRef = + unsafePerformIO $ newIORef defaultDisplayBacktraceMechanisms +{-# NOINLINE displayBacktraceMechanismsRef #-} + -- | Returns the currently enabled 'BacktraceMechanism's. getEnabledBacktraceMechanisms :: IO EnabledBacktraceMechanisms getEnabledBacktraceMechanisms = readIORef enabledBacktraceMechanismsRef @@ -86,37 +115,41 @@ setBacktraceMechanismState bm enabled = do _ <- atomicModifyIORef'_ enabledBacktraceMechanismsRef (setBacktraceMechanismEnabled bm enabled) return () +-- TODO @fendor +getDisplayBacktraceMechanisms :: IO DisplayBacktraceMechanisms +getDisplayBacktraceMechanisms = readIORef displayBacktraceMechanismsRef + +-- TODO @fendor: +setDisplayBacktraceMechanismsState :: DisplayBacktraceMechanisms -> IO () +setDisplayBacktraceMechanismsState dbm = do + _ <- atomicModifyIORef'_ displayBacktraceMechanismsRef (const dbm) + return () + -- | A collection of backtraces. data Backtraces = Backtraces { btrCostCentre :: Maybe (Ptr CCS.CostCentreStack), + btrDisplayCostCentre :: Ptr CCS.CostCentreStack -> String, btrHasCallStack :: Maybe HCS.CallStack, + btrDisplayHasCallStack :: HCS.CallStack -> String, btrExecutionStack :: Maybe [ExecStack.Location], - btrIpe :: Maybe [CloneStack.StackEntry] + btrDisplayExecutionStack :: [ExecStack.Location] -> String, + btrIpe :: Maybe CloneStack.StackSnapshot, + btrDisplayIpe :: CloneStack.StackSnapshot -> String } -- | Render a set of backtraces to a human-readable string. displayBacktraces :: Backtraces -> String displayBacktraces bts = concat - [ displayOne "Cost-centre stack backtrace" btrCostCentre displayCc - , displayOne "Native stack backtrace" btrExecutionStack displayExec - , displayOne "IPE backtrace" btrIpe displayIpe - , displayOne "HasCallStack backtrace" btrHasCallStack displayHsc + [ displayOne "Cost-centre stack backtrace" btrCostCentre btrDisplayCostCentre + , displayOne "Native stack backtrace" btrExecutionStack btrDisplayExecutionStack + , displayOne "IPE backtrace" btrIpe btrDisplayIpe + , displayOne "HasCallStack backtrace" btrHasCallStack btrDisplayHasCallStack ] where - indent :: Int -> String -> String - indent n s = replicate n ' ' ++ s - - -- The unsafePerformIO here is safe as we don't currently unload cost-centres. - displayCc = unlines . map (indent 2) . unsafePerformIO . CCS.ccsToStrings - displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") - displayIpe = unlines . map (indent 2 . CloneStack.prettyStackEntry) - displayHsc = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack - where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc - - displayOne :: String -> (Backtraces -> Maybe rep) -> (rep -> String) -> String + displayOne :: String -> (Backtraces -> Maybe rep) -> (Backtraces -> rep -> String) -> String displayOne label getBt displ - | Just bt <- getBt bts = concat [label, ":\n", displ bt] + | Just bt <- getBt bts = concat [label, ":\n", displ bts bt] | otherwise = "" instance ExceptionAnnotation Backtraces where @@ -125,12 +158,14 @@ instance ExceptionAnnotation Backtraces where -- | Collect a set of 'Backtraces'. collectBacktraces :: (?callStack :: CallStack) => IO Backtraces collectBacktraces = HCS.withFrozenCallStack $ do - getEnabledBacktraceMechanisms >>= collectBacktraces' + bm <- getEnabledBacktraceMechanisms + dpm <- getDisplayBacktraceMechanisms + collectBacktraces' bm dpm collectBacktraces' :: (?callStack :: CallStack) - => EnabledBacktraceMechanisms -> IO Backtraces -collectBacktraces' enabled = HCS.withFrozenCallStack $ do + => EnabledBacktraceMechanisms -> DisplayBacktraceMechanisms -> IO Backtraces +collectBacktraces' enabled renderers = HCS.withFrozenCallStack $ do let collect :: BacktraceMechanism -> IO (Maybe a) -> IO (Maybe a) collect mech f | backtraceMechanismEnabled mech enabled = f @@ -144,14 +179,17 @@ collectBacktraces' enabled = HCS.withFrozenCallStack $ do ipe <- collect IPEBacktrace $ do stack <- CloneStack.cloneMyStack - stackEntries <- CloneStack.decode stack - return (Just stackEntries) + return (Just stack) hcs <- collect HasCallStackBacktrace $ do return (Just ?callStack) return (Backtraces { btrCostCentre = ccs + , btrDisplayCostCentre = displayCostCentreBacktrace renderers , btrHasCallStack = hcs + , btrDisplayHasCallStack = displayHasCallStackBacktrace renderers , btrExecutionStack = exec + , btrDisplayExecutionStack = displayExecutionBacktrace renderers , btrIpe = ipe + , btrDisplayIpe = displayIpeBacktrace renderers }) ===================================== 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/Clos…> +-- +-- 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/Info…> +-- 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/-/compare/dda9f19838c09d3253c62351a49aae… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/dda9f19838c09d3253c62351a49aae… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/haanss/depdir] 6 commits: NCG/LA64: Support finer-grained DBAR hints
by Hassan Al-Awwadi (＠hassan.awwadi) 17 Jul '25

17 Jul '25

Hassan Al-Awwadi pushed to branch wip/haanss/depdir at Glasgow Haskell Compiler / GHC Commits: bbaa44a7 by Peng Fan at 2025-07-16T16:50:42-04:00 NCG/LA64: Support finer-grained DBAR hints For LA664 and newer uarchs, they have made finer granularity hints available: Bit4: ordering or completion (0: completion, 1: ordering) Bit3: barrier for previous read (0: true, 1: false) Bit2: barrier for previous write (0: true, 1: false) Bit1: barrier for succeeding read (0: true, 1: false) Bit0: barrier for succeeding write (0: true, 1: false) And not affect the existing models because other hints are treated as 'dbar 0' there. - - - - - 7da86e16 by Andreas Klebinger at 2025-07-16T16:51:25-04:00 Disable -fprof-late-overloaded-calls for join points. Currently GHC considers cost centres as destructive to join contexts. Or in other words this is not considered valid: join f x = ... in ... -> scc<tick> jmp This makes the functionality of `-fprof-late-overloaded-calls` not feasible for join points in general. We used to try to work around this by putting the ticks on the rhs of the join point rather than around the jump. However beyond the loss of accuracy this was broken for recursive join points as we ended up with something like: rec-join f x = scc<tick> ... jmp f x Which similarly is not valid as the tick once again destroys the tail call. One might think we could limit ourselves to non-recursive tail calls and do something clever like: join f x = scc<tick> ... in ... jmp f x And sometimes this works! But sometimes the full rhs would look something like: join g x = .... join f x = scc<tick> ... -> jmp g x Which, would again no longer be valid. I believe in the long run we can make cost centre ticks non-destructive to join points. Or we could keep track of where we are/are not allowed to insert a cost centre. But in the short term I will simply disable the annotation of join calls under this flag. - - - - - 7ee22fd5 by ARATA Mizuki at 2025-07-17T06:05:30-04:00 x86 NCG: Better lowering for shuffleFloatX4# and shuffleDoubleX2# The new implementation * make use of specialized instructions like (V)UNPCK{L,H}{PS,PD}, and * do not require -mavx. Close #26096 Co-authored-by: sheaf <sam.derbyshire(a)gmail.com> - - - - - c6cd2da1 by Jappie Klooster at 2025-07-17T06:06:20-04:00 Update interact docs to explain about buffering We need to tell the user to set to the appropriate buffer format. Otherwise, this function may get randomly stuck, or just behave confusingly. issue: https://gitlab.haskell.org/ghc/ghc/-/issues/26131 NB, I'm running this with cabal *NOT* ghci. ghci messes with buffering anyway. ```haskell interaction :: String -> String interaction "jappie" = "hi" interaction "jakob" = "hello" interaction x = "unkown input: " <> x main :: IO () main = interact interaction ``` so in my input (prefixed by `>`) I get: ``` > jappie unkown input: jappie ``` we confirmed later this was due to lack of \n matching. Anyway movnig on to more unexpected stuff: ```haskell main :: IO () main = do interact (concatMap interaction . lines) ``` get's stuck forever. actually `^D` (ctrl+d) unstucks it and runs all input as expected. for example you can get: ``` > sdfkds > fakdsf unkown input: sdfkdsunkown input: fakdsf ``` This program works! ```haskell interaction :: String -> String interaction "jappie" = "hi \n" interaction "jakob" = "hello \n" interaction x = "unkown input: " <> x <> "\n" main :: IO () main = do interact (concatMap interaction . lines) ``` the reason is that linebuffering is set for both in and output by default. so lines eats the input lines, and all the \n postfixes make sure the buffer is put out. - - - - - 9fa590a6 by Zubin Duggal at 2025-07-17T06:07:03-04:00 fetch_gitlab: Ensure we copy users_guide.pdf and Haddock.pdf to the release docs directory Fixes #24093 - - - - - 029703a1 by Hassan Al-Awwadi at 2025-07-17T15:05:12+02:00 Adds the fucnction addDependentDirectory to Q, resolving issue #26148. This function adds a new directory to the list of things a module depends upon. That means that when the contents of the directory change, the recompilation checker will notice this and the module will be recompiled. Documentation has also been added for addDependentFunction and addDependentDirectory in the user guide. - - - - - 42 changed files: - .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py - compiler/GHC/CmmToAsm/LA64/CodeGen.hs - compiler/GHC/CmmToAsm/LA64/Instr.hs - compiler/GHC/CmmToAsm/LA64/Ppr.hs - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - compiler/GHC/Core/LateCC/OverloadedCalls.hs - compiler/GHC/HsToCore/Usage.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Recomp/Types.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - compiler/GHC/Unit/Module/Deps.hs - docs/users_guide/9.14.1-notes.rst - docs/users_guide/profiling.rst - docs/users_guide/separate_compilation.rst - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/TH/Syntax.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/TH.hs - libraries/template-haskell/Language/Haskell/TH/Syntax.hs - testsuite/.gitignore - testsuite/tests/interface-stability/template-haskell-exports.stdout - testsuite/tests/simd/should_run/all.T - + testsuite/tests/simd/should_run/doublex2_shuffle.hs - + testsuite/tests/simd/should_run/doublex2_shuffle.stdout - + testsuite/tests/simd/should_run/doublex2_shuffle_baseline.hs - + testsuite/tests/simd/should_run/doublex2_shuffle_baseline.stdout - + testsuite/tests/simd/should_run/floatx4_shuffle.hs - + testsuite/tests/simd/should_run/floatx4_shuffle.stdout - + testsuite/tests/simd/should_run/floatx4_shuffle_baseline.hs - + testsuite/tests/simd/should_run/floatx4_shuffle_baseline.stdout - testsuite/tests/th/Makefile - + testsuite/tests/th/TH_Depends_Dir.hs - + testsuite/tests/th/TH_Depends_Dir.stdout - + testsuite/tests/th/TH_Depends_Dir_External.hs - testsuite/tests/th/all.T The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/519c8edebeebd4eca5aa36e5e732f5… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/519c8edebeebd4eca5aa36e5e732f5… You're receiving this email because of your account on gitlab.haskell.org.

1 0