July 2025 - ghc-commits

[Git][ghc/ghc][wip/fendor/backtraces-decoders] Allow users to customise the collection of exception annotations
by Hannes Siebenhandl (＠fendor) 21 Jul '25

21 Jul '25

Hannes Siebenhandl pushed to branch wip/fendor/backtraces-decoders at Glasgow Haskell Compiler / GHC Commits: 9ed4e1d4 by fendor at 2025-07-21T13:52:12+02:00 Allow users to customise the collection of exception annotations Add a global `CollectExceptionAnnotationMechanism` which determines how `ExceptionAnnotation`s are collected upon throwing an `Exception`. By overriding how we collect `Backtraces`, we can control how the `Backtraces` are displayed to the user by newtyping `Backtraces` and giving a different instance for `ExceptionAnnotation`. A concrete use-case for this feature is allowing us to experiment with alternative stack decoders, without having to modify `base`, which take additional information from the stack frames. This commit does not modify how `Backtraces` are currently collected or displayed. - - - - - 5 changed files: - libraries/base/src/Control/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Exception.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs - libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot - libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs Changes: ===================================== libraries/base/src/Control/Exception/Backtrace.hs ===================================== @@ -54,6 +54,11 @@ module Control.Exception.Backtrace , Backtraces(..) , displayBacktraces , collectBacktraces + -- * Collecting exception annotations (like backtraces) + , CollectExceptionAnnotationMechanism + , getCollectExceptionAnnotationMechanism + , setCollectExceptionAnnotation + , collectExceptionAnnotation ) where import GHC.Internal.Exception.Backtrace ===================================== libraries/ghc-internal/src/GHC/Internal/Exception.hs ===================================== @@ -70,7 +70,7 @@ import GHC.Internal.Show import GHC.Internal.Stack.Types import GHC.Internal.IO.Unsafe import {-# SOURCE #-} GHC.Internal.Stack (prettyCallStackLines, prettyCallStack, prettySrcLoc, withFrozenCallStack) -import {-# SOURCE #-} GHC.Internal.Exception.Backtrace (collectBacktraces) +import {-# SOURCE #-} GHC.Internal.Exception.Backtrace (collectExceptionAnnotation) import GHC.Internal.Exception.Type -- | Throw an exception. Exceptions may be thrown from purely @@ -166,8 +166,8 @@ toExceptionWithBacktrace :: (HasCallStack, Exception e) => e -> IO SomeException toExceptionWithBacktrace e | backtraceDesired e = do - bt <- collectBacktraces - return (addExceptionContext bt (toException e)) + ea <- collectExceptionAnnotation + return (addExceptionContext ea (toException e)) | otherwise = return (toException e) -- | This is thrown when the user calls 'error'. The @String@ is the ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs ===================================== @@ -12,7 +12,7 @@ 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 GHC.Internal.Stack.Types as GHC.Stack (CallStack, HasCallStack) import qualified GHC.Internal.Stack as HCS import qualified GHC.Internal.ExecutionStack.Internal as ExecStack import qualified GHC.Internal.Stack.CloneStack as CloneStack @@ -86,6 +86,40 @@ setBacktraceMechanismState bm enabled = do _ <- atomicModifyIORef'_ enabledBacktraceMechanismsRef (setBacktraceMechanismEnabled bm enabled) return () +-- | How to collect 'ExceptionAnnotation's on throwing 'Exception's. +-- +-- @since base-4.23.0.0 +data CollectExceptionAnnotationMechanism = CollectExceptionAnnotationMechanism + { ceaCollectExceptionAnnotationMechanism :: HasCallStack => IO SomeExceptionAnnotation + } + +defaultCollectExceptionAnnotationMechanism :: CollectExceptionAnnotationMechanism +defaultCollectExceptionAnnotationMechanism = CollectExceptionAnnotationMechanism + { ceaCollectExceptionAnnotationMechanism = SomeExceptionAnnotation `fmap` collectBacktraces + } + +collectExceptionAnnotationMechanismRef :: IORef CollectExceptionAnnotationMechanism +collectExceptionAnnotationMechanismRef = + unsafePerformIO $ newIORef defaultCollectExceptionAnnotationMechanism +{-# NOINLINE collectExceptionAnnotationMechanismRef #-} + +-- | Returns the current callback for collecting 'ExceptionAnnotation's on throwing 'Exception's. +-- +-- @since base-4.23.0.0 +getCollectExceptionAnnotationMechanism :: IO CollectExceptionAnnotationMechanism +getCollectExceptionAnnotationMechanism = readIORef collectExceptionAnnotationMechanismRef + +-- | Set the callback for collecting an 'ExceptionAnnotation'. +-- +-- @since base-4.23.0.0 +setCollectExceptionAnnotation :: ExceptionAnnotation a => (HasCallStack => IO a) -> IO () +setCollectExceptionAnnotation collector = do + let cea = CollectExceptionAnnotationMechanism + { ceaCollectExceptionAnnotationMechanism = fmap SomeExceptionAnnotation collector + } + _ <- atomicModifyIORef'_ collectExceptionAnnotationMechanismRef (const cea) + return () + -- | A collection of backtraces. data Backtraces = Backtraces { @@ -124,6 +158,15 @@ displayBacktraces bts = concat instance ExceptionAnnotation Backtraces where displayExceptionAnnotation = displayBacktraces +-- | Collect 'SomeExceptionAnnotation' based on the configuration of the +-- global 'CollectExceptionAnnotationMechanism'. +-- +-- @since base-4.23.0.0 +collectExceptionAnnotation :: HasCallStack => IO SomeExceptionAnnotation +collectExceptionAnnotation = HCS.withFrozenCallStack $ do + cea <- getCollectExceptionAnnotationMechanism + ceaCollectExceptionAnnotationMechanism cea + -- | Collect a set of 'Backtraces'. collectBacktraces :: (?callStack :: CallStack) => IO Backtraces collectBacktraces = HCS.withFrozenCallStack $ do ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Backtrace.hs-boot ===================================== @@ -5,11 +5,7 @@ module GHC.Internal.Exception.Backtrace where import GHC.Internal.Base (IO) import GHC.Internal.Stack.Types (HasCallStack) -import GHC.Internal.Exception.Context (ExceptionAnnotation) - -data Backtraces - -instance ExceptionAnnotation Backtraces +import GHC.Internal.Exception.Context (SomeExceptionAnnotation) -- For GHC.Exception -collectBacktraces :: HasCallStack => IO Backtraces +collectExceptionAnnotation :: HasCallStack => IO SomeExceptionAnnotation ===================================== libraries/ghc-internal/src/GHC/Internal/Exception/Context.hs ===================================== @@ -99,6 +99,9 @@ displayExceptionContext (ExceptionContext anns0) = mconcat $ intersperse "\n" $ data SomeExceptionAnnotation = forall a. ExceptionAnnotation a => SomeExceptionAnnotation a +instance ExceptionAnnotation SomeExceptionAnnotation where + displayExceptionAnnotation (SomeExceptionAnnotation ann) = displayExceptionAnnotation ann + -- | 'ExceptionAnnotation's are types which can decorate exceptions as -- 'ExceptionContext'. -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ed4e1d45c4801c5222155045f51e8a… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9ed4e1d45c4801c5222155045f51e8a… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26115] 3 commits: Solve forall-constraints immediately, or not at all
by Simon Peyton Jones (＠simonpj) 21 Jul '25

21 Jul '25

Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: c1f7d8ea by Simon Peyton Jones at 2025-07-21T12:07:01+01:00 Solve forall-constraints immediately, or not at all Triggered by the new short-cut solver, I realised that it is nicer to solve forall-constraints immediately, rather than emitting an implication constraint to be solved later. This is an un-forced refactoring, but it saves quite a bit of plumbing; e.g - The `wl_implics` field of `WorkList` is gone, - The types of `solveSimpleWanteds` and friends are simplified. - An EvFun contains binding, rather than an EvBindsVar ref-cell that will in the future contain bindings. That makes `evVarsOfTerm` simpler It also improves error messages a bit. One tiresome point: in the tricky case of `inferConstraintsCoerceBased` we make a forall-constraint. This we /do/ want to partially solve, so we can infer a suitable context. (I'd be quite happy to force the user to write a context, bt I don't want to change behavior.) So we want to generate an /implication/ constraint in `emitPredSpecConstraints` rather than a /forall-constraint/ as we were doing before. Incidental refactoring * `GHC.Tc.Deriv.Infer.inferConstraints` was consulting the state monad for the DerivEnv that the caller had just consulted. Nicer to pass it as an argument I think, so I have done that. No change in behaviour. - - - - - 38758a5d by Simon Peyton Jones at 2025-07-21T12:07:01+01:00 Remove duplicated code in Ast.hs for evTermFreeVars This is just a tidy up. - - - - - ed5d029b by Simon Peyton Jones at 2025-07-21T12:07:01+01:00 Small tc-tracing changes only - - - - - 30 changed files: - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Solve.hs - + compiler/GHC/Tc/Solver/Solve.hs-boot - compiler/GHC/Tc/Zonk/Type.hs - testsuite/tests/deriving/should_compile/T20815.hs - testsuite/tests/impredicative/T17332.stderr - testsuite/tests/quantified-constraints/T15290a.stderr - testsuite/tests/quantified-constraints/T19690.stderr - testsuite/tests/quantified-constraints/T19921.stderr - testsuite/tests/quantified-constraints/T21006.stderr - testsuite/tests/typecheck/should_compile/T12427a.stderr - testsuite/tests/typecheck/should_fail/T14605.hs - testsuite/tests/typecheck/should_fail/T14605.stderr - testsuite/tests/typecheck/should_fail/T15801.stderr - testsuite/tests/typecheck/should_fail/T18640a.stderr - testsuite/tests/typecheck/should_fail/T18640b.stderr - testsuite/tests/typecheck/should_fail/T19627.stderr - testsuite/tests/typecheck/should_fail/T21530b.stderr - testsuite/tests/typecheck/should_fail/T22912.stderr - testsuite/tests/typecheck/should_fail/tcfail174.stderr Changes: ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -32,12 +32,12 @@ import GHC.Types.Basic import GHC.Data.BooleanFormula import GHC.Core.Class ( className, classSCSelIds ) import GHC.Core.ConLike ( conLikeName ) -import GHC.Core.FVs import GHC.Core.DataCon ( dataConNonlinearType ) import GHC.Types.FieldLabel import GHC.Hs import GHC.Hs.Syn.Type import GHC.Utils.Monad ( concatMapM, MonadIO(liftIO) ) +import GHC.Utils.FV ( fvVarList, filterFV ) import GHC.Types.Id ( isDataConId_maybe ) import GHC.Types.Name ( Name, nameSrcSpan, nameUnique, wiredInNameTyThing_maybe, getName ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) @@ -45,8 +45,8 @@ import GHC.Types.Name.Reader ( RecFieldInfo(..), WithUserRdr(..) ) import GHC.Types.SrcLoc import GHC.Core.Type ( Type, ForAllTyFlag(..) ) import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) -import GHC.Core.Predicate import GHC.Core.InstEnv +import GHC.Core.Predicate ( isEvId ) import GHC.Tc.Types import GHC.Tc.Types.Evidence import GHC.Types.Var ( Id, Var, EvId, varName, varType, varUnique ) @@ -672,22 +672,16 @@ instance ToHie (Context (Located Name)) where instance ToHie (Context (Located (WithUserRdr Name))) where toHie (C c (L l (WithUserRdr _ n))) = toHie $ C c (L l n) -evVarsOfTermList :: EvTerm -> [EvId] -evVarsOfTermList (EvExpr e) = exprSomeFreeVarsList isEvVar e -evVarsOfTermList (EvTypeable _ ev) = - case ev of - EvTypeableTyCon _ e -> concatMap evVarsOfTermList e - EvTypeableTyApp e1 e2 -> concatMap evVarsOfTermList [e1,e2] - EvTypeableTrFun e1 e2 e3 -> concatMap evVarsOfTermList [e1,e2,e3] - EvTypeableTyLit e -> evVarsOfTermList e -evVarsOfTermList (EvFun{}) = [] +hieEvIdsOfTerm :: EvTerm -> [EvId] +-- Returns only EvIds satisfying relevantEvId +hieEvIdsOfTerm tm = fvVarList (filterFV isEvId (evTermFVs tm)) instance ToHie (EvBindContext (LocatedA TcEvBinds)) where toHie (EvBindContext sc sp (L span (EvBinds bs))) = concatMapM go $ bagToList bs where go evbind = do - let evDeps = evVarsOfTermList $ eb_rhs evbind + let evDeps = hieEvIdsOfTerm $ eb_rhs evbind depNames = EvBindDeps $ map varName evDeps concatM $ [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp) @@ -708,7 +702,7 @@ instance ToHie (LocatedA HsWrapper) where toHie $ C (EvidenceVarBind EvWrapperBind (mkScope osp) (getRealSpanA osp)) $ L osp a (WpEvApp a) -> - concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a + concatMapM (toHie . C EvidenceVarUse . L osp) $ hieEvIdsOfTerm a _ -> pure [] instance HiePass p => HasType (LocatedA (HsBind (GhcPass p))) where ===================================== compiler/GHC/Tc/Deriv.hs ===================================== @@ -1432,13 +1432,13 @@ See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom -- EarlyDerivSpec from it. mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec mk_eqn_from_mechanism mechanism - = do DerivEnv { denv_overlap_mode = overlap_mode - , denv_tvs = tvs - , denv_cls = cls - , denv_inst_tys = inst_tys - , denv_ctxt = deriv_ctxt - , denv_skol_info = skol_info - , denv_warn = warn } <- ask + = do env@(DerivEnv { denv_overlap_mode = overlap_mode + , denv_tvs = tvs + , denv_cls = cls + , denv_inst_tys = inst_tys + , denv_ctxt = deriv_ctxt + , denv_skol_info = skol_info + , denv_warn = warn }) <- ask user_ctxt <- askDerivUserTypeCtxt doDerivInstErrorChecks1 mechanism loc <- lift getSrcSpanM @@ -1446,7 +1446,7 @@ mk_eqn_from_mechanism mechanism case deriv_ctxt of InferContext wildcard -> do { (inferred_constraints, tvs', inst_tys', mechanism') - <- inferConstraints mechanism + <- inferConstraints mechanism env ; return $ InferTheta $ DS { ds_loc = loc , ds_name = dfun_name, ds_tvs = tvs' ===================================== compiler/GHC/Tc/Deriv/Infer.hs ===================================== @@ -66,7 +66,7 @@ import Data.Maybe ---------------------- -inferConstraints :: DerivSpecMechanism +inferConstraints :: DerivSpecMechanism -> DerivEnv -> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) -- inferConstraints figures out the constraints needed for the -- instance declaration generated by a 'deriving' clause on a @@ -83,12 +83,12 @@ inferConstraints :: DerivSpecMechanism -- Generate a sufficiently large set of constraints that typechecking the -- generated method definitions should succeed. This set will be simplified -- before being used in the instance declaration -inferConstraints mechanism - = do { DerivEnv { denv_tvs = tvs - , denv_cls = main_cls - , denv_inst_tys = inst_tys } <- ask - ; wildcard <- isStandaloneWildcardDeriv - ; let infer_constraints :: DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) +inferConstraints mechanism (DerivEnv { denv_ctxt = ctxt + , denv_tvs = tvs + , denv_cls = main_cls + , denv_inst_tys = inst_tys }) + = do { let wildcard = isStandaloneWildcardDeriv ctxt + infer_constraints :: DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) infer_constraints = case mechanism of DerivSpecStock{dsm_stock_dit = dit} @@ -169,12 +169,12 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys , dit_tc_args = tc_args , dit_rep_tc = rep_tc , dit_rep_tc_args = rep_tc_args }) - = do DerivEnv { denv_tvs = tvs + = do DerivEnv { denv_ctxt = ctxt + , denv_tvs = tvs , denv_cls = main_cls , denv_inst_tys = inst_tys } <- ask - wildcard <- isStandaloneWildcardDeriv - - let inst_ty = mkTyConApp tc tc_args + let wildcard = isStandaloneWildcardDeriv ctxt + inst_ty = mkTyConApp tc tc_args tc_binders = tyConBinders rep_tc choose_level bndr | isNamedTyConBinder bndr = KindLevel @@ -370,13 +370,14 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys -- derived instance context. inferConstraintsAnyclass :: DerivM ThetaSpec inferConstraintsAnyclass - = do { DerivEnv { denv_cls = cls + = do { DerivEnv { denv_ctxt = ctxt + , denv_cls = cls , denv_inst_tys = inst_tys } <- ask ; let gen_dms = [ (sel_id, dm_ty) | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ] - ; wildcard <- isStandaloneWildcardDeriv - ; let meth_pred :: (Id, Type) -> PredSpec + ; let wildcard = isStandaloneWildcardDeriv ctxt + meth_pred :: (Id, Type) -> PredSpec -- (Id,Type) are the selector Id and the generic default method type -- NB: the latter is /not/ quantified over the class variables -- See Note [Gathering and simplifying constraints for DeriveAnyClass] @@ -408,10 +409,10 @@ inferConstraintsAnyclass inferConstraintsCoerceBased :: [Type] -> Type -> DerivM ThetaSpec inferConstraintsCoerceBased cls_tys rep_ty = do - DerivEnv { denv_tvs = tvs + DerivEnv { denv_ctxt = ctxt + , denv_tvs = tvs , denv_cls = cls , denv_inst_tys = inst_tys } <- ask - sa_wildcard <- isStandaloneWildcardDeriv let -- rep_ty might come from: -- GeneralizedNewtypeDeriving / DerivSpecNewtype: -- the underlying type of the newtype () @@ -426,6 +427,7 @@ inferConstraintsCoerceBased cls_tys rep_ty = do -- we are going to get all the methods for the final -- dictionary deriv_origin = mkDerivOrigin sa_wildcard + sa_wildcard = isStandaloneWildcardDeriv ctxt -- Next we collect constraints for the class methods -- If there are no methods, we don't need any constraints @@ -574,7 +576,7 @@ Consider the `deriving Alt` part of this example (from the passing part of T20815a): class Alt f where - some :: Applicative f => f a -> f [a] + some :: forall a. Applicative f => f a -> f [a] newtype T f a = T (f a) deriving Alt ===================================== compiler/GHC/Tc/Deriv/Utils.hs ===================================== @@ -35,11 +35,11 @@ import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor import GHC.Tc.Deriv.Generics import GHC.Tc.Errors.Types -import GHC.Tc.Types.Constraint (WantedConstraints, mkNonCanonical) +import GHC.Tc.Types.Constraint (WantedConstraints, mkNonCanonical, mkSimpleWC) import GHC.Tc.Types.Origin import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Unify (tcSubTypeSigma) +import GHC.Tc.Utils.Unify (tcSubTypeSigma, buildImplicationFor) import GHC.Tc.Zonk.Type import GHC.Core.Class @@ -71,7 +71,6 @@ import GHC.Utils.Error import GHC.Utils.Unique (sameUnique) import Control.Monad.Trans.Reader -import Data.Foldable (traverse_) import Data.Maybe import qualified GHC.LanguageExtensions as LangExt import GHC.Data.List.SetOps (assocMaybe) @@ -92,12 +91,9 @@ isStandaloneDeriv = asks (go . denv_ctxt) -- | Is GHC processing a standalone deriving declaration with an -- extra-constraints wildcard as the context? -- (e.g., @deriving instance _ => Eq (Foo a)@) -isStandaloneWildcardDeriv :: DerivM Bool -isStandaloneWildcardDeriv = asks (go . denv_ctxt) - where - go :: DerivContext -> Bool - go (InferContext wildcard) = isJust wildcard - go (SupplyContext {}) = False +isStandaloneWildcardDeriv :: DerivContext -> Bool +isStandaloneWildcardDeriv (InferContext wildcard) = isJust wildcard +isStandaloneWildcardDeriv (SupplyContext {}) = False -- | Return 'InstDeclCtxt' if processing with a standalone @deriving@ -- declaration or 'DerivClauseCtxt' if processing a @deriving@ clause. @@ -563,11 +559,17 @@ data PredSpec SimplePredSpec { sps_pred :: TcPredType -- ^ The constraint to emit as a wanted + -- Usually just a simple predicate like (Eq a) or (ki ~# Type), + -- but (hack) in the case of GHC.Tc.Deriv.Infer.inferConstraintsCoerceBased, + -- it can be a forall-constraint + , sps_origin :: CtOrigin -- ^ The origin of the constraint + , sps_type_or_kind :: TypeOrKind -- ^ Whether the constraint is a type or kind } + | -- | A special 'PredSpec' that is only used by @DeriveAnyClass@. This -- will check if @stps_ty_actual@ is a subtype of (i.e., more polymorphic -- than) @stps_ty_expected@ in the constraint solving machinery, emitting an @@ -677,8 +679,8 @@ captureThetaSpecConstraints :: -- @deriving@ declaration -> ThetaSpec -- ^ The specs from which constraints will be created -> TcM (TcLevel, WantedConstraints) -captureThetaSpecConstraints user_ctxt theta = - pushTcLevelM $ mk_wanteds theta +captureThetaSpecConstraints user_ctxt theta + = pushTcLevelM $ mk_wanteds theta where -- Create the constraints we need to solve. For stock and newtype -- deriving, these constraints will be simple wanted constraints @@ -689,34 +691,49 @@ captureThetaSpecConstraints user_ctxt theta = mk_wanteds :: ThetaSpec -> TcM WantedConstraints mk_wanteds preds = do { (_, wanteds) <- captureConstraints $ - traverse_ emit_constraints preds + mapM_ (emitPredSpecConstraints user_ctxt) preds ; pure wanteds } - -- Emit the appropriate constraints depending on what sort of - -- PredSpec we are dealing with. - emit_constraints :: PredSpec -> TcM () - emit_constraints ps = - case ps of - -- For constraints like (C a, Ord b), emit the - -- constraints directly as simple wanted constraints. - SimplePredSpec { sps_pred = wanted - , sps_origin = orig - , sps_type_or_kind = t_or_k - } -> do - ev <- newWanted orig (Just t_or_k) wanted - emitSimple (mkNonCanonical ev) - - -- For DeriveAnyClass, check if ty_actual is a subtype of - -- ty_expected, which emits an implication constraint as a - -- side effect. See - -- Note [Gathering and simplifying constraints for DeriveAnyClass]. - -- in GHC.Tc.Deriv.Infer. - SubTypePredSpec { stps_ty_actual = ty_actual - , stps_ty_expected = ty_expected - , stps_origin = orig - } -> do - _ <- tcSubTypeSigma orig user_ctxt ty_actual ty_expected - return () +emitPredSpecConstraints :: UserTypeCtxt -> PredSpec -> TcM () +--- Emit the appropriate constraints depending on what sort of +-- PredSpec we are dealing with. +emitPredSpecConstraints _ (SimplePredSpec { sps_pred = wanted_pred + , sps_origin = orig + , sps_type_or_kind = t_or_k }) + -- For constraints like (C a) or (Ord b), emit the + -- constraints directly as simple wanted constraints. + | isRhoTy wanted_pred + = do { ev <- newWanted orig (Just t_or_k) wanted_pred + ; emitSimple (mkNonCanonical ev) } + + | otherwise + -- Forall-constraints, which come exclusively from + -- GHC.Tc.Deriv.Infer.inferConstraintsCoerceBased. + -- For these we want to emit an implication constraint, and NOT a + -- forall-constraint. Why? Because forall-constraints are solved all-or-nothing, + -- but here when we are trying to infer the context for an instance decl, we + -- need that half-solved implication. See deriving/should_compile/T20815 + -- and Note [Inferred contexts from method constraints] + = do { let skol_info_anon = DerivSkol wanted_pred + ; skol_info <- mkSkolemInfo skol_info_anon + ; (_wrapper, tv_prs, givens, wanted_rho) <- topSkolemise skol_info wanted_pred + -- _wrapper: we ignore the evidence from all these constraints + ; (tc_lvl, ev) <- pushTcLevelM $ newWanted orig (Just t_or_k) wanted_rho + ; let skol_tvs = map (binderVar . snd) tv_prs + ; (implic, _) <- buildImplicationFor tc_lvl skol_info_anon skol_tvs + givens (mkSimpleWC [ev]) + ; emitImplications implic } + +emitPredSpecConstraints user_ctxt + (SubTypePredSpec { stps_ty_actual = ty_actual + , stps_ty_expected = ty_expected + , stps_origin = orig }) +-- For DeriveAnyClass, check if ty_actual is a subtype of ty_expected, +-- which emits an implication constraint as a side effect. See +-- Note [Gathering and simplifying constraints for DeriveAnyClass] +-- in GHC.Tc.Deriv.Infer. + = do { _ <- tcSubTypeSigma orig user_ctxt ty_actual ty_expected + ; return () } {- ************************************************************************ ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -623,7 +623,8 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics -- report2: we suppress these if there are insolubles elsewhere in the tree report2 = [ ("Implicit params", is_ip, False, mkGroupReporter mkIPErr) , ("Irreds", is_irred, False, mkGroupReporter mkIrredErr) - , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) ] + , ("Dicts", is_dict, False, mkGroupReporter mkDictErr) + , ("Quantified", is_qc, False, mkGroupReporter mkQCErr) ] -- report3: suppressed errors should be reported as categorized by either report1 -- or report2. Keep this in sync with the suppress function above @@ -687,6 +688,9 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics is_irred _ (IrredPred {}) = True is_irred _ _ = False + is_qc _ (ForAllPred {}) = True + is_qc _ _ = False + -- See situation (1) of Note [Suppressing confusing errors] is_ww_fundep item _ = is_ww_fundep_item item is_ww_fundep_item = isWantedWantedFunDepOrigin . errorItemOrigin @@ -2214,6 +2218,15 @@ Warn of loopy local equalities that were dropped. ************************************************************************ -} +mkQCErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport +mkQCErr ctxt items + | item1 :| _ <- tryFilter (not . ei_suppress) items + -- Ignore multiple qc-errors on the same line + = do { let msg = mkPlainMismatchMsg $ + CouldNotDeduce (getUserGivens ctxt) (item1 :| []) Nothing + ; return $ important ctxt msg } + + mkDictErr :: HasDebugCallStack => SolverReportErrCtxt -> NonEmpty ErrorItem -> TcM SolverReport mkDictErr ctxt orig_items = do { inst_envs <- tcGetInstEnvs @@ -2231,8 +2244,8 @@ mkDictErr ctxt orig_items ; return $ SolverReport { sr_important_msg = SolverReportWithCtxt ctxt err - , sr_supplementary = - [ SupplementaryImportErrors imps | imps <- maybeToList (NE.nonEmpty imp_errs) ] + , sr_supplementary = [ SupplementaryImportErrors imps + | imps <- maybeToList (NE.nonEmpty imp_errs) ] , sr_hints = hints } } ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -460,6 +460,7 @@ finishApp tc_head@(tc_fun,_) tc_args app_res_rho res_wrap ; res_expr <- if isTagToEnum tc_fun then tcTagToEnum tc_head tc_args app_res_rho else return (rebuildHsApps tc_head tc_args) + ; traceTc "End tcApp }" (ppr tc_fun) ; return (mkHsWrap res_wrap res_expr) } checkResultTy :: HsExpr GhcRn ===================================== compiler/GHC/Tc/Gen/Expr.hs ===================================== @@ -1481,6 +1481,7 @@ expandRecordUpd record_expr possible_parents rbnds res_ty vcat [ text "relevant_con:" <+> ppr relevant_con , text "res_ty:" <+> ppr res_ty , text "ds_res_ty:" <+> ppr ds_res_ty + , text "ds_expr:" <+> ppr ds_expr ] ; return (ds_expr, ds_res_ty, RecordUpdCtxt relevant_cons upd_fld_names ex_tvs) } ===================================== compiler/GHC/Tc/Solver.hs ===================================== @@ -1036,8 +1036,7 @@ findInferredDiff annotated_theta inferred_theta -- See `Note [Quantification and partial signatures]` Wrinkle 2 ; return (map (box_pred . ctPred) $ - bagToList $ - wc_simple residual) } + bagToList residual) } where box_pred :: PredType -> PredType box_pred pred = case classifyPredType pred of ===================================== compiler/GHC/Tc/Solver/Default.hs ===================================== @@ -1188,8 +1188,8 @@ tryDefaultGroup wanteds (Proposal assignments) ; new_wanteds <- sequence [ new_wtd_ct wtd | CtWanted wtd <- map ctEvidence wanteds ] - ; residual_wc <- solveSimpleWanteds (listToBag new_wanteds) - ; return $ if isEmptyWC residual_wc then Just (tvs, subst) else Nothing } + ; residual <- solveSimpleWanteds (listToBag new_wanteds) + ; return $ if isEmptyBag residual then Just (tvs, subst) else Nothing } | otherwise = return Nothing ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -10,6 +10,8 @@ module GHC.Tc.Solver.Equality( import GHC.Prelude +import {-# SOURCE #-} GHC.Tc.Solver.Solve( trySolveImplication ) + import GHC.Tc.Solver.Irred( solveIrred ) import GHC.Tc.Solver.Dict( matchLocalInst, chooseInstance ) import GHC.Tc.Solver.Rewrite @@ -468,7 +470,7 @@ can_eq_nc_forall :: CtEvidence -> EqRel -- See Note [Solving forall equalities] can_eq_nc_forall ev eq_rel s1 s2 - | CtWanted (WantedCt { ctev_dest = orig_dest }) <- ev + | CtWanted (WantedCt { ctev_dest = orig_dest, ctev_loc = loc }) <- ev = do { let (bndrs1, phi1, bndrs2, phi2) = split_foralls s1 s2 flags1 = binderFlags bndrs1 flags2 = binderFlags bndrs2 @@ -479,11 +481,11 @@ can_eq_nc_forall ev eq_rel s1 s2 , ppr flags1, ppr flags2 ] ; canEqHardFailure ev s1 s2 } - else do { - traceTcS "Creating implication for polytype equality" (ppr ev) - ; let free_tvs = tyCoVarsOfTypes [s1,s2] - empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs - ; skol_info <- mkSkolemInfo (UnifyForAllSkol phi1) + else + do { let free_tvs = tyCoVarsOfTypes [s1,s2] + empty_subst1 = mkEmptySubst $ mkInScopeSet free_tvs + skol_info_anon = UnifyForAllSkol phi1 + ; skol_info <- mkSkolemInfo skol_info_anon ; (subst1, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst1 $ binderVars bndrs1 @@ -522,16 +524,34 @@ can_eq_nc_forall ev eq_rel s1 s2 init_subst2 = mkEmptySubst (substInScopeSet subst1) + ; traceTcS "Generating wanteds" (ppr s1 $$ ppr s2) + -- Generate the constraints that live in the body of the implication -- See (SF5) in Note [Solving forall equalities] ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $ unifyForAllBody ev (eqRelRole eq_rel) $ \uenv -> go uenv skol_tvs init_subst2 bndrs1 bndrs2 - ; emitTvImplicationTcS lvl (getSkolemInfo skol_info) skol_tvs wanteds - - ; setWantedEq orig_dest all_co - ; stopWith ev "Deferred polytype equality" } } + -- 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 $ + (implicationPrototype (ctLocEnv loc)) + { ic_tclvl = lvl + , ic_binds = ev_binds_var + , ic_info = skol_info_anon + , ic_warn_inaccessible = False + , ic_skols = skol_tvs + , ic_given = [] + , ic_wanted = emptyWC { wc_simple = wanteds } } + + ; if solved + then do { zonked_all_co <- zonkCo all_co + -- ToDo: explain this zonk + ; setWantedEq orig_dest zonked_all_co + ; stopWith ev "Polytype equality: solved" } + else canEqSoftFailure IrredShapeReason ev s1 s2 } } | otherwise = do { traceTcS "Omitting decomposition of given polytype equality" $ @@ -556,7 +576,8 @@ can_eq_nc_forall ev eq_rel s1 s2 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To solve an equality between foralls [W] (forall a. t1) ~ (forall b. t2) -the basic plan is simple: just create the implication constraint +the basic plan is simple: use `trySolveImplication` to solve the +implication constraint [W] forall a. { t1 ~ (t2[a/b]) } The evidence we produce is a ForAllCo; see the typing rule for @@ -601,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] @@ -834,18 +870,26 @@ canTyConApp ev eq_rel both_generative (ty1,tc1,tys1) (ty2,tc2,tys2) = do { inerts <- getInertSet ; if can_decompose inerts then canDecomposableTyConAppOK ev eq_rel tc1 (ty1,tys1) (ty2,tys2) - else canEqSoftFailure ev eq_rel ty1 ty2 } + else assert (eq_rel == ReprEq) $ + canEqSoftFailure ReprEqReason ev ty1 ty2 } -- See Note [Skolem abstract data] in GHC.Core.Tycon | tyConSkolem tc1 || tyConSkolem tc2 = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2) ; finishCanWithIrred AbstractTyConReason ev } - | otherwise -- Different TyCons - = if both_generative -- See (TC2) and (TC3) in - -- Note [Canonicalising TyCon/TyCon equalities] - then canEqHardFailure ev ty1 ty2 - else canEqSoftFailure ev eq_rel ty1 ty2 + -- Different TyCons + | NomEq <- eq_rel + = canEqHardFailure ev ty1 ty2 + + -- Different TyCons, eq_rel = ReprEq + -- See (TC2) and (TC3) in + -- Note [Canonicalising TyCon/TyCon equalities] + | both_generative + = canEqHardFailure ev ty1 ty2 + + | otherwise + = canEqSoftFailure ReprEqReason ev ty1 ty2 where -- See Note [Decomposing TyConApp equalities] -- and Note [Decomposing newtype equalities] @@ -1417,20 +1461,18 @@ canDecomposableFunTy ev eq_rel af f1@(ty1,m1,a1,r1) f2@(ty2,m2,a2,r2) -- | Call canEqSoftFailure when canonicalizing an equality fails, but if the -- equality is representational, there is some hope for the future. -canEqSoftFailure :: CtEvidence -> EqRel -> TcType -> TcType +canEqSoftFailure :: CtIrredReason -> CtEvidence -> TcType -> TcType -> TcS (StopOrContinue (Either IrredCt a)) -canEqSoftFailure ev NomEq ty1 ty2 - = canEqHardFailure ev ty1 ty2 -canEqSoftFailure ev ReprEq ty1 ty2 +canEqSoftFailure reason ev ty1 ty2 = do { (redn1, rewriters1) <- rewrite ev ty1 ; (redn2, rewriters2) <- rewrite ev ty2 -- We must rewrite the types before putting them in the -- inert set, so that we are sure to kick them out when -- new equalities become available - ; traceTcS "canEqSoftFailure with ReprEq" $ + ; traceTcS "canEqSoftFailure" $ vcat [ ppr ev, ppr redn1, ppr redn2 ] ; new_ev <- rewriteEqEvidence (rewriters1 S.<> rewriters2) ev NotSwapped redn1 redn2 - ; finishCanWithIrred ReprEqReason new_ev } + ; finishCanWithIrred reason new_ev } -- | Call when canonicalizing an equality fails with utterly no hope. canEqHardFailure :: CtEvidence -> TcType -> TcType @@ -2681,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) @@ -2692,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 } @@ -2741,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 ===================================== @@ -154,17 +154,6 @@ So we arrange to put these particular class constraints in the wl_eqs. NB: since we do not currently apply the substitution to the inert_solved_dicts, the knot-tying still seems a bit fragile. But this makes it better. - -Note [Residual implications] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The wl_implics in the WorkList are the residual implication -constraints that are generated while solving or canonicalising the -current worklist. Specifically, when canonicalising - (forall a. t1 ~ forall a. t2) -from which we get the implication - (forall a. t1 ~ t2) -See GHC.Tc.Solver.Monad.deferTcSForAllEq - -} -- See Note [WorkList priorities] @@ -186,8 +175,6 @@ data WorkList -- in GHC.Tc.Types.Constraint for more details. , wl_rest :: [Ct] - - , wl_implics :: Bag Implication -- See Note [Residual implications] } isNominalEqualityCt :: Ct -> Bool @@ -202,15 +189,12 @@ isNominalEqualityCt ct appendWorkList :: WorkList -> WorkList -> WorkList appendWorkList - (WL { wl_eqs_N = eqs1_N, wl_eqs_X = eqs1_X, wl_rw_eqs = rw_eqs1 - , wl_rest = rest1, wl_implics = implics1 }) - (WL { wl_eqs_N = eqs2_N, wl_eqs_X = eqs2_X, wl_rw_eqs = rw_eqs2 - , wl_rest = rest2, wl_implics = implics2 }) + (WL { wl_eqs_N = eqs1_N, wl_eqs_X = eqs1_X, wl_rw_eqs = rw_eqs1, wl_rest = rest1 }) + (WL { wl_eqs_N = eqs2_N, wl_eqs_X = eqs2_X, wl_rw_eqs = rw_eqs2, wl_rest = rest2 }) = WL { wl_eqs_N = eqs1_N ++ eqs2_N , wl_eqs_X = eqs1_X ++ eqs2_X , wl_rw_eqs = rw_eqs1 ++ rw_eqs2 - , wl_rest = rest1 ++ rest2 - , wl_implics = implics1 `unionBags` implics2 } + , wl_rest = rest1 ++ rest2 } workListSize :: WorkList -> Int workListSize (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X, wl_rw_eqs = rw_eqs, wl_rest = rest }) @@ -268,9 +252,6 @@ extendWorkListNonEq :: Ct -> WorkList -> WorkList -- Extension by non equality extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } -extendWorkListImplic :: Implication -> WorkList -> WorkList -extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl } - extendWorkListCt :: Ct -> WorkList -> WorkList -- Agnostic about what kind of constraint extendWorkListCt ct wl @@ -294,18 +275,18 @@ extendWorkListCts :: Cts -> WorkList -> WorkList extendWorkListCts cts wl = foldr extendWorkListCt wl cts isEmptyWorkList :: WorkList -> Bool -isEmptyWorkList (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X, wl_rw_eqs = rw_eqs - , wl_rest = rest, wl_implics = implics }) - = null eqs_N && null eqs_X && null rw_eqs && null rest && isEmptyBag implics +isEmptyWorkList (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X + , wl_rw_eqs = rw_eqs, wl_rest = rest }) + = null eqs_N && null eqs_X && null rw_eqs && null rest emptyWorkList :: WorkList emptyWorkList = WL { wl_eqs_N = [], wl_eqs_X = [] - , wl_rw_eqs = [], wl_rest = [], wl_implics = emptyBag } + , wl_rw_eqs = [], wl_rest = [] } -- Pretty printing instance Outputable WorkList where - ppr (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X, wl_rw_eqs = rw_eqs - , wl_rest = rest, wl_implics = implics }) + ppr (WL { wl_eqs_N = eqs_N, wl_eqs_X = eqs_X + , wl_rw_eqs = rw_eqs, wl_rest = rest }) = text "WL" <+> (braces $ vcat [ ppUnless (null eqs_N) $ text "Eqs_N =" <+> vcat (map ppr eqs_N) @@ -315,9 +296,6 @@ instance Outputable WorkList where text "RwEqs =" <+> vcat (map ppr rw_eqs) , ppUnless (null rest) $ text "Non-eqs =" <+> vcat (map ppr rest) - , ppUnless (isEmptyBag implics) $ - ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics))) - (text "(Implics omitted)") ]) {- ********************************************************************* ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -120,19 +120,17 @@ simplify_loop n limit definitely_redo_implications , int (lengthBag simples) <+> text "simples to solve" ]) ; traceTcS "simplify_loop: wc =" (ppr wc) - ; (unifs1, wc1) <- reportUnifications $ -- See Note [Superclass iteration] - solveSimpleWanteds simples + ; (unifs1, simples1) <- reportUnifications $ -- See Note [Superclass iteration] + solveSimpleWanteds simples -- Any insoluble constraints are in 'simples' and so get rewritten -- See Note [Rewrite insolubles] in GHC.Tc.Solver.InertSet ; wc2 <- if not definitely_redo_implications -- See Note [Superclass iteration] && unifs1 == 0 -- for this conditional - && isEmptyBag (wc_impl wc1) - then return (wc { wc_simple = wc_simple wc1 }) -- Short cut - else do { implics2 <- solveNestedImplications $ - implics `unionBags` (wc_impl wc1) - ; return (wc { wc_simple = wc_simple wc1 - , wc_impl = implics2 }) } + then return (wc { wc_simple = simples1 }) -- Short cut + else do { implics1 <- solveNestedImplications implics + ; return (wc { wc_simple = simples1 + , wc_impl = implics1 }) } ; unif_happened <- resetUnificationFlag ; csTraceTcS $ text "unif_happened" <+> ppr unif_happened @@ -262,6 +260,11 @@ more meaningful error message (see T19627) This also applies for quantified constraints; see `-fqcs-fuel` compiler flag and `QCI.qci_pend_sc` field. -} +{- ******************************************************************************** +* * +* Solving implication constraints * +* * +******************************************************************************** -} solveNestedImplications :: Bag Implication -> TcS (Bag Implication) @@ -282,8 +285,37 @@ solveNestedImplications implics ; return unsolved_implics } +{- Note [trySolveImplication] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +`trySolveImplication` may be invoked while solving simple wanteds, notably from +`solveWantedForAll`. It returns a Bool to say if solving succeeded or failed. + +It uses `nestImplicTcS` to build a nested scope. One subtle point is that +`nestImplicTcS` uses the `inert_givens` (not the `inert_cans`) of the current +inert set to initialse the `InertSet` of the nested scope. It is super-important not +to pollute the sub-solving problem with the unsolved Wanteds of the current scope. + +Whenever we do `solveSimpleGivens`, we snapshot the `inert_cans` into `inert_givens`. +(At that moment there should be no Wanteds.) +-} + +trySolveImplication :: Implication -> TcS Bool +-- See Note [trySolveImplication] +trySolveImplication (Implic { ic_tclvl = tclvl + , ic_binds = ev_binds_var + , ic_given = given_ids + , ic_wanted = wanteds + , ic_env = ct_loc_env + , ic_info = info }) + = nestImplicTcS ev_binds_var tclvl $ + do { let loc = mkGivenLoc tclvl info ct_loc_env + givens = mkGivens loc given_ids + ; solveSimpleGivens givens + ; residual_wanted <- solveWanteds wanteds + ; return (isSolvedWC residual_wanted) } + solveImplication :: Implication -- Wanted - -> TcS Implication -- Simplified implication (empty or singleton) + -> TcS Implication -- Simplified implication -- Precondition: The TcS monad contains an empty worklist and given-only inerts -- which after trying to solve this implication we must restore to their original value solveImplication imp@(Implic { ic_tclvl = tclvl @@ -291,6 +323,7 @@ solveImplication imp@(Implic { ic_tclvl = tclvl , ic_given = given_ids , ic_wanted = wanteds , ic_info = info + , ic_env = ct_loc_env , ic_status = status }) | isSolvedStatus status = return imp -- Do nothing @@ -308,7 +341,7 @@ solveImplication imp@(Implic { ic_tclvl = tclvl -- Solve the nested constraints ; (has_given_eqs, given_insols, residual_wanted) <- nestImplicTcS ev_binds_var tclvl $ - do { let loc = mkGivenLoc tclvl info (ic_env imp) + do { let loc = mkGivenLoc tclvl info ct_loc_env givens = mkGivens loc given_ids ; solveSimpleGivens givens @@ -534,7 +567,7 @@ neededEvVars implic@(Implic { ic_info = info , ic_need_implic = old_need_implic -- See (TRC1) }) = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var - ; tcvs <- TcS.getTcEvTyCoVars ev_binds_var + ; used_cos <- TcS.getTcEvTyCoVars ev_binds_var ; let -- Find the variables needed by `implics` new_need_implic@(ENS { ens_dms = dm_seeds, ens_fvs = other_seeds }) @@ -544,7 +577,8 @@ neededEvVars implic@(Implic { ic_info = info -- Get the variables needed by the solved bindings -- (It's OK to use a non-deterministic fold here -- because add_wanted is commutative.) - seeds_w = nonDetStrictFoldEvBindMap add_wanted tcvs ev_binds + used_covars = coVarsOfCos used_cos + seeds_w = nonDetStrictFoldEvBindMap add_wanted used_covars ev_binds need_ignoring_dms = findNeededGivenEvVars ev_binds (other_seeds `unionVarSet` seeds_w) need_from_dms = findNeededGivenEvVars ev_binds dm_seeds @@ -565,7 +599,7 @@ neededEvVars implic@(Implic { ic_info = info ; traceTcS "neededEvVars" $ vcat [ text "old_need_implic:" <+> ppr old_need_implic , text "new_need_implic:" <+> ppr new_need_implic - , text "tcvs:" <+> ppr tcvs + , text "used_covars:" <+> ppr used_covars , text "need_ignoring_dms:" <+> ppr need_ignoring_dms , text "need_from_dms:" <+> ppr need_from_dms , text "need:" <+> ppr need @@ -589,7 +623,7 @@ neededEvVars implic@(Implic { ic_info = info add_wanted :: EvBind -> VarSet -> VarSet add_wanted (EvBind { eb_info = info, eb_rhs = rhs }) needs | EvBindGiven{} <- info = needs -- Add the rhs vars of the Wanted bindings only - | otherwise = evVarsOfTerm rhs `unionVarSet` needs + | otherwise = nestedEvIdsOfTerm rhs `unionVarSet` needs is_dm_skol :: SkolemInfoAnon -> Bool is_dm_skol (MethSkol _ is_dm) = is_dm @@ -611,7 +645,7 @@ findNeededGivenEvVars ev_binds seeds | Just ev_bind <- lookupEvBind ev_binds v , EvBind { eb_info = EvBindGiven, eb_rhs = rhs } <- ev_bind -- Look at Given bindings only - = evVarsOfTerm rhs `unionVarSet` needs + = nestedEvIdsOfTerm rhs `unionVarSet` needs | otherwise = needs @@ -1008,17 +1042,13 @@ solveSimpleWanteds simples else return (n, wc2) } -- Done -solve_simple_wanteds :: WantedConstraints -> TcS WantedConstraints +solve_simple_wanteds :: Cts -> TcS Cts -- Try solving these constraints -- Affects the unification state (of course) but not the inert set -- The result is not necessarily zonked -solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_errors = errs }) - = nestTcS $ - do { solveSimples simples1 - ; (implics2, unsolved) <- getUnsolvedInerts - ; return (WC { wc_simple = unsolved - , wc_impl = implics1 `unionBags` implics2 - , wc_errors = errs }) } +solve_simple_wanteds simples + = nestTcS $ do { solveSimples simples + ; getUnsolvedInerts } {- Note [The solveSimpleWanteds loop] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1038,9 +1068,10 @@ Solving a bunch of simple constraints is done in a loop, -- The main solver loop implements Note [Basic Simplifier Plan] --------------------------------------------------------------- + solveSimples :: Cts -> TcS () --- Returns the final InertSet in TcS --- Has no effect on work-list or residual-implications +-- Solve this bag of constraints, +-- returning the final InertSet in TcS -- The constraints are initially examined in left-to-right order solveSimples cts @@ -1124,14 +1155,15 @@ solveCt (CEqCan (EqCt { eq_ev = ev, eq_eq_rel = eq_rel , eq_lhs = lhs, eq_rhs = rhs })) = solveEquality ev eq_rel (canEqLHSType lhs) rhs -solveCt (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc })) - = do { ev <- rewriteEvidence ev +solveCt (CQuantCan qci@(QCI { qci_ev = ev })) + = do { ev' <- rewriteEvidence ev -- It is (much) easier to rewrite and re-classify than to -- rewrite the pieces and build a Reduction that will rewrite -- the whole constraint - ; case classifyPredType (ctEvPred ev) of - ForAllPred tvs theta body_pred -> - Stage $ solveForAll ev tvs theta body_pred pend_sc + ; case classifyPredType (ctEvPred ev') of + ForAllPred tvs theta body_pred + -> solveForAll (qci { qci_ev = ev', qci_tvs = tvs + , qci_theta = theta, qci_body = body_pred }) _ -> pprPanic "SolveCt" (ppr ev) } solveCt (CDictCan (DictCt { di_ev = ev, di_pend_sc = pend_sc })) @@ -1165,7 +1197,7 @@ solveNC ev -- And then re-classify ; case classifyPredType (ctEvPred ev) of ClassPred cls tys -> solveDictNC ev cls tys - ForAllPred tvs th p -> Stage $ solveForAllNC ev tvs th p + ForAllPred tvs th p -> solveForAllNC ev tvs th p IrredPred {} -> solveIrred (IrredCt { ir_ev = ev, ir_reason = IrredShapeReason }) EqPred eq_rel ty1 ty2 -> solveEquality ev eq_rel ty1 ty2 -- EqPred only happens if (say) `c` is unified with `a ~# b`, @@ -1256,50 +1288,49 @@ type signature. -- -- Precondition: the constraint has already been rewritten by the inert set. solveForAllNC :: CtEvidence -> [TcTyVar] -> TcThetaType -> TcPredType - -> TcS (StopOrContinue Void) + -> SolverStage Void solveForAllNC ev tvs theta body_pred - | Just (cls,tys) <- getClassPredTys_maybe body_pred - , classHasSCs cls - = do { dflags <- getDynFlags - -- Either expand superclasses (Givens) or provide fuel to do so (Wanteds) - ; if isGiven ev - then - -- See Note [Eagerly expand given superclasses] - -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] - do { sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev tvs theta cls tys - ; emitWork (listToBag sc_cts) - ; solveForAll ev tvs theta body_pred doNotExpand } - else - -- See invariants (a) and (b) in QCI.qci_pend_sc - -- qcsFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] - -- See Note [Quantified constraints] - do { solveForAll ev tvs theta body_pred (qcsFuel dflags) } - } + = do { fuel <- simpleStage mk_super_classes + ; solveForAll (QCI { qci_ev = ev, qci_tvs = tvs, qci_theta = theta + , qci_body = body_pred, qci_pend_sc = fuel }) } - | otherwise - = solveForAll ev tvs theta body_pred doNotExpand + where + mk_super_classes :: TcS ExpansionFuel + mk_super_classes + | Just (cls,tys) <- getClassPredTys_maybe body_pred + , classHasSCs cls + = do { dflags <- getDynFlags + -- Either expand superclasses (Givens) or provide fuel to do so (Wanteds) + ; if isGiven ev + then + -- See Note [Eagerly expand given superclasses] + -- givensFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] + do { sc_cts <- mkStrictSuperClasses (givensFuel dflags) ev tvs theta cls tys + ; emitWork (listToBag sc_cts) + ; return doNotExpand } + else + -- See invariants (a) and (b) in QCI.qci_pend_sc + -- qcsFuel dflags: See Note [Expanding Recursive Superclasses and ExpansionFuel] + -- See Note [Quantified constraints] + return (qcsFuel dflags) + } + + | otherwise + = return doNotExpand -- | Solve a canonical quantified constraint. -- -- Precondition: the constraint has already been rewritten by the inert set. -solveForAll :: CtEvidence -> [TcTyVar] -> TcThetaType -> PredType -> ExpansionFuel - -> TcS (StopOrContinue Void) -solveForAll ev tvs theta body_pred fuel = - case ev of - CtGiven {} -> - -- See Note [Solving a Given forall-constraint] - do { addInertForAll qci - ; stopWith ev "Given forall-constraint" } - CtWanted wtd -> - -- See Note [Solving a Wanted forall-constraint] - runSolverStage $ - do { tryInertQCs qci - ; Stage $ solveWantedForAll_implic wtd tvs theta body_pred - } - where - qci = QCI { qci_ev = ev, qci_tvs = tvs - , qci_body = body_pred, qci_pend_sc = fuel } - +solveForAll :: QCInst -> SolverStage Void +solveForAll qci@(QCI { qci_ev = ev, qci_tvs = tvs, qci_theta = theta, qci_body = pred }) + = case ev of + CtGiven {} -> + -- See Note [Solving a Given forall-constraint] + do { simpleStage (addInertForAll qci) + ; stopWithStage ev "Given forall-constraint" } + CtWanted wtd -> + do { tryInertQCs qci + ; solveWantedForAll qci tvs theta pred wtd } tryInertQCs :: QCInst -> SolverStage () tryInertQCs qc @@ -1310,7 +1341,8 @@ tryInertQCs qc try_inert_qcs :: QCInst -> [QCInst] -> TcS (StopOrContinue ()) try_inert_qcs (QCI { qci_ev = ev_w }) inerts = case mapMaybe matching_inert inerts of - [] -> continueWith () + [] -> do { traceTcS "tryInertQCs:nothing" (ppr ev_w $$ ppr inerts) + ; continueWith () } ev_i:_ -> do { traceTcS "tryInertQCs:KeepInert" (ppr ev_i) ; setEvBindIfWanted ev_w EvCanonical (ctEvTerm ev_i) @@ -1323,57 +1355,72 @@ try_inert_qcs (QCI { qci_ev = ev_w }) inerts = = Nothing -- | Solve a (canonical) Wanted quantified constraint by emitting an implication. --- -- See Note [Solving a Wanted forall-constraint] -solveWantedForAll_implic :: WantedCtEvidence -> [TcTyVar] -> TcThetaType -> PredType -> TcS (StopOrContinue Void) -solveWantedForAll_implic - wtd@(WantedCt { ctev_dest = dest, ctev_loc = loc, ctev_rewriters = rewriters }) - tvs theta body_pred = - -- We are about to do something irreversible (turning a quantified constraint - -- into an implication), so wrap the inner call in solveCompletelyIfRequired - -- to ensure we can roll back if we can't solve the implication fully. - -- See Note [TcSSpecPrag] in GHC.Tc.Solver.Monad. - solveCompletelyIfRequired (mkNonCanonical $ CtWanted wtd) $ - - -- This setSrcSpan is important: the emitImplicationTcS uses that - -- TcLclEnv for the implication, and that in turn sets the location - -- for the Givens when solving the constraint (#21006) - TcS.setSrcSpan (getCtLocEnvLoc $ ctLocEnv loc) $ - do { let empty_subst = mkEmptySubst $ mkInScopeSet $ - tyCoVarsOfTypes (body_pred:theta) `delVarSetList` tvs - is_qc = IsQC (ctLocOrigin loc) - - -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] +solveWantedForAll :: QCInst -> [TcTyVar] -> TcThetaType -> PredType + -> WantedCtEvidence -> SolverStage Void +solveWantedForAll qci tvs theta body_pred + wtd@(WantedCt { ctev_dest = dest, ctev_loc = ct_loc + , ctev_rewriters = rewriters }) + = Stage $ + TcS.setSrcSpan (getCtLocEnvLoc loc_env) $ + -- This setSrcSpan is important: the emitImplicationTcS uses that + -- TcLclEnv for the implication, and that in turn sets the location + -- for the Givens when solving the constraint (#21006) + + do { -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv] -- in GHC.Tc.Utils.TcType -- Very like the code in tcSkolDFunType - ; rec { skol_info <- mkSkolemInfo skol_info_anon + rec { skol_info <- mkSkolemInfo skol_info_anon ; (subst, skol_tvs) <- tcInstSkolTyVarsX skol_info empty_subst tvs ; let inst_pred = substTy subst body_pred inst_theta = substTheta subst theta skol_info_anon = InstSkol is_qc (get_size inst_pred) } - ; given_ev_vars <- mapM newEvVar inst_theta - ; (lvl, (w_id, wanteds)) - <- pushLevelNoWorkList (ppr skol_info) $ - do { let loc' = setCtLocOrigin loc (ScOrigin is_qc NakedSc) - -- Set the thing to prove to have a ScOrigin, so we are - -- careful about its termination checks. - -- See (QC-INV) in Note [Solving a Wanted forall-constraint] - ; wanted_ev <- newWantedNC loc' rewriters inst_pred - -- NB: inst_pred can be an equality - ; return ( wantedCtEvEvId wanted_ev - , unitBag (mkNonCanonical $ CtWanted wanted_ev)) } - - ; traceTcS "solveForAll" (ppr given_ev_vars $$ ppr wanteds $$ ppr w_id) - ; ev_binds <- emitImplicationTcS lvl skol_info_anon skol_tvs given_ev_vars wanteds - - ; setWantedEvTerm dest EvCanonical $ - EvFun { et_tvs = skol_tvs, et_given = given_ev_vars - , et_binds = ev_binds, et_body = w_id } - - ; stopWith (CtWanted wtd) "Wanted forall-constraint (implication)" - } + ; given_ev_vars <- mapM newEvVar inst_theta + ; (lvl, (w_id, wanteds)) + <- pushLevelNoWorkList (ppr skol_info) $ + do { let ct_loc' = setCtLocOrigin ct_loc (ScOrigin is_qc NakedSc) + -- Set the thing to prove to have a ScOrigin, so we are + -- careful about its termination checks. + -- See (QC-INV) in Note [Solving a Wanted forall-constraint] + ; wanted_ev <- newWantedNC ct_loc' rewriters inst_pred + -- NB: inst_pred can be an equality + ; return ( wantedCtEvEvId wanted_ev + , unitBag (mkNonCanonical $ CtWanted wanted_ev)) } + + ; traceTcS "solveForAll {" (ppr skol_tvs $$ ppr given_ev_vars $$ ppr wanteds $$ ppr w_id) + + -- Try to solve the constraint completely + ; ev_binds_var <- TcS.newTcEvBinds + ; solved <- trySolveImplication $ + (implicationPrototype loc_env) + { ic_tclvl = lvl + , ic_binds = ev_binds_var + , ic_info = skol_info_anon + , ic_warn_inaccessible = False + , ic_skols = skol_tvs + , ic_given = given_ev_vars + , ic_wanted = emptyWC { wc_simple = wanteds } } + ; traceTcS "solveForAll }" (ppr solved) + ; evbs <- TcS.getTcEvBindsMap ev_binds_var + ; if not solved + then do { -- Not completely solved; abandon that attempt and add the + -- original constraint to the inert set + addInertForAll qci + ; stopWith (CtWanted wtd) "Wanted forall-constraint:unsolved" } + + else do { -- Completely solved; build an evidence term + setWantedEvTerm dest EvCanonical $ + EvFun { et_tvs = skol_tvs, et_given = given_ev_vars + , et_binds = evBindMapBinds evbs, et_body = w_id } + ; stopWith (CtWanted wtd) "Wanted forall-constraint:solved" } } where + loc_env = ctLocEnv ct_loc + is_qc = IsQC (ctLocOrigin ct_loc) + + empty_subst = mkEmptySubst $ mkInScopeSet $ + tyCoVarsOfTypes (body_pred:theta) `delVarSetList` tvs + -- Getting the size of the head is a bit horrible -- because of the special treament for class predicates get_size pred = case classifyPredType pred of @@ -1384,36 +1431,68 @@ solveWantedForAll_implic ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Solving a wanted forall (quantified) constraint [W] df :: forall a b. (Eq a, Ord b) => C x a b -is delightfully easy. Just build an implication constraint +is delightfully easy in principle. Just build an implication constraint forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a and discharge df thus: df = /\ab. \g1 g2. let <binds> in d where <binds> is filled in by solving the implication constraint. All the machinery is to hand; there is little to do. -We can take a more straightforward parth when there is a matching Given, e.g. - [W] dg :: forall c d. (Eq c, Ord d) => C x c d -In this case, it's better to directly solve the Wanted from the Given, instead -of building an implication. This is more than a simple optimisation; see -Note [Solving Wanted QCs from Given QCs]. +There are some tricky corners though: + +(WFA1) We can take a more straightforward path when there is a matching Given, e.g. + [W] dg :: forall c d. (Eq c, Ord d) => C x c d + In this case, it's better to directly solve the Wanted from the Given, instead + of building an implication. This is more than a simple optimisation; see + Note [Solving Wanted QCs from Given QCs]. + +(WFA2) Termination: see #19690. We want to maintain the invariant (QC-INV): + + (QC-INV) Every quantified constraint returns a non-bottom dictionary + + just as every top-level instance declaration guarantees to return a non-bottom + dictionary. But as #19690 shows, it is possible to get a bottom dictionary + by superclass selection if we aren't careful. The situation is very similar + to that described in Note [Recursive superclasses] in GHC.Tc.TyCl.Instance; + and we use the same solution: + + * Give the Givens a CtOrigin of (GivenOrigin (InstSkol IsQC head_size)) + * Give the Wanted a CtOrigin of (ScOrigin IsQC NakedSc) + + Both of these things are done in solveForAll. Now the mechanism described + in Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance takes over. + +(WFA3) We do not actually emit an implication to solve later. Rather we + try to solve it completely immediately using `trySolveImplication` + - If successful, we can build evidence + - If unsuccessful, we abandon the attempt and add the unsolved + forall-constraint to the inert set. + Several reasons for this "solve immediately" approach -The tricky point is about termination: see #19690. We want to maintain -the invariant (QC-INV): + - It saves quite a bit of plumbing, tracking the emitted implications for + later solving; and the evidence would have to contain as-yet-incomplte + bindings which complicates tracking of unused Givens. - (QC-INV) Every quantified constraint returns a non-bottom dictionary + - We get better error messages, about failing to solve, say + (forall a. a->a) ~ (forall b. b->Int) -just as every top-level instance declaration guarantees to return a non-bottom -dictionary. But as #19690 shows, it is possible to get a bottom dicionary -by superclass selection if we aren't careful. The situation is very similar -to that described in Note [Recursive superclasses] in GHC.Tc.TyCl.Instance; -and we use the same solution: + - Consider + f :: forall f a. (Ix a, forall x. Eq x => Eq (f x)) => a -> f a + {-# SPECIALISE f :: forall f. (forall x. Eq x => Eq (f x)) => Int -> f Int #-} + This SPECIALISE is treated like an expression with a type signature, so + we instantiate the constraints, simplify them and re-generalise. From the + instantiation we get [W] d :: (forall x. Eq a => Eq (f x)) + and we want to generalise over that. We do not want to attempt to solve it + and then get stuck, and emit an error message. If we can't solve it, better + to leave it alone. -* Give the Givens a CtOrigin of (GivenOrigin (InstSkol IsQC head_size)) -* Give the Wanted a CtOrigin of (ScOrigin IsQC NakedSc) + We still need to simplify quantified constraints that can be + /fully solved/ from instances, otherwise we would never be able to + specialise them away. Example: {-# SPECIALISE f @[] @a #-}. -Both of these things are done in solveForAll. Now the mechanism described -in Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance takes over. + You might worry about the wasted work, but it is seldom repeated (because the + constraint solver seldom iterates much). Note [Solving a Given forall-constraint] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1576,13 +1655,13 @@ runTcPluginsGiven -- work) and a bag of insolubles. The boolean indicates whether -- 'solveSimpleWanteds' should feed the updated wanteds back into the -- main solver. -runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints) -runTcPluginsWanted wc@(WC { wc_simple = simples1 }) +runTcPluginsWanted :: Cts -> TcS (Bool, Cts) +runTcPluginsWanted simples1 | isEmptyBag simples1 - = return (False, wc) + = return (False, simples1) | otherwise = do { solvers <- getTcPluginSolvers - ; if null solvers then return (False, wc) else + ; if null solvers then return (False, simples1) else do { given <- getInertGivens ; wanted <- TcS.zonkSimples simples1 -- Plugin requires zonked inputs @@ -1604,8 +1683,7 @@ runTcPluginsWanted wc@(WC { wc_simple = simples1 }) ; mapM_ setEv solved_wanted ; traceTcS "Finished plugins }" (ppr new_wanted) - ; return ( notNull (pluginNewCts p) - , wc { wc_simple = all_new_wanted } ) } } + ; return ( notNull (pluginNewCts p), all_new_wanted ) } } where setEv :: (EvTerm,Ct) -> TcS () setEv (ev,ct) = case ctEvidence ct of ===================================== compiler/GHC/Tc/Solver/Solve.hs-boot ===================================== @@ -0,0 +1,8 @@ +module GHC.Tc.Solver.Solve where + +import Prelude( Bool ) +import GHC.Tc.Solver.Monad( TcS ) +import GHC.Tc.Types.Constraint( Cts, Implication ) + +solveSimpleWanteds :: Cts -> TcS Cts +trySolveImplication :: Implication -> TcS Bool ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -746,8 +746,12 @@ zonk_bind (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs runZonkBndrT (zonkTyBndrsX tyvars ) $ \ new_tyvars -> runZonkBndrT (zonkEvBndrsX evs ) $ \ new_evs -> runZonkBndrT (zonkTcEvBinds_s ev_binds) $ \ new_ev_binds -> - do { (new_val_bind, new_exports) <- mfix $ \ ~(new_val_binds, _) -> - runZonkBndrT (extendIdZonkEnvRec $ collectHsBindsBinders CollNoDictBinders new_val_binds) $ \ _ -> + do { (new_val_bind, new_exports) <- mfix $ \ ~(new_val_binds, new_exports) -> + let new_bndrs = collectHsBindsBinders CollNoDictBinders new_val_binds + ++ map abe_poly new_exports + -- Tie the knot with the `abe_poly` binders too, since they + -- may be mentioned in the `abe_prags` of the `exports` + in runZonkBndrT (extendIdZonkEnvRec new_bndrs) $ \ _ -> do { new_val_binds <- mapM zonk_val_bind val_binds ; new_exports <- mapM zonk_export exports ; return (new_val_binds, new_exports) @@ -854,6 +858,7 @@ zonkLTcSpecPrags ps ; skol_tvs_ref <- lift $ newTcRef [] ; setZonkType (SkolemiseFlexi skol_tvs_ref) $ -- SkolemiseFlexi: see Note [Free tyvars on rule LHS] + runZonkBndrT (zonkCoreBndrsX bndrs) $ \ bndrs' -> do { spec_e' <- zonkLExpr spec_e ; skol_tvs <- lift $ readTcRef skol_tvs_ref @@ -1759,7 +1764,7 @@ zonkEvTerm (EvFun { et_tvs = tvs, et_given = evs , et_binds = ev_binds, et_body = body_id }) = runZonkBndrT (zonkTyBndrsX tvs) $ \ new_tvs -> runZonkBndrT (zonkEvBndrsX evs) $ \ new_evs -> - runZonkBndrT (zonkTcEvBinds ev_binds) $ \ new_ev_binds -> + runZonkBndrT (zonkEvBinds ev_binds) $ \ new_ev_binds -> do { new_body_id <- zonkIdOcc body_id ; return (EvFun { et_tvs = new_tvs, et_given = new_evs , et_binds = new_ev_binds, et_body = new_body_id }) } ===================================== testsuite/tests/deriving/should_compile/T20815.hs ===================================== @@ -12,3 +12,5 @@ instance Alt [] where (<!>) = (++) newtype L a = L [a] deriving (Functor, Alt) + +newtype T f a = T (f a) deriving (Functor, Alt) ===================================== testsuite/tests/impredicative/T17332.stderr ===================================== @@ -1,7 +1,6 @@ - T17332.hs:13:7: error: [GHC-05617] - • Could not solve: ‘a’ - arising from the head of a quantified constraint + • Could not solve: ‘forall (a :: Constraint). a’ arising from a use of ‘MkDict’ • In the expression: MkDict In an equation for ‘aux’: aux = MkDict + ===================================== testsuite/tests/quantified-constraints/T15290a.stderr ===================================== @@ -1,9 +1,9 @@ T15290a.hs:25:12: error: [GHC-18872] - • Couldn't match representation of type: m (Int, IntStateT m a1) - with that of: m (Int, StateT Int m a1) + • Couldn't match representation of type: forall a. + StateT Int m (StateT Int m a) -> StateT Int m a + with that of: forall a. + IntStateT m (IntStateT m a) -> IntStateT m a arising from a use of ‘coerce’ - Note: We cannot know what roles the parameters to ‘m’ have; - we must assume that the role is nominal. • In the expression: coerce @(forall a. StateT Int m (StateT Int m a) -> StateT Int m a) ===================================== testsuite/tests/quantified-constraints/T19690.stderr ===================================== @@ -1,10 +1,5 @@ - T19690.hs:12:16: error: [GHC-05617] - • Could not deduce ‘c’ - arising from the head of a quantified constraint - arising from a use of ‘go’ - from the context: Hold c - bound by a quantified context at T19690.hs:12:16-17 + • Could not solve: ‘Hold c => c’ arising from a use of ‘go’ • In the expression: go In an equation for ‘anythingDict’: anythingDict @@ -12,5 +7,4 @@ T19690.hs:12:16: error: [GHC-05617] where go :: (Hold c => c) => Dict c go = Dict - • Relevant bindings include - anythingDict :: Dict c (bound at T19690.hs:12:1) + ===================================== testsuite/tests/quantified-constraints/T19921.stderr ===================================== @@ -1,12 +1,6 @@ - T19921.hs:29:8: error: [GHC-05617] - • Could not deduce ‘r’ - arising from the head of a quantified constraint - arising from the head of a quantified constraint + • Could not solve: ‘((x \/ y) \/ z) ⇒ (x \/ (y \/ z))’ arising from a use of ‘Dict’ - from the context: (x \/ y) \/ z - bound by a quantified context at T19921.hs:29:8-11 - or from: (x ⇒ r, (y \/ z) ⇒ r) - bound by a quantified context at T19921.hs:29:8-11 • In the expression: Dict In an equation for ‘dict’: dict = Dict + ===================================== testsuite/tests/quantified-constraints/T21006.stderr ===================================== @@ -1,8 +1,7 @@ - T21006.hs:14:10: error: [GHC-05617] - • Could not deduce ‘c’ - arising from the head of a quantified constraint + • Could not solve: ‘forall b (c :: Constraint). + (Determines b, Determines c) => + c’ arising from the superclasses of an instance declaration - from the context: (Determines b, Determines c) - bound by a quantified context at T21006.hs:14:10-15 • In the instance declaration for ‘OpCode’ + ===================================== testsuite/tests/typecheck/should_compile/T12427a.stderr ===================================== @@ -1,4 +1,3 @@ - T12427a.hs:17:29: error: [GHC-91028] • Couldn't match expected type ‘p’ with actual type ‘(forall b. [b] -> [b]) -> Int’ @@ -24,12 +23,11 @@ T12427a.hs:28:6: error: [GHC-91028] • In the pattern: T1 _ x1 In a pattern binding: T1 _ x1 = undefined -T12427a.hs:41:6: error: [GHC-25897] - • Couldn't match type ‘b’ with ‘[b]’ +T12427a.hs:41:6: error: [GHC-83865] + • Couldn't match type: forall b. [b] -> [b] + with: forall a. a -> a Expected: (forall b. [b] -> [b]) -> Int Actual: (forall a. a -> a) -> Int - ‘b’ is a rigid type variable bound by - the type [b] -> [b] - at T12427a.hs:41:1-19 • In the pattern: T1 _ x3 In a pattern binding: T1 _ x3 = undefined + ===================================== testsuite/tests/typecheck/should_fail/T14605.hs ===================================== @@ -6,6 +6,8 @@ -- -- The ticket #14605 has a much longer example that -- also fails; it does not use ImpredicativeTypes +-- +-- The error message is not great; but it's an obscure program module T14605 where ===================================== testsuite/tests/typecheck/should_fail/T14605.stderr ===================================== @@ -1,10 +1,8 @@ - -T14605.hs:14:13: error: [GHC-10283] - • Couldn't match representation of type ‘x’ with that of ‘()’ +T14605.hs:16:13: error: [GHC-18872] + • Couldn't match representation of type: forall x. () + with that of: forall x. x arising from a use of ‘coerce’ - ‘x’ is a rigid type variable bound by - the type () - at T14605.hs:14:1-49 • In the expression: coerce @(forall x. ()) @(forall x. x) In an equation for ‘duplicate’: duplicate = coerce @(forall x. ()) @(forall x. x) + ===================================== testsuite/tests/typecheck/should_fail/T15801.stderr ===================================== @@ -1,7 +1,6 @@ - -T15801.hs:52:10: error: [GHC-18872] - • Couldn't match representation of type: UnOp op_a -> UnOp b - with that of: op_a --> b - arising from the head of a quantified constraint +T15801.hs:52:10: error: [GHC-05617] + • Could not solve: ‘forall (op_a :: Op (*)) (b :: Op (*)). + op_a -#- b’ arising from the superclasses of an instance declaration • In the instance declaration for ‘OpRíki (Op (*))’ + ===================================== testsuite/tests/typecheck/should_fail/T18640a.stderr ===================================== @@ -1,9 +1,5 @@ - -T18640a.hs:12:1: error: [GHC-25897] - • Couldn't match kind ‘a’ with ‘*’ - Expected: forall (b :: k). * -> * - Actual: forall (b :: k). * -> a - ‘a’ is a rigid type variable bound by - the type family declaration for ‘F2’ - at T18640a.hs:12:17 +T18640a.hs:12:1: error: [GHC-83865] + • Couldn't match expected kind: forall (b :: k). * -> * + with actual kind: forall (b :: k). * -> a • In the type family declaration for ‘F2’ + ===================================== testsuite/tests/typecheck/should_fail/T18640b.stderr ===================================== @@ -1,12 +1,5 @@ - -T18640b.hs:14:10: error: [GHC-25897] - • Couldn't match kind ‘k’ with ‘a’ - Expected kind ‘forall b -> a’, but ‘F1’ has kind ‘forall k -> k’ - ‘k’ is a rigid type variable bound by - the type k - at T18640b.hs:14:3-11 - ‘a’ is a rigid type variable bound by - a family instance declaration - at T18640b.hs:14:6 +T18640b.hs:14:10: error: [GHC-83865] + • Expected kind ‘forall b -> a’, but ‘F1’ has kind ‘forall k -> k’ • In the type ‘F1’ In the type family declaration for ‘F3’ + ===================================== testsuite/tests/typecheck/should_fail/T19627.stderr ===================================== @@ -18,28 +18,3 @@ T19627.hs:108:3: error: [GHC-05617] Not (p a b) -> b <#- a In the class declaration for ‘Lol’ -T19627.hs:108:3: error: [GHC-05617] - • Could not deduce ‘Not (Not (p0 a1 b1)) ~ p0 a1 b1’ - arising from a superclass required to satisfy ‘Prop (p0 a1 b1)’, - arising from the head of a quantified constraint - arising from a superclass required to satisfy ‘Iso p0’, - arising from a superclass required to satisfy ‘Lol p0’, - arising from a type ambiguity check for - the type signature for ‘apartR’ - from the context: Lol p - bound by the type signature for: - apartR :: forall (p :: * -> * -> *) a b. - Lol p => - Not (p a b) -> b <#- a - at T19627.hs:108:3-34 - or from: (Prop a1, Prop b1) - bound by a quantified context at T19627.hs:108:3-34 - The type variable ‘p0’ is ambiguous - • In the ambiguity check for ‘apartR’ - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - When checking the class method: - apartR :: forall (p :: * -> * -> *) a b. - Lol p => - Not (p a b) -> b <#- a - In the class declaration for ‘Lol’ - ===================================== testsuite/tests/typecheck/should_fail/T21530b.stderr ===================================== @@ -1,8 +1,8 @@ - T21530b.hs:9:5: error: [GHC-83865] - • Couldn't match type: Eq a => a -> String - with: a -> String + • Couldn't match type: forall a. (Show a, Eq a) => a -> String + with: forall a. Show a => a -> String Expected: (forall a. Show a => a -> String) -> String Actual: (forall a. (Show a, Eq a) => a -> String) -> String • In the expression: f In an equation for ‘g’: g = f + ===================================== testsuite/tests/typecheck/should_fail/T22912.stderr ===================================== @@ -1,16 +1,6 @@ - -T22912.hs:17:16: error: [GHC-39999] - • Could not deduce ‘Implies c’ - arising from the head of a quantified constraint +T22912.hs:17:16: error: [GHC-05617] + • Could not solve: ‘Exactly (Implies c) => Implies c’ arising from a use of ‘go’ - from the context: Exactly (Implies c) - bound by a quantified context at T22912.hs:17:16-17 - Possible fix: - add (Implies c) to the context of - the type signature for: - anythingDict :: forall (c :: Constraint). Dict c - or If the constraint looks soluble from a superclass of the instance context, - read 'Undecidable instances and loopy superclasses' in the user manual • In the expression: go In an equation for ‘anythingDict’: anythingDict @@ -18,3 +8,4 @@ T22912.hs:17:16: error: [GHC-39999] where go :: (Exactly (Implies c) => Implies c) => Dict c go = Dict + ===================================== testsuite/tests/typecheck/should_fail/tcfail174.stderr ===================================== @@ -1,33 +1,22 @@ - -tcfail174.hs:20:14: error: [GHC-25897] - • Couldn't match type ‘a1’ with ‘a’ +tcfail174.hs:20:14: error: [GHC-83865] + • Couldn't match type: forall a1. a1 -> a1 + with: forall x. x -> a Expected: Capture (forall x. x -> a) Actual: Capture (forall a. a -> a) - ‘a1’ is a rigid type variable bound by - the type a -> a - at tcfail174.hs:20:1-14 - ‘a’ is a rigid type variable bound by - the inferred type of h1 :: Capture a - at tcfail174.hs:20:1-14 • In the first argument of ‘Capture’, namely ‘g’ In the expression: Capture g In an equation for ‘h1’: h1 = Capture g • Relevant bindings include h1 :: Capture a (bound at tcfail174.hs:20:1) -tcfail174.hs:23:14: error: [GHC-25897] - • Couldn't match type ‘a’ with ‘b’ +tcfail174.hs:23:14: error: [GHC-83865] + • Couldn't match type: forall a. a -> a + with: forall x. x -> b Expected: Capture (forall x. x -> b) Actual: Capture (forall a. a -> a) - ‘a’ is a rigid type variable bound by - the type a -> a - at tcfail174.hs:1:1 - ‘b’ is a rigid type variable bound by - the type signature for: - h2 :: forall b. Capture b - at tcfail174.hs:22:1-15 • In the first argument of ‘Capture’, namely ‘g’ In the expression: Capture g In an equation for ‘h2’: h2 = Capture g • Relevant bindings include h2 :: Capture b (bound at tcfail174.hs:23:1) + View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d433cb52777c4eb4784d29c5239722… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d433cb52777c4eb4784d29c5239722… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fendor/ann-frame] WIP: move iterator based stack decoder to ghc-internal
by Hannes Siebenhandl (＠fendor) 21 Jul '25

21 Jul '25

Hannes Siebenhandl pushed to branch wip/fendor/ann-frame at Glasgow Haskell Compiler / GHC Commits: f2e641b5 by fendor at 2025-07-21T12:28:50+02:00 WIP: move iterator based stack decoder to ghc-internal - - - - - 19 changed files: - libraries/ghc-experimental/src/GHC/Stack/Annotation/Experimental.hs - libraries/ghc-heap/GHC/Exts/Stack/Decode.hs - libraries/ghc-heap/tests/stack-annotation/ann_frame001.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 ===================================== @@ -23,28 +23,7 @@ import Data.Typeable import GHC.Exts import GHC.IO import GHC.Internal.Stack - --- ---------------------------------------------------------------------------- --- 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 +import GHC.Internal.Stack.Annotation data StringAnnotation where StringAnnotation :: String -> StringAnnotation ===================================== libraries/ghc-heap/GHC/Exts/Stack/Decode.hs ===================================== @@ -24,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 (..), ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame001.hs ===================================== @@ -14,7 +14,7 @@ hello x y = annotateShow (x,y) $ {-# NOINLINE decodeAndPrintAnnotationFrames #-} decodeAndPrintAnnotationFrames :: a -> a -decodeAndPrintAnnotationFrames a = unsafePerformIO $ do +decodeAndPrintAnnotationFrames !a = unsafePerformIO $ do stack <- GHC.Stack.CloneStack.cloneMyStack decoded <- GHC.Exts.Stack.Decode.decodeStack stack print [ displayStackAnnotation a ===================================== libraries/ghc-heap/tests/stack-annotation/ann_frame004.hs ===================================== @@ -1,6 +1,4 @@ - {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -ddump-to-file -ddump-stg-final -ddump-simpl -dsuppress-all #-} import Control.Monad import GHC.Stack.Types import Control.Exception @@ -9,21 +7,8 @@ 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" ===================================== 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 GHC.Internal.Stack.Types as GHC.Stack (CallStack) import qualified GHC.Internal.Stack as HCS 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. @@ -112,7 +115,7 @@ displayBacktraces bts = concat displayExec = unlines . map (indent 2 . flip ExecStack.showLocation "") . fromMaybe [] . ExecStack.stackFrames -- The unsafePerformIO here is safe as 'StackSnapshot' makes sure neither the stack frames nor -- references closures can be garbage collected. - displayIpe = unlines . map (indent 2 . CloneStack.prettyStackEntry) . unsafePerformIO . CloneStack.decode + displayIpe = unlines . map (indent 2 . Decode.prettyStackEntry) . unsafePerformIO . CloneStack.decode displayHsc = unlines . map (indent 2 . prettyCallSite) . HCS.getCallStack where prettyCallSite (f, loc) = f ++ ", called at " ++ HCS.prettySrcLoc loc ===================================== 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/-/commit/f2e641b5e405ab10c684bb955e54819… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f2e641b5e405ab10c684bb955e54819… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26115] 4 commits: Improve treatment of SPECIALISE pragmas -- again!
by Simon Peyton Jones (＠simonpj) 21 Jul '25

21 Jul '25

Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: 1b3d25dd by Simon Peyton Jones at 2025-07-21T10:51:20+01:00 Improve treatment of SPECIALISE pragmas -- again! This MR does another major refactor of the way that SPECIALISE pragmas work, to fix #26115, #26116, #26117. * We now /always/ solve forall-constraints in an all-or-nothing way. See Note [Solving a Wanted forall-constraint] in GHC.Tc.Solver.Solve This means we might have unsolved quantified constraints, which need to be reported. See `inert_insts` in `getUnsolvedInerts`. * I refactored the short-cut solver for type classes to work by recursively calling the solver rather than by having a little baby solver that kept being not clever enough. See Note [Shortcut solving] in GHC.Tc.Solver.Dict * I totally rewrote the desugaring of SPECIALISE pragmas, again. The new story is in Note [Desugaring new-form SPECIALISE pragmas] in GHC.HsToCore.Binds Both old-form and new-form SPECIALISE pragmas now route through the same function `dsSpec_help`. The tricky function `decomposeRuleLhs` is now used only for user-written RULES, not for SPECIALISE pragmas. * I improved `solveOneFromTheOther` to account for rewriter sets. Previously it would solve a non-rewritten dict from a rewritten one. For equalities we were already dealing with this, in Some incidental refactoring * A small refactor: `ebv_tcvs` in `EvBindsBar` now has a list of coercions, rather than a set of tyvars. We just delay taking the free vars. * GHC.Core.FVs.exprFVs now returns /all/ free vars. Use `exprLocalFVs` for Local vars. Reason: I wanted another variant for /evidence/ variables. * Ues `EvId` in preference to `EvVar`. (Evidence variables are always Ids.) Rename `isEvVar` to `isEvId`. * I moved `inert_safehask` out of `InertCans` and into `InertSet` where it more properly belongs. Compiler-perf changes: * There was a palpable bug (#26117) which this MR fixes in newWantedEvVar, which bypassed all the subtle overlapping-Given and shortcutting logic. (See the new `newWantedEvVar`.) Fixing this but leads to extra dictionary bindings; they are optimised away quickly but they made CoOpt_Read allocate 3.6% more. * Hpapily T15164 improves. * The net compiler-allocation change is 0.0% Metric Decrease: T15164 Metric Increase: CoOpt_Read T12425 - - - - - bdc68a92 by Simon Peyton Jones at 2025-07-21T10:54:13+01:00 Solve forall-constraints immediately, or not at all Triggered by the new short-cut solver, I realised that it is nicer to solve forall-constraints immediately, rather than emitting an implication constraint to be solved later. This is an un-forced refactoring, but it saves quite a bit of plumbing; e.g - The `wl_implics` field of `WorkList` is gone, - The types of `solveSimpleWanteds` and friends are simplified. - An EvFun contains binding, rather than an EvBindsVar ref-cell that will in the future contain bindings. That makes `evVarsOfTerm` simpler It also improves error messages a bit. One tiresome point: in the tricky case of `inferConstraintsCoerceBased` we make a forall-constraint. This we /do/ want to partially solve, so we can infer a suitable context. (I'd be quite happy to force the user to write a context, bt I don't want to change behavior.) So we want to generate an /implication/ constraint in `emitPredSpecConstraints` rather than a /forall-constraint/ as we were doing before. Incidental refactoring * `GHC.Tc.Deriv.Infer.inferConstraints` was consulting the state monad for the DerivEnv that the caller had just consulted. Nicer to pass it as an argument I think, so I have done that. No change in behaviour. - - - - - 521af58c by Simon Peyton Jones at 2025-07-21T10:54:13+01:00 Remove duplicated code in Ast.hs for evTermFreeVars This is just a tidy up. - - - - - d433cb52 by Simon Peyton Jones at 2025-07-21T10:54:13+01:00 Small tc-tracing changes only - - - - - 58 changed files: - compiler/GHC/Core.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Errors/Ppr.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Solver/Types.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/Var.hs - testsuite/tests/deriving/should_compile/T20815.hs - testsuite/tests/impredicative/T17332.stderr - testsuite/tests/quantified-constraints/T15290a.stderr - testsuite/tests/quantified-constraints/T19690.stderr - testsuite/tests/quantified-constraints/T19921.stderr - testsuite/tests/quantified-constraints/T21006.stderr - + testsuite/tests/simplCore/should_compile/T26115.hs - + testsuite/tests/simplCore/should_compile/T26115.stderr - + testsuite/tests/simplCore/should_compile/T26116.hs - + testsuite/tests/simplCore/should_compile/T26116.stderr - + testsuite/tests/simplCore/should_compile/T26117.hs - + testsuite/tests/simplCore/should_compile/T26117.stderr - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/typecheck/should_compile/T12427a.stderr - testsuite/tests/typecheck/should_compile/T23171.hs - testsuite/tests/typecheck/should_compile/TcSpecPragmas.stderr - testsuite/tests/typecheck/should_fail/T14605.hs - testsuite/tests/typecheck/should_fail/T14605.stderr - testsuite/tests/typecheck/should_fail/T15801.stderr - testsuite/tests/typecheck/should_fail/T18640a.stderr - testsuite/tests/typecheck/should_fail/T18640b.stderr - testsuite/tests/typecheck/should_fail/T19627.stderr - testsuite/tests/typecheck/should_fail/T21530b.stderr - testsuite/tests/typecheck/should_fail/T22912.stderr - testsuite/tests/typecheck/should_fail/tcfail174.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e7e9dcb4637b98f1cadbf6bf4cdc63… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/e7e9dcb4637b98f1cadbf6bf4cdc63… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26115] 12 commits: x86 NCG: Better lowering for shuffleFloatX4# and shuffleDoubleX2#
by Simon Peyton Jones (＠simonpj) 21 Jul '25

21 Jul '25

Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: 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 - - - - - 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 - - - - - 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 - - - - - 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. - - - - - bfb4afec by Simon Peyton Jones at 2025-07-21T10:09:41+01:00 Renaming around predicate types .. we were (as it turned out) abstracting over type-class selectors in SPECIALISATION rules! Wibble isEqPred - - - - - f07cefb5 by Simon Peyton Jones at 2025-07-21T10:50:28+01:00 Refactor of Specialise.hs This patch just tidies up `specHeader` a bit, removing one of its many results, and adding some comments. No change in behaviour. Also add a few more `HasDebugCallStack` contexts. - - - - - 475dd9b4 by Simon Peyton Jones at 2025-07-21T10:50:28+01:00 Improve treatment of SPECIALISE pragmas -- again! This MR does another major refactor of the way that SPECIALISE pragmas work, to fix #26115, #26116, #26117. * We now /always/ solve forall-constraints in an all-or-nothing way. See Note [Solving a Wanted forall-constraint] in GHC.Tc.Solver.Solve This means we might have unsolved quantified constraints, which need to be reported. See `inert_insts` in `getUnsolvedInerts`. * I refactored the short-cut solver for type classes to work by recursively calling the solver rather than by having a little baby solver that kept being not clever enough. See Note [Shortcut solving] in GHC.Tc.Solver.Dict * I totally rewrote the desugaring of SPECIALISE pragmas, again. The new story is in Note [Desugaring new-form SPECIALISE pragmas] in GHC.HsToCore.Binds Both old-form and new-form SPECIALISE pragmas now route through the same function `dsSpec_help`. The tricky function `decomposeRuleLhs` is now used only for user-written RULES, not for SPECIALISE pragmas. * I improved `solveOneFromTheOther` to account for rewriter sets. Previously it would solve a non-rewritten dict from a rewritten one. For equalities we were already dealing with this, in Some incidental refactoring * A small refactor: `ebv_tcvs` in `EvBindsBar` now has a list of coercions, rather than a set of tyvars. We just delay taking the free vars. * GHC.Core.FVs.exprFVs now returns /all/ free vars. Use `exprLocalFVs` for Local vars. Reason: I wanted another variant for /evidence/ variables. * Ues `EvId` in preference to `EvVar`. (Evidence variables are always Ids.) Rename `isEvVar` to `isEvId`. * I moved `inert_safehask` out of `InertCans` and into `InertSet` where it more properly belongs. - - - - - 8c6b9463 by Simon Peyton Jones at 2025-07-21T10:50:28+01:00 Solve forall-constraints immediately, or not at all Triggered by the new short-cut solver, I realised that it is nicer to solve forall-constraints immediately, rather than emitting an implication constraint to be solved later. This is an un-forced refactoring, but it saves quite a bit of plumbing; e.g - The `wl_implics` field of `WorkList` is gone, - The types of `solveSimpleWanteds` and friends are simplified. - An EvFun contains binding, rather than an EvBindsVar ref-cell that will in the future contain bindings. That makes `evVarsOfTerm` simpler It also improves error messages a bit. One tiresome point: in the tricky case of `inferConstraintsCoerceBased` we make a forall-constraint. This we /do/ want to partially solve, so we can infer a suitable context. (I'd be quite happy to force the user to write a context, bt I don't want to change behavior.) So we want to generate an /implication/ constraint in `emitPredSpecConstraints` rather than a /forall-constraint/ as we were doing before. Incidental refactoring * `GHC.Tc.Deriv.Infer.inferConstraints` was consulting the state monad for the DerivEnv that the caller had just consulted. Nicer to pass it as an argument I think, so I have done that. No change in behaviour. - - - - - a66459c2 by Simon Peyton Jones at 2025-07-21T10:50:28+01:00 Remove duplicated code in Ast.hs for evTermFreeVars This is just a tidy up. - - - - - e7e9dcb4 by Simon Peyton Jones at 2025-07-21T10:50:28+01:00 Small tc-tracing changes only - - - - - 97 changed files: - .gitlab/rel_eng/fetch-gitlab-artifacts/fetch_gitlab.py - compiler/GHC/CmmToAsm/X86/CodeGen.hs - compiler/GHC/CmmToAsm/X86/Instr.hs - compiler/GHC/CmmToAsm/X86/Ppr.hs - compiler/GHC/Core.hs - compiler/GHC/Core/FVs.hs - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/Subst.hs - compiler/GHC/Core/TyCo/Rep.hs - compiler/GHC/Core/Unfold/Make.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Errors/Ppr.hs - compiler/GHC/HsToCore/Pmc/Solver/Types.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Parser.y - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Default.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Solver/Rewrite.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Solver/Types.hs - compiler/GHC/Tc/TyCl/PatSyn.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcMType.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Validity.hs - compiler/GHC/Tc/Zonk/Type.hs - compiler/GHC/Types/Var.hs - docs/users_guide/9.14.1-notes.rst - libraries/base/changelog.md - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/GHC/Weak/Finalize.hs - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - testsuite/tests/deriving/should_compile/T20815.hs - testsuite/tests/impredicative/T17332.stderr - 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 - testsuite/tests/printer/Makefile - + testsuite/tests/printer/TestLevelImports.hs - + testsuite/tests/printer/TestNamedDefaults.hs - testsuite/tests/printer/all.T - testsuite/tests/quantified-constraints/T15290a.stderr - testsuite/tests/quantified-constraints/T19690.stderr - testsuite/tests/quantified-constraints/T19921.stderr - testsuite/tests/quantified-constraints/T21006.stderr - 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/simplCore/should_compile/T26115.hs - + testsuite/tests/simplCore/should_compile/T26115.stderr - + testsuite/tests/simplCore/should_compile/T26116.hs - + testsuite/tests/simplCore/should_compile/T26116.stderr - + testsuite/tests/simplCore/should_compile/T26117.hs - + testsuite/tests/simplCore/should_compile/T26117.stderr - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/typecheck/should_compile/T12427a.stderr - testsuite/tests/typecheck/should_compile/T23171.hs - testsuite/tests/typecheck/should_compile/TcSpecPragmas.stderr - testsuite/tests/typecheck/should_fail/T14605.hs - testsuite/tests/typecheck/should_fail/T14605.stderr - testsuite/tests/typecheck/should_fail/T15801.stderr - testsuite/tests/typecheck/should_fail/T18640a.stderr - testsuite/tests/typecheck/should_fail/T18640b.stderr - testsuite/tests/typecheck/should_fail/T19627.stderr - testsuite/tests/typecheck/should_fail/T21530b.stderr - testsuite/tests/typecheck/should_fail/T22912.stderr - testsuite/tests/typecheck/should_fail/tcfail174.stderr - utils/check-exact/ExactPrint.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/13986e8d787ab795c621c4b37734a9… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/13986e8d787ab795c621c4b37734a9… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Add Data.List.NonEmpty.mapMaybe
by Marge Bot (＠marge-bot) 21 Jul '25

21 Jul '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job 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 - - - - - 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 - - - - - 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. - - - - - e2ed9a3f by Matthew Pickering at 2025-07-21T05:46:13-04:00 level imports: Fix infinite loop with cyclic module imports I didn't anticipate that downsweep would run before we checked for cyclic imports. Therefore we need to use the reachability function which handles cyclic graphs. Fixes #26087 - - - - - 9480fe96 by Pierre Thierry at 2025-07-21T05:46:16-04:00 Fix documentation about deriving from generics - - - - - 20 changed files: - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Parser.y - compiler/GHC/Unit/Module/Graph.hs - libraries/base/changelog.md - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/GHC/Generics.hs - libraries/base/src/GHC/Weak/Finalize.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 - testsuite/tests/printer/Makefile - + testsuite/tests/printer/TestLevelImports.hs - + testsuite/tests/printer/TestNamedDefaults.hs - testsuite/tests/printer/all.T - + testsuite/tests/splice-imports/T26087.stderr - + testsuite/tests/splice-imports/T26087A.hs - + testsuite/tests/splice-imports/T26087B.hs - testsuite/tests/splice-imports/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) } ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -866,7 +866,7 @@ mkTransZeroDeps = first graphReachability {- module graph is acyclic -} . module -- | Transitive dependencies, but with the stage that each module is required at. mkStageDeps :: [ModuleGraphNode] -> (ReachabilityIndex StageSummaryNode, (NodeKey, ModuleStage) -> Maybe StageSummaryNode) -mkStageDeps = first graphReachability . moduleGraphNodesStages +mkStageDeps = first cyclicGraphReachability . moduleGraphNodesStages type ZeroSummaryNode = Node Int ZeroScopeKey ===================================== libraries/base/changelog.md ===================================== @@ -1,6 +1,11 @@ # 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* + * 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/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 ===================================== libraries/base/src/GHC/Generics.hs ===================================== @@ -392,9 +392,14 @@ module GHC.Generics ( -- instance (Encode a) => Encode (Tree a) -- @ -- --- The generic default is being used. In the future, it will hopefully be --- possible to use @deriving Encode@ as well, but GHC does not yet support --- that syntax for this situation. +-- The generic default is being used. Alternatively the @DeriveAnyClass@ language extension can be +-- used to derive Encode: +-- +-- @ +-- {-# LANGUAGE DeriveAnyClass #-} +-- data Tree a = Leaf a | Node (Tree a) (Tree a) +-- deriving (Generic, Encode) +-- @ -- -- Having @Encode@ as a class has the advantage that we can define -- non-generic special cases, which is particularly useful for abstract ===================================== 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 ===================================== 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 ===================================== 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 ===================================== testsuite/tests/splice-imports/T26087.stderr ===================================== @@ -0,0 +1,6 @@ +./T26087B.hs: error: [GHC-92213] + Module graph contains a cycle: + module ‘main:T26087B’ (./T26087B.hs) + imports module ‘main:T26087A’ (T26087A.hs) + which imports module ‘main:T26087B’ (./T26087B.hs) + ===================================== testsuite/tests/splice-imports/T26087A.hs ===================================== @@ -0,0 +1,4 @@ +{-# LANGUAGE ExplicitLevelImports #-} +module T26087A where + +import quote T26087B ===================================== testsuite/tests/splice-imports/T26087B.hs ===================================== @@ -0,0 +1,4 @@ +{-# LANGUAGE ExplicitLevelImports, TemplateHaskell #-} +module T26087B where + +import T26087A ===================================== testsuite/tests/splice-imports/all.T ===================================== @@ -46,3 +46,4 @@ test('SI35', compile_and_run, ['-package ghc']) test('SI36', [extra_files(["SI36_A.hs", "SI36_B1.hs", "SI36_B2.hs", "SI36_B3.hs", "SI36_C1.hs", "SI36_C2.hs", "SI36_C3.hs"])], multimod_compile_fail, ['SI36', '-v0']) +test('T26087', [], multimod_compile_fail, ['T26087A', '']) ===================================== 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/-/compare/6e97e52bd33432a41c9257e5098248… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6e97e52bd33432a41c9257e5098248… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] more changes to printing origin
by Apoorv Ingle (＠ani) 21 Jul '25

21 Jul '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 34a46b7b by Apoorv Ingle at 2025-07-20T22:17:21-05:00 more changes to printing origin - - - - - 2 changed files: - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Types/Origin.hs Changes: ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -22,7 +22,7 @@ import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence import GHC.Tc.Types.CtLoc -import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) ) +import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(ExpansionOrigin) ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst, FamInstEnvs ) import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) ) @@ -61,7 +61,7 @@ import GHC.Data.Maybe ( expectJust ) import GHC.Unit.Module.Warnings -import GHC.Hs.Extension +import GHC.Hs import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import GHC.Types.Id.Info @@ -1327,7 +1327,7 @@ warnIncompleteRecSel dflags sel_id ct_loc -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin, -- despite the expansion to (getField @"x" r) - isGetFieldOrigin (GetFieldOrigin {}) = True + isGetFieldOrigin (ExpansionOrigin (OrigExpr (HsGetField {}))) = True isGetFieldOrigin _ = False lookupHasFieldLabel ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -783,10 +783,7 @@ lexprCtOrigin (L _ e) = exprCtOrigin e exprCtOrigin :: HsExpr GhcRn -> CtOrigin exprCtOrigin (HsVar _ (L _ (WithUserRdr _ name))) = OccurrenceOf name -exprCtOrigin e@(HsGetField _ _ (L _ _)) = ExpansionOrigin (OrigExpr e) - -- GetFieldOrigin (field_label $ unLoc $ dfoLabel f) exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l -exprCtOrigin (ExplicitList {}) = ListOrigin exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" @@ -796,18 +793,15 @@ exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op exprCtOrigin (NegApp _ e _) = lexprCtOrigin e exprCtOrigin (HsPar _ e) = lexprCtOrigin e -exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e) exprCtOrigin (SectionL _ _ _) = SectionOrigin exprCtOrigin (SectionR _ _ _) = SectionOrigin exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches -exprCtOrigin (HsIf {}) = IfThenElseOrigin exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e exprCtOrigin (HsDo {}) = DoStmtOrigin exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" -exprCtOrigin (RecordUpd{}) = RecordUpdOrigin exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" exprCtOrigin (HsPragE _ _ e) = lexprCtOrigin e @@ -822,6 +816,11 @@ exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression" exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms] exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms] exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms] +exprCtOrigin e@(ExplicitList {}) = ExpansionOrigin (OrigExpr e) +exprCtOrigin e@(HsIf {}) = ExpansionOrigin (OrigExpr e) +exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e) +exprCtOrigin e@(RecordUpd{}) = ExpansionOrigin (OrigExpr e) +exprCtOrigin e@(HsGetField{}) = ExpansionOrigin (OrigExpr e) exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f) @@ -868,8 +867,10 @@ pprCtOrigin (ExpansionOrigin o) OrigExpr (HsGetField _ _ (L _ f)) -> hsep [text "selecting the field", quotes (ppr f)] OrigExpr (HsOverLabel _ l) -> - hsep [text "the overloaded label" ,quotes (char '#' <> ppr l)] - OrigExpr e@(RecordUpd{}) -> hsep [text "a record update" <+> quotes (ppr e) ] + hsep [text "the overloaded label" , quotes (char '#' <> ppr l)] + OrigExpr (RecordUpd{}) -> text "a record update" + OrigExpr (ExplicitList{}) -> text "an overloaded list" + OrigExpr (HsIf{}) -> text "an if-then-else expression" OrigExpr e -> text "the expression" <+> (ppr e) pprCtOrigin (GivenSCOrigin sk d blk) @@ -1088,7 +1089,11 @@ pprCtO (WantedSuperclassOrigin {}) = text "a superclass constraint" pprCtO (InstanceSigOrigin {}) = text "a type signature in an instance" pprCtO (AmbiguityCheckOrigin {}) = text "a type ambiguity check" pprCtO (ImpedanceMatching {}) = text "combining required constraints" -pprCtO (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)] +pprCtO (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern", quotes (ppr pat)] +pprCtO (ExpansionOrigin (OrigExpr (HsOverLabel _ l))) = hsep [text "the overloaded label", quotes (char '#' <> ppr l)] +pprCtO (ExpansionOrigin (OrigExpr (RecordUpd{}))) = text "a record update" +pprCtO (ExpansionOrigin (OrigExpr (ExplicitList{}))) = text "an overloaded list" +pprCtO (ExpansionOrigin (OrigExpr (HsIf{}))) = text "an if-then-else expression" pprCtO (ExpansionOrigin (OrigExpr e)) = text "an expression" <+> ppr e pprCtO (ExpansionOrigin (OrigStmt{})) = text "a do statement" pprCtO (ExpansionOrigin (OrigPat{})) = text "a pattern" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/34a46b7b606a90b4e2f83f23eecaecb… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/34a46b7b606a90b4e2f83f23eecaecb… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] more changes to printing origin
by Apoorv Ingle (＠ani) 21 Jul '25

21 Jul '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: 6898bc9d by Apoorv Ingle at 2025-07-20T19:58:03-05:00 more changes to printing origin - - - - - 2 changed files: - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Types/Origin.hs Changes: ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -22,7 +22,7 @@ import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence import GHC.Tc.Types.CtLoc -import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(GetFieldOrigin) ) +import GHC.Tc.Types.Origin ( InstanceWhat (..), SafeOverlapping, CtOrigin(ExpansionOrigin) ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst, FamInstEnvs ) import GHC.Rename.Env( addUsedGRE, addUsedDataCons, DeprecationWarnings (..) ) @@ -61,7 +61,7 @@ import GHC.Data.Maybe ( expectJust ) import GHC.Unit.Module.Warnings -import GHC.Hs.Extension +import GHC.Hs import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import GHC.Types.Id.Info @@ -1327,7 +1327,7 @@ warnIncompleteRecSel dflags sel_id ct_loc -- GHC.Tc.Gen.App.tcInstFun arranges that the CtOrigin of (r.x) is GetFieldOrigin, -- despite the expansion to (getField @"x" r) - isGetFieldOrigin (GetFieldOrigin {}) = True + isGetFieldOrigin (ExpansionOrigin (OrigExpr (HsGetField {}))) = True isGetFieldOrigin _ = False lookupHasFieldLabel ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -783,10 +783,7 @@ lexprCtOrigin (L _ e) = exprCtOrigin e exprCtOrigin :: HsExpr GhcRn -> CtOrigin exprCtOrigin (HsVar _ (L _ (WithUserRdr _ name))) = OccurrenceOf name -exprCtOrigin e@(HsGetField _ _ (L _ _)) = ExpansionOrigin (OrigExpr e) - -- GetFieldOrigin (field_label $ unLoc $ dfoLabel f) exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l -exprCtOrigin (ExplicitList {}) = ListOrigin exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" @@ -796,18 +793,15 @@ exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op exprCtOrigin (NegApp _ e _) = lexprCtOrigin e exprCtOrigin (HsPar _ e) = lexprCtOrigin e -exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e) exprCtOrigin (SectionL _ _ _) = SectionOrigin exprCtOrigin (SectionR _ _ _) = SectionOrigin exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches -exprCtOrigin (HsIf {}) = IfThenElseOrigin exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e exprCtOrigin (HsDo {}) = DoStmtOrigin exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" -exprCtOrigin (RecordUpd{}) = RecordUpdOrigin exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" exprCtOrigin (HsPragE _ _ e) = lexprCtOrigin e @@ -822,6 +816,12 @@ exprCtOrigin (HsHole _) = Shouldn'tHappenOrigin "hole expression" exprCtOrigin (HsForAll {}) = Shouldn'tHappenOrigin "forall telescope" -- See Note [Types in terms] exprCtOrigin (HsQual {}) = Shouldn'tHappenOrigin "constraint context" -- See Note [Types in terms] exprCtOrigin (HsFunArr {}) = Shouldn'tHappenOrigin "function arrow" -- See Note [Types in terms] +exprCtOrigin e@(HsProjection _ _) = ExpansionOrigin (OrigExpr e) +exprCtOrigin e@(ExplicitList {}) = ExpansionOrigin (OrigExpr e) +exprCtOrigin e@(HsIf {}) = ExpansionOrigin (OrigExpr e) +exprCtOrigin e@(RecordUpd{}) = ExpansionOrigin (OrigExpr e) +exprCtOrigin e@(HsGetField{}) = ExpansionOrigin (OrigExpr e) + -- GetFieldOrigin (field_label $ unLoc $ dfoLabel f) exprCtOrigin (XExpr (ExpandedThingRn o _)) = ExpansionOrigin o exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e exprCtOrigin (XExpr (HsRecSelRn f)) = OccurrenceOfRecSel (foExt f) @@ -869,7 +869,9 @@ pprCtOrigin (ExpansionOrigin o) hsep [text "selecting the field", quotes (ppr f)] OrigExpr (HsOverLabel _ l) -> hsep [text "the overloaded label" ,quotes (char '#' <> ppr l)] - OrigExpr e@(RecordUpd{}) -> hsep [text "a record update" <+> quotes (ppr e) ] + OrigExpr (RecordUpd{}) -> hsep [text "a record update"] + OrigExpr (ExplicitList{}) -> text "an overloaded list" + OrigExpr (HsIf{}) -> text "an if-then-else expression" OrigExpr e -> text "the expression" <+> (ppr e) pprCtOrigin (GivenSCOrigin sk d blk) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6898bc9de8d412f2b7d2b75a7c54eb2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6898bc9de8d412f2b7d2b75a7c54eb2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/spj-apporv-Oct24] 65 commits: Specialise: Improve specialisation by refactoring interestingDict
by Apoorv Ingle (＠ani) 21 Jul '25

21 Jul '25

Apoorv Ingle pushed to branch wip/spj-apporv-Oct24 at Glasgow Haskell Compiler / GHC Commits: f707bab4 by Andreas Klebinger at 2025-07-12T14:56:16+01:00 Specialise: Improve specialisation by refactoring interestingDict This MR addresses #26051, which concerns missed type-class specialisation. The main payload of the MR is to completely refactor the key function `interestingDict` in GHC.Core.Opt.Specialise The main change is that we now also look at the structure of the dictionary we consider specializing on, rather than only the type. See the big `Note [Interesting dictionary arguments]` - - - - - ca7a9d42 by Simon Peyton Jones at 2025-07-12T14:56:16+01:00 Treat tuple dictionaries uniformly; don't unbox them See `Note [Do not unbox class dictionaries]` in DmdAnal.hs, sep (DNB1). This MR reverses the plan in #23398, which suggested a special case to unbox tuple dictionaries in worker/wrapper. But: - This was the cause of a pile of complexity in the specialiser (#26158) - Even with that complexity, specialision was still bad, very bad See https://gitlab.haskell.org/ghc/ghc/-/issues/19747#note_626297 And it's entirely unnecessary! Specialision works fine without unboxing tuple dictionaries. - - - - - be7296c9 by Andreas Klebinger at 2025-07-12T14:56:16+01:00 Remove complex special case from the type-class specialiser There was a pretty tricky special case in Specialise which is no longer necessary. * Historical Note [Floating dictionaries out of cases] * #26158 * #19747 https://gitlab.haskell.org/ghc/ghc/-/issues/19747#note_626297 This MR removes it. Hooray. - - - - - 4acf3a86 by Ben Gamari at 2025-07-15T05:46:32-04:00 configure: bump version to 9.15 - - - - - 45efaf71 by Teo Camarasu at 2025-07-15T05:47:13-04:00 rts/nonmovingGC: remove n_free We remove the nonmovingHeap.n_free variable. We wanted this to track the length of nonmovingHeap.free. But this isn't possible to do atomically. When this isn't accurate we can get a segfault by going past the end of the list. Instead, we just count the length of the list when we grab it in nonmovingPruneFreeSegment. Resolves #26186 - - - - - c635f164 by Ben Gamari at 2025-07-15T14:05:54-04:00 configure: Drop probing of ld.gold As noted in #25716, `gold` has been dropped from binutils-2.44. Fixes #25716. Metric Increase: size_hello_artifact_gzip size_hello_unicode_gzip ghc_prim_so - - - - - 637bb538 by Ben Gamari at 2025-07-15T14:05:55-04:00 testsuite/recomp015: Ignore stderr This is necessary since ld.bfd complains that we don't have a .note.GNU-stack section, potentially resulting in an executable stack. - - - - - d3cd4ec8 by Wen Kokke at 2025-07-15T14:06:39-04:00 Fix documentation for heap profile ID - - - - - 73082769 by Ben Gamari at 2025-07-15T16:56:38-04:00 Bump win32-tarballs to v0.9 - - - - - 3b63b254 by Ben Gamari at 2025-07-15T16:56:39-04:00 rts/LoadArchive: Handle null terminated string tables As of `llvm-ar` now emits filename tables terminated with null characters instead of the usual POSIX `/\n` sequence. Fixes #26150. - - - - - 195f6527 by Tamar Christina at 2025-07-15T16:56:39-04:00 rts: rename label so name doesn't conflict with param - - - - - 63373b95 by Tamar Christina at 2025-07-15T16:56:39-04:00 rts: Handle API set symbol versioning conflicts - - - - - 48e9aa3e by Tamar Christina at 2025-07-15T16:56:39-04:00 rts: Mark API set symbols as HIDDEN and correct symbol type - - - - - 959e827a by Tamar Christina at 2025-07-15T16:56:39-04:00 rts: Implement WEAK EXTERNAL undef redirection by target symbol name - - - - - 65f19293 by Ben Gamari at 2025-07-15T16:56:39-04:00 rts/LoadArchive: Handle string table entries terminated with / llvm-ar appears to terminate string table entries with `/\n` [1]. This matters in the case of thin archives, since the filename is used. In the past this worked since `llvm-ar` would produce archives with "small" filenames when possible. However, now it appears to always use the string table. [1] https://github.com/llvm/llvm-project/blob/bfb686bb5ba503e9386dc899e1ebbe248… - - - - - 9cbb3ef5 by Ben Gamari at 2025-07-15T16:56:39-04:00 testsuite: Mark T12497 as fixed Thanks to the LLVM toolchain update. Closes #22694. - - - - - 2854407e by Ben Gamari at 2025-07-15T16:56:39-04:00 testsuite: Accept new output of T11223_link_order_a_b_2_fail on Windows The archive member number changed due to the fact that llvm-ar now uses a string table. - - - - - 28439593 by Ben Gamari at 2025-07-15T16:56:39-04:00 rts/linker/PEi386: Implement IMAGE_REL_AMD64_SECREL This appears to now be used by libc++ as distributed by msys2. - - - - - 2b053755 by Tamar Christina at 2025-07-15T16:56:39-04:00 rts: Cleanup merge resolution residue in lookupSymbolInDLL_PEi386 and make safe without dependent - - - - - e8acd2e7 by Wen Kokke at 2025-07-16T08:37:04-04:00 Remove the `profile_id` parameter from various RTS functions. Various RTS functions took a `profile_id` parameter, intended to be used to distinguish parallel heap profile breakdowns (e.g., `-hT` and `-hi`). However, this feature was never implemented and the `profile_id` parameter was set to 0 throughout the RTS. This commit removes the parameter but leaves the hardcoded profile ID in the functions that emit the encoded eventlog events as to not change the protocol. The affected functions are `traceHeapProfBegin`, `postHeapProfBegin`, `traceHeapProfSampleString`, `postHeapProfSampleString`, `traceHeapProfSampleCostCentre`, and `postHeapProfSampleCostCentre`. - - - - - 76d392a2 by Wen Kokke at 2025-07-16T08:37:04-04:00 Make `traceHeapProfBegin` an init event. - - - - - 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 - - - - - 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 - - - - - 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 - - - - - 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. - - - - - d70843f8 by Apoorv Ingle at 2025-07-20T18:41:01-05:00 - Remove one `SrcSpan` field from `VAExpansion`. It is no longer needed. - Make `tcExpr` take a `Maybe HsThingRn` which will be passed on to tcApp and used by splitHsApps to determine a more accurate `AppCtx` - `tcXExpr` is less hacky now - do not look through HsExpansion applications - kill OrigPat and remove HsThingRn From VAExpansion - look through XExpr ExpandedThingRn while inferring type of head - always set in generated code after stepping inside a ExpandedThingRn - fixing record update error messages - remove special case of tcbody from tcLambdaMatches - wrap last stmt expansion in a HsPar so that the error messages are prettier - remove special case of dsExpr for ExpandedThingTc - make EExpand (HsExpr GhcRn) instead of EExpand HsThingRn - fixing error messages for rebindable - - - - - 2b3c8450 by Apoorv Ingle at 2025-07-20T18:41:01-05:00 fix the case where head of the application chain is an expanded expression and the argument is a type application c.f. T19167.hs - - - - - d8f3dfc0 by Apoorv Ingle at 2025-07-20T18:41:01-05:00 move setQLInstLevel inside tcInstFun - - - - - 33e11348 by Apoorv Ingle at 2025-07-20T18:41:01-05:00 ignore ds warnings originating from gen locations - - - - - 5acb3cfc by Apoorv Ingle at 2025-07-20T18:41:01-05:00 filter expr stmts error msgs - - - - - c30a3c45 by Apoorv Ingle at 2025-07-20T18:41:01-05:00 exception for AppDo while making error ctxt - - - - - ada43b1d by Apoorv Ingle at 2025-07-20T18:41:01-05:00 moving around things for locations and error ctxts - - - - - 46475c66 by Apoorv Ingle at 2025-07-20T18:41:01-05:00 popErrCtxt doesn't push contexts and popErrCtxts in the first argument to bind and >> in do expansion statements - - - - - de83f212 by Apoorv Ingle at 2025-07-20T18:41:01-05:00 accept test cases with changed error messages ------------------------- Metric Decrease: T9020 ------------------------- - - - - - 083bc8d2 by Apoorv Ingle at 2025-07-20T18:41:01-05:00 look through PopErrCtxt while splitting exprs in application chains - - - - - 25f07892 by Apoorv Ingle at 2025-07-20T18:41:01-05:00 check the right origin for record selector incomplete warnings - - - - - 7ea6be0b by Apoorv Ingle at 2025-07-20T18:41:02-05:00 kill VAExpansion - - - - - c35b44bb by Apoorv Ingle at 2025-07-20T18:41:02-05:00 pass CtOrigin to tcApp for instantiateSigma - - - - - 029d3acf by Apoorv Ingle at 2025-07-20T18:41:02-05:00 do not suppress pprArising - - - - - 6929668d by Apoorv Ingle at 2025-07-20T18:41:02-05:00 kill VACall - - - - - db7bc4df by Apoorv Ingle at 2025-07-20T18:41:02-05:00 kill AppCtxt - - - - - 7b38504e by Apoorv Ingle at 2025-07-20T18:41:02-05:00 remove addHeadCtxt - - - - - 912e2d00 by Apoorv Ingle at 2025-07-20T18:41:02-05:00 fix pprArising for MonadFailErrors - - - - - eabead83 by Apoorv Ingle at 2025-07-20T18:41:02-05:00 rename ctxt to sloc - - - - - d5112e07 by Apoorv Ingle at 2025-07-20T18:41:02-05:00 fix RepPolyDoBind error message herald - - - - - 03e70c9e by Apoorv Ingle at 2025-07-20T18:41:02-05:00 SrcCodeCtxt more changes - - - - - 6ca2b543 by Apoorv Ingle at 2025-07-20T18:41:02-05:00 make tcl_in_gen_code a SrcCodeCtxt and rename DoOrigin to DoStmtOrigin - - - - - 612cade9 by Apoorv Ingle at 2025-07-20T18:41:02-05:00 make error messages for records saner - - - - - 508feefc by Apoorv Ingle at 2025-07-20T18:41:02-05:00 accept the right test output - - - - - 8737968e by Apoorv Ingle at 2025-07-20T18:41:02-05:00 make make sure to set inGenerated code for RecordUpdate checks - - - - - 00d11910 by Apoorv Ingle at 2025-07-20T18:41:02-05:00 rename HsThingRn to SrcCodeOrigin - - - - - e131f506 by Apoorv Ingle at 2025-07-20T18:41:02-05:00 minor lclenv getter setter changes - - - - - 4ce0eb71 by Apoorv Ingle at 2025-07-20T18:41:02-05:00 fix exprCtOrigin for HsProjection case. It was assigned to be SectionOrigin, but it should be GetFieldOrigin - - - - - 67b74b00 by Apoorv Ingle at 2025-07-20T18:41:02-05:00 undo test changes - - - - - 185dcfee by Apoorv Ingle at 2025-07-20T18:41:02-05:00 fix unused do binding warning error location - - - - - 4e1e9835 by Apoorv Ingle at 2025-07-20T18:41:02-05:00 FRRRecordUpdate message change - - - - - 2107f858 by Apoorv Ingle at 2025-07-20T18:41:02-05:00 - kill tcl_in_gen_code - It is subsumed by `ErrCtxtStack` which keep tracks of `ErrCtxt` and code ctxt - - - - - 906ce0f1 by Apoorv Ingle at 2025-07-20T18:41:02-05:00 kill ExpectedFunTyOrig - - - - - ad0ff7a9 by Apoorv Ingle at 2025-07-20T18:41:02-05:00 update argument position number of CtOrigin - - - - - 285c65c4 by Apoorv Ingle at 2025-07-20T18:41:02-05:00 fix suggestion in error message for record field and modify herald everywhere - - - - - 18b66c85 by Apoorv Ingle at 2025-07-20T19:12:15-05:00 new CtOrigin ExpectedTySyntax - - - - - 121 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/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Predicate.hs - compiler/GHC/Hs.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/ImpExp.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - compiler/GHC/HsToCore/Pmc.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Parser.y - compiler/GHC/Rename/Expr.hs - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - + compiler/GHC/Tc/Gen/App.hs-boot - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Expr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Gen/Match.hs - compiler/GHC/Tc/Gen/Pat.hs - compiler/GHC/Tc/Solver.hs - compiler/GHC/Tc/Solver/Dict.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Types/LclEnv.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Utils/Unify.hs - + compiler/hie.yaml - configure.ac - docs/users_guide/9.14.1-notes.rst - docs/users_guide/eventlog-formats.rst - docs/users_guide/profiling.rst - libraries/base/changelog.md - libraries/base/src/Data/List/NonEmpty.hs - libraries/base/src/GHC/Weak/Finalize.hs - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - m4/find_ld.m4 - mk/get-win32-tarballs.py - rts/ProfHeap.c - rts/RetainerSet.c - rts/Trace.c - rts/Trace.h - rts/eventlog/EventLog.c - rts/eventlog/EventLog.h - rts/linker/LoadArchive.c - rts/linker/PEi386.c - rts/sm/NonMoving.c - rts/sm/NonMoving.h - rts/sm/NonMovingAllocate.c - rts/sm/Sanity.c - testsuite/tests/default/default-fail05.stderr - testsuite/tests/dmdanal/should_compile/T23398.hs - testsuite/tests/dmdanal/should_compile/T23398.stderr - testsuite/tests/driver/recomp015/all.T - testsuite/tests/indexed-types/should_fail/T2693.stderr - testsuite/tests/indexed-types/should_fail/T5439.stderr - 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 - + testsuite/tests/perf/should_run/SpecTyFamRun.hs - + testsuite/tests/perf/should_run/SpecTyFamRun.stdout - + testsuite/tests/perf/should_run/SpecTyFam_Import.hs - testsuite/tests/perf/should_run/all.T - testsuite/tests/plugins/test-defaulting-plugin.stderr - testsuite/tests/polykinds/T13393.stderr - testsuite/tests/printer/Makefile - testsuite/tests/printer/T17697.stderr - + testsuite/tests/printer/TestLevelImports.hs - + testsuite/tests/printer/TestNamedDefaults.hs - testsuite/tests/printer/all.T - testsuite/tests/rep-poly/RepPolyRecordUpdate.stderr - testsuite/tests/rts/all.T - testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-32-mingw32 - testsuite/tests/rts/linker/T11223/T11223_link_order_a_b_2_fail.stderr-ws-64-mingw32 - 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/simplCore/should_compile/T26051.hs - + testsuite/tests/simplCore/should_compile/T26051.stderr - + testsuite/tests/simplCore/should_compile/T26051_Import.hs - testsuite/tests/simplCore/should_compile/all.T - testsuite/tests/typecheck/should_compile/T14590.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_fail/DoExpansion1.stderr - testsuite/tests/typecheck/should_fail/DoExpansion2.stderr - testsuite/tests/typecheck/should_fail/T10971d.stderr - testsuite/tests/typecheck/should_fail/T13311.stderr - testsuite/tests/typecheck/should_fail/T24064.stderr - testsuite/tests/typecheck/should_fail/T3323.stderr - testsuite/tests/typecheck/should_fail/T3613.stderr - testsuite/tests/typecheck/should_fail/T7851.stderr - testsuite/tests/typecheck/should_fail/T8603.stderr - testsuite/tests/typecheck/should_fail/T9612.stderr - testsuite/tests/typecheck/should_fail/tcfail102.stderr - testsuite/tests/typecheck/should_fail/tcfail128.stderr - testsuite/tests/typecheck/should_fail/tcfail168.stderr - testsuite/tests/warnings/should_fail/CaretDiagnostics1.stderr - utils/check-exact/ExactPrint.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs - utils/haddock/haddock-api/haddock-api.cabal The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c1dfddb4d0ab6aec42b35b29019220… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c1dfddb4d0ab6aec42b35b29019220… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26115] Use an implication constraint in Deriv
by Simon Peyton Jones (＠simonpj) 20 Jul '25

20 Jul '25

Simon Peyton Jones pushed to branch wip/T26115 at Glasgow Haskell Compiler / GHC Commits: 13986e8d by Simon Peyton Jones at 2025-07-21T00:18:42+01:00 Use an implication constraint in Deriv - - - - - 4 changed files: - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Infer.hs - compiler/GHC/Tc/Deriv/Utils.hs - testsuite/tests/deriving/should_compile/T20815.hs Changes: ===================================== compiler/GHC/Tc/Deriv.hs ===================================== @@ -1432,13 +1432,13 @@ See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom -- EarlyDerivSpec from it. mk_eqn_from_mechanism :: DerivSpecMechanism -> DerivM EarlyDerivSpec mk_eqn_from_mechanism mechanism - = do DerivEnv { denv_overlap_mode = overlap_mode - , denv_tvs = tvs - , denv_cls = cls - , denv_inst_tys = inst_tys - , denv_ctxt = deriv_ctxt - , denv_skol_info = skol_info - , denv_warn = warn } <- ask + = do env@(DerivEnv { denv_overlap_mode = overlap_mode + , denv_tvs = tvs + , denv_cls = cls + , denv_inst_tys = inst_tys + , denv_ctxt = deriv_ctxt + , denv_skol_info = skol_info + , denv_warn = warn }) <- ask user_ctxt <- askDerivUserTypeCtxt doDerivInstErrorChecks1 mechanism loc <- lift getSrcSpanM @@ -1446,7 +1446,7 @@ mk_eqn_from_mechanism mechanism case deriv_ctxt of InferContext wildcard -> do { (inferred_constraints, tvs', inst_tys', mechanism') - <- inferConstraints mechanism + <- inferConstraints mechanism env ; return $ InferTheta $ DS { ds_loc = loc , ds_name = dfun_name, ds_tvs = tvs' ===================================== compiler/GHC/Tc/Deriv/Infer.hs ===================================== @@ -66,7 +66,7 @@ import Data.Maybe ---------------------- -inferConstraints :: DerivSpecMechanism +inferConstraints :: DerivSpecMechanism -> DerivEnv -> DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) -- inferConstraints figures out the constraints needed for the -- instance declaration generated by a 'deriving' clause on a @@ -83,12 +83,12 @@ inferConstraints :: DerivSpecMechanism -- Generate a sufficiently large set of constraints that typechecking the -- generated method definitions should succeed. This set will be simplified -- before being used in the instance declaration -inferConstraints mechanism - = do { DerivEnv { denv_tvs = tvs - , denv_cls = main_cls - , denv_inst_tys = inst_tys } <- ask - ; wildcard <- isStandaloneWildcardDeriv - ; let infer_constraints :: DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) +inferConstraints mechanism (DerivEnv { denv_ctxt = ctxt + , denv_tvs = tvs + , denv_cls = main_cls + , denv_inst_tys = inst_tys }) + = do { let wildcard = isStandaloneWildcardDeriv ctxt + infer_constraints :: DerivM (ThetaSpec, [TyVar], [TcType], DerivSpecMechanism) infer_constraints = case mechanism of DerivSpecStock{dsm_stock_dit = dit} @@ -169,12 +169,12 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys , dit_tc_args = tc_args , dit_rep_tc = rep_tc , dit_rep_tc_args = rep_tc_args }) - = do DerivEnv { denv_tvs = tvs + = do DerivEnv { denv_ctxt = ctxt + , denv_tvs = tvs , denv_cls = main_cls , denv_inst_tys = inst_tys } <- ask - wildcard <- isStandaloneWildcardDeriv - - let inst_ty = mkTyConApp tc tc_args + let wildcard = isStandaloneWildcardDeriv ctxt + inst_ty = mkTyConApp tc tc_args tc_binders = tyConBinders rep_tc choose_level bndr | isNamedTyConBinder bndr = KindLevel @@ -370,13 +370,14 @@ inferConstraintsStock dit@(DerivInstTys { dit_cls_tys = cls_tys -- derived instance context. inferConstraintsAnyclass :: DerivM ThetaSpec inferConstraintsAnyclass - = do { DerivEnv { denv_cls = cls + = do { DerivEnv { denv_ctxt = ctxt + , denv_cls = cls , denv_inst_tys = inst_tys } <- ask ; let gen_dms = [ (sel_id, dm_ty) | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ] - ; wildcard <- isStandaloneWildcardDeriv - ; let meth_pred :: (Id, Type) -> PredSpec + ; let wildcard = isStandaloneWildcardDeriv ctxt + meth_pred :: (Id, Type) -> PredSpec -- (Id,Type) are the selector Id and the generic default method type -- NB: the latter is /not/ quantified over the class variables -- See Note [Gathering and simplifying constraints for DeriveAnyClass] @@ -408,10 +409,10 @@ inferConstraintsAnyclass inferConstraintsCoerceBased :: [Type] -> Type -> DerivM ThetaSpec inferConstraintsCoerceBased cls_tys rep_ty = do - DerivEnv { denv_tvs = tvs + DerivEnv { denv_ctxt = ctxt + , denv_tvs = tvs , denv_cls = cls , denv_inst_tys = inst_tys } <- ask - sa_wildcard <- isStandaloneWildcardDeriv let -- rep_ty might come from: -- GeneralizedNewtypeDeriving / DerivSpecNewtype: -- the underlying type of the newtype () @@ -426,6 +427,7 @@ inferConstraintsCoerceBased cls_tys rep_ty = do -- we are going to get all the methods for the final -- dictionary deriv_origin = mkDerivOrigin sa_wildcard + sa_wildcard = isStandaloneWildcardDeriv ctxt -- Next we collect constraints for the class methods -- If there are no methods, we don't need any constraints @@ -574,7 +576,7 @@ Consider the `deriving Alt` part of this example (from the passing part of T20815a): class Alt f where - some :: Applicative f => f a -> f [a] + some :: forall a. Applicative f => f a -> f [a] newtype T f a = T (f a) deriving Alt ===================================== compiler/GHC/Tc/Deriv/Utils.hs ===================================== @@ -35,11 +35,11 @@ import GHC.Tc.Deriv.Generate import GHC.Tc.Deriv.Functor import GHC.Tc.Deriv.Generics import GHC.Tc.Errors.Types -import GHC.Tc.Types.Constraint (WantedConstraints, mkNonCanonical) +import GHC.Tc.Types.Constraint (WantedConstraints, mkNonCanonical, mkSimpleWC) import GHC.Tc.Types.Origin import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType -import GHC.Tc.Utils.Unify (tcSubTypeSigma) +import GHC.Tc.Utils.Unify (tcSubTypeSigma, buildImplicationFor) import GHC.Tc.Zonk.Type import GHC.Core.Class @@ -71,7 +71,6 @@ import GHC.Utils.Error import GHC.Utils.Unique (sameUnique) import Control.Monad.Trans.Reader -import Data.Foldable (traverse_) import Data.Maybe import qualified GHC.LanguageExtensions as LangExt import GHC.Data.List.SetOps (assocMaybe) @@ -92,12 +91,9 @@ isStandaloneDeriv = asks (go . denv_ctxt) -- | Is GHC processing a standalone deriving declaration with an -- extra-constraints wildcard as the context? -- (e.g., @deriving instance _ => Eq (Foo a)@) -isStandaloneWildcardDeriv :: DerivM Bool -isStandaloneWildcardDeriv = asks (go . denv_ctxt) - where - go :: DerivContext -> Bool - go (InferContext wildcard) = isJust wildcard - go (SupplyContext {}) = False +isStandaloneWildcardDeriv :: DerivContext -> Bool +isStandaloneWildcardDeriv (InferContext wildcard) = isJust wildcard +isStandaloneWildcardDeriv (SupplyContext {}) = False -- | Return 'InstDeclCtxt' if processing with a standalone @deriving@ -- declaration or 'DerivClauseCtxt' if processing a @deriving@ clause. @@ -563,11 +559,17 @@ data PredSpec SimplePredSpec { sps_pred :: TcPredType -- ^ The constraint to emit as a wanted + -- Usually just a simple predicate like (Eq a) or (ki ~# Type), + -- but (hack) in the case of GHC.Tc.Deriv.Infer.inferConstraintsCoerceBased, + -- it can be a forall-constraint + , sps_origin :: CtOrigin -- ^ The origin of the constraint + , sps_type_or_kind :: TypeOrKind -- ^ Whether the constraint is a type or kind } + | -- | A special 'PredSpec' that is only used by @DeriveAnyClass@. This -- will check if @stps_ty_actual@ is a subtype of (i.e., more polymorphic -- than) @stps_ty_expected@ in the constraint solving machinery, emitting an @@ -677,8 +679,8 @@ captureThetaSpecConstraints :: -- @deriving@ declaration -> ThetaSpec -- ^ The specs from which constraints will be created -> TcM (TcLevel, WantedConstraints) -captureThetaSpecConstraints user_ctxt theta = - pushTcLevelM $ mk_wanteds theta +captureThetaSpecConstraints user_ctxt theta + = pushTcLevelM $ mk_wanteds theta where -- Create the constraints we need to solve. For stock and newtype -- deriving, these constraints will be simple wanted constraints @@ -689,34 +691,48 @@ captureThetaSpecConstraints user_ctxt theta = mk_wanteds :: ThetaSpec -> TcM WantedConstraints mk_wanteds preds = do { (_, wanteds) <- captureConstraints $ - traverse_ emit_constraints preds + mapM_ (emitPredSpecConstraints user_ctxt) preds ; pure wanteds } - -- Emit the appropriate constraints depending on what sort of - -- PredSpec we are dealing with. - emit_constraints :: PredSpec -> TcM () - emit_constraints ps = - case ps of - -- For constraints like (C a, Ord b), emit the - -- constraints directly as simple wanted constraints. - SimplePredSpec { sps_pred = wanted - , sps_origin = orig - , sps_type_or_kind = t_or_k - } -> do - ev <- newWanted orig (Just t_or_k) wanted - emitSimple (mkNonCanonical ev) - - -- For DeriveAnyClass, check if ty_actual is a subtype of - -- ty_expected, which emits an implication constraint as a - -- side effect. See - -- Note [Gathering and simplifying constraints for DeriveAnyClass]. - -- in GHC.Tc.Deriv.Infer. - SubTypePredSpec { stps_ty_actual = ty_actual - , stps_ty_expected = ty_expected - , stps_origin = orig - } -> do - _ <- tcSubTypeSigma orig user_ctxt ty_actual ty_expected - return () +emitPredSpecConstraints :: UserTypeCtxt -> PredSpec -> TcM () +--- Emit the appropriate constraints depending on what sort of +-- PredSpec we are dealing with. +emitPredSpecConstraints _ (SimplePredSpec { sps_pred = wanted_pred + , sps_origin = orig + , sps_type_or_kind = t_or_k }) + -- For constraints like (C a) or (Ord b), emit the + -- constraints directly as simple wanted constraints. + | isRhoTy wanted_pred + = do { ev <- newWanted orig (Just t_or_k) wanted_pred + ; emitSimple (mkNonCanonical ev) } + + | otherwise + -- Forall-constraints, which come exclusively from + -- GHC.Tc.Deriv.Infer.inferConstraintsCoerceBased. + -- For these we want to emit an implication constraint, and NOT a forall-constraint + -- Why? Because forall-constraints are solved all-or-nothing, but here when we + -- are trying to infer the context for an instance decl, we need that half-solved + -- implicatation (see deriving/should_compile/T20815). + = do { let skol_info_anon = DerivSkol wanted_pred + ; skol_info <- mkSkolemInfo skol_info_anon + ; (_wrapper, tv_prs, givens, wanted_rho) <- topSkolemise skol_info wanted_pred + -- _wrapper: we ignore the evidence from all these constraints + ; (tc_lvl, ev) <- pushTcLevelM $ newWanted orig (Just t_or_k) wanted_rho + ; let skol_tvs = map (binderVar . snd) tv_prs + ; (implic, _) <- buildImplicationFor tc_lvl skol_info_anon skol_tvs + givens (mkSimpleWC [ev]) + ; emitImplications implic } + +emitPredSpecConstraints user_ctxt + (SubTypePredSpec { stps_ty_actual = ty_actual + , stps_ty_expected = ty_expected + , stps_origin = orig }) +-- For DeriveAnyClass, check if ty_actual is a subtype of ty_expected, +-- which emits an implication constraint as a side effect. See +-- Note [Gathering and simplifying constraints for DeriveAnyClass] +-- in GHC.Tc.Deriv.Infer. + = do { _ <- tcSubTypeSigma orig user_ctxt ty_actual ty_expected + ; return () } {- ************************************************************************ ===================================== testsuite/tests/deriving/should_compile/T20815.hs ===================================== @@ -12,3 +12,5 @@ instance Alt [] where (<!>) = (++) newtype L a = L [a] deriving (Functor, Alt) + +newtype T f a = T (f a) deriving (Functor, Alt) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13986e8d787ab795c621c4b37734a9e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/13986e8d787ab795c621c4b37734a9e… You're receiving this email because of your account on gitlab.haskell.org.

1 0