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