- ghc-commits - Haskell.org

[Git][ghc/ghc][wip/T26349] Remove trace
by Simon Peyton Jones (＠simonpj) 25 Oct '25

25 Oct '25

Simon Peyton Jones pushed to branch wip/T26349 at Glasgow Haskell Compiler / GHC Commits: 66ad3ca0 by Simon Peyton Jones at 2025-10-25T13:18:56+01:00 Remove trace - - - - - 1 changed file: - compiler/GHC/Tc/Types/Evidence.hs Changes: ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -135,8 +135,51 @@ maybeSymCo NotSwapped co = co ************************************************************************ -} -{- Note [WpSubType] -~~~~~~~~~~~~~~~~~~~ +{- Note [Deep subsumption and WpSubType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When making DeepSubsumption checks, we may end up with hard-to-spot identity wrappers. +For example (#26255) suppose we have + (forall a. Eq a => a->a) -> Int <= (forall a. Eq a => a->a) -> Int +The two types are equal so we should certainly get an identity wrapper. But we'll get +tihs wrapper from `tcSubType`: + WpFun (WpTyLam a <.> WpEvLam dg <.> WpLet (dw=dg) <.> WpEvApp dw <.> WpTyApp a) + WpHole +That elaborate wrapper is really just a no-op, but it's far from obvious. If we just +desugar (HsWrap f wp) straightforwardly we'll get + \(g:forall a. Eq a => a -> a). + f (/\a. \(dg:Eq a). let dw=dg in g a dw) + +To recognise that as just `f`, we'd have to eta-reduce twice. But eta-reduction +is not sound in general, so we'll end up retaining the lambdas. Two bad results + +* Adding DeepSubsumption gratuitiously makes programs less efficient. + +* When the subsumption is on the LHS of a rule, or in a SPECIALISE pragma, we + may not be able to make a decent RULE at all, and will fail with "LHS of rule + is too complicated to desugar (#26255) + +It'd be nicest to solve the problem at source, by never generating those +gruesome wrappers in the first place, but we can't do that because + +* The WpTyLam and WpTyApp are not introduced together in `tcSubType`, so we can't + easily cancel them out. Even if we have + forall a. t1 <= forall a. t2 + there is no guarantee that these are the "same" a. E.g. + forall a b. a -> b -> b <= forall x y. y -> x - >x + Similarly WpEvLam and WpEvApp + +* We have not yet done constraint solving so we don't know what evidence will + end up in those WpLet bindings. + +TL;DR we must generate +Here's our solution + +(DSST1) Tag the wrappers generated from a subtype check with WpSubType. In normal + wrappers the binders of a WpTyLam or WpEvLam can scope over the "hole" of the + wrapper -- that is how we introduce type-lambdas and dictionary-lambda into the + terms! But in /subtype/ wrappers, these type/dictionary lambdas only scope over + the WpTyApp and WpEvApp nodes in the /same/ wrapper. That is w + (WpSubType wp) means the same as `wp`, but with the added promise that the binders in `wp` do not scope over the hole -} @@ -378,7 +421,7 @@ collectHsWrapBinders wrap = go wrap [] optSubTypeHsWrapper :: HsWrapper -> HsWrapper optSubTypeHsWrapper wrap - = pprTrace "optHsWrapper" (vcat [ text "in:" <+> ppr wrap, text "out:" <+> ppr (opt wrap) ]) $ + = -- pprTrace "optHsWrapper" (vcat [ text "in:" <+> ppr wrap, text "out:" <+> ppr (opt wrap) ]) $ opt wrap where opt :: HsWrapper -> HsWrapper View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66ad3ca0e80547646d98a3df5f35133… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66ad3ca0e80547646d98a3df5f35133… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T26349] Better now
by Simon Peyton Jones (＠simonpj) 25 Oct '25

25 Oct '25

Simon Peyton Jones pushed to branch wip/T26349 at Glasgow Haskell Compiler / GHC Commits: ce4975ed by Simon Peyton Jones at 2025-10-25T12:51:24+01:00 Better now Added WpSubType - - - - - 5 changed files: - compiler/GHC/Hs/Syn/Type.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/Tc/Zonk/Type.hs Changes: ===================================== compiler/GHC/Hs/Syn/Type.hs ===================================== @@ -191,6 +191,7 @@ hsWrapperType :: HsWrapper -> Type -> Type hsWrapperType wrap ty = prTypeType $ go wrap (ty,[]) where go WpHole = id + go (WpSubType w) = go w go (w1 `WpCompose` w2) = go w1 . go w2 go (WpFun _ w2 (Scaled m exp_arg) _) = liftPRType $ \t -> let act_res = funResultTy t ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -1598,9 +1598,10 @@ ds_hs_wrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a ds_hs_wrapper hs_wrap - = go (optHsWrapper hs_wrap) + = go hs_wrap where go WpHole k = k $ \e -> e + go (WpSubType w) k = go (optSubTypeHsWrapper w) k go (WpTyApp ty) k = k $ \e -> App e (Type ty) go (WpEvLam ev) k = k $ Lam ev go (WpTyLam tv) k = k $ Lam tv ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -8,11 +8,11 @@ module GHC.Tc.Types.Evidence ( -- * HsWrapper HsWrapper(..), (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpForAllCast, - mkWpEvLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, mkWpEta, + mkWpEvLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, mkWpEta, mkWpSubType, collectHsWrapBinders, idHsWrapper, isIdHsWrapper, pprHsWrapper, hsWrapDictBinders, - optHsWrapper, + optSubTypeHsWrapper, -- * Evidence bindings TcEvBinds(..), EvBindsVar(..), @@ -135,11 +135,20 @@ maybeSymCo NotSwapped co = co ************************************************************************ -} +{- Note [WpSubType] +~~~~~~~~~~~~~~~~~~~ +(WpSubType wp) means the same as `wp`, but with the added promise that +the binders in `wp` do not scope over the hole +-} + -- We write wrap :: t1 ~> t2 -- if wrap[ e::t1 ] :: t2 data HsWrapper = WpHole -- The identity coercion + | WpSubType HsWrapper -- (WpSubType wp) Means the same as `wp` + -- But see Note [WpSubType] + | WpCompose HsWrapper HsWrapper -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]] -- @@ -246,6 +255,11 @@ mkWpFun w_arg w_res t1 t2 = WpFun w_arg w_res t1 t2 -- Unfortunately, we can't check this with an assertion here, because of -- [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. +mkWpSubType :: HsWrapper -> HsWrapper +mkWpSubType WpHole = WpHole +mkWpSubType (WpCast co) = WpCast co +mkWpSubType w = WpSubType w + mkWpEta :: Type -> [Id] -> HsWrapper -> HsWrapper -- (mkWpEta [x1, x2] wrap) [e] -- = \x1. \x2. wrap[e x1 x2] @@ -336,6 +350,7 @@ hsWrapDictBinders wrap = go wrap go (w1 `WpCompose` w2) = go w1 `unionBags` go w2 go (WpFun _ w _ _) = go w go WpHole = emptyBag + go (WpSubType {}) = emptyBag -- See Note [WpSubType] go (WpCast {}) = emptyBag go (WpEvApp {}) = emptyBag go (WpTyLam {}) = emptyBag @@ -351,6 +366,7 @@ collectHsWrapBinders wrap = go wrap [] go :: HsWrapper -> [HsWrapper] -> ([Var], HsWrapper) go (WpEvLam v) wraps = add_lam v (gos wraps) go (WpTyLam v) wraps = add_lam v (gos wraps) + go (WpSubType w) wraps = go w wraps go (WpCompose w1 w2) wraps = go w1 (w2:wraps) go wrap wraps = ([], foldl' (<.>) wrap wraps) @@ -360,124 +376,113 @@ collectHsWrapBinders wrap = go wrap [] add_lam v (vs,w) = (v:vs, w) -optHsWrapper :: HsWrapper -> HsWrapper -optHsWrapper wrap - = foldr (<.>) WpHole (norm wrap []) - -- let wrap' = foldr (<.>) WpHole (norm wrap []) - -- in pprTrace "optHsWrapper" (vcat [ text "in:" <+> ppr wrap, text "out:" <+> ppr wrap' ]) $ - -- wrap' +optSubTypeHsWrapper :: HsWrapper -> HsWrapper +optSubTypeHsWrapper wrap + = pprTrace "optHsWrapper" (vcat [ text "in:" <+> ppr wrap, text "out:" <+> ppr (opt wrap) ]) $ + opt wrap where - norm :: HsWrapper -> [HsWrapper] -> [HsWrapper] - -- norm w ws = w <.> (foldr <.> WpHole ws) - -- INVARIANT: ws:[HsWrapper] is normalised - norm WpHole ws = ws - norm (w1 `WpCompose` w2) ws = norm w1 (norm w2 ws) - norm (WpCast co) ws = norm_co co ws - norm (WpEvLam ev) ws = norm_ev_lam ev ws - norm (WpTyLam tv) ws = norm_ty_lam tv ws - norm (WpLet binds) ws = norm_let binds ws - norm (WpFun w1 w2 sty1 ty2) ws = norm_fun w1 w2 sty1 ty2 ws - norm w@(WpTyApp {}) ws = w : ws - norm w@(WpEvApp {}) ws = w : ws + opt :: HsWrapper -> HsWrapper + opt w = foldr (<.>) WpHole (opt1 w []) + + opt1 :: HsWrapper -> [HsWrapper] -> [HsWrapper] + -- opt1 w ws = w <.> (foldr <.> WpHole ws) + -- INVARIANT: ws:[HsWrapper] is optimised + opt1 WpHole ws = ws + opt1 (WpSubType w) ws = opt1 w ws + opt1 (w1 `WpCompose` w2) ws = opt1 w1 (opt1 w2 ws) + opt1 (WpCast co) ws = opt_co co ws + opt1 (WpEvLam ev) ws = opt_ev_lam ev ws + opt1 (WpTyLam tv) ws = opt_ty_lam tv ws + opt1 (WpLet binds) ws = opt_let binds ws + opt1 (WpFun w1 w2 sty1 ty2) ws = mk_wp_fun (opt w1) (opt w2) sty1 ty2 ws + opt1 w@(WpTyApp {}) ws = w : ws + opt1 w@(WpEvApp {}) ws = w : ws ------------------ - norm_let b@(EvBinds bs) ws | isEmptyBag bs = ws - | otherwise = WpLet b : ws - norm_let (TcEvBinds {}) _ = pprPanic "optHsWrapper1" (ppr wrap) + opt_let b@(EvBinds bs) ws | isEmptyBag bs = ws + | otherwise = WpLet b : ws + opt_let (TcEvBinds {}) _ = pprPanic "optHsWrapper1" (ppr wrap) ----------------- -- (WpTyLam a <+> WpTyApp a <+> w) = w - norm_ty_lam tv (WpTyApp ty : ws) + opt_ty_lam tv (WpTyApp ty : ws) | Just tv' <- getTyVar_maybe ty , tv==tv' = ws -- (WpTyLam a <+> WpCastCo co <+> w) -- = WpCast (ForAllCo a co) (WpTyLam <.> w) - norm_ty_lam tv (WpCast co : ws) - = norm_co (mkHomoForAllCo tv co) (norm_ty_lam tv ws) + opt_ty_lam tv (WpCast co : ws) + = opt_co (mkHomoForAllCo tv co) (opt_ty_lam tv ws) - norm_ty_lam tv (WpLet bs : ws) + opt_ty_lam tv (WpLet bs : ws) | Just ws' <- pushWpLet bs ws - = norm_ty_lam tv ws' + = opt_ty_lam tv ws' - norm_ty_lam tv ws + opt_ty_lam tv ws = WpTyLam tv : ws ----------------- -- (WpEvLam ev <+> WpEvAp ev <+> w) = w - norm_ev_lam ev (WpEvApp ev_tm : ws) + opt_ev_lam ev (WpEvApp ev_tm : ws) | EvExpr (Var ev') <- ev_tm , ev == ev' = ws -- (WpEvLam ev <.> WpCast co <.> w) -- = WpCast (FunCo ev co) (WpEvLam <.> w) - norm_ev_lam ev (WpCast co : ws) - = norm_co fun_co (norm_ev_lam ev ws) + opt_ev_lam ev (WpCast co : ws) + = opt_co fun_co (opt_ev_lam ev ws) where fun_co = mkFunCo Representational FTF_C_T (mkNomReflCo ManyTy) (mkRepReflCo (idType ev)) co - norm_ev_lam ev (WpLet bs : ws) + opt_ev_lam ev (WpLet bs : ws) | Just ws' <- pushWpLet bs ws - = norm_ev_lam ev ws' + = opt_ev_lam ev ws' - norm_ev_lam ev ws + opt_ev_lam ev ws = WpEvLam ev : ws ----------------- -- WpCast co <.> WpCast co' <+> ws = WpCast (co;co') ws - norm_co co (WpCast co' : ws) = norm_co (co `mkTransCo` co') ws - norm_co co ws | isReflexiveCo co = ws - | otherwise = WpCast co : ws + opt_co co (WpCast co' : ws) = opt_co (co `mkTransCo` co') ws + opt_co co ws | isReflexiveCo co = ws + | otherwise = WpCast co : ws ------------------ - norm_fun w1 w2 (Scaled w t1) t2 ws - = case (optHsWrapper w1, optHsWrapper w2) of + mk_wp_fun w1 w2 sty1@(Scaled w t1) ty2 ws + = case (w1, w2) of (WpHole, WpHole) -> ws - (WpLet {}, WpHole) -> ws (WpHole, WpCast co2) -> co_ify (mkRepReflCo t1) co2 - (WpCast co1, WpHole) -> co_ify (mkSymCo co1) (mkRepReflCo t2) + (WpCast co1, WpHole) -> co_ify (mkSymCo co1) (mkRepReflCo ty2) (WpCast co1, WpCast co2) -> co_ify (mkSymCo co1) co2 - (w1', w2') -> WpFun w1' w2' (Scaled w t1) t2 : ws + (w1', w2') -> WpFun w1' w2' sty1 ty2 : ws where - co_ify co1 co2 = norm_co (mk_wp_fun_co w co1 co2) ws + co_ify co1 co2 = opt_co (mk_wp_fun_co w co1 co2) ws pushWpLet :: TcEvBinds -> [HsWrapper] -> Maybe [HsWrapper] pushWpLet tc_ev_binds ws | EvBinds binds <- tc_ev_binds , Just env <- evBindIdSwizzle binds - = case go env ws of - WpLet {} : _ -> Nothing - ws' -> Just ws' + = go env ws | otherwise = Nothing where - go :: IdEnv Id -> [HsWrapper] -> [HsWrapper] - go env (WpTyApp ty : ws') = WpTyApp ty : go env ws' - go env (WpCast co : ws') = WpCast co : go env ws' - go env (WpTyLam tv : ws') - | not (tv_captures env tv) - = WpTyLam tv : go env ws' - - go env (WpEvLam ev : ws') - | not (ev `elemVarEnv` env) -- `ev` must not be in the domain - , not (anyVarEnv (== ev) env) -- or range of `env` - = WpEvLam ev : go env ws' - - go env (WpEvApp (EvExpr (Var v)) : ws') - | Just v' <- swizzleId env v - = WpEvApp (EvExpr (Var v')) : go env ws' - - go _ ws = WpLet tc_ev_binds : ws - - tv_captures :: IdEnv Id -> TyVar -> Bool - tv_captures env tv = anyVarEnv bad env - where - bad id = anyFreeVarsOfType (== tv) (idType id) - + go :: IdEnv Id -> [HsWrapper] -> Maybe [HsWrapper] + go env (WpCast co : ws) = do { ws' <- go env ws + ; return (WpCast co : ws') } + go env (WpTyApp ty : ws) = do { ws' <- go env ws + ; return (WpTyApp ty : ws') } + go env (WpEvApp (EvExpr (Var v)) : ws) + = do { v' <- swizzleId env v + ; ws' <- go env ws + ; return (WpEvApp (EvExpr (Var v')) : ws') } + + go _ ws = case ws of + [] -> Just [] + (_:_) -> Nothing -- Could not fully eliminate it swizzleId :: IdEnv Id -> Id -> Maybe Id -- Nothing <=> ran out of fuel @@ -1158,7 +1163,8 @@ pprHsWrapper wrap pp_thing_inside -- True <=> appears in function application position -- False <=> appears as body of let or lambda help it WpHole = it - help it (WpCompose f1 f2) = help (help it f2) f1 + help it (WpCompose w1 w2) = help (help it w2) w1 + help it (WpSubType w) = no_parens $ text "subtype" <> braces (help it w False) help it (WpFun f1 f2 (Scaled w t1) _) = add_parens $ text "\\(x" <> dcolon <> brackets (ppr w) <> ppr t1 <> text ")." <+> help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False help it (WpCast co) = add_parens $ sep [it False, nest 2 (text "|>" ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -1426,11 +1426,12 @@ tcSubTypeDS :: HsExpr GhcRn -- DeepSubsumption <=> when checking, this type -- is deeply skolemised -> TcM HsWrapper --- Only one call site, in GHC.Tc.Gen.App.tcApp +-- Only one call site, in GHC.Tc.Gen.App.checkResultTy tcSubTypeDS rn_expr act_rho exp_rho - = tc_sub_type_deep Top (unifyExprType rn_expr) orig GenSigCtxt act_rho exp_rho - where - orig = exprCtOrigin rn_expr + = do { wrap <- tc_sub_type_deep Top (unifyExprType rn_expr) + (exprCtOrigin rn_expr) + GenSigCtxt act_rho exp_rho + ; return (mkWpSubType wrap) } --------------- @@ -1503,7 +1504,8 @@ tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify ---------------------- tc_sub_type unify inst_orig ctxt ty_actual ty_expected = do { ds_flag <- getDeepSubsumptionFlag - ; tc_sub_type_ds Top ds_flag unify inst_orig ctxt ty_actual ty_expected } + ; wrap <- tc_sub_type_ds Top ds_flag unify inst_orig ctxt ty_actual ty_expected + ; return (mkWpSubType wrap) } ---------------------- tc_sub_type_ds :: Position p -- ^ position in the type (for error messages only) ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -1231,6 +1231,8 @@ zonk_cmd_top (HsCmdTop (CmdTopTc stack_tys ty ids) cmd) ------------------------------------------------------------------------- zonkCoFn :: HsWrapper -> ZonkBndrTcM HsWrapper zonkCoFn WpHole = return WpHole +zonkCoFn (WpSubType w) = do { w' <- zonkCoFn w + ; return (WpSubType w') } zonkCoFn (WpCompose c1 c2) = do { c1' <- zonkCoFn c1 ; c2' <- zonkCoFn c2 ; return (WpCompose c1' c2') } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ce4975ed0c0af9479fc5ab11e25f7f2… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ce4975ed0c0af9479fc5ab11e25f7f2… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Postscript to fix for #26255
by Marge Bot (＠marge-bot) 25 Oct '25

25 Oct '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 4f5bf93b by Simon Peyton Jones at 2025-10-25T04:05:34-04:00 Postscript to fix for #26255 This MR has comments only - - - - - 1 changed file: - compiler/GHC/Tc/Errors.hs Changes: ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -557,9 +557,9 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics -- if there's a *given* insoluble here (= inaccessible code) -- If there are no other errors to report, report suppressed errors. - -- See Note [Suppressing confusing errors]. NB: with -fdefer-type-errors - -- we might have reported warnings only from `reportable_items`, but we - -- still want to suppress the `suppressed_items`. + -- See (SCE3) in Note [Suppressing confusing errors]. + -- NB: with -fdefer-type-errors we might have reported warnings only from + -- reportable_items`, but we still want to suppress the `suppressed_items`. ; when (null reportable_items) $ do { (_, more_leftovers) <- tryReporters ctxt_for_insols (report1++report2) suppressed_items @@ -762,7 +762,7 @@ isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of Certain errors we might encounter are potentially confusing to users. If there are any other errors to report, at all, we want to suppress these. -Which errors are suppressed? +Which errors should be suppressed? (SCE1) Superclasses of Wanteds. These are generated only in case they trigger functional dependencies. If such a constraint is unsolved, then its "parent" constraint must @@ -777,9 +777,6 @@ Which errors are suppressed? We definitely want to report d1 and not d2! Happily it's easy to filter out those superclass-Wanteds, becuase their Origin betrays them. - See test T18851 for an example of how it is (just, barely) possible for the /only/ - errors to be superclass-of-Wanted constraints. - (SCE2) Errors which arise from the interaction of two Wanted fun-dep constraints. Example: @@ -810,9 +807,15 @@ Which errors are suppressed? Mechanism: -We use the `suppress` function within reportWanteds to filter out these two -cases, then report all other errors. Lastly, we return to these suppressed -ones and report them only if there have been no errors so far. +We use the `suppress` function within reportWanteds to filter out these +"suppress" cases, then report all other errors. After doing so, we return to these +suppressed ones and report them only if there have been no errors so far. + +(SCE3) How can it happen that there are /only/ suppressed errors? See test T18851 + for an example of how it is (just, barely) possible for the /only/ errors to + be superclass-of-Wanted constraints. + + Note [Constraints to ignore] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4f5bf93ba3ed1b61e0fa74d9ec867d3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4f5bf93ba3ed1b61e0fa74d9ec867d3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] 2 commits: Fix stack decoding when using profiled runtime
by Marge Bot (＠marge-bot) 25 Oct '25

25 Oct '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: 38d65187 by Matthew Pickering at 2025-10-21T13:12:20+01:00 Fix stack decoding when using profiled runtime There are three fixes in this commit. * We need to replicate the `InfoTable` and `InfoTableProf` approach for the other stack constants (see the new Stack.ConstantsProf file). * Then we need to appropiately import the profiled or non-profiled versions. * Finally, there was an incorrect addition in `stackFrameSize`. We need to cast after performing addition on words. Fixes #26507 - - - - - 17231bfb by fendor at 2025-10-21T13:12:20+01:00 Add regression test for #26507 - - - - - 8 changed files: - libraries/ghc-internal/cbits/Stack_c.c - libraries/ghc-internal/ghc-internal.cabal.in - + libraries/ghc-internal/src/GHC/Internal/Stack/ConstantsProf.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - + libraries/ghc-internal/tests/backtraces/T26507.hs - + libraries/ghc-internal/tests/backtraces/T26507.stderr - libraries/ghc-internal/tests/backtraces/all.T - libraries/ghc-internal/tests/stack-annotation/all.T Changes: ===================================== libraries/ghc-internal/cbits/Stack_c.c ===================================== @@ -9,13 +9,13 @@ #include "rts/storage/InfoTables.h" StgWord stackFrameSize(StgStack *stack, StgWord offset) { - StgClosure *c = (StgClosure *)stack->sp + 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; + StgClosure *frame = (StgClosure *)(stack->sp + offset); ASSERT(LOOKS_LIKE_CLOSURE_PTR(frame)); const StgRetInfoTable *info = get_ret_itbl((StgClosure *)frame); ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -300,6 +300,7 @@ Library GHC.Internal.Stack.CCS GHC.Internal.Stack.CloneStack GHC.Internal.Stack.Constants + GHC.Internal.Stack.ConstantsProf GHC.Internal.Stack.Decode GHC.Internal.Stack.Types GHC.Internal.Stats ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/ConstantsProf.hsc ===================================== @@ -0,0 +1,140 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module GHC.Internal.Stack.ConstantsProf where + +import GHC.Internal.Base +import GHC.Internal.Enum +import GHC.Internal.Num +import GHC.Internal.Show +import GHC.Internal.Real + +-- This file is a copy of GHC.Internal.Stack.Constants, but compiled with PROFILING +-- defined, since hsc is only invoked once per build in the vanilla way. +-- +-- Also see GHC.Internal.Heap.InfoTable{Prof} +#define PROFILING +#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 ===================================== @@ -54,9 +54,19 @@ import GHC.Internal.Heap.Closures GenStackField(..) ) import GHC.Internal.Heap.Constants (wORD_SIZE_IN_BITS) -import GHC.Internal.Heap.InfoTable import GHC.Internal.Stack.Annotation +-- See Note [No way-dependent imports] +#if defined(PROFILING) +import GHC.Internal.Stack.Constants () +import GHC.Internal.Stack.ConstantsProf +import GHC.Internal.Heap.InfoTable () +import GHC.Internal.Heap.InfoTableProf +#else +import GHC.Internal.Heap.InfoTable +import GHC.Internal.Heap.InfoTableProf () import GHC.Internal.Stack.Constants +import GHC.Internal.Stack.ConstantsProf () +#endif import GHC.Internal.Stack.CloneStack import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE) ===================================== libraries/ghc-internal/tests/backtraces/T26507.hs ===================================== @@ -0,0 +1,7 @@ +import GHC.Internal.Control.Exception +import GHC.Internal.Exception.Backtrace + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + throwIO $ ErrorCall "Throw error" ===================================== libraries/ghc-internal/tests/backtraces/T26507.stderr ===================================== @@ -0,0 +1,8 @@ +T26507: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: + +Throw error + +IPE backtrace: +HasCallStack backtrace: + throwIO, called at T26507.hs:7:3 in main:Main + ===================================== libraries/ghc-internal/tests/backtraces/all.T ===================================== @@ -1,2 +1,6 @@ test('T14532a', [], compile_and_run, ['']) test('T14532b', [], compile_and_run, ['']) +test('T26507', [ when(have_profiling(), extra_ways(['prof'])) + , when(js_arch(), skip) + , exit_code(1)], compile_and_run, ['']) + ===================================== libraries/ghc-internal/tests/stack-annotation/all.T ===================================== @@ -1,7 +1,10 @@ # Javascript backend don't support annotation frames, yet -setTestOpts(when(js_arch(), skip)) +# and test with profiling way if available (#26507) +ann_frame_opts = [ when(js_arch(), skip) + , when(have_profiling(), extra_ways(['prof'])) + , extra_files(['TestUtils.hs'])] -test('ann_frame001', [extra_files(['TestUtils.hs'])], compile_and_run, ['']) -test('ann_frame002', [extra_files(['TestUtils.hs'])], compile_and_run, ['']) -test('ann_frame003', [extra_files(['TestUtils.hs'])], compile_and_run, ['']) -test('ann_frame004', [extra_files(['TestUtils.hs'])], compile_and_run, ['']) +test('ann_frame001', ann_frame_opts, compile_and_run, ['']) +test('ann_frame002', ann_frame_opts, compile_and_run, ['']) +test('ann_frame003', ann_frame_opts, compile_and_run, ['']) +test('ann_frame004', ann_frame_opts, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3d3058895c0dac15c9ee4f88c15cac… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3d3058895c0dac15c9ee4f88c15cac… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Improve error handling in 'getPackageArchives'
by Marge Bot (＠marge-bot) 24 Oct '25

24 Oct '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 91b6be10 by Julian Ospald at 2025-10-20T18:21:03-04:00 Improve error handling in 'getPackageArchives' When the library dirs in the package conf files are not set up correctly, the JS linker will happily ignore such packages and not link against them, although they're part of the link plan. Fixes #26383 - - - - - 6c5269da by Sven Tennie at 2025-10-20T18:21:44-04:00 Align coding style Improve readability by using the same style for all constructor calls in this function. - - - - - 3d305889 by Sven Tennie at 2025-10-20T18:21:44-04:00 Reduce complexity by removing joins with mempty ldArgs, cArgs and cppArgs are all `mempty`. Thus concatenating them adds nothing but some complexity while reading the code. - - - - - 38d65187 by Matthew Pickering at 2025-10-21T13:12:20+01:00 Fix stack decoding when using profiled runtime There are three fixes in this commit. * We need to replicate the `InfoTable` and `InfoTableProf` approach for the other stack constants (see the new Stack.ConstantsProf file). * Then we need to appropiately import the profiled or non-profiled versions. * Finally, there was an incorrect addition in `stackFrameSize`. We need to cast after performing addition on words. Fixes #26507 - - - - - 17231bfb by fendor at 2025-10-21T13:12:20+01:00 Add regression test for #26507 - - - - - ad88789e by Simon Peyton Jones at 2025-10-24T19:34:27-04:00 Postscript to fix for #26255 This MR has comments only - - - - - 16 changed files: - compiler/GHC/StgToJS/Linker/Linker.hs - compiler/GHC/Tc/Errors.hs - hadrian/src/Rules/Gmp.hs - hadrian/src/Rules/Libffi.hs - hadrian/src/Settings/Builders/Cabal.hs - hadrian/src/Settings/Builders/Common.hs - hadrian/src/Settings/Builders/DeriveConstants.hs - hadrian/src/Settings/Builders/Hsc2Hs.hs - libraries/ghc-internal/cbits/Stack_c.c - libraries/ghc-internal/ghc-internal.cabal.in - + libraries/ghc-internal/src/GHC/Internal/Stack/ConstantsProf.hsc - libraries/ghc-internal/src/GHC/Internal/Stack/Decode.hs - + libraries/ghc-internal/tests/backtraces/T26507.hs - + libraries/ghc-internal/tests/backtraces/T26507.stderr - libraries/ghc-internal/tests/backtraces/all.T - libraries/ghc-internal/tests/stack-annotation/all.T Changes: ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -2,6 +2,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- -- | @@ -666,12 +667,19 @@ renderLinkerStats s = getPackageArchives :: StgToJSConfig -> UnitEnv -> [UnitId] -> IO [FilePath] -getPackageArchives cfg unit_env units = - filterM doesFileExist [ ST.unpack p </> "lib" ++ ST.unpack l ++ profSuff <.> "a" - | u <- units - , p <- getInstalledPackageLibDirs ue_state u - , l <- getInstalledPackageHsLibs ue_state u - ] +getPackageArchives cfg unit_env units = do + fmap concat $ forM units $ \u -> do + let archives = [ ST.unpack p </> "lib" ++ ST.unpack l ++ profSuff <.> "a" + | p <- getInstalledPackageLibDirs ue_state u + , l <- getInstalledPackageHsLibs ue_state u + ] + foundArchives <- filterM doesFileExist archives + if | not (null archives) + , null foundArchives + -> do + throwGhcExceptionIO (InstallationError $ "Could not find any library archives for unit-id: " <> (renderWithContext (csContext cfg) $ ppr u)) + | otherwise + -> pure foundArchives where ue_state = ue_homeUnitState unit_env ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -557,9 +557,9 @@ reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics -- if there's a *given* insoluble here (= inaccessible code) -- If there are no other errors to report, report suppressed errors. - -- See Note [Suppressing confusing errors]. NB: with -fdefer-type-errors - -- we might have reported warnings only from `reportable_items`, but we - -- still want to suppress the `suppressed_items`. + -- See (SCE3) in Note [Suppressing confusing errors]. + -- NB: with -fdefer-type-errors we might have reported warnings only from + -- reportable_items`, but we still want to suppress the `suppressed_items`. ; when (null reportable_items) $ do { (_, more_leftovers) <- tryReporters ctxt_for_insols (report1++report2) suppressed_items @@ -762,7 +762,7 @@ isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of Certain errors we might encounter are potentially confusing to users. If there are any other errors to report, at all, we want to suppress these. -Which errors are suppressed? +Which errors should be suppressed? (SCE1) Superclasses of Wanteds. These are generated only in case they trigger functional dependencies. If such a constraint is unsolved, then its "parent" constraint must @@ -777,9 +777,6 @@ Which errors are suppressed? We definitely want to report d1 and not d2! Happily it's easy to filter out those superclass-Wanteds, becuase their Origin betrays them. - See test T18851 for an example of how it is (just, barely) possible for the /only/ - errors to be superclass-of-Wanted constraints. - (SCE2) Errors which arise from the interaction of two Wanted fun-dep constraints. Example: @@ -810,9 +807,15 @@ Which errors are suppressed? Mechanism: -We use the `suppress` function within reportWanteds to filter out these two -cases, then report all other errors. Lastly, we return to these suppressed -ones and report them only if there have been no errors so far. +We use the `suppress` function within reportWanteds to filter out these +"suppress" cases, then report all other errors. After doing so, we return to these +suppressed ones and report them only if there have been no errors so far. + +(SCE3) How can it happen that there are /only/ suppressed errors? See test T18851 + for an example of how it is (just, barely) possible for the /only/ errors to + be superclass-of-Wanted constraints. + + Note [Constraints to ignore] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== hadrian/src/Rules/Gmp.hs ===================================== @@ -11,7 +11,7 @@ import Target import Utilities import Hadrian.BuildPath import Hadrian.Expression -import Settings.Builders.Common (cArgs, getStagedCCFlags) +import Settings.Builders.Common (getStagedCCFlags) -- | Build in-tree GMP library objects (if GmpInTree flag is set) and return -- their paths. @@ -125,8 +125,7 @@ gmpRules = do cFlags <- interpretInContext ctx $ mconcat - [ cArgs - , getStagedCCFlags + [ getStagedCCFlags -- gmp symbols are only used by bignum logic in -- ghc-internal and shouldn't be exported by the -- ghc-internal shared library. ===================================== hadrian/src/Rules/Libffi.hs ===================================== @@ -130,17 +130,14 @@ fixLibffiMakefile top = configureEnvironment :: Stage -> Action [CmdOption] configureEnvironment stage = do context <- libffiContext stage - cFlags <- interpretInContext context $ mconcat - [ cArgs - , getStagedCCFlags ] - ldFlags <- interpretInContext context ldArgs + cFlags <- interpretInContext context getStagedCCFlags sequence [ builderEnvironment "CC" $ Cc CompileC stage , builderEnvironment "CXX" $ Cc CompileC stage - , builderEnvironment "AR" (Ar Unpack stage) + , builderEnvironment "AR" $ Ar Unpack stage , builderEnvironment "NM" Nm , builderEnvironment "RANLIB" Ranlib , return . AddEnv "CFLAGS" $ unwords cFlags ++ " -w" - , return . AddEnv "LDFLAGS" $ unwords ldFlags ++ " -w" ] + , return . AddEnv "LDFLAGS" $ "-w" ] -- Need the libffi archive and `trackAllow` all files in the build directory. -- See [Libffi indicating inputs]. ===================================== hadrian/src/Settings/Builders/Cabal.hs ===================================== @@ -188,18 +188,16 @@ configureArgs cFlags' ldFlags' = do values <- unwords <$> expr not (null values) ? arg ("--configure-option=" ++ key ++ "=" ++ values) - cFlags = mconcat [ remove ["-Werror"] cArgs - , getStagedCCFlags + cFlags = mconcat [ getStagedCCFlags -- See https://github.com/snowleopard/hadrian/issues/523 , arg $ "-iquote" , arg $ top -/- pkgPath pkg , cFlags' ] - ldFlags = ldArgs <> ldFlags' mconcat [ conf "CFLAGS" cFlags - , conf "LDFLAGS" ldFlags + , conf "LDFLAGS" ldFlags' , conf "--with-iconv-includes" $ arg =<< getSetting IconvIncludeDir , conf "--with-iconv-libraries" $ arg =<< getSetting IconvLibDir , conf "--with-gmp-includes" $ arg =<< getSetting GmpIncludeDir ===================================== hadrian/src/Settings/Builders/Common.hs ===================================== @@ -5,7 +5,7 @@ module Settings.Builders.Common ( module Oracles.Setting, module Settings, module UserSettings, - cIncludeArgs, ldArgs, cArgs, cppArgs, cWarnings, + cIncludeArgs, cWarnings, packageDatabaseArgs, bootPackageDatabaseArgs, getStagedCCFlags, wayCcArgs ) where @@ -38,15 +38,6 @@ cIncludeArgs = do , pure [ "-I" ++ pkgPath pkg -/- dir | dir <- incDirs ] , pure [ "-I" ++ unifyPath dir | dir <- depDirs ] ] -ldArgs :: Args -ldArgs = mempty - -cArgs :: Args -cArgs = mempty - -cppArgs :: Args -cppArgs = mempty - -- TODO: should be in a different file cWarnings :: Args cWarnings = mconcat ===================================== hadrian/src/Settings/Builders/DeriveConstants.hs ===================================== @@ -40,8 +40,7 @@ includeCcArgs :: Args includeCcArgs = do stage <- getStage rtsPath <- expr $ rtsBuildPath stage - mconcat [ cArgs - , cWarnings + mconcat [ cWarnings , prgFlags . ccProgram . tgtCCompiler <$> expr (targetStage Stage1) , queryTargetTarget tgtUnregisterised ? arg "-DUSE_MINIINTERPRETER" , arg "-Irts" ===================================== hadrian/src/Settings/Builders/Hsc2Hs.hs ===================================== @@ -50,7 +50,7 @@ getCFlags = do autogen <- expr $ autogenPath context let cabalMacros = autogen -/- "cabal_macros.h" expr $ need [cabalMacros] - mconcat [ remove ["-O"] (cArgs <> getStagedCCFlags) + mconcat [ remove ["-O"] getStagedCCFlags -- Either "-E" is not part of the configured cpp args, or we can't add those args to invocations of things like this -- ROMES:TODO: , prgFlags . cppProgram . tgtCPreprocessor <$> getStagedTargetConfig , cIncludeArgs @@ -64,6 +64,5 @@ getCFlags = do getLFlags :: Expr [String] getLFlags = mconcat [ prgFlags . ccLinkProgram . tgtCCompilerLink <$> getStagedTarget - , ldArgs , getContextData ldOpts , getContextData depLdOpts ] ===================================== libraries/ghc-internal/cbits/Stack_c.c ===================================== @@ -9,13 +9,13 @@ #include "rts/storage/InfoTables.h" StgWord stackFrameSize(StgStack *stack, StgWord offset) { - StgClosure *c = (StgClosure *)stack->sp + 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; + StgClosure *frame = (StgClosure *)(stack->sp + offset); ASSERT(LOOKS_LIKE_CLOSURE_PTR(frame)); const StgRetInfoTable *info = get_ret_itbl((StgClosure *)frame); ===================================== libraries/ghc-internal/ghc-internal.cabal.in ===================================== @@ -300,6 +300,7 @@ Library GHC.Internal.Stack.CCS GHC.Internal.Stack.CloneStack GHC.Internal.Stack.Constants + GHC.Internal.Stack.ConstantsProf GHC.Internal.Stack.Decode GHC.Internal.Stack.Types GHC.Internal.Stats ===================================== libraries/ghc-internal/src/GHC/Internal/Stack/ConstantsProf.hsc ===================================== @@ -0,0 +1,140 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module GHC.Internal.Stack.ConstantsProf where + +import GHC.Internal.Base +import GHC.Internal.Enum +import GHC.Internal.Num +import GHC.Internal.Show +import GHC.Internal.Real + +-- This file is a copy of GHC.Internal.Stack.Constants, but compiled with PROFILING +-- defined, since hsc is only invoked once per build in the vanilla way. +-- +-- Also see GHC.Internal.Heap.InfoTable{Prof} +#define PROFILING +#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 ===================================== @@ -54,9 +54,19 @@ import GHC.Internal.Heap.Closures GenStackField(..) ) import GHC.Internal.Heap.Constants (wORD_SIZE_IN_BITS) -import GHC.Internal.Heap.InfoTable import GHC.Internal.Stack.Annotation +-- See Note [No way-dependent imports] +#if defined(PROFILING) +import GHC.Internal.Stack.Constants () +import GHC.Internal.Stack.ConstantsProf +import GHC.Internal.Heap.InfoTable () +import GHC.Internal.Heap.InfoTableProf +#else +import GHC.Internal.Heap.InfoTable +import GHC.Internal.Heap.InfoTableProf () import GHC.Internal.Stack.Constants +import GHC.Internal.Stack.ConstantsProf () +#endif import GHC.Internal.Stack.CloneStack import GHC.Internal.InfoProv.Types (InfoProv (..), ipLoc, lookupIPE) ===================================== libraries/ghc-internal/tests/backtraces/T26507.hs ===================================== @@ -0,0 +1,7 @@ +import GHC.Internal.Control.Exception +import GHC.Internal.Exception.Backtrace + +main :: IO () +main = do + setBacktraceMechanismState IPEBacktrace True + throwIO $ ErrorCall "Throw error" ===================================== libraries/ghc-internal/tests/backtraces/T26507.stderr ===================================== @@ -0,0 +1,8 @@ +T26507: Uncaught exception ghc-internal:GHC.Internal.Exception.ErrorCall: + +Throw error + +IPE backtrace: +HasCallStack backtrace: + throwIO, called at T26507.hs:7:3 in main:Main + ===================================== libraries/ghc-internal/tests/backtraces/all.T ===================================== @@ -1,2 +1,6 @@ test('T14532a', [], compile_and_run, ['']) test('T14532b', [], compile_and_run, ['']) +test('T26507', [ when(have_profiling(), extra_ways(['prof'])) + , when(js_arch(), skip) + , exit_code(1)], compile_and_run, ['']) + ===================================== libraries/ghc-internal/tests/stack-annotation/all.T ===================================== @@ -1,7 +1,10 @@ # Javascript backend don't support annotation frames, yet -setTestOpts(when(js_arch(), skip)) +# and test with profiling way if available (#26507) +ann_frame_opts = [ when(js_arch(), skip) + , when(have_profiling(), extra_ways(['prof'])) + , extra_files(['TestUtils.hs'])] -test('ann_frame001', [extra_files(['TestUtils.hs'])], compile_and_run, ['']) -test('ann_frame002', [extra_files(['TestUtils.hs'])], compile_and_run, ['']) -test('ann_frame003', [extra_files(['TestUtils.hs'])], compile_and_run, ['']) -test('ann_frame004', [extra_files(['TestUtils.hs'])], compile_and_run, ['']) +test('ann_frame001', ann_frame_opts, compile_and_run, ['']) +test('ann_frame002', ann_frame_opts, compile_and_run, ['']) +test('ann_frame003', ann_frame_opts, compile_and_run, ['']) +test('ann_frame004', ann_frame_opts, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c4e6e0df69e566f6f1eb840e3562a0… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c4e6e0df69e566f6f1eb840e3562a0… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/wasm-dyld-pie] wasm: support running dyld fully client side in browser
by Cheng Shao (＠TerrorJack) 24 Oct '25

24 Oct '25

Cheng Shao pushed to branch wip/wasm-dyld-pie at Glasgow Haskell Compiler / GHC Commits: 33278bf7 by Cheng Shao at 2025-10-24T23:30:48+02:00 wasm: support running dyld fully client side in browser - - - - - 1 changed file: - utils/jsffi/dyld.mjs Changes: ===================================== utils/jsffi/dyld.mjs ===================================== @@ -285,7 +285,10 @@ function originFromServerAddress({ address, family, port }) { } // Browser/node portable code stays above this watermark. -const isNode = Boolean(globalThis?.process?.versions?.node); +let isNode = Boolean(globalThis?.process?.versions?.node); +if (globalThis.Deno) { + isNode = false; +} // Too cumbersome to only import at use sites. Too troublesome to // factor out browser-only/node-only logic into different modules. For @@ -307,18 +310,22 @@ if (isNode) { ws = require("ws"); } catch {} } else { - wasi = await import( - "https://cdn.jsdelivr.net/npm/@bjorn3/browser_wasi_shim@0.4.2/dist/index.js" - ); + wasi = await import("https://esm.sh/gh/haskell-wasm/browser_wasi_shim"); } // A subset of dyld logic that can only be run in the host node // process and has full access to local filesystem -class DyLDHost { +export class DyLDHost { // Deduped absolute paths of directories where we lookup .so files #rpaths = new Set(); constructor({ out_fd, in_fd }) { + // When running a non-iserv shared library with node, the DyLDHost + // instance is created without a pair of fds, so skip creation of + // readStream/writeStream, they won't be used anyway + if (!(typeof out_fd === "number" && typeof in_fd === "number")) { + return; + } this.readStream = stream.Readable.toWeb( fs.createReadStream(undefined, { fd: in_fd }) ); @@ -373,6 +380,77 @@ class DyLDHost { } } +// Runs in the browser and uses the in-memory vfs, doesn't do any RPC +// calls +export class DyLDBrowserHost { + // Deduped absolute paths of directories where we lookup .so files + #rpaths = new Set(); + // The PreopenDirectory object of the root filesystem + rootfs; + + // Given canonicalized absolute file path, return Uint8Array of file + // content, or null if absent + #readFile(p) { + const { ret, entry } = this.rootfs.dir.get_entry_for_path({ + parts: p.split("/").filter((tok) => tok !== ""), + is_dir: false, + }); + return ret === 0 ? entry.data : null; + } + + constructor({ rootfs }) { + this.rootfs = rootfs; + } + + close() {} + + installSignalHandlers(_cb) {} + + // p must be canonicalized absolute path + async addLibrarySearchPath(p) { + this.#rpaths.add(p); + return null; + } + + async findSystemLibrary(f) { + if (f.startsWith("/")) { + if (this.#readFile(f)) { + return f; + } + throw new Error(`findSystemLibrary(${f}): not found in /`); + } + + for (const rpath of this.#rpaths) { + const r = `${rpath}/${f}`; + if (this.#readFile(r)) { + return r; + } + } + + throw new Error( + `findSystemLibrary(${f}): not found in ${[...this.#rpaths]}` + ); + } + + async fetchWasm(p) { + let buf = this.#readFile(p); + if (buf.buffer.resizable) { + buf = new Uint8Array(buf); + } + return new Response(buf, { + headers: { "Content-Type": "application/wasm" }, + }); + } + + stdout(msg) { + console.info(msg); + } + + stderr(msg) { + console.warn(msg); + } +} + // Fulfill the same functionality as DyLDHost by doing fetch() calls // to respective RPC endpoints of a host http server. Also manages // WebSocket connections back to host. @@ -540,7 +618,7 @@ class DyLDRPCServer { res.end( ` import { DyLDRPC, main } from "./fs${dyldPath}"; -const args = ${JSON.stringify({ libdir, ghciSoPath, args })}; +const args = ${JSON.stringify({ libdirs: [libdir], ghciSoPath, args })}; args.rpc = new DyLDRPC({origin: "${origin}", redirectWasiConsole: ${redirectWasiConsole}}); args.rpc.opened.then(() => main(args)); ` @@ -832,6 +910,10 @@ class DyLD { ], { debug: false } ); + + if (this.#rpc instanceof DyLDBrowserHost) { + this.#wasi.fds[3] = this.#rpc.rootfs; + } } // Both wasi implementations we use provide @@ -1218,15 +1300,39 @@ class DyLD { } } -export async function main({ rpc, libdir, ghciSoPath, args }) { +// The main entry point of dyld that may be run on node/browser, and +// may run either iserv defaultMain from the ghci library or an +// alternative entry point from another shared library +export async function main({ + rpc, // Handle the side effects of DyLD + libdirs, // Initial library search directories + ghciSoPath, // Could also be another shared library that's actually not ghci + args, // WASI argv without the executable name. +RTS etc will be respected + altEntry, // Optional alternative entry point function name + altArgs, // Argument array to pass to the alternative entry point function +}) { try { const dyld = new DyLD({ args: ["dyld.so", ...args], rpc, }); - await dyld.addLibrarySearchPath(libdir); + for (const libdir of libdirs) { + await dyld.addLibrarySearchPath(libdir); + } await dyld.loadDLLs(ghciSoPath); + // At this point, rts/ghc-internal are loaded, perform wasm shared + // library specific RTS startup logic, see Note [JSFFI + // initialization] + dyld.exportFuncs.__ghc_wasm_jsffi_init(); + + // We're not running iserv, just invoke user-specified alternative + // entry point and pass the arguments + if (altEntry) { + return await dyld.exportFuncs[altEntry](...altArgs); + } + + // iserv-specific logic follows const reader = rpc.readStream.getReader(); const writer = rpc.writeStream.getWriter(); @@ -1245,19 +1351,19 @@ export async function main({ rpc, libdir, ghciSoPath, args }) { writer.write(new Uint8Array(buf)); }; - dyld.exportFuncs.__ghc_wasm_jsffi_init(); - await dyld.exportFuncs.defaultServer(cb_sig, cb_recv, cb_send); + return await dyld.exportFuncs.defaultServer(cb_sig, cb_recv, cb_send); } finally { rpc.close(); } } -export async function nodeMain({ libdir, ghciSoPath, out_fd, in_fd, args }) { +// node-specific iserv-specific logic +async function nodeMain({ libdir, ghciSoPath, out_fd, in_fd, args }) { if (!process.env.GHCI_BROWSER) { const rpc = new DyLDHost({ out_fd, in_fd }); await main({ rpc, - libdir, + libdirs: [libdir], ghciSoPath, args, }); @@ -1370,6 +1476,8 @@ export async function nodeMain({ libdir, ghciSoPath, out_fd, in_fd, args }) { ); } +// Can't be reused with isMain in post-link.mjs, import.meta.filename +// evaluates to filename of source location function isNodeMain() { if (!globalThis?.process?.versions?.node) { return false; @@ -1378,6 +1486,8 @@ function isNodeMain() { return import.meta.filename === process.argv[1]; } +// node iserv as invoked by +// GHC.Runtime.Interpreter.Wasm.spawnWasmInterp if (isNodeMain()) { const libdir = process.argv[2]; const ghciSoPath = process.argv[3]; View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/33278bf705b96a4e22bb8defd11aa8c… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/33278bf705b96a4e22bb8defd11aa8c… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/wasm-dyld-pie] wasm: factor out nodeMain in dyld
by Cheng Shao (＠TerrorJack) 24 Oct '25

24 Oct '25

Cheng Shao pushed to branch wip/wasm-dyld-pie at Glasgow Haskell Compiler / GHC Commits: 82c0689a by Cheng Shao at 2025-10-24T19:07:39+02:00 wasm: factor out nodeMain in dyld - - - - - 1 changed file: - utils/jsffi/dyld.mjs Changes: ===================================== utils/jsffi/dyld.mjs ===================================== @@ -318,11 +318,7 @@ class DyLDHost { // Deduped absolute paths of directories where we lookup .so files #rpaths = new Set(); - constructor() { - // Inherited pipe file descriptors from GHC - const out_fd = Number.parseInt(process.argv[4]), - in_fd = Number.parseInt(process.argv[5]); - + constructor({ out_fd, in_fd }) { this.readStream = stream.Readable.toWeb( fs.createReadStream(undefined, { fd: in_fd }) ); @@ -494,7 +490,7 @@ export class DyLDRPC { // Actual implementation of endpoints used by DyLDRPC class DyLDRPCServer { - #dyldHost = new DyLDHost(); + #dyldHost; #server; #wss; @@ -504,9 +500,13 @@ class DyLDRPCServer { dyldPath, libdir, ghciSoPath, + out_fd, + in_fd, args, redirectWasiConsole, }) { + this.#dyldHost = new DyLDHost({ out_fd, in_fd }); + this.#server = http.createServer(async (req, res) => { const origin = originFromServerAddress(await this.listening); @@ -1252,17 +1252,9 @@ export async function main({ rpc, libdir, ghciSoPath, args }) { } } -(async () => { - if (!isNode) { - return; - } - - const libdir = process.argv[2]; - const ghciSoPath = process.argv[3]; - const args = process.argv.slice(6); - +export async function nodeMain({ libdir, ghciSoPath, out_fd, in_fd, args }) { if (!process.env.GHCI_BROWSER) { - const rpc = new DyLDHost(); + const rpc = new DyLDHost({ out_fd, in_fd }); await main({ rpc, libdir, @@ -1284,6 +1276,8 @@ export async function main({ rpc, libdir, ghciSoPath, args }) { dyldPath: import.meta.filename, libdir, ghciSoPath, + out_fd, + in_fd, args, redirectWasiConsole: process.env.GHCI_BROWSER_PUPPETEER_LAUNCH_OPTS || @@ -1374,4 +1368,22 @@ export async function main({ rpc, libdir, ghciSoPath, args }) { console.log( `Open ${origin}/main.html or import ${origin}/main.js to boot ghci` ); -})(); +} + +function isNodeMain() { + if (!globalThis?.process?.versions?.node) { + return false; + } + + return import.meta.filename === process.argv[1]; +} + +if (isNodeMain()) { + const libdir = process.argv[2]; + const ghciSoPath = process.argv[3]; + const out_fd = Number.parseInt(process.argv[4]), + in_fd = Number.parseInt(process.argv[5]); + const args = process.argv.slice(6); + + nodeMain({ libdir, ghciSoPath, out_fd, in_fd, args }); +} View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82c0689a4aef740fc399a1f88c84bea… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/82c0689a4aef740fc399a1f88c84bea… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/int-index/subordinate-export-namespaces] Fix namespace specifiers in subordinate exports (#12488)
by Vladislav Zavialov (＠int-index) 24 Oct '25

24 Oct '25

Vladislav Zavialov pushed to branch wip/int-index/subordinate-export-namespaces at Glasgow Haskell Compiler / GHC Commits: 21002761 by Vladislav Zavialov at 2025-10-24T15:38:36+03:00 Fix namespace specifiers in subordinate exports (#12488) This patch fixes an oversight in the `lookupChildrenExport` function that caused explicit namespace specifiers of subordinate export items to be ignored: module M (T (type A)) where -- should be rejected data T = A Based on the `IEWrappedName` data type, there are 5 cases to consider: 1. Unadorned name: P(X) 2. Named default: P(default X) 3. Pattern synonym: P(pattern X) 4. Type name: P(type X) 5. Data name: P(data X) Case 1 is already handled correctly; cases 2 and 3 are parse errors; and it is cases 4 and 5 that we are concerned with in this patch. Following the precedent established in `LookupExactName`, we introduce a boolean flag in `LookupChildren` to control whether to look up in all namespaces or in a specific one. If an export item is accompanied by an explicit namespace specifier `type` or `data`, we restrict the lookup in `lookupGRE` to a specific namespace. - - - - - 17 changed files: - compiler/GHC/Rename/Env.hs - compiler/GHC/Tc/Gen/Export.hs - compiler/GHC/Types/Name/Reader.hs - + testsuite/tests/parser/should_fail/T12488c.hs - + testsuite/tests/parser/should_fail/T12488c.stderr - + testsuite/tests/parser/should_fail/T12488d.hs - + testsuite/tests/parser/should_fail/T12488d.stderr - testsuite/tests/parser/should_fail/all.T - + testsuite/tests/rename/should_compile/T12488b.hs - testsuite/tests/rename/should_compile/all.T - + testsuite/tests/rename/should_fail/T12488a.hs - + testsuite/tests/rename/should_fail/T12488a.stderr - + testsuite/tests/rename/should_fail/T12488a_foo.hs - + testsuite/tests/rename/should_fail/T12488a_foo.stderr - + testsuite/tests/rename/should_fail/T12488e.hs - + testsuite/tests/rename/should_fail/T12488e.stderr - testsuite/tests/rename/should_fail/all.T Changes: ===================================== compiler/GHC/Rename/Env.hs ===================================== @@ -681,19 +681,20 @@ lookupGlobalOccRn will find it. -} -- | Used in export lists to lookup the children. -lookupSubBndrOcc_helper :: Bool +lookupSubBndrOcc_helper :: Bool -- ^ must have a parent + -> Bool -- ^ look up in all namespaces -> DeprecationWarnings -> ParentGRE -- ^ parent -> RdrName -- ^ thing we are looking up -> RnM ChildLookupResult -lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent_gre rdr_name +lookupSubBndrOcc_helper must_have_parent all_ns warn_if_deprec parent_gre rdr_name | isUnboundName (parentGRE_name parent_gre) -- Avoid an error cascade = return (FoundChild (mkUnboundGRERdr rdr_name)) | otherwise = do gre_env <- getGlobalRdrEnv - let original_gres = lookupGRE gre_env (LookupChildren parent_gre (rdrNameOcc rdr_name)) + let original_gres = lookupGRE gre_env (LookupChildren parent_gre (rdrNameOcc rdr_name) all_ns) picked_gres = pick_gres original_gres -- The remaining GREs are things that we *could* export here. -- Note that this includes things which have `NoParent`; @@ -846,7 +847,7 @@ lookupSubBndrOcc :: DeprecationWarnings lookupSubBndrOcc warn_if_deprec the_parent what_subordinate rdr_name = lookupExactOrOrig rdr_name (Right . greName) $ -- This happens for built-in classes, see mod052 for example - do { child <- lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name + do { child <- lookupSubBndrOcc_helper True True warn_if_deprec the_parent rdr_name ; return $ case child of FoundChild g -> Right (greName g) NameNotFound -> Left unknown_sub ===================================== compiler/GHC/Tc/Gen/Export.hs ===================================== @@ -36,7 +36,6 @@ import GHC.Data.Maybe import GHC.Data.FastString (fsLit) import GHC.Driver.Env import GHC.Driver.DynFlags -import GHC.Parser.PostProcess ( setRdrNameSpace ) import qualified GHC.LanguageExtensions as LangExt import GHC.Types.Unique.Map @@ -792,17 +791,19 @@ lookupChildrenExport parent_gre rdr_items = mapAndReportM doOne rdr_items -> RnM (LIEWrappedName GhcRn, GlobalRdrElt) doOne n = do + let all_ns = case unLoc n of + IEName{} -> True -- Ignore the namespace iff the name is unadorned + _ -> False let bareName = (ieWrappedName . unLoc) n -- Do not report export list declaration deprecations - name <- lookupSubBndrOcc_helper False ExportDeprecationWarnings + name <- lookupSubBndrOcc_helper False all_ns ExportDeprecationWarnings (ParentGRE spec_parent (greInfo parent_gre)) bareName traceRn "lookupChildrenExport" (ppr name) - -- Default to data constructors for slightly better error - -- messages + -- Default to data namespace for slightly better error messages let unboundName :: RdrName - unboundName = if rdrNameSpace bareName == varName - then bareName - else setRdrNameSpace bareName dataName + unboundName + | all_ns = fromMaybe bareName (demoteRdrName bareName) + | otherwise = bareName case name of NameNotFound -> ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -1182,8 +1182,12 @@ data LookupGRE info where -- | Look up children 'GlobalRdrElt's with a given 'Parent'. LookupChildren - :: ParentGRE -- ^ the parent - -> OccName -- ^ the child 'OccName' to look up + :: { lookupParentGRE :: ParentGRE -- ^ the parent + , lookupChildOccName :: OccName -- ^ the child 'OccName' to look up + , lookupChildrenInAllNameSpaces :: Bool + -- ^ whether to look in *all* 'NameSpace's, or just + -- in the 'NameSpace' of the 'OccName' + } -> LookupGRE GREInfo -- | How should we look up in a 'GlobalRdrEnv'? @@ -1420,10 +1424,15 @@ lookupGRE env = \case occ = nameOccName nm lkup | all_ns = concat $ lookupOccEnv_AllNameSpaces env occ | otherwise = fromMaybe [] $ lookupOccEnv env occ - LookupChildren parent child_occ -> - let ns = occNameSpace child_occ - all_gres = concat $ lookupOccEnv_AllNameSpaces env child_occ - in highestPriorityGREs (childGREPriority parent ns) all_gres + LookupChildren { lookupParentGRE = parent + , lookupChildOccName = child_occ + , lookupChildrenInAllNameSpaces = all_ns } -> + highestPriorityGREs (childGREPriority parent ns) $ + concat $ lkup env child_occ + where + ns = occNameSpace child_occ + lkup | all_ns = lookupOccEnv_AllNameSpaces + | otherwise = lookupOccEnv_WithFields -- | Collect the 'GlobalRdrElt's with the highest priority according -- to the given function (lower value <=> higher priority). ===================================== testsuite/tests/parser/should_fail/T12488c.hs ===================================== @@ -0,0 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} +module T12488c ( T (pattern A) ) where + +data T = A \ No newline at end of file ===================================== testsuite/tests/parser/should_fail/T12488c.stderr ===================================== @@ -0,0 +1,2 @@ +T12488c.hs:2:21: error: [GHC-58481] parse error on input ‘pattern’ + ===================================== testsuite/tests/parser/should_fail/T12488d.hs ===================================== @@ -0,0 +1,6 @@ +{-# LANGUAGE NamedDefaults #-} +module T12488d ( T (default C) ) where + +class C a where + +data T = A \ No newline at end of file ===================================== testsuite/tests/parser/should_fail/T12488d.stderr ===================================== @@ -0,0 +1,2 @@ +T12488d.hs:2:21: error: [GHC-58481] parse error on input ‘default’ + ===================================== testsuite/tests/parser/should_fail/all.T ===================================== @@ -242,3 +242,5 @@ test('T25258b', normal, compile_fail, ['']) test('T25258c', normal, compile_fail, ['']) test('T25530', normal, compile_fail, ['']) test('T26418', normal, compile_fail, ['']) +test('T12488c', normal, compile_fail, ['']) +test('T12488d', normal, compile_fail, ['']) ===================================== testsuite/tests/rename/should_compile/T12488b.hs ===================================== @@ -0,0 +1,4 @@ +{-# LANGUAGE ExplicitNamespaces #-} +module T12488b ( T (data A) ) where + +data T = A ===================================== testsuite/tests/rename/should_compile/all.T ===================================== @@ -245,3 +245,4 @@ test('T25899a', normal, compile, ['']) test('T25899b', normal, compile, ['']) test('T25899c', [extra_files(['T25899c_helper.hs'])], multimod_compile, ['T25899c', '-v0']) test('T25899d', combined_output, ghci_script, ['T25899d.script']) +test('T12488b', normal, compile, ['']) ===================================== testsuite/tests/rename/should_fail/T12488a.hs ===================================== @@ -0,0 +1,4 @@ +{-# LANGUAGE ExplicitNamespaces #-} +module T12488a ( T (type A) ) where + +data T = A ===================================== testsuite/tests/rename/should_fail/T12488a.stderr ===================================== @@ -0,0 +1,5 @@ +T12488a.hs:2:18: error: [GHC-76037] + • Not in scope: type constructor or class ‘A’ + • In the export: T(type A) + Suggested fix: Perhaps use data constructor ‘A’ (line 4) + ===================================== testsuite/tests/rename/should_fail/T12488a_foo.hs ===================================== @@ -0,0 +1,9 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE TypeFamilies #-} +module T12488a_foo ( T (type A) ) where + +data T = A + +class Foo a where + type A a + foo :: a -> Int ===================================== testsuite/tests/rename/should_fail/T12488a_foo.stderr ===================================== @@ -0,0 +1,5 @@ +T12488a_foo.hs:3:22: error: [GHC-76037] + • Not in scope: type constructor or class ‘A’ + • In the export: T(type A) + Suggested fix: Perhaps use data constructor ‘A’ (line 5) + ===================================== testsuite/tests/rename/should_fail/T12488e.hs ===================================== @@ -0,0 +1,6 @@ +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE TypeFamilies #-} +module T12488e ( C (data A) ) where + +class C a where + type A a ===================================== testsuite/tests/rename/should_fail/T12488e.stderr ===================================== @@ -0,0 +1,5 @@ +T12488e.hs:3:18: error: [GHC-76037] + • Not in scope: data constructor ‘A’ + • In the export: C(data A) + Suggested fix: Perhaps use type constructor or class ‘A’ (line 6) + ===================================== testsuite/tests/rename/should_fail/all.T ===================================== @@ -246,3 +246,6 @@ test('T25899e1', normal, compile_fail, ['']) test('T25899e2', normal, compile_fail, ['']) test('T25899e3', [extra_files(['T25899e_helper.hs'])], multimod_compile_fail, ['T25899e3', '-v0']) test('T25899f', [extra_files(['T25899f_helper.hs'])], multimod_compile_fail, ['T25899f', '-v0']) +test('T12488a', normal, compile_fail, ['']) +test('T12488a_foo', normal, compile_fail, ['']) +test('T12488e', normal, compile_fail, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/210027618405b85224187569d5c604e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/210027618405b85224187569d5c604e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/wasm-dyld-pie] 5 commits: Improve error handling in 'getPackageArchives'
by Cheng Shao (＠TerrorJack) 24 Oct '25

24 Oct '25

Cheng Shao pushed to branch wip/wasm-dyld-pie at Glasgow Haskell Compiler / GHC Commits: 91b6be10 by Julian Ospald at 2025-10-20T18:21:03-04:00 Improve error handling in 'getPackageArchives' When the library dirs in the package conf files are not set up correctly, the JS linker will happily ignore such packages and not link against them, although they're part of the link plan. Fixes #26383 - - - - - 6c5269da by Sven Tennie at 2025-10-20T18:21:44-04:00 Align coding style Improve readability by using the same style for all constructor calls in this function. - - - - - 3d305889 by Sven Tennie at 2025-10-20T18:21:44-04:00 Reduce complexity by removing joins with mempty ldArgs, cArgs and cppArgs are all `mempty`. Thus concatenating them adds nothing but some complexity while reading the code. - - - - - 647d3b9c by Cheng Shao at 2025-10-24T13:13:48+02:00 wasm: reformat dyld source code This commit reformats dyld source code with prettier, to avoid introducing unnecessary diffs in subsequent patches when they're formatted before committing. - - - - - a13ec8dd by Cheng Shao at 2025-10-24T13:13:48+02:00 wasm: simplify _initialize logic in dyld This commit simplifies how we _initialize a wasm shared library in dyld and removes special treatment for libc.so, see added comment for detailed explanation. - - - - - 8 changed files: - compiler/GHC/StgToJS/Linker/Linker.hs - hadrian/src/Rules/Gmp.hs - hadrian/src/Rules/Libffi.hs - hadrian/src/Settings/Builders/Cabal.hs - hadrian/src/Settings/Builders/Common.hs - hadrian/src/Settings/Builders/DeriveConstants.hs - hadrian/src/Settings/Builders/Hsc2Hs.hs - utils/jsffi/dyld.mjs Changes: ===================================== compiler/GHC/StgToJS/Linker/Linker.hs ===================================== @@ -2,6 +2,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE MultiWayIf #-} ----------------------------------------------------------------------------- -- | @@ -666,12 +667,19 @@ renderLinkerStats s = getPackageArchives :: StgToJSConfig -> UnitEnv -> [UnitId] -> IO [FilePath] -getPackageArchives cfg unit_env units = - filterM doesFileExist [ ST.unpack p </> "lib" ++ ST.unpack l ++ profSuff <.> "a" - | u <- units - , p <- getInstalledPackageLibDirs ue_state u - , l <- getInstalledPackageHsLibs ue_state u - ] +getPackageArchives cfg unit_env units = do + fmap concat $ forM units $ \u -> do + let archives = [ ST.unpack p </> "lib" ++ ST.unpack l ++ profSuff <.> "a" + | p <- getInstalledPackageLibDirs ue_state u + , l <- getInstalledPackageHsLibs ue_state u + ] + foundArchives <- filterM doesFileExist archives + if | not (null archives) + , null foundArchives + -> do + throwGhcExceptionIO (InstallationError $ "Could not find any library archives for unit-id: " <> (renderWithContext (csContext cfg) $ ppr u)) + | otherwise + -> pure foundArchives where ue_state = ue_homeUnitState unit_env ===================================== hadrian/src/Rules/Gmp.hs ===================================== @@ -11,7 +11,7 @@ import Target import Utilities import Hadrian.BuildPath import Hadrian.Expression -import Settings.Builders.Common (cArgs, getStagedCCFlags) +import Settings.Builders.Common (getStagedCCFlags) -- | Build in-tree GMP library objects (if GmpInTree flag is set) and return -- their paths. @@ -125,8 +125,7 @@ gmpRules = do cFlags <- interpretInContext ctx $ mconcat - [ cArgs - , getStagedCCFlags + [ getStagedCCFlags -- gmp symbols are only used by bignum logic in -- ghc-internal and shouldn't be exported by the -- ghc-internal shared library. ===================================== hadrian/src/Rules/Libffi.hs ===================================== @@ -130,17 +130,14 @@ fixLibffiMakefile top = configureEnvironment :: Stage -> Action [CmdOption] configureEnvironment stage = do context <- libffiContext stage - cFlags <- interpretInContext context $ mconcat - [ cArgs - , getStagedCCFlags ] - ldFlags <- interpretInContext context ldArgs + cFlags <- interpretInContext context getStagedCCFlags sequence [ builderEnvironment "CC" $ Cc CompileC stage , builderEnvironment "CXX" $ Cc CompileC stage - , builderEnvironment "AR" (Ar Unpack stage) + , builderEnvironment "AR" $ Ar Unpack stage , builderEnvironment "NM" Nm , builderEnvironment "RANLIB" Ranlib , return . AddEnv "CFLAGS" $ unwords cFlags ++ " -w" - , return . AddEnv "LDFLAGS" $ unwords ldFlags ++ " -w" ] + , return . AddEnv "LDFLAGS" $ "-w" ] -- Need the libffi archive and `trackAllow` all files in the build directory. -- See [Libffi indicating inputs]. ===================================== hadrian/src/Settings/Builders/Cabal.hs ===================================== @@ -188,18 +188,16 @@ configureArgs cFlags' ldFlags' = do values <- unwords <$> expr not (null values) ? arg ("--configure-option=" ++ key ++ "=" ++ values) - cFlags = mconcat [ remove ["-Werror"] cArgs - , getStagedCCFlags + cFlags = mconcat [ getStagedCCFlags -- See https://github.com/snowleopard/hadrian/issues/523 , arg $ "-iquote" , arg $ top -/- pkgPath pkg , cFlags' ] - ldFlags = ldArgs <> ldFlags' mconcat [ conf "CFLAGS" cFlags - , conf "LDFLAGS" ldFlags + , conf "LDFLAGS" ldFlags' , conf "--with-iconv-includes" $ arg =<< getSetting IconvIncludeDir , conf "--with-iconv-libraries" $ arg =<< getSetting IconvLibDir , conf "--with-gmp-includes" $ arg =<< getSetting GmpIncludeDir ===================================== hadrian/src/Settings/Builders/Common.hs ===================================== @@ -5,7 +5,7 @@ module Settings.Builders.Common ( module Oracles.Setting, module Settings, module UserSettings, - cIncludeArgs, ldArgs, cArgs, cppArgs, cWarnings, + cIncludeArgs, cWarnings, packageDatabaseArgs, bootPackageDatabaseArgs, getStagedCCFlags, wayCcArgs ) where @@ -38,15 +38,6 @@ cIncludeArgs = do , pure [ "-I" ++ pkgPath pkg -/- dir | dir <- incDirs ] , pure [ "-I" ++ unifyPath dir | dir <- depDirs ] ] -ldArgs :: Args -ldArgs = mempty - -cArgs :: Args -cArgs = mempty - -cppArgs :: Args -cppArgs = mempty - -- TODO: should be in a different file cWarnings :: Args cWarnings = mconcat ===================================== hadrian/src/Settings/Builders/DeriveConstants.hs ===================================== @@ -40,8 +40,7 @@ includeCcArgs :: Args includeCcArgs = do stage <- getStage rtsPath <- expr $ rtsBuildPath stage - mconcat [ cArgs - , cWarnings + mconcat [ cWarnings , prgFlags . ccProgram . tgtCCompiler <$> expr (targetStage Stage1) , queryTargetTarget tgtUnregisterised ? arg "-DUSE_MINIINTERPRETER" , arg "-Irts" ===================================== hadrian/src/Settings/Builders/Hsc2Hs.hs ===================================== @@ -50,7 +50,7 @@ getCFlags = do autogen <- expr $ autogenPath context let cabalMacros = autogen -/- "cabal_macros.h" expr $ need [cabalMacros] - mconcat [ remove ["-O"] (cArgs <> getStagedCCFlags) + mconcat [ remove ["-O"] getStagedCCFlags -- Either "-E" is not part of the configured cpp args, or we can't add those args to invocations of things like this -- ROMES:TODO: , prgFlags . cppProgram . tgtCPreprocessor <$> getStagedTargetConfig , cIncludeArgs @@ -64,6 +64,5 @@ getCFlags = do getLFlags :: Expr [String] getLFlags = mconcat [ prgFlags . ccLinkProgram . tgtCCompilerLink <$> getStagedTarget - , ldArgs , getContextData ldOpts , getContextData depLdOpts ] ===================================== utils/jsffi/dyld.mjs ===================================== @@ -834,6 +834,27 @@ class DyLD { ); } + // Both wasi implementations we use provide + // wasi.initialize(instance) to initialize a wasip1 reactor + // module. However, instance does not really need to be a + // WebAssembly.Instance object; the wasi implementations only need + // to access instance.exports.memory for the wasi syscalls to + // work. + // + // Given we'll reuse the same wasi object across different + // WebAssembly.Instance objects anyway and + // wasi.initialize(instance) can't be called more than once, we + // use this simple trick and pass a fake instance object that + // contains just enough info for the wasi implementation to + // initialize its internal state. Later when we load each wasm + // shared library, we can just manually invoke their + // initialization functions. + this.#wasi.initialize({ + exports: { + memory: this.#memory, + }, + }); + // Keep this in sync with rts/wasm/Wasm.S! for (let i = 1; i <= 10; ++i) { this.#regs[`__R${i}`] = new WebAssembly.Global({ @@ -930,10 +951,15 @@ class DyLD { async loadDLLs(packed) { // Normalize input to an array of strings. When called from Haskell // we pass a single JSString containing NUL-separated paths. - const paths = (typeof packed === "string" - ? (packed.length === 0 ? [] : packed.split("\0")) - : [packed] // tolerate an accidental single path object - ).filter((s) => s.length > 0).reverse(); + const paths = ( + typeof packed === "string" + ? packed.length === 0 + ? [] + : packed.split("\0") + : [packed] + ) // tolerate an accidental single path object + .filter((s) => s.length > 0) + .reverse(); // Compute a single downsweep plan for the whole batch. // Note: #downsweep mutates #loadedSos to break cycles and dedup. @@ -1154,22 +1180,6 @@ class DyLD { throw new Error(`cannot handle export ${k} ${v}`); } - // We call wasi.initialize when loading libc.so, then reuse the - // wasi instance globally. When loading later .so files, just - // manually invoke _initialize(). - if (soname === "libc.so") { - instance.exports.__wasm_apply_data_relocs(); - // wasm-ld forbits --export-memory with --shared, I don't know - // why but this is sufficient to make things work - this.#wasi.initialize({ - exports: { - memory: this.#memory, - _initialize: instance.exports._initialize, - }, - }); - continue; - } - // See // https://gitlab.haskell.org/haskell-wasm/llvm-project/-/blob/release/21.x/ll…, // __wasm_apply_data_relocs is now optional so only call it if @@ -1180,7 +1190,7 @@ class DyLD { // been called upon instantiation, see // Writer::createStartFunction(). if (instance.exports.__wasm_apply_data_relocs) { - instance.exports.__wasm_apply_data_relocs(); + instance.exports.__wasm_apply_data_relocs(); } instance.exports._initialize(); View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b5d2ee34d0686c7f599218a1f0006e… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b5d2ee34d0686c7f599218a1f0006e… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/int-index/subordinate-export-namespaces] drop unused import
by Vladislav Zavialov (＠int-index) 24 Oct '25

24 Oct '25

Vladislav Zavialov pushed to branch wip/int-index/subordinate-export-namespaces at Glasgow Haskell Compiler / GHC Commits: 03e39706 by Vladislav Zavialov at 2025-10-24T11:20:45+03:00 drop unused import - - - - - 1 changed file: - compiler/GHC/Tc/Gen/Export.hs Changes: ===================================== compiler/GHC/Tc/Gen/Export.hs ===================================== @@ -36,7 +36,6 @@ import GHC.Data.Maybe import GHC.Data.FastString (fsLit) import GHC.Driver.Env import GHC.Driver.DynFlags -import GHC.Parser.PostProcess ( setRdrNameSpace ) import qualified GHC.LanguageExtensions as LangExt import GHC.Types.Unique.Map View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/03e397065bdcf413eceb387644f3498… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/03e397065bdcf413eceb387644f3498… You're receiving this email because of your account on gitlab.haskell.org.

1 0