[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 8 commits: Allow transformers-0.6 in ghc, ghci, ghc-bin and hadrian
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Dec 21 16:51:58 UTC 2022
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
3ce2ab94 by Bodigrim at 2022-12-21T06:17:56-05:00
Allow transformers-0.6 in ghc, ghci, ghc-bin and hadrian
- - - - -
954de93a by Bodigrim at 2022-12-21T06:17:56-05:00
Update submodule haskeline to HEAD (to allow transformers-0.6)
- - - - -
cefbeec3 by Bodigrim at 2022-12-21T06:17:56-05:00
Update submodule transformers to 0.6.0.4
- - - - -
b4730b62 by Bodigrim at 2022-12-21T06:17:56-05:00
Fix tests
T13253 imports MonadTrans, which acquired a quantified constraint in transformers-0.6, thus increase in allocations
Metric Increase:
T13253
- - - - -
0be75261 by Simon Peyton Jones at 2022-12-21T06:18:32-05:00
Abstract over the right free vars
Fix #22459, in two ways:
(1) Make the Specialiser not create a bogus specialisation if
it is presented by strangely polymorphic dictionary.
See Note [Weird special case in SpecDict] in
GHC.Core.Opt.Specialise
(2) Be more careful in abstractFloats
See Note [Which type variables to abstract over]
in GHC.Core.Opt.Simplify.Utils.
So (2) stops creating the excessively polymorphic dictionary in
abstractFloats, while (1) stops crashing if some other pass should
nevertheless create a weirdly polymorphic dictionary.
- - - - -
c755ada3 by Ying-Ruei Liang (TheKK) at 2022-12-21T11:51:45-05:00
rts: explicitly store return value of ccall checkClosure to prevent type error (#22617)
- - - - -
45f83fe6 by Simon Peyton Jones at 2022-12-21T11:51:45-05:00
Fix shadowing lacuna in OccurAnal
Issue #22623 demonstrated another lacuna in the implementation
of wrinkle (BS3) in Note [The binder-swap substitution] in
the occurrence analyser.
I was failing to add TyVar lambda binders using
addInScope/addOneInScope and that led to a totally bogus binder-swap
transformation.
Very easy to fix.
- - - - -
a44a4e67 by Simon Peyton Jones at 2022-12-21T11:51:45-05:00
Fix an assertion check in addToEqualCtList
The old assertion saw that a constraint ct could rewrite itself
(of course it can) and complained (stupid).
Fixes #22645
- - - - -
21 changed files:
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Tc/Solver/Types.hs
- compiler/ghc.cabal.in
- ghc/ghc-bin.cabal.in
- hadrian/hadrian.cabal
- libraries/ghci/ghci.cabal.in
- libraries/haskeline
- libraries/transformers
- rts/ContinuationOps.cmm
- testsuite/tests/ghci/scripts/T5979.stderr
- + testsuite/tests/simplCore/should_compile/T22459.hs
- + testsuite/tests/simplCore/should_compile/T22623.hs
- + testsuite/tests/simplCore/should_compile/T22623a.hs
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/typecheck/should_fail/T22645.hs
- + testsuite/tests/typecheck/should_fail/T22645.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -1820,7 +1820,8 @@ occAnalLam :: OccEnv -> CoreExpr -> (WithUsageDetails CoreExpr)
occAnalLam env (Lam bndr expr)
| isTyVar bndr
- = let (WithUsageDetails usage expr') = occAnalLam env expr
+ = let env1 = addOneInScope env bndr
+ WithUsageDetails usage expr' = occAnalLam env1 expr
in WithUsageDetails usage (Lam bndr expr')
-- Important: Keep the 'env' unchanged so that with a RHS like
-- \(@ x) -> K @x (f @x)
@@ -2466,10 +2467,11 @@ data OccEnv
-- If x :-> (y, co) is in the env,
-- then please replace x by (y |> mco)
-- Invariant of course: idType x = exprType (y |> mco)
- , occ_bs_env :: !(VarEnv (OutId, MCoercion))
- , occ_bs_rng :: !VarSet -- Vars free in the range of occ_bs_env
+ , occ_bs_env :: !(IdEnv (OutId, MCoercion))
-- Domain is Global and Local Ids
-- Range is just Local Ids
+ , occ_bs_rng :: !VarSet
+ -- Vars (TyVars and Ids) free in the range of occ_bs_env
}
@@ -2546,14 +2548,15 @@ isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of
_ -> False
addOneInScope :: OccEnv -> CoreBndr -> OccEnv
+-- Needed for all Vars not just Ids
+-- See Note [The binder-swap substitution] (BS3)
addOneInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndr
| bndr `elemVarSet` rng_vars = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
| otherwise = env { occ_bs_env = swap_env `delVarEnv` bndr }
addInScope :: OccEnv -> [Var] -> OccEnv
--- See Note [The binder-swap substitution]
--- It's only necessary to call this on in-scope Ids,
--- but harmless to include TyVars too
+-- Needed for all Vars not just Ids
+-- See Note [The binder-swap substitution] (BS3)
addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs
| any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }
| otherwise = env { occ_bs_env = swap_env `delVarEnvList` bndrs }
@@ -2712,25 +2715,29 @@ Some tricky corners:
(BS3) We need care when shadowing. Suppose [x :-> b] is in occ_bs_env,
and we encounter:
- - \x. blah
- Here we want to delete the x-binding from occ_bs_env
-
- - \b. blah
- This is harder: we really want to delete all bindings that
- have 'b' free in the range. That is a bit tiresome to implement,
- so we compromise. We keep occ_bs_rng, which is the set of
- free vars of rng(occc_bs_env). If a binder shadows any of these
- variables, we discard all of occ_bs_env. Safe, if a bit
- brutal. NB, however: the simplifer de-shadows the code, so the
- next time around this won't happen.
+ (i) \x. blah
+ Here we want to delete the x-binding from occ_bs_env
+
+ (ii) \b. blah
+ This is harder: we really want to delete all bindings that
+ have 'b' free in the range. That is a bit tiresome to implement,
+ so we compromise. We keep occ_bs_rng, which is the set of
+ free vars of rng(occc_bs_env). If a binder shadows any of these
+ variables, we discard all of occ_bs_env. Safe, if a bit
+ brutal. NB, however: the simplifer de-shadows the code, so the
+ next time around this won't happen.
These checks are implemented in addInScope.
-
- The occurrence analyser itself does /not/ do cloning. It could, in
- principle, but it'd make it a bit more complicated and there is no
- great benefit. The simplifer uses cloning to get a no-shadowing
- situation, the care-when-shadowing behaviour above isn't needed for
- long.
+ (i) is needed only for Ids, but (ii) is needed for tyvars too (#22623)
+ because if occ_bs_env has [x :-> ...a...] where `a` is a tyvar, we
+ must not replace `x` by `...a...` under /\a. ...x..., or similarly
+ under a case pattern match that binds `a`.
+
+ An alternative would be for the occurrence analyser to do cloning as
+ it goes. In principle it could do so, but it'd make it a bit more
+ complicated and there is no great benefit. The simplifer uses
+ cloning to get a no-shadowing situation, the care-when-shadowing
+ behaviour above isn't needed for long.
(BS4) The domain of occ_bs_env can include GlobaIds. Eg
case M.foo of b { alts }
=====================================
compiler/GHC/Core/Opt/Simplify.hs
=====================================
@@ -132,7 +132,11 @@ data SimplifyOpts = SimplifyOpts
{ so_dump_core_sizes :: !Bool
, so_iterations :: !Int
, so_mode :: !SimplMode
+
, so_pass_result_cfg :: !(Maybe LintPassResultConfig)
+ -- Nothing => Do not Lint
+ -- Just cfg => Lint like this
+
, so_hpt_rules :: !RuleBase
, so_top_env_cfg :: !TopEnvConfig
}
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -2063,34 +2063,51 @@ it is guarded by the doFloatFromRhs call in simplLazyBind.
Note [Which type variables to abstract over]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Abstract only over the type variables free in the rhs wrt which the
-new binding is abstracted. Note that
-
- * The naive approach of abstracting wrt the
- tyvars free in the Id's /type/ fails. Consider:
- /\ a b -> let t :: (a,b) = (e1, e2)
- x :: a = fst t
- in ...
- Here, b isn't free in x's type, but we must nevertheless
- abstract wrt b as well, because t's type mentions b.
- Since t is floated too, we'd end up with the bogus:
- poly_t = /\ a b -> (e1, e2)
- poly_x = /\ a -> fst (poly_t a *b*)
-
- * We must do closeOverKinds. Example (#10934):
+new binding is abstracted. Several points worth noting
+
+(AB1) The naive approach of abstracting wrt the
+ tyvars free in the Id's /type/ fails. Consider:
+ /\ a b -> let t :: (a,b) = (e1, e2)
+ x :: a = fst t
+ in ...
+ Here, b isn't free in x's type, but we must nevertheless
+ abstract wrt b as well, because t's type mentions b.
+ Since t is floated too, we'd end up with the bogus:
+ poly_t = /\ a b -> (e1, e2)
+ poly_x = /\ a -> fst (poly_t a *b*)
+
+(AB2) We must do closeOverKinds. Example (#10934):
f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ...
- Here we want to float 't', but we must remember to abstract over
- 'k' as well, even though it is not explicitly mentioned in the RHS,
- otherwise we get
- t = /\ (f:k->*) (a:k). AccFailure @ (f a)
- which is obviously bogus.
-
- * We get the variables to abstract over by filtering down the
- the main_tvs for the original function, picking only ones
- mentioned in the abstracted body. This means:
- - they are automatically in dependency order, because main_tvs is
- - there is no issue about non-determinism
- - we don't gratuitously change order, which may help (in a tiny
- way) with CSE and/or the compiler-debugging experience
+ Here we want to float 't', but we must remember to abstract over
+ 'k' as well, even though it is not explicitly mentioned in the RHS,
+ otherwise we get
+ t = /\ (f:k->*) (a:k). AccFailure @ (f a)
+ which is obviously bogus.
+
+(AB3) We get the variables to abstract over by filtering down the
+ the main_tvs for the original function, picking only ones
+ mentioned in the abstracted body. This means:
+ - they are automatically in dependency order, because main_tvs is
+ - there is no issue about non-determinism
+ - we don't gratuitously change order, which may help (in a tiny
+ way) with CSE and/or the compiler-debugging experience
+
+(AB4) For a recursive group, it's a bit of a pain to work out the minimal
+ set of tyvars over which to abstract:
+ /\ a b c. let x = ...a... in
+ letrec { p = ...x...q...
+ q = .....p...b... } in
+ ...
+ Since 'x' is abstracted over 'a', the {p,q} group must be abstracted
+ over 'a' (because x is replaced by (poly_x a)) as well as 'b'.
+ Remember this bizarre case too:
+ x::a = x
+ Here, we must abstract 'x' over 'a'.
+
+ Why is it worth doing this? Partly tidiness; and partly #22459
+ which showed that it's harder to do polymorphic specialisation well
+ if there are dictionaries abstracted over unnecessary type variables.
+ See Note [Weird special case for SpecDict] in GHC.Core.Opt.Specialise
-}
abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats
@@ -2115,33 +2132,40 @@ abstractFloats uf_opts top_lvl main_tvs floats body
rhs' = GHC.Core.Subst.substExpr subst rhs
-- tvs_here: see Note [Which type variables to abstract over]
- tvs_here = filter (`elemVarSet` free_tvs) main_tvs
- free_tvs = closeOverKinds $
- exprSomeFreeVars isTyVar rhs'
+ tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs')
abstract subst (Rec prs)
- = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids
- ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)
- poly_pairs = [ mk_poly2 poly_id tvs_here rhs'
- | (poly_id, rhs) <- poly_ids `zip` rhss
- , let rhs' = GHC.Core.Subst.substExpr subst' rhs ]
- ; return (subst', Rec poly_pairs) }
+ = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids
+ ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)
+ poly_pairs = [ mk_poly2 poly_id tvs_here rhs'
+ | (poly_id, rhs) <- poly_ids `zip` rhss
+ , let rhs' = GHC.Core.Subst.substExpr subst' rhs ]
+ ; return (subst', Rec poly_pairs) }
+ where
+ (ids,rhss) = unzip prs
+
+
+ -- tvs_here: see Note [Which type variables to abstract over]
+ tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs prs)
+
+ -- See wrinkle (AB4) in Note [Which type variables to abstract over]
+ get_bind_fvs (id,rhs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs
+ get_rec_rhs_tvs rhs = nonDetStrictFoldVarSet get_tvs emptyVarSet (exprFreeVars rhs)
+
+ get_tvs :: Var -> VarSet -> VarSet
+ get_tvs var free_tvs
+ | isTyVar var -- CoVars have been substituted away
+ = extendVarSet free_tvs var
+ | Just poly_app <- GHC.Core.Subst.lookupIdSubst_maybe subst var
+ = -- 'var' is like 'x' in (AB4)
+ exprSomeFreeVars isTyVar poly_app `unionVarSet` free_tvs
+ | otherwise
+ = free_tvs
+
+ choose_tvs free_tvs
+ = filter (`elemVarSet` all_free_tvs) main_tvs -- (AB3)
where
- (ids,rhss) = unzip prs
- -- For a recursive group, it's a bit of a pain to work out the minimal
- -- set of tyvars over which to abstract:
- -- /\ a b c. let x = ...a... in
- -- letrec { p = ...x...q...
- -- q = .....p...b... } in
- -- ...
- -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted
- -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'.
- -- Since it's a pain, we just use the whole set, which is always safe
- --
- -- If you ever want to be more selective, remember this bizarre case too:
- -- x::a = x
- -- Here, we must abstract 'x' over 'a'.
- tvs_here = scopedSort main_tvs
+ all_free_tvs = closeOverKinds free_tvs -- (AB2)
mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr)
mk_poly1 tvs_here var
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -2516,6 +2516,8 @@ specHeader env (bndr : bndrs) (UnspecType : args)
-- the nitty-gritty), as a LHS rule and unfolding details.
specHeader 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)
@@ -2531,6 +2533,8 @@ specHeader env (bndr : bndrs) (SpecDict d : args)
, spec_dict : spec_args
)
}
+ where
+ in_scope = Core.getSubstInScope (se_subst env)
-- Finally, we don't want to specialise on this argument 'i':
-- - It's an UnSpecArg, or
@@ -2752,6 +2756,8 @@ monomorpic, and specialised in one go.
Wrinkles.
+* See Note [Weird special case for SpecDict]
+
* With -XOverlappingInstances you might worry about this:
class C a where ...
instance C (Maybe Int) where ... -- $df1 :: C (Maybe Int)
@@ -2777,6 +2783,33 @@ Wrinkles.
it's a hard test to make.)
But see Note [Specialisation and overlapping instances].
+
+Note [Weird special case for SpecDict]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are trying to specialise for this this call:
+ $wsplit @T (mkD @k @(a::k) :: C T)
+where
+ mkD :: forall k (a::k). C T
+is a top-level dictionary-former. This actually happened in #22459,
+because of (MP1) of Note [Specialising polymorphic dictionaries].
+
+How can we speicalise $wsplit? We might try
+
+ RULE "SPEC" forall (d :: C T). $wsplit @T d = $s$wsplit
+
+but then in the body of $s$wsplit what will we use for the dictionary
+evidence? We can't use (mkD @k @(a::k)) because k and a aren't in scope.
+We could zap `k` to (Any @Type) and `a` to (Any @(Any @Type)), but that
+is a lot of hard work for a very strange case.
+
+So we simply refrain from specialising in this case; hence the guard
+ allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d)
+in the SpecDict cased of specHeader.
+
+How did this strange polymorphic mkD arise in the first place?
+From GHC.Core.Opt.Utils.abstractFloats, which was abstracting
+over too many type variables. But that too is now fixed;
+see Note [Which type variables to abstract over] in that module.
-}
instance Outputable DictBind where
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -15,7 +15,7 @@ module GHC.Core.Subst (
deShadowBinds, substRuleInfo, substRulesForImportedIds,
substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC,
substUnfolding, substUnfoldingSC,
- lookupIdSubst, substIdType, substIdOcc,
+ lookupIdSubst, lookupIdSubst_maybe, substIdType, substIdOcc,
substTickish, substDVarSet, substIdInfo,
-- ** Operations on substitutions
@@ -184,9 +184,11 @@ extendSubstList subst [] = subst
extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs
-- | Find the substitution for an 'Id' in the 'Subst'
+-- The Id should not be a CoVar
lookupIdSubst :: HasDebugCallStack => Subst -> Id -> CoreExpr
lookupIdSubst (Subst in_scope ids _ _) v
- | not (isLocalId v) = Var v
+ | assertPpr (isId v && not (isCoVar v)) (ppr v)
+ not (isLocalId v) = Var v
| Just e <- lookupVarEnv ids v = e
| Just v' <- lookupInScope in_scope v = Var v'
-- Vital! See Note [Extending the IdSubstEnv]
@@ -194,6 +196,12 @@ lookupIdSubst (Subst in_scope ids _ _) v
-- it's a bad bug and we really want to know
| otherwise = pprPanic "lookupIdSubst" (ppr v $$ ppr in_scope)
+lookupIdSubst_maybe :: HasDebugCallStack => Subst -> Id -> Maybe CoreExpr
+-- Just look up in the substitution; do not check the in-scope set
+lookupIdSubst_maybe (Subst _ ids _ _) v
+ = assertPpr (isId v && not (isCoVar v)) (ppr v) $
+ lookupVarEnv ids v
+
delBndr :: Subst -> Var -> Subst
delBndr (Subst in_scope ids tvs cvs) v
| isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v)
=====================================
compiler/GHC/Tc/Solver/Types.hs
=====================================
@@ -273,21 +273,29 @@ addToEqualCtList ct old_eqs
| debugIsOn
= case ct of
CEqCan { cc_lhs = TyVarLHS tv } ->
- let shares_lhs (CEqCan { cc_lhs = TyVarLHS old_tv }) = tv == old_tv
- shares_lhs _other = False
- in
- assert (all shares_lhs old_eqs) $
- assert (null ([ (ct1, ct2) | ct1 <- ct : old_eqs
- , ct2 <- ct : old_eqs
- , let { fr1 = ctFlavourRole ct1
- ; fr2 = ctFlavourRole ct2 }
- , fr1 `eqCanRewriteFR` fr2 ])) $
+ assert (all (shares_lhs tv) old_eqs) $
+ assertPpr (null bad_prs)
+ (vcat [ text "bad_prs" <+> ppr bad_prs
+ , text "ct:old_eqs" <+> ppr (ct : old_eqs) ]) $
(ct : old_eqs)
_ -> pprPanic "addToEqualCtList not CEqCan" (ppr ct)
| otherwise
= ct : old_eqs
+ where
+ shares_lhs tv (CEqCan { cc_lhs = TyVarLHS old_tv }) = tv == old_tv
+ shares_lhs _ _ = False
+ bad_prs = filter is_bad_pair (distinctPairs (ct : old_eqs))
+ is_bad_pair (ct1,ct2) = ctFlavourRole ct1 `eqCanRewriteFR` ctFlavourRole ct2
+
+distinctPairs :: [a] -> [(a,a)]
+-- distinctPairs [x1,...xn] is the list of all pairs [ ...(xi, xj)...]
+-- where i /= j
+-- NB: does not return pairs (xi,xi), which would be stupid in the
+-- context of addToEqualCtList (#22645)
+distinctPairs [] = []
+distinctPairs (x:xs) = concatMap (\y -> [(x,y),(y,x)]) xs ++ distinctPairs xs
-- returns Nothing when the new list is empty, to keep the environments smaller
filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList
=====================================
compiler/ghc.cabal.in
=====================================
@@ -88,7 +88,7 @@ Library
filepath >= 1 && < 1.5,
template-haskell == 2.19.*,
hpc == 0.6.*,
- transformers == 0.5.*,
+ transformers >= 0.5 && < 0.7,
exceptions == 0.10.*,
stm,
ghc-boot == @ProjectVersionMunged@,
=====================================
ghc/ghc-bin.cabal.in
=====================================
@@ -38,7 +38,7 @@ Executable ghc
process >= 1 && < 1.7,
filepath >= 1 && < 1.5,
containers >= 0.5 && < 0.7,
- transformers == 0.5.*,
+ transformers >= 0.5 && < 0.7,
ghc-boot == @ProjectVersionMunged@,
ghc == @ProjectVersionMunged@
=====================================
hadrian/hadrian.cabal
=====================================
@@ -158,7 +158,7 @@ executable hadrian
, mtl >= 2.2 && < 2.4
, parsec >= 3.1 && < 3.2
, shake >= 0.18.3 && < 0.20
- , transformers >= 0.4 && < 0.6
+ , transformers >= 0.4 && < 0.7
, unordered-containers >= 0.2.1 && < 0.3
, text >= 1.2 && < 3
ghc-options: -Wall
=====================================
libraries/ghci/ghci.cabal.in
=====================================
@@ -80,7 +80,7 @@ library
ghc-boot == @ProjectVersionMunged@,
ghc-heap == @ProjectVersionMunged@,
template-haskell == 2.19.*,
- transformers == 0.5.*
+ transformers >= 0.5 && < 0.7
if !os(windows)
Build-Depends: unix >= 2.7 && < 2.9
=====================================
libraries/haskeline
=====================================
@@ -1 +1 @@
-Subproject commit d4f343509e905a717ea463ad84462c126d8990d8
+Subproject commit ad40faf532ca86ae6d0839a299234db2ce4fc424
=====================================
libraries/transformers
=====================================
@@ -1 +1 @@
-Subproject commit def8c55d0c47c1c40de985d83f052f3659b40cfd
+Subproject commit 2745db6c374c7e830a0f8fdeb8cc39bd8f054f36
=====================================
rts/ContinuationOps.cmm
=====================================
@@ -166,11 +166,12 @@ INFO_TABLE_FUN(stg_CONTINUATION,0,0,CONTINUATION,"CONTINUATION","CONTINUATION",2
// see Note [Continuations overview] in Continuation.c
stg_CONTINUATION_apply // explicit stack
{
+ W_ _unused;
P_ cont, io;
cont = R1;
io = R2;
- IF_DEBUG(sanity, ccall checkClosure(cont "ptr"));
+ IF_DEBUG(sanity, (_unused) = ccall checkClosure(cont "ptr"));
W_ new_stack_words, apply_mask_frame, mask_frame_offset;
new_stack_words = StgContinuation_stack_size(cont);
=====================================
testsuite/tests/ghci/scripts/T5979.stderr
=====================================
@@ -4,4 +4,4 @@
Perhaps you meant
Control.Monad.Trans.State (from transformers-0.5.6.2)
Control.Monad.Trans.Cont (from transformers-0.5.6.2)
- Control.Monad.Trans.List (from transformers-0.5.6.2)
+ Control.Monad.Trans.Class (from transformers-0.5.6.2)
=====================================
testsuite/tests/simplCore/should_compile/T22459.hs
=====================================
@@ -0,0 +1,23 @@
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -O #-}
+
+module Lib (foo) where
+
+import qualified Data.Map as M
+
+newtype Fix f = Fix (f (Fix f))
+
+instance Eq (f (Fix f)) => Eq (Fix f) where
+ Fix a == Fix b = a == b
+
+instance Ord (f (Fix f)) => Ord (Fix f) where
+ Fix a `compare` Fix b = a `compare` b
+
+data Foo i r = Foo i r
+ deriving (Eq, Ord)
+
+newtype Bar a = Bar (M.Map Char (M.Map (Fix (Foo ())) Word))
+
+foo :: Bar a -> Bar a -> Bar a
+foo (Bar a) (Bar b) = Bar (M.unionWith M.union a b)
=====================================
testsuite/tests/simplCore/should_compile/T22623.hs
=====================================
@@ -0,0 +1,34 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module T22623 where
+
+import T22623a
+
+type BindNonEmptyList :: NonEmpty -> NonEmpty -> [Q]
+type family BindNonEmptyList (x :: NonEmpty) (y :: NonEmpty) :: [Q] where
+ BindNonEmptyList ('(:|) a as) c = Tail c ++ Foldr2 a c as
+
+sBindNonEmptyList ::
+ forall (t :: NonEmpty)
+ (c :: NonEmpty). SNonEmpty t -> SNonEmpty c -> SList (BindNonEmptyList t c :: [Q])
+sBindNonEmptyList
+ ((:%|) (sA :: SQ a) (sAs :: SList as)) (sC :: SNonEmpty c)
+ = let
+ sMyHead :: SNonEmpty c -> SQ (MyHead a c)
+ sMyHead ((:%|) x _) = x
+
+ sFoldr :: forall t. SList t -> SList (Foldr2 a c t)
+ sFoldr SNil = SNil
+ sFoldr (SCons _ sYs) = SCons (sMyHead sC) (sFoldr sYs)
+
+ sF :: Id (SLambda (ConstSym1 c))
+ sF = SLambda (const sC)
+
+ sBs :: SList (Tail c)
+ _ :%| sBs = applySing sF sA
+ in
+ sBs %++ sFoldr sAs
=====================================
testsuite/tests/simplCore/should_compile/T22623a.hs
=====================================
@@ -0,0 +1,60 @@
+{-# LANGUAGE GHC2021 #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+module T22623a where
+
+import Data.Kind
+
+type Id :: Type -> Type
+type family Id x
+type instance Id x = x
+
+data Q
+data SQ (x :: Q)
+
+data NonEmpty where
+ (:|) :: Q -> [Q] -> NonEmpty
+
+type Tail :: NonEmpty -> [Q]
+type family Tail y where
+ Tail ('(:|) _ y) = y
+type MyHead :: Q -> NonEmpty -> Q
+type family MyHead x y where
+ MyHead _ ('(:|) c _) = c
+
+type SList :: [Q] -> Type
+data SList z where
+ SNil :: SList '[]
+ SCons :: SQ x -> SList xs -> SList (x:xs)
+
+type SNonEmpty :: NonEmpty -> Type
+data SNonEmpty z where
+ (:%|) :: SQ x -> SList xs -> SNonEmpty (x :| xs)
+
+data TyFun
+type F = TyFun -> Type
+
+type Apply :: F -> Q -> NonEmpty
+type family Apply f x
+
+type ConstSym1 :: NonEmpty -> F
+data ConstSym1 (x :: NonEmpty) :: F
+type instance Apply (ConstSym1 x) _ = x
+
+type SLambda :: F -> Type
+newtype SLambda (f :: F) =
+ SLambda { applySing :: forall t. SQ t -> SNonEmpty (f `Apply` t) }
+
+type Foldr2 :: Q -> NonEmpty -> [Q] -> [Q]
+type family Foldr2 a c x where
+ Foldr2 _ _ '[] = '[]
+ Foldr2 a c (_:ys) = MyHead a c : Foldr2 a c ys
+
+type (++) :: [Q] -> [Q] -> [Q]
+type family (++) xs ys where
+ (++) '[] ys = ys
+ (++) ('(:) x xs) ys = '(:) x (xs ++ ys)
+
+(%++) :: forall (x :: [Q]) (y :: [Q]). SList x -> SList y -> SList (x ++ y)
+(%++) SNil sYs = sYs
+(%++) (SCons sX sXs) sYs = SCons sX (sXs %++ sYs)
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -458,3 +458,5 @@ test('T22494', [grep_errmsg(r'case') ], compile, ['-O -ddump-simpl -dsuppress-un
test('T22491', normal, compile, ['-O2'])
test('T21476', normal, compile, [''])
test('T22272', normal, multimod_compile, ['T22272', '-O -fexpose-all-unfoldings -fno-omit-interface-pragmas -fno-ignore-interface-pragmas'])
+test('T22459', normal, compile, [''])
+test('T22623', normal, multimod_compile, ['T22623', '-O -v0'])
=====================================
testsuite/tests/typecheck/should_fail/T22645.hs
=====================================
@@ -0,0 +1,9 @@
+module T22645 where
+
+import Data.Coerce
+
+type T :: (* -> *) -> * -> *
+data T m a = MkT (m a)
+
+p :: Coercible a b => T Maybe a -> T Maybe b
+p = coerce
=====================================
testsuite/tests/typecheck/should_fail/T22645.stderr
=====================================
@@ -0,0 +1,15 @@
+
+T22645.hs:9:5: error: [GHC-25897]
+ • Couldn't match type ‘a’ with ‘b’ arising from a use of ‘coerce’
+ ‘a’ is a rigid type variable bound by
+ the type signature for:
+ p :: forall a b. Coercible a b => T Maybe a -> T Maybe b
+ at T22645.hs:8:1-44
+ ‘b’ is a rigid type variable bound by
+ the type signature for:
+ p :: forall a b. Coercible a b => T Maybe a -> T Maybe b
+ at T22645.hs:8:1-44
+ • In the expression: coerce
+ In an equation for ‘p’: p = coerce
+ • Relevant bindings include
+ p :: T Maybe a -> T Maybe b (bound at T22645.hs:9:1)
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -666,3 +666,4 @@ test('T21447', normal, compile_fail, [''])
test('T21530a', normal, compile_fail, [''])
test('T21530b', normal, compile_fail, [''])
test('T22570', normal, compile_fail, [''])
+test('T22645', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4aaee2087ce5d3a63b1d8352ce1a15e096f777e8...a44a4e6753bf68e4d7823fa5c20b5d628576d5ab
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4aaee2087ce5d3a63b1d8352ce1a15e096f777e8...a44a4e6753bf68e4d7823fa5c20b5d628576d5ab
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221221/966601df/attachment-0001.html>
More information about the ghc-commits
mailing list