Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: d4871438 by Simon Peyton Jones at 2025-09-09T00:14:59-04:00 Fix a scoping error in Specialise This small patch fixes #26329, which triggered a scoping error. Test is in T21391, with -fpolymorphic-specialisation enabled - - - - - 80d3436c by Andreas Klebinger at 2025-09-09T00:15:01-04:00 Add regression test for #26056 - - - - - 5e052e33 by sheaf at 2025-09-09T00:15:17-04:00 Deep subsumption: unify mults without tcEqMult As seen in #26332, we may well end up with a non-reflexive multiplicity coercion when doing deep subsumption. We should do the same thing that we do without deep subsumption: unify the multiplicities normally, without requiring that the coercion is reflexive (which is what 'tcEqMult' was doing). Fixes #26332 - - - - - 90d94d17 by Moritz Angermann at 2025-09-09T00:15:17-04:00 testsuite: Fix broken exec_signals_child.c There is no signal 0. The signal mask is 1-32. - - - - - 7 changed files: - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Tc/Utils/Unify.hs - + testsuite/tests/linear/should_compile/T26332.hs - testsuite/tests/linear/should_compile/all.T - + testsuite/tests/profiling/should_compile/T26056.hs - testsuite/tests/profiling/should_compile/all.T - testsuite/tests/rts/exec_signals_child.c Changes: ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -1205,14 +1205,21 @@ specExpr env (Tick tickish body) ---------------- Applications might generate a call instance -------------------- specExpr env expr@(App {}) = do { let (fun_in, args_in) = collectArgs expr + ; (fun_out, uds_fun) <- specExpr env fun_in ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in - ; let env_args = env `bringFloatedDictsIntoScope` ud_binds uds_args - -- Some dicts may have floated out of args_in; - -- they should be in scope for fireRewriteRules (#21689) - (fun_in', args_out') = fireRewriteRules env_args fun_in args_out - ; (fun_out', uds_fun) <- specExpr env fun_in' + ; let uds_app = uds_fun `thenUDs` uds_args + env_args = zapSubst env `bringFloatedDictsIntoScope` ud_binds uds_app + -- zapSubst: we have now fully applied the substitution + -- bringFloatedDictsIntoScope: some dicts may have floated out of + -- args_in; they should be in scope for fireRewriteRules (#21689) + + -- Try firing rewrite rules + -- See Note [Fire rules in the specialiser] + ; let (fun_out', args_out') = fireRewriteRules env_args fun_out args_out + + -- Make a call record, and return ; let uds_call = mkCallUDs env fun_out' args_out' - ; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) } + ; return (fun_out' `mkApps` args_out', uds_app `thenUDs` uds_call) } ---------------- Lambda/case require dumping of usage details -------------------- specExpr env e@(Lam {}) @@ -1246,17 +1253,18 @@ specExpr env (Let bind body) -- See Note [Specialisation modulo dictionary selectors] -- Note [ClassOp/DFun selection] -- Note [Fire rules in the specialiser] -fireRewriteRules :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr]) +fireRewriteRules :: SpecEnv -- Substitution is already zapped + -> OutExpr -> [OutExpr] -> (OutExpr, [OutExpr]) fireRewriteRules env (Var f) args | let rules = getRules (se_rules env) f , Just (rule, expr) <- specLookupRule env f args activeInInitialPhase rules , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target] - zapped_subst = Core.zapSubst (se_subst env) - expr' = simpleOptExprWith defaultSimpleOpts zapped_subst expr + zapped_subst = se_subst env -- Just needed for the InScopeSet + expr' = simpleOptExprWith defaultSimpleOpts zapped_subst (mkApps expr rest_args) -- simplOptExpr needed because lookupRule returns -- (\x y. rhs) arg1 arg2 , (fun', args') <- collectArgs expr' - = fireRewriteRules env fun' (args'++rest_args) + = fireRewriteRules env fun' args' fireRewriteRules _ fun args = (fun, args) -------------- @@ -1669,10 +1677,19 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs ; let all_rule_bndrs = poly_qvars ++ rule_bndrs env' = env { se_subst = subst'' } -{- - ; pprTrace "spec_call" (vcat + -- Check for (a) usefulness and (b) not already covered + -- See (SC1) in Note [Specialisations already covered] + ; let all_rules = rules_acc ++ existing_rules + -- all_rules: we look both in the rules_acc (generated by this invocation + -- of specCalls), and in existing_rules (passed in to specCalls) + already_covered = alreadyCovered env' all_rule_bndrs fn + rule_lhs_args is_active all_rules + +{- ; pprTrace "spec_call" (vcat [ text "fun: " <+> ppr fn , text "call info: " <+> ppr _ci + , text "useful: " <+> ppr useful + , text "already_covered:" <+> ppr already_covered , text "poly_qvars: " <+> ppr poly_qvars , text "useful: " <+> ppr useful , text "all_rule_bndrs:" <+> ppr all_rule_bndrs @@ -1681,17 +1698,13 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs , text "dx_binds:" <+> ppr dx_binds , text "spec_args: " <+> ppr spec_args , text "rhs_bndrs" <+> ppr rhs_bndrs - , text "rhs_body" <+> ppr rhs_body ]) $ + , text "rhs_body" <+> ppr rhs_body + , text "subst''" <+> ppr subst'' ]) $ return () -} - -- Check for (a) usefulness and (b) not already covered - -- See (SC1) in Note [Specialisations already covered] - ; let all_rules = rules_acc ++ existing_rules - -- all_rules: we look both in the rules_acc (generated by this invocation - -- of specCalls), and in existing_rules (passed in to specCalls) - ; if not useful -- No useful specialisation - || alreadyCovered env' all_rule_bndrs fn rule_lhs_args is_active all_rules + ; if not useful -- No useful specialisation + || already_covered -- Useful, but done already then return spec_acc else @@ -1702,6 +1715,12 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs -- Run the specialiser on the specialised RHS ; (rhs_body', rhs_uds) <- specExpr env'' rhs_body +{- ; pprTrace "spec_call2" (vcat + [ text "fun:" <+> ppr fn + , text "rhs_body':" <+> ppr rhs_body' ]) $ + return () +-} + -- Make the RHS of the specialised function ; let spec_rhs_bndrs = spec_bndrs ++ inner_rhs_bndrs' (rhs_uds1, inner_dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds ===================================== compiler/GHC/Tc/Utils/Unify.hs ===================================== @@ -1853,8 +1853,8 @@ where we eta-expanded that (:). But now foldr expects an argument with ->{Many} and gets an argument with ->{m1} or ->{m2}, and Lint complains. -The easiest solution was to use tcEqMult in tc_sub_type_deep, and -insist on equality. This is only in the DeepSubsumption code anyway. +The easiest solution was to unify the multiplicities in tc_sub_type_deep, +insisting on equality. This is only in the DeepSubsumption code anyway. Note [FunTy vs non-FunTy case in tc_sub_type_deep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2047,10 +2047,7 @@ tc_sub_type_deep pos unify inst_orig ctxt ty_actual ty_expected -- GenSigCtxt: See Note [Setting the argument context] ; res_wrap <- tc_sub_type_deep (Result pos) unify inst_orig ctxt act_res exp_res - -- See Note [Multiplicity in deep subsumption] - ; tcEqMult inst_orig act_mult exp_mult - - ; mkWpFun_FRR pos + ; mkWpFun_FRR unify pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res arg_wrap res_wrap @@ -2058,20 +2055,32 @@ tc_sub_type_deep pos unify inst_orig ctxt ty_actual ty_expected where given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg []) --- | Like 'mkWpFun', except that it performs representation-polymorphism --- checks on the argument type. +-- | Like 'mkWpFun', except that it performs the necessary +-- representation-polymorphism checks on the argument type in the case that +-- we introduce a lambda abstraction. mkWpFun_FRR - :: Position p + :: (TcType -> TcType -> TcM TcCoercionN) -- ^ how to unify + -> Position p -> FunTyFlag -> Type -> TcType -> Type -- actual FunTy -> FunTyFlag -> Type -> TcType -> Type -- expected FunTy -> HsWrapper -- ^ exp_arg ~> act_arg -> HsWrapper -- ^ act_res ~> exp_res -> TcM HsWrapper -- ^ act_funTy ~> exp_funTy -mkWpFun_FRR pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res arg_wrap res_wrap - | needs_eta - -- See Wrinkle [Representation-polymorphism checking during subtyping] - = do { (exp_arg_co, exp_arg_frr) <- hasFixedRuntimeRep (FRRDeepSubsumption True pos) exp_arg - ; (act_arg_co, _act_arg_frr) <- hasFixedRuntimeRep (FRRDeepSubsumption False pos) act_arg +mkWpFun_FRR unify pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res arg_wrap res_wrap + = do { ((exp_arg_co, exp_arg_frr), (act_arg_co, _act_arg_frr)) <- + if needs_frr_checks + -- See Wrinkle [Representation-polymorphism checking during subtyping] + then do { exp_frr_wrap <- hasFixedRuntimeRep (frr_ctxt True ) exp_arg + ; act_frr_wrap <- hasFixedRuntimeRep (frr_ctxt False) act_arg + ; return (exp_frr_wrap, act_frr_wrap) } + else return ((mkNomReflCo exp_arg, exp_arg), (mkNomReflCo act_arg, act_arg)) + + -- Enforce equality of multiplicities (not the more natural sub-multiplicity). + -- See Note [Multiplicity in deep subsumption] + ; act_arg_mult_co <- unify act_mult exp_mult + -- NB: don't use tcEqMult: that would require the evidence for + -- equality to be Refl, but it might well not be (#26332). + ; let exp_arg_fun_co = mkFunCo Nominal exp_af @@ -2080,7 +2089,7 @@ mkWpFun_FRR pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res (mkReflCo Nominal exp_res) act_arg_fun_co = mkFunCo Nominal act_af - (mkReflCo Nominal act_mult) + act_arg_mult_co act_arg_co (mkReflCo Nominal act_res) arg_wrap_frr = @@ -2090,24 +2099,16 @@ mkWpFun_FRR pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res -- arg_wrap :: exp_arg ~> act_arg -- arg_wrap_frr :: exp_arg_frr ~> act_arg_frr - -- NB: because of the needs_eta guard, we know that mkWpFun will - -- return (WpFun ...); so we might as well just use the WpFun constructor. ; return $ mkWpCastN exp_arg_fun_co <.> - WpFun arg_wrap_frr res_wrap (Scaled exp_mult exp_arg_frr) + mkWpFun arg_wrap_frr res_wrap (Scaled exp_mult exp_arg_frr) exp_res <.> - mkWpCastN act_arg_fun_co } - | otherwise - = return $ - mkWpFun arg_wrap res_wrap (Scaled exp_mult exp_arg) exp_res - -- NB: because of 'needs_eta', this will never actually be a WpFun. - -- mkWpFun will turn it into a WpHole or WpCast, which is why - -- we can skip the hasFixedRuntimeRep checks in this case. - -- See Wrinkle [Representation-polymorphism checking during subtyping] + mkWpCastN act_arg_fun_co + } where - needs_eta :: Bool - needs_eta = + needs_frr_checks :: Bool + needs_frr_checks = not (hole_or_cast arg_wrap) || not (hole_or_cast res_wrap) @@ -2115,6 +2116,12 @@ mkWpFun_FRR pos act_af act_mult act_arg act_res exp_af exp_mult exp_arg exp_res hole_or_cast WpHole = True hole_or_cast (WpCast {}) = True hole_or_cast _ = False + frr_ctxt :: Bool -> FixedRuntimeRepContext + frr_ctxt is_exp_ty = + FRRDeepSubsumption + { frrDSExpected = is_exp_ty + , frrDSPosition = pos + } ----------------------- deeplySkolemise :: SkolemInfo -> TcSigmaType ===================================== testsuite/tests/linear/should_compile/T26332.hs ===================================== @@ -0,0 +1,12 @@ +{-# LANGUAGE DeepSubsumption #-} +{-# LANGUAGE LinearTypes #-} + +module T26332 where + +import Unsafe.Coerce + +toLinear + :: forall a b p q. + (a %p-> b) %1-> (a %q-> b) +toLinear f = case unsafeEqualityProof @p @q of + UnsafeRefl -> f ===================================== testsuite/tests/linear/should_compile/all.T ===================================== @@ -41,6 +41,7 @@ test('T19400', unless(compiler_debugged(), skip), compile, ['']) test('T20023', normal, compile, ['']) test('T22546', normal, compile, ['']) test('T23025', normal, compile, ['-dlinear-core-lint']) +test('T26332', normal, compile, ['-O -dlinear-core-lint']) test('LinearRecUpd', normal, compile, ['']) test('T23814', normal, compile, ['']) test('LinearLet', normal, compile, ['']) ===================================== testsuite/tests/profiling/should_compile/T26056.hs ===================================== @@ -0,0 +1,21 @@ +module M where + +import GHC.Exts ( Any ) +import Unsafe.Coerce ( unsafeCoerce ) + +data Sigma = MkT Any + +testSubList :: Maybe Bool -> Sigma -> Sigma +testSubList (Just x) final = {-# SCC "y" #-} ( + let x' = seq x () + in case testSubList Nothing final of + MkT w -> {-# SCC "x" #-} + (unsafeCoerce MkT (konst x' myHead (unsafeCoerce w)))) +testSubList Nothing final = final + +myHead :: [a] -> a +myHead (x:_) = x + +konst :: () -> ([a] -> a) -> [a] -> a +konst _ x = x +{-# OPAQUE konst #-} ===================================== testsuite/tests/profiling/should_compile/all.T ===================================== @@ -20,3 +20,4 @@ test('T14931', [test_opts, unless(have_dynamic(), skip)], test('T15108', [test_opts], compile, ['-O -prof -fprof-auto']) test('T19894', [test_opts, extra_files(['T19894'])], multimod_compile, ['Main', '-v0 -O2 -prof -fprof-auto -iT19894']) test('T20938', [test_opts], compile, ['-O -prof']) +test('T26056', [test_opts], compile, ['-O -prof']) ===================================== testsuite/tests/rts/exec_signals_child.c ===================================== @@ -2,8 +2,11 @@ #include <stdio.h> #include <errno.h> -// Prints the state of the signal handlers to stdout -int main() +// Prints the state of the signal handlers to stdout. +// NOTE: We intentionally start at signal 1 (not 0). Signal number 0 is not a +// real signal; passing 0 to sigismember/sigaction is undefined behaviour and +// on Darwin was observed to yield memory corruption / junk bytes in output. +int main(void) { int open = 0, i; sigset_t blockedsigs; @@ -11,7 +14,7 @@ int main() printf("ChildInfo { masked = ["); sigprocmask(SIG_BLOCK, NULL, &blockedsigs); - for(i = 0; i < NSIG; ++i) + for(i = 1; i < NSIG; ++i) { int ret = sigismember(&blockedsigs, i); if(ret >= 0) @@ -26,7 +29,7 @@ int main() printf("], handlers = ["); open = 0; - for(i = 0; i < NSIG; ++i) + for(i = 1; i < NSIG; ++i) { struct sigaction old; if(sigaction(i, NULL, &old) >= 0) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5ddfe1af3ca965eea83eb7372274770... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5ddfe1af3ca965eea83eb7372274770... You're receiving this email because of your account on gitlab.haskell.org.