Magnus pushed to branch wip/mangoiv/9.12.5-rc3-fixes at Glasgow Haskell Compiler / GHC Commits: a9197261 by Andreas Klebinger at 2026-07-10T17:21:16+02:00 Fix a profiling race condition resulting in segfaults. StgToCmm: Don't assume tagged FUN closures in closureCodeBody. When entering a closure the self/node pointer might not be tagged in some situations when a thunk is evaluated by multiple threads. So we most AND away the tag bits rather than subtracting an expected tag. Apply.cmm: Fix a race condition occuring when a thunk is mutated during GC. In stg_ap_0_fast when might need to run GC before entering a thunk. If this happens another thread or the GC itself might mutate the closure making entering it no longer valid. We now check for this. Add test and changelog for #27123 fixes. (cherry picked from commit ed09895d7de1ca116a561868c151fd825a16ad0c) - - - - - f0a42e63 by Zubin Duggal at 2026-07-10T17:21:16+02:00 Bump semaphore-compat submodule to 2.0.1 This versions includes some cruicial fixes for darwin (cherry picked from commit 4180af3f71754472dbd49b85179b25fd29bd9998) - - - - - 27022a1e by Zubin Duggal at 2026-07-10T17:21:16+02:00 CorePrep: Don't speculatively evaluate bindings that we have already discovered to be absent In #25924, we segfault because speculation forces a projection out of a RUBBISH dictionary (which we generated because it absent). Solution: Don't speculate on bindings we already know are absent. Fixes 25924 (cherry picked from commit 9b714c4c833461c621f0a050680848d7248aa57e) - - - - - 31cf766a by Zubin Duggal at 2026-07-10T17:21:16+02:00 Don't make absent fillers for terminating types In #25924 we discovered that we could speculatively evaluate an absent filler for a dictionary, and project a field (a superclass selector) out of it, resulting in segfaults. Solution: Never make an absent filler or rubbish literal for a terminating type like a dictionary. mkAbsentFiller returns Nothing for isTerminatingType, so worker/wrapper and the specialiser keep the real argument instead. Some small metric decreases because we do a little less work in the simplifier now. Metric Decrease: T9872a T9872b T9872c TcPlugin_RewritePerf (cherry picked from commit 4a59b3eece9b7106fcbe73d2d06a49755be4ea8f) - - - - - 22 changed files: - + changelog.d/T27123.md - + changelog.d/fix-absent-dict-projection - changelog.d/semaphore-v2 - compiler/GHC/Core/Make.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Core/Opt/WorkWrap/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/StgToCmm/Bind.hs - compiler/GHC/Types/Literal.hs - hadrian/src/Settings/Warnings.hs - libraries/semaphore-compat - rts/Apply.cmm - + testsuite/tests/core-to-stg/T25924/B.hs - + testsuite/tests/core-to-stg/T25924/Main.hs - + testsuite/tests/core-to-stg/T25924/all.T - + testsuite/tests/core-to-stg/T25924a.hs - + testsuite/tests/core-to-stg/T25924a.stdout - testsuite/tests/core-to-stg/all.T - testsuite/tests/dmdanal/should_compile/T18982.stderr - + testsuite/tests/rts/T27123.hs - testsuite/tests/rts/all.T Changes: ===================================== changelog.d/T27123.md ===================================== @@ -0,0 +1,7 @@ +section: compiler +synopsis: Fix two crashes that could happen in a multithreaded setting when profiling. +description: There were two bugs that could cause occasional segfaults or crashes with +an `PAP object entered` error when profiling. They only happened when two threads +where racing to evaluate the same thunk, and specific GC timings. +mrs: !16214 +issues: #27123 ===================================== changelog.d/fix-absent-dict-projection ===================================== @@ -0,0 +1,8 @@ +section: compiler +synopsis: Fix a miscompilation that could project a field out of an absent dictionary, resulting in a segfault. +issues: #25924 +mrs: !16219 +description: + We no longer make an absent filler (a rubbish literal or error thunk) for an + absent dictionary or other terminating type. We also no longer speculatively + evaluate a binding once we have discovered that it is absent. ===================================== changelog.d/semaphore-v2 ===================================== @@ -2,7 +2,7 @@ section: compiler issues: #25087 mrs: !15729 synopsis: - Update to semaphore-compat 2.0.0 (``-jsem`` protocol v2) + Update to semaphore-compat 2.0.1 (``-jsem`` protocol v2) description: On Linux and other POSIX platforms, GHC's ``-jsem`` jobserver client now speaks v2 of the semaphore-compat protocol, which uses Unix ===================================== compiler/GHC/Core/Make.hs ===================================== @@ -219,13 +219,16 @@ mkLitRubbish :: Type -> Maybe CoreExpr -- Fail (returning Nothing) if -- * the RuntimeRep of the Type is not monomorphic; -- * the type is (a ~# b), the type of coercion --- See INVARIANT 1 and 2 of item (2) in Note [Rubbish literals] +-- * the type is terminating (isTerminatingType), e.g. a dictionary +-- See INVARIANT 1, 2 and 3 of item (2) in Note [Rubbish literals] -- in GHC.Types.Literal mkLitRubbish ty | not (noFreeVarsOfType rep) = Nothing -- Satisfy INVARIANT 1 | isCoVarType ty = Nothing -- Satisfy INVARIANT 2 + | isTerminatingType ty + = Nothing -- Satisfy INVARIANT 3 | otherwise = Just (Lit (LitRubbish torc rep) `mkTyApps` [ty]) where ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -20,11 +20,13 @@ import GHC.Core.Multiplicity import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith ) import GHC.Core.Predicate import GHC.Core.Coercion( Coercion ) +import GHC.Core.DataCon ( StrictnessMark (..) ) import GHC.Core.Opt.Monad + import qualified GHC.Core.Subst as Core import GHC.Core.Unfold.Make import GHC.Core -import GHC.Core.Make ( mkLitRubbish ) +import GHC.Core.Opt.WorkWrap.Utils ( mkAbsentFiller ) import GHC.Core.Unify ( tcMatchTy ) import GHC.Core.Rules import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable @@ -1711,7 +1713,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs ; ( useful, rhs_env2, leftover_bndrs , rule_bndrs, rule_lhs_args - , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args + , spec_bndrs1, dx_binds, spec_args) <- specHeader this_mod env rhs_bndrs all_call_args -- ; pprTrace "spec_call" (vcat -- [ text "fun: " <+> ppr fn @@ -2562,7 +2564,8 @@ isSpecDict _ = False -- , [T1, T2, c, i, dEqT1, dShow1] -- ) specHeader - :: SpecEnv + :: Module -- The module being compiled, for mkAbsentFiller + -> SpecEnv -> [InBndr] -- The binders from the original function 'f' -> [SpecArg] -- From the CallInfo -> SpecM ( Bool -- True <=> some useful specialisation happened @@ -2588,7 +2591,7 @@ specHeader -- We want to specialise on type 'T1', and so we must construct a substitution -- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding -- details. -specHeader env (bndr : bndrs) (SpecType ty : args) +specHeader mod env (bndr : bndrs) (SpecType ty : args) = do { -- Find qvars, the type variables to add to the binders for the rule -- Namely those free in `ty` that aren't in scope -- See (MP2) in Note [Specialising polymorphic dictionaries] @@ -2600,7 +2603,7 @@ specHeader env (bndr : bndrs) (SpecType ty : args) ty' = substTy env1 ty env2 = extendTvSubst env1 bndr ty' ; (useful, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader env2 bndrs args + <- specHeader mod env2 bndrs args ; pure ( useful , env3 , leftover_bndrs @@ -2616,10 +2619,10 @@ specHeader env (bndr : bndrs) (SpecType ty : args) -- a substitution on it (in case the type refers to 'a'). Additionally, we need -- to produce a binder, LHS argument and RHS argument for the resulting rule, -- /and/ a binder for the specialised body. -specHeader env (bndr : bndrs) (UnspecType : args) +specHeader mod env (bndr : bndrs) (UnspecType : args) = do { let (env', bndr') = substBndr env bndr ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader env' bndrs args + <- specHeader mod env' bndrs args ; pure ( useful , env'' , leftover_bndrs @@ -2630,18 +2633,17 @@ specHeader env (bndr : bndrs) (UnspecType : args) , varToCoreExpr bndr' : spec_args ) } - -- Next we want to specialise the 'Eq a' dict away. We need to construct -- a wildcard binder to match the dictionary (See Note [Specialising Calls] for -- the nitty-gritty), as a LHS rule and unfolding details. -specHeader env (bndr : bndrs) (SpecDict d : args) +specHeader mod env (bndr : bndrs) (SpecDict d : args) | not (isDeadBinder bndr) , allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d) -- See Note [Weird special case for SpecDict] = do { (env1, bndr') <- newDictBndr env bndr -- See Note [Zap occ info in rule binders] ; let (env2, dx_bind, spec_dict) = bindAuxiliaryDict env1 bndr bndr' d ; (_, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader env2 bndrs args + <- specHeader mod env2 bndrs args ; pure ( True -- Ha! A useful specialisation! , env3 , leftover_bndrs @@ -2666,21 +2668,24 @@ specHeader env (bndr : bndrs) (SpecDict d : args) -- why 'i' doesn't appear in our RULE above. But we have no guarantee that -- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so -- this case must be here. -specHeader env (bndr : bndrs) (_ : args) +specHeader mod env (bndr : bndrs) (_ : args) -- The "_" can be UnSpecArg, or SpecDict where the bndr is dead = do { -- see Note [Zap occ info in rule binders] let (env', bndr') = substBndr env (zapIdOccInfo bndr) ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) - <- specHeader env' bndrs args - - ; let bndr_ty = idType bndr' + <- specHeader mod env' bndrs args - -- See Note [Drop dead args from specialisations] + ; let -- See Note [Drop dead args from specialisations] -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let (mb_spec_bndr, spec_arg) | isDeadBinder bndr - , Just lit_expr <- mkLitRubbish bndr_ty - = (Nothing, lit_expr) + , Just filler <- mkAbsentFiller mod bndr' NotMarkedStrict + -- NB: mkAbsentFiller returns Nothing for a terminating type (e.g. a + -- dictionary), so this guard fails and we fall through, keeping the + -- argument instead of dropping it. + -- See Note [Don't make fillers for terminating types] + -- in GHC.Core.Opt.WorkWrap.Utils + = (Nothing, filler) | otherwise = (Just bndr', varToCoreExpr bndr') @@ -2699,12 +2704,12 @@ specHeader env (bndr : bndrs) (_ : args) -- If we run out of binders, stop immediately -- See Note [Specialisation Must Preserve Sharing] -specHeader env [] _ = pure (False, env, [], [], [], [], [], []) +specHeader _ env [] _ = pure (False, env, [], [], [], [], [], []) -- Return all remaining binders from the original function. These have the -- invariant that they should all correspond to unspecialised arguments, so -- it's safe to stop processing at this point. -specHeader env bndrs [] +specHeader _ env bndrs [] = pure (False, env', bndrs', [], [], [], [], []) where (env', bndrs') = substBndrs env bndrs ===================================== compiler/GHC/Core/Opt/WorkWrap.hs ===================================== @@ -550,7 +550,7 @@ tryWW ww_opts is_rec fn_id rhs -- See Note [Drop absent bindings] | isAbsDmd (demandInfo fn_info) , not (isJoinId fn_id) - , Just filler <- mkAbsentFiller ww_opts fn_id NotMarkedStrict + , Just filler <- mkAbsentFiller (wo_module ww_opts) fn_id NotMarkedStrict = return [(new_fn_id, filler)] -- See Note [Don't w/w INLINE things] ===================================== compiler/GHC/Core/Opt/WorkWrap/Utils.hs ===================================== @@ -29,7 +29,6 @@ import GHC.Core.Subst import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.Coercion -import GHC.Core.Predicate( isDictTy ) import GHC.Core.Reduction import GHC.Core.FamInstEnv import GHC.Core.TyCon @@ -936,7 +935,7 @@ mkWWstr_one opts arg str_mark = _ | isTyVar arg -> do_nothing DropAbsent - | Just absent_filler <- mkAbsentFiller opts arg str_mark + | Just absent_filler <- mkAbsentFiller (wo_module opts) arg str_mark -- Absent case. Drop the argument from the worker. -- We can't always handle absence for arbitrary -- unlifted types, so we need to choose just the cases we can @@ -1007,14 +1006,20 @@ unbox_one_arg opts arg_var -- -- If @mkAbsentFiller _ id == Just e@, then @e@ is an absent filler with the -- same type as @id@. Otherwise, no suitable filler could be found. -mkAbsentFiller :: WwOpts -> Id -> StrictnessMark -> Maybe CoreExpr -mkAbsentFiller opts arg str +mkAbsentFiller :: Module -> Id -> StrictnessMark -> Maybe CoreExpr +mkAbsentFiller mod arg str + -- We never make a filler for a terminating type: it might be speculatively + -- evaluated or have a field projected out of it. + -- See (AF4) in Note [Absent fillers], and + -- Note [Don't make fillers for terminating types]. + | isTerminatingType arg_ty + = Nothing + -- The lifted case: bind 'absentError'. See (AF1) in Note [Absent fillers] -- We want to use this case if possible, because we get a nice runtime panic message -- if we are wrong (like we were in #11126). Otherwise we fall through to the -- less-desirable mkLitRubbish case. | mightBeLiftedType arg_ty - , not (isDictTy arg_ty) -- See (AF4) in Note [Absent fillers] , not (isStrictDmd (idDemandInfo arg)) -- See (AF2) , not (isMarkedStrict str) -- in Note [Absent fillers] = Just (mkAbsentErrorApp arg_ty msg) @@ -1041,7 +1046,7 @@ mkAbsentFiller opts arg str -- will have different lengths and hence different costs for -- the inliner leading to different inlining. -- See also Note [Unique Determinism] in GHC.Types.Unique - file_msg = text "In module" <+> quotes (ppr $ wo_module opts) + file_msg = text "In module" <+> quotes (ppr mod) {- Note [Worker/wrapper for Strictness and Absence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1234,27 +1239,8 @@ Needless to say, there are some wrinkles: have to be representation monomorphic. But in the future, we might allow levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'. -(AF4) Consider (#24934) - f :: (a~b) => blah {-# INLINE f #-} - f d x = case eq_sel d of co -> body - In #24934 it turned out that `co` was unused; and we discarded the - entire case-scrutinisation via the `exprOkToDiscard` test in - `GHC.Core.Opt.Simplify.Iteration.rebuildCase`. So now `d` is absent. - But in the /unfolding/ for some reason we did not discard the `case`; - so when we inline `f` we end up evaluating that `d` argument. So we had - better not replace it with an error thunk! - - The root of it is this: `exprOkToDiscard` assumes that a dictionary is - non-bottom (Note [exprOkForSpeculation and type classes]); but then we replace - the (a~b) dictionary with an error thunk, breaking the invariant that every - dictionary is non-bottom. (If -XDictsStrict is on, the invariant is even - more important.) - - Simple solution: never use an error thunk for a dictionary; instead fall - through to mkRubbishLit. (The only downside is that we lose the compiler - debugging advantages of (AF1).) - - This is quite delicate. +(AF4) We never make an absent filler for a terminating type. + See Note [Don't make fillers for terminating types]. While (AF1) and (AF2) are simply an optimisation in terms of compiler debugging experience, (AF3) should be irrelevant in most programs, if not all. @@ -1276,6 +1262,47 @@ fragile because `MkT` is strict in its Int# argument, so we get an absentError exception when we shouldn't. Very annoying! +Note [Don't make fillers for terminating types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never make an absent filler, error thunk or rubbish literal, for a terminating +type (isTerminatingType): a non-unary class dictionary, a boxed equality, or a +constraint tuple. + +GHC relies on a dictionary value never being bottom (see +Note [NON-BOTTOM-DICTS invariant] in GHC.Core). GHC uses "speculation" to +evaluated guaranteed-non-bottom values: see Note [Speculative evaluation] in +GHC.CoreToStg.Prep. This speculative evaluation is fundamentally incompatible +with replacing a dictionary with an absent filler. Attempts to to do so gave +rise to a succession of bugs including: + + * #24934: we evaluated an absent dictionary + * #25924: we selected a superclass from an absent dictionary + +A terminating type is exactly what speculation will force: see +Note [exprOkForSpeculation and type classes] in GHC.Core.Utils. So we refuse to +make a filler for precisely those types. + +So the safe thing is to make no filler at all for a terminating type. Then there +is no bogus dictionary to evaluate or project from. Specifically + + * `mkAbsentFiller` returns `Nothing` for a terminating type, so worker/wrapper + keeps the real argument. + + * `Specialise.specHeader` calls `mkAbsentFiller` too, so it likewise keeps the + dead dictionary argument rather than dropping it for a filler. + +Prior failed approaches + +We used to paper over this. !13233 replaced the error thunk for an absent +dictionary with a rubbish literal, so that it could at least be evaluated +without complaint. But #25924 showed that this is not enough, because we do not +only evaluate the absent dictionary, we also select a superclass from it. + +We could instead teach speculation to leave absent bindings alone, and we do +that too (see Note [Speculative evaluation] in GHC.CoreToStg.Prep). But that is +not a guarantee. After optimisation a binding that holds an absent filler may no +longer be marked absent, so we cannot rely on the demand to protect us. + Note [Unboxing through unboxed tuples] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We should not to a worker/wrapper split just for unboxing the components of ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -1960,6 +1960,20 @@ It is also similar to Note [Do not strictify a DFun's parameter dictionaries], where marking recursive DFuns (of undecidable *instances*) strict in dictionary *parameters* leads to quite the same change in termination as above. +Belt and braces: do not speculate absent bindings + +In 'decideFloatInfo' we decline to speculate a binding whose demand is absent. +There is no point in speculating an absent binding, since its value is +(presumably) not needed. + +This used to matter more. Worker/wrapper would bind an absent dictionary to a +rubbish literal filler, and speculation could force a superclass selection out +of that rubbish literal, causing a segfault (#25924). Nowadays we never make a +filler for a dictionary in the first place, so this can no longer happen and +the guard is merely belt and braces. +See Note [Don't make fillers for terminating types] +in GHC.Core.Opt.WorkWrap.Utils. + Note [BindInfo and FloatInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The `BindInfo` of a `Float` describes whether it will be case-bound or @@ -2204,12 +2218,16 @@ mkNonRecFloat env is_unlifted bndr rhs | exprIsTickedString rhs = (CaseBound, TopLvlFloatable) -- String literals are unboxed (so must be case-bound) and float to -- the top-level - | is_unlifted, ok_for_spec = (CaseBound, LazyContextFloatable) - | is_lifted, ok_for_spec = (CaseBound, TopLvlFloatable) + | is_unlifted, ok_for_spec, not (isAbsDmd dmd) = (CaseBound, LazyContextFloatable) + | is_lifted, ok_for_spec, not (isAbsDmd dmd) = (CaseBound, TopLvlFloatable) -- See Note [Speculative evaluation] -- Ok-for-spec-eval things will be case-bound, lifted or not. -- But when it's lifted we are ok with floating it to top-level -- (where it is actually bound lazily). + -- + -- Don't speculate an absent binding. See #25924 and + -- "Belt and braces" in Note [Speculative evaluation]. + | is_unlifted || is_strict = (CaseBound, StrictContextFloatable) -- These will never be floated out of a lazy RHS context | otherwise = assertPpr is_lifted (ppr rhs) $ ===================================== compiler/GHC/StgToCmm/Bind.hs ===================================== @@ -587,9 +587,8 @@ closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details -- ticky after heap check to avoid double counting ; tickyEnterFun cl_info ; enterCostCentreFun cc - (CmmMachOp (mo_wordSub platform) - [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification] - , mkIntExpr platform (funTag platform cl_info) ]) + (cmmUntag platform (CmmReg (CmmLocal node))) -- See [NodeReg clobbered with loopification] + ; fv_bindings <- mapM bind_fv fv_details -- Load free vars out of closure *after* -- heap check, to reduce live vars over check ===================================== compiler/GHC/Types/Literal.hs ===================================== @@ -988,6 +988,14 @@ data type. Here are the moving parts: This is sad, though: see #18983. + INVARIANT 3: we never make a rubbish literal of a terminating type + (isTerminatingType), such as a class dictionary. GHC relies on a value of + a terminating type never being bottom, and so may speculatively evaluate + a dictionary or select a superclass from it. Either would crash on a + rubbish literal (#24934, #25924). + See Note [Don't make fillers for terminating types] + in GHC.Core.Opt.WorkWrap.Utils. + 3. STG: The type app in `RUBBISH[IntRep] @Int# :: Int#` is erased and we get the (untyped) 'StgLit' `RUBBISH[IntRep] :: Int#` in STG. ===================================== hadrian/src/Settings/Warnings.hs ===================================== @@ -89,4 +89,6 @@ ghcWarningsArgs = do , "-Wno-deprecations" -- https://gitlab.haskell.org/ghc/ghc/-/issues/24240 , "-Wno-deriving-typeable" ] - , package xhtml ? pure [ "-Wno-unused-imports" ] ] ] + , package xhtml ? pure [ "-Wno-unused-imports" ] + , package semaphoreCompat ? pure [ "-Wno-unused-imports" ] + ] ] ===================================== libraries/semaphore-compat ===================================== @@ -1 +1 @@ -Subproject commit 44e7488dd93cbf333ceca1319a60146898f6224f +Subproject commit ebcb68506e67de9c8190c0394e10c913593d85da ===================================== rts/Apply.cmm ===================================== @@ -99,12 +99,14 @@ again: W_ info; P_ untaggedfun; W_ arity; + W_ closure_type; // We must obey the correct heap object observation pattern in // Note [Heap memory barriers] in SMP.h. untaggedfun = UNTAG(fun); info = %INFO_PTR(untaggedfun); + closure_type = TO_W_( %INFO_TYPE(%STD_INFO(info)) ); switch [INVALID_OBJECT .. N_CLOSURE_TYPES] - (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) { + (closure_type) { case IND, IND_STATIC: @@ -212,10 +214,17 @@ again: // We can't use the value of 'info' any more, because if // STK_CHK_GEN() did a GC then the closure we're looking // at may have changed, e.g. a THUNK_SELECTOR may have - // been evaluated by the GC. So we reload the info - // pointer now. + // been evaluated by the GC. + // We always reload the info pointer now. And if + // the closure type changed we need to take a different case + // alt altogether so we retry from the start in that case. + untaggedfun = UNTAG(fun); info = %INFO_PTR(untaggedfun); + if(closure_type != TO_W_( %INFO_TYPE(%STD_INFO(info)) ) ) + { + goto again; + } jump %ENTRY_CODE(info) (stg_restore_cccs_eval_info, CCCS) ===================================== testsuite/tests/core-to-stg/T25924/B.hs ===================================== @@ -0,0 +1,89 @@ +{-# LANGUAGE AllowAmbiguousTypes, TypeFamilies, QuantifiedConstraints, TypeAbstractions #-} +module B where + +import Data.Kind + +class ABITypeable a where + abiTypeInfo :: String + abiTypeInfo = "" + + unused :: a -> a + unused x = x + +data REF a + +instance ABITypeable () where +instance ABITypeable a => ABITypeable (REF a) where + +class (ABITypeable a, ABITypeable a) => YulCatObj a where -- crash stops without duplicate constraint +instance YulCatObj () +instance YulCatObj a => YulCatObj (REF a) + +type YulO1 a = YulCatObj a +type YulO2 a b = (YulCatObj a, YulCatObj b) + + +type YulCat :: Type -> Type -> Type +data YulCat a b where + YulExtendType :: forall b. (YulO2 () b) => YulCat () b + YulComp :: forall a b c. YulCat c b -> YulCat a c -> YulCat a b + YulJmpB :: forall a b. (YulO2 a b) => YulCat a b + +data Trie a b where + Z :: Trie a a + (:.) :: (YulCatObj a, YulCatObj b) => YulCat a b -> Trie b c -> Trie a c + +type Cat a b = forall c. Trie b c -> Trie a c + +normalize :: forall a b unused ξ. (Int ~ unused, YulCatObj a, YulCatObj b) + => Trie a b -> (forall c. YulCatObj c => Trie a c -> YulCat c b -> ξ) -> ξ +normalize t0 k = case t0 of + Z -> k Z undefined + φ :. f -> normalize f $ \f' s -> case f' of + Z -> k Z (s `YulComp` φ) + _ -> undefined + + +toSMC :: forall a b . (YulCatObj a, YulCatObj b) => Cat a b -> YulCat a b +toSMC t = normalize (t Z) $ \f g -> case f of + Z -> g + _ -> error "toSMC: normalisation process failed" + + +encode :: (YulCatObj r, YulCatObj a, YulCatObj b) => (a `YulCat` b) -> (P r a -> P r b) +encode φ (Y f) = Y (\x -> f (φ :. x)) + + +type P :: Type -> Type -> Type +data P r a = Y (Cat r a) + +fromP :: P r a -> Cat r a +fromP (Y f) = f + + +decode :: (YulCatObj a, YulCatObj b) => (P a a -> P a b) -> YulCat a b +decode f = toSMC (extract f) + +extract ::(YulCatObj a, YulCatObj b) => (P a a -> P a b) -> Cat a b +extract f = fromP (f (Y id)) + + +yulShow :: YulCat a' b' -> String +yulShow (YulExtendType @b) = "Te" <> abiTypeInfo @b +yulShow (YulComp cb ac) = yulShow ac <> yulShow cb +yulShow YulJmpB = "Jb" + + +lfn' :: forall b unused. + ( YulO1 (REF b) + , () ~ unused + ) => + (forall r. YulO1 r => P r () -> P r (REF b)) -> String +lfn' f = yulShow (decode f) + + +extendType'l :: forall a r. (YulO1 a, YulO1 r) => P r () -> P r a +extendType'l = encode YulExtendType + +keccak256'l :: forall a r. YulO2 r a => P r a -> P r () +keccak256'l = encode YulJmpB ===================================== testsuite/tests/core-to-stg/T25924/Main.hs ===================================== @@ -0,0 +1,14 @@ +module Main where +import B + +getCounterRef' :: forall b r. + ( YulO1 b + , YulO1 r + -- , YulO1 (REF b) + ) => + P r () -> P r (REF b) +getCounterRef' a = extendType'l (keccak256'l a) +{-# NOINLINE getCounterRef' #-} + +main :: IO () +main = putStrLn $ lfn' @() getCounterRef' ===================================== testsuite/tests/core-to-stg/T25924/all.T ===================================== @@ -0,0 +1,4 @@ +test('T25924', + [exit_code(1), ignore_stderr, extra_files(['Main.hs', 'B.hs'])], + multimod_compile_and_run, + ['Main', '-O']) ===================================== testsuite/tests/core-to-stg/T25924a.hs ===================================== @@ -0,0 +1,31 @@ +{-# LANGUAGE GADTs, TypeApplications, ScopedTypeVariables, AllowAmbiguousTypes #-} +module Main where + +class D a where + m :: a -> Int + m _ = 0 + n :: a -> Int + n _ = 0 + +class (D a, D a) => C a + +data T a + +instance D a => D (T a) +instance C a => C (T a) + +instance D () +instance C () + +data G where + MkG :: forall a. C (T a) => T a -> G + +sh :: G -> Int +sh (MkG x) = m x + +f :: forall b. C b => G +f = MkG (undefined :: T b) +{-# NOINLINE f #-} + +main :: IO () +main = print (sh (f @())) ===================================== testsuite/tests/core-to-stg/T25924a.stdout ===================================== @@ -0,0 +1 @@ +0 ===================================== testsuite/tests/core-to-stg/all.T ===================================== @@ -7,3 +7,4 @@ test('T14895', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsupp test('T24124', normal, compile, ['-O -ddump-stg-final -dno-typeable-binds -dsuppress-uniques']) test('T24334', normal, compile_and_run, ['-O']) test('T24463', normal, compile, ['-O']) +test('T25924a', [ignore_stderr], compile_and_run, ['-O']) ===================================== testsuite/tests/dmdanal/should_compile/T18982.stderr ===================================== @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 295, types: 206, coercions: 4, joins: 0/0} +Result size of Tidy Core = {terms: 297, types: 214, coercions: 4, joins: 0/0} -- RHS size: {terms: 8, types: 9, coercions: 1, joins: 0/0} T18982.$WExGADT :: forall e. (e ~ Int) => e %1 -> Int %1 -> ExGADT Int @@ -194,13 +194,13 @@ T18982.$tc'ExGADT2 = GHC.Types.TrNameS T18982.$tc'ExGADT3 T18982.$tc'ExGADT :: GHC.Types.TyCon T18982.$tc'ExGADT = GHC.Types.TyCon 8468257409157161049#Word64 5503123603717080600#Word64 T18982.$trModule T18982.$tc'ExGADT2 1# T18982.$tc'ExGADT1 --- RHS size: {terms: 11, types: 10, coercions: 0, joins: 0/0} -T18982.$wi :: forall a e. (a GHC.Prim.~# Int) => e -> GHC.Prim.Int# -> GHC.Prim.Int# -T18982.$wi = \ (@a) (@e) (ww :: a GHC.Prim.~# Int) (ww1 :: e) (ww2 :: GHC.Prim.Int#) -> case ww1 of { __DEFAULT -> GHC.Prim.+# ww2 1# } +-- RHS size: {terms: 12, types: 14, coercions: 0, joins: 0/0} +T18982.$wi :: forall a e. (a GHC.Prim.~# Int, e ~ Int) => e -> GHC.Prim.Int# -> GHC.Prim.Int# +T18982.$wi = \ (@a) (@e) (ww :: a GHC.Prim.~# Int) _ (ww2 :: e) (ww3 :: GHC.Prim.Int#) -> case ww2 of { __DEFAULT -> GHC.Prim.+# ww3 1# } --- RHS size: {terms: 15, types: 22, coercions: 1, joins: 0/0} +-- RHS size: {terms: 16, types: 22, coercions: 1, joins: 0/0} i :: forall a. ExGADT a -> Int -i = \ (@a) (ds :: ExGADT a) -> case ds of { ExGADT @e ww ww1 ww2 ww3 -> case ww3 of { GHC.Types.I# ww4 -> case T18982.$wi @a @e @~(ww :: a GHC.Prim.~# Int) ww2 ww4 of ww5 { __DEFAULT -> GHC.Types.I# ww5 } } } +i = \ (@a) (ds :: ExGADT a) -> case ds of { ExGADT @e ww ww1 ww2 ww3 -> case ww3 of { GHC.Types.I# ww4 -> case T18982.$wi @a @e @~(ww :: a GHC.Prim.~# Int) ww1 ww2 ww4 of ww5 { __DEFAULT -> GHC.Types.I# ww5 } } } -- RHS size: {terms: 6, types: 7, coercions: 0, joins: 0/0} T18982.$wh :: forall a. (a GHC.Prim.~# Int) => GHC.Prim.Int# -> GHC.Prim.Int# ===================================== testsuite/tests/rts/T27123.hs ===================================== @@ -0,0 +1,68 @@ +{-# OPTIONS_GHC -fno-full-laziness -fno-worker-wrapper #-} +{-# LANGUAGE MagicHash, UnboxedTuples #-} + +-- This test checks that the auto-apply code (stg_ap_0_fast, stg_ap_p) is robust +-- against another thread or the GC evaluating a closure at the same time. + +module Main + -- (main) +where + +import Control.Monad +import Control.Concurrent +import System.IO +import GHC.Data.SmallArray +import GHC.Exts +import GHC.IO + +type Arr = SmallMutableArray RealWorld (Int->Int) + +io :: (State# RealWorld -> (# State# RealWorld, a #)) -> IO a +io f = IO f + +io_ :: (State# RealWorld -> State# RealWorld ) -> IO () +io_ f = IO (\s -> case f s of s2 -> (# s2, () #)) + +{-# NOINLINE readSmallArray #-} +readSmallArray (SmallMutableArray arr) (I# idx) = IO $ \s -> case readSmallArray# arr idx s of + (# s2, r #) -> (# s2, r #) + +-- Continually overwrites the array with unevaluated thunks that will evaluated to +-- a PAP under profiling. +{-# NOINLINE mkThunks #-} +mkThunks :: Arr -> IO () +mkThunks arr = do + forever $ do + yield + forM_ [0..100] $ \_j -> do + forM_ [0..5 :: Int] $ \i -> do + -- With profiling results in a thunk that will evaluate to a PAP capturing the SCC + let g = {-# SCC g #-} succ + io_ (writeSmallArray arr i g) + +-- Evaluate the array repeatedly in the given order. +{-# NOINLINE evaluateThunks #-} +evaluateThunks :: Arr -> [Int] -> IO () +evaluateThunks arr idxs = do + forever $ do + yield + -- putStr "." >> hFlush stdout + forM [0..5000::Int] $ \j -> do + forM_ idxs $ \i -> do + !g <- readSmallArray arr i + seq (g i) (pure ()) + +main :: IO () +main = do + -- We spawn three threads. + -- * Two are evaluating the thunks in the array in opposite directions + -- * One thread is writing thunks to the array. + -- The reading threads will race to evaluate the same thunk triggering potential + -- race conditions. + arr <- io (newSmallArray 6 (id)) + _ <- forkIO $ do + evaluateThunks arr [0..5] + _ <- forkIO $ do + evaluateThunks arr [5,4..0] + forkIO $ mkThunks arr + threadDelay 10_000_000 ===================================== testsuite/tests/rts/all.T ===================================== @@ -639,3 +639,5 @@ test('T25280', [unless(opsys('linux'),skip),req_process,js_skip], compile_and_ru test('T25560', [req_c_rts, ignore_stderr], compile_and_run, ['']) test('TestProddableBlockSet', [req_c_rts], multimod_compile_and_run, ['TestProddableBlockSet.c', '-no-hs-main']) + +test('T27123', [when(have_profiling(), extra_ways(['prof']))], compile_and_run, ['-O -package ghc']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6c91e5e1a5fd411cd1e467063e699e7... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/6c91e5e1a5fd411cd1e467063e699e7... You're receiving this email because of your account on gitlab.haskell.org.