[Git][ghc/ghc][wip/T21909] 6 commits: No default finalizer exception handler
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Fri Feb 17 15:56:05 UTC 2023
Apoorv Ingle pushed to branch wip/T21909 at Glasgow Haskell Compiler / GHC
Commits:
681e0e8c by sheaf at 2023-02-16T14:09:56-05:00
No default finalizer exception handler
Commit cfc8e2e2 introduced a mechanism for handling of exceptions
that occur during Handle finalization, and 372cf730 set the default
handler to print out the error to stderr.
However, #21680 pointed out we might not want to set this by default,
as it might pollute users' terminals with unwanted information.
So, for the time being, the default handler discards the exception.
Fixes #21680
- - - - -
b3ac17ad by Matthew Pickering at 2023-02-16T14:10:31-05:00
unicode: Don't inline bitmap in generalCategory
generalCategory contains a huge literal string but is marked INLINE,
this will duplicate the string into any use site of generalCategory. In
particular generalCategory is used in functions like isSpace and the
literal gets inlined into this function which makes it massive.
https://github.com/haskell/core-libraries-committee/issues/130
Fixes #22949
-------------------------
Metric Decrease:
T4029
T18304
-------------------------
- - - - -
8988eeef by sheaf at 2023-02-16T20:32:27-05:00
Expand synonyms in RoughMap
We were failing to expand type synonyms in the function
GHC.Core.RoughMap.typeToRoughMatchLookupTc, even though the
RoughMap infrastructure crucially relies on type synonym expansion
to work.
This patch adds the missing type-synonym expansion.
Fixes #22985
- - - - -
3dd50e2f by Matthew Pickering at 2023-02-16T20:33:03-05:00
ghcup-metadata: Add test artifact
Add the released testsuite tarball to the generated ghcup metadata.
- - - - -
c6a967d9 by Matthew Pickering at 2023-02-16T20:33:03-05:00
ghcup-metadata: Use Ubuntu and Rocky bindists
Prefer to use the Ubuntu 20.04 and 18.04 binary distributions on Ubuntu
and Linux Mint. Prefer to use the Rocky 8 binary distribution on
unknown distributions.
- - - - -
2f0b717c by Apoorv Ingle at 2023-02-17T09:53:43-06:00
Constraint simplification loop now depends on `ExpansionFuel`
instead of a boolean flag for `CDictCan.cc_pend_sc`.
Pending givens get a fuel of 3 while Wanted and quantified constraints get a fuel of 1.
This helps pending given constraints to keep up with pending wanted constraints in case of
`UndecidableSuperClasses` and superclass expansions while simplifying the infered type.
Adds 3 dynamic flags for controlling the fuels for each type of constraints
`-fgivens-expansion-fuel` for givens `-fwanteds-expansion-fuel` for wanteds and `-fqcs-expansion-fuel` for quantified constraints
Fixes #21909
Added Tests T21909, T21909b
Added Note [SimplifyInfer and UndecidableSuperClasses]
- - - - -
28 changed files:
- .gitlab-ci.yml
- .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
- compiler/GHC/Core/RoughMap.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Settings/Constants.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Canonical.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/Constraint.hs
- docs/users_guide/9.6.1-notes.rst
- docs/users_guide/expected-undocumented-flags.txt
- libraries/base/GHC/TopHandler.hs
- libraries/base/GHC/Unicode/Internal/Char/UnicodeData/GeneralCategory.hs
- libraries/base/changelog.md
- + libraries/base/tests/IO/T21336/FinalizerExceptionHandler.hs
- libraries/base/tests/IO/T21336/T21336a.hs
- libraries/base/tests/IO/T21336/T21336a.stderr
- libraries/base/tests/IO/T21336/T21336b.hs
- libraries/base/tests/IO/T21336/T21336b.stderr
- libraries/base/tests/IO/T21336/T21336c.hs
- libraries/base/tests/IO/T21336/all.T
- − libraries/base/tests/T13167.stderr
- libraries/base/tools/ucd2haskell/exe/Parser/Text.hs
- + testsuite/tests/typecheck/should_compile/T21909.hs
- + testsuite/tests/typecheck/should_compile/T21909b.hs
- + testsuite/tests/typecheck/should_compile/T22985a.hs
- + testsuite/tests/typecheck/should_compile/T22985b.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -1011,6 +1011,12 @@ ghcup-metadata-nightly:
artifacts: false
- job: nightly-x86_64-linux-centos7-validate
artifacts: false
+ - job: nightly-x86_64-linux-ubuntu20_04-validate
+ artifacts: false
+ - job: nightly-x86_64-linux-ubuntu18_04-validate
+ artifacts: false
+ - job: nightly-x86_64-linux-rocky8-validate
+ artifacts: false
- job: nightly-x86_64-darwin-validate
artifacts: false
- job: nightly-aarch64-darwin-validate
=====================================
.gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
=====================================
@@ -73,6 +73,7 @@ class PlatformSpec(NamedTuple):
subdir: str
source_artifact = Artifact('source-tarball', 'ghc-{version}-src.tar.xz', 'ghc-{version}' )
+test_artifact = Artifact('source-tarball', 'ghc-{version}-testsuite.tar.xz', 'ghc-{version}' )
def debian(arch, n):
return linux_platform(arch, "{arch}-linux-deb{n}".format(arch=arch, n=n))
@@ -93,6 +94,12 @@ def fedora(n):
def alpine(n):
return linux_platform("x86_64", "x86_64-linux-alpine{n}".format(n=n))
+def rocky(n):
+ return linux_platform("x86_64", "x86_64-linux-rocky{n}".format(n=n))
+
+def ubuntu(n):
+ return linux_platform("x86_64", "x86_64-linux-ubuntu{n}".format(n=n))
+
def linux_platform(arch, opsys):
return PlatformSpec( opsys, 'ghc-{version}-{arch}-unknown-linux'.format(version="{version}", arch=arch) )
@@ -156,6 +163,9 @@ def mk_new_yaml(release_mode, version, pipeline_type, job_map):
eprint("\n=== " + platform.name + " " + ('=' * (75 - len(platform.name))))
return mk_one_metadata(release_mode, version, job_map, mk_from_platform(pipeline_type, platform))
+ ubuntu1804 = mk(ubuntu("18_04"))
+ ubuntu2004 = mk(ubuntu("20_04"))
+ rocky8 = mk(rocky("8"))
# Here are all the bindists we can distribute
centos7 = mk(centos(7))
fedora33 = mk(fedora(33))
@@ -170,6 +180,7 @@ def mk_new_yaml(release_mode, version, pipeline_type, job_map):
deb9_i386 = mk(debian("i386", 9))
source = mk_one_metadata(release_mode, version, job_map, source_artifact)
+ test = mk_one_metadata(release_mode, version, job_map, test_artifact)
# The actual metadata, this is not a precise science, but just what the ghcup
# developers want.
@@ -178,18 +189,18 @@ def mk_new_yaml(release_mode, version, pipeline_type, job_map):
, "(>= 10 && < 11)": deb10
, ">= 11": deb11
, "unknown_versioning": deb11 }
- , "Linux_Ubuntu" : { "unknown_versioning": deb10
- , "( >= 16 && < 19 )": deb9
+ , "Linux_Ubuntu" : { "unknown_versioning": ubuntu2004
+ , "( >= 16 && < 19 )": ubuntu1804
}
- , "Linux_Mint" : { "< 20": deb9
- , ">= 20": deb10 }
+ , "Linux_Mint" : { "< 20": ubuntu1804
+ , ">= 20": ubuntu2004 }
, "Linux_CentOS" : { "( >= 7 && < 8 )" : centos7
, "unknown_versioning" : centos7 }
, "Linux_Fedora" : { ">= 33": fedora33
, "unknown_versioning": centos7 }
, "Linux_RedHat" : { "unknown_versioning": centos7 }
#MP: Replace here with Rocky8 when that job is in the pipeline
- , "Linux_UnknownLinux" : { "unknown_versioning": fedora33 }
+ , "Linux_UnknownLinux" : { "unknown_versioning": rocky8 }
, "Darwin" : { "unknown_versioning" : darwin_x86 }
, "Windows" : { "unknown_versioning" : windows }
, "Linux_Alpine" : { "unknown_versioning": alpine3_12 }
@@ -220,6 +231,7 @@ def mk_new_yaml(release_mode, version, pipeline_type, job_map):
# Check that this link exists
, "viChangeLog": change_log
, "viSourceDL": source
+ , "viTestDL": test
, "viArch": { "A_64": a64
, "A_32": a32
, "A_ARM64": arm64
=====================================
compiler/GHC/Core/RoughMap.hs
=====================================
@@ -320,7 +320,11 @@ roughMatchTcsLookup tys = map typeToRoughMatchLookupTc tys
typeToRoughMatchLookupTc :: Type -> RoughMatchLookupTc
typeToRoughMatchLookupTc ty
- | Just (ty', _) <- splitCastTy_maybe ty
+ -- Expand synonyms first, as explained in Note [Rough matching in class and family instances].
+ -- Failing to do so led to #22985.
+ | Just ty' <- coreView ty
+ = typeToRoughMatchLookupTc ty'
+ | CastTy ty' _ <- ty
= typeToRoughMatchLookupTc ty'
| otherwise
= case splitAppTys ty of
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -517,6 +517,12 @@ data DynFlags = DynFlags {
reductionDepth :: IntWithInf, -- ^ Typechecker maximum stack depth
solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver
-- Typically only 1 is needed
+ givensFuel :: Int, -- ^ Number of layers of superclass expansion
+ -- Should be < solverIterations
+ wantedsFuel :: Int, -- ^ Number of layers of superclass expansion
+ -- Should be < givensFuel
+ qcsFuel :: Int, -- ^ Number of layers of superclass expansion
+ -- Should be < givensFuel
homeUnitId_ :: UnitId, -- ^ Target home unit-id
homeUnitInstanceOf_ :: Maybe UnitId, -- ^ Id of the unit to instantiate
@@ -1148,6 +1154,9 @@ defaultDynFlags mySettings =
mainFunIs = Nothing,
reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH,
solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS,
+ givensFuel = mAX_GIVENS_FUEL,
+ wantedsFuel = mAX_WANTEDS_FUEL,
+ qcsFuel = mAX_QC_FUEL,
homeUnitId_ = mainUnitId,
homeUnitInstanceOf_ = Nothing,
@@ -2733,6 +2742,12 @@ dynamic_flags_deps = [
(intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n }))
, make_ord_flag defFlag "fconstraint-solver-iterations"
(intSuffix (\n d -> d { solverIterations = treatZeroAsInf n }))
+ , make_ord_flag defFlag "fgivens-expansion-fuel"
+ (intSuffix (\n d -> d { givensFuel = n }))
+ , make_ord_flag defFlag "fwanteds-expansion-fuel"
+ (intSuffix (\n d -> d { wantedsFuel = n }))
+ , make_ord_flag defFlag "fqcs-expansion-fuel"
+ (intSuffix (\n d -> d { qcsFuel = n }))
, (Deprecated, defFlag "fcontext-stack"
(intSuffixM (\n d ->
do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead"
=====================================
compiler/GHC/Settings/Constants.hs
=====================================
@@ -30,6 +30,21 @@ mAX_REDUCTION_DEPTH = 200
mAX_SOLVER_ITERATIONS :: Int
mAX_SOLVER_ITERATIONS = 4
+-- | In case of loopy quantified costraints constraints,
+-- how many times should we allow superclass expansions
+mAX_QC_FUEL :: Int
+mAX_QC_FUEL = 3
+
+-- | In case of loopy wanted constraints,
+-- how many times should we allow superclass expansions
+mAX_WANTEDS_FUEL :: Int
+mAX_WANTEDS_FUEL = 1
+
+-- | In case of loopy given constraints,
+-- how many times should we allow superclass expansions
+mAX_GIVENS_FUEL :: Int
+mAX_GIVENS_FUEL = 3
+
wORD64_SIZE :: Int
wORD64_SIZE = 8
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -2338,6 +2338,10 @@ maybe_simplify_again n limit unif_happened wc@(WC { wc_simple = simples })
do { new_given <- makeSuperClasses pending_given
; new_wanted <- makeSuperClasses pending_wanted
; solveSimpleGivens new_given -- Add the new Givens to the inert set
+ ; traceTcS "maybe_simplify_again" (vcat [ text "pending_given" <+> ppr pending_given
+ , text "new_given" <+> ppr new_given
+ , text "pending_wanted" <+> ppr pending_wanted
+ , text "new_wanted" <+> ppr new_wanted ])
; simplify_loop n limit (not (null pending_given)) $
wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } }
-- (not (null pending_given)): see Note [Superclass iteration]
@@ -2366,6 +2370,43 @@ superclasses. In that case we check whether the new Wanteds actually led to
any new unifications, and iterate the implications only if so.
-}
+{- Note [SimplifyInfer with UndecidableSuperClasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In some cases while infering the type of a term well typed term, it is necessary to ensure
+we limit the wanted superclass expansions.
+Expanding them too many times will lead to the given constraint superclass expansion
+not being able solve all the wanted constraints, by entering a perpetual loop and erroring out on
+too many solver iterations. Expanding them too little will not give us a simplified type signature.
+
+Consider the program (T21909)
+
+ class C [a] => C a where
+ foo :: a -> Int
+
+ bar :: C a => a -> Int
+ bar x = foolocal x
+ where
+ foolocal x = foo x
+
+In the current implimentation
+We infer the type of foolocal to be `(C a) => a -> Int`
+and then simplify it to `(C a, C [[a]]) => a -> Int`
+
+This indeed is not simplification per say, but we are in UndecidableSuperclass case
+so we cannot guarantee simplification of contraints. What we aim for is for the
+the solver to not to loop unnecessarily generating more wanted constraints than
+in can solve in `maybe_simplify_again`.
+
+If we did not limit the wanteds superclass expansion we would simplify the type signature of
+foolocal as `(C a , C [[a]], C[[[[a]]]], C[[[[a]]]], C [[[[[[[[a]]]]]]]]) => a -> Int`
+Definitely _worse_ than above type!
+
+The current limit the expansion of such recursive wanted constraints to 1 (mAX_WANTEDS_FUEL),
+and limit the expansion of recursive given constraints to 3 (mAX_GIVENS_FUEL).
+
+-}
+
+
solveNestedImplications :: Bag Implication
-> TcS (Bag Implication)
-- Precondition: the TcS inerts may contain unsolved simples which have
=====================================
compiler/GHC/Tc/Solver/Canonical.hs
=====================================
@@ -58,7 +58,7 @@ import Control.Monad
import Data.Maybe ( isJust, isNothing )
import Data.List ( zip4 )
import GHC.Types.Basic
-
+import GHC.Driver.Session ( DynFlags, givensFuel, wantedsFuel, qcsFuel )
import qualified Data.Semigroup as S
import Data.Bifunctor ( bimap )
@@ -127,14 +127,16 @@ canonicalize (CEqCan { cc_ev = ev
canNC :: CtEvidence -> TcS (StopOrContinue Ct)
canNC ev =
case classifyPredType pred of
- ClassPred cls tys -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)
- canClassNC ev cls tys
+ ClassPred cls tys -> do dflags <- getDynFlags
+ traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)
+ canClassNC dflags ev cls tys
EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)
canEqNC ev eq_rel ty1 ty2
IrredPred {} -> do traceTcS "canEvNC:irred" (ppr pred)
canIrred ev
- ForAllPred tvs th p -> do traceTcS "canEvNC:forall" (ppr pred)
- canForAllNC ev tvs th p
+ ForAllPred tvs th p -> do dflags <- getDynFlags
+ traceTcS "canEvNC:forall" (ppr pred)
+ canForAllNC dflags ev tvs th p
where
pred = ctEvPred ev
@@ -147,15 +149,16 @@ canNC ev =
************************************************************************
-}
-canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct)
+canClassNC :: DynFlags -> CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct)
-- "NC" means "non-canonical"; that is, we have got here
-- from a NonCanonical constraint, not from a CDictCan
-- Precondition: EvVar is class evidence
-canClassNC ev cls tys
+canClassNC dflags ev cls tys
| isGiven ev -- See Note [Eagerly expand given superclasses]
- = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys
+ = do { let gf = givensFuel dflags
+ ; sc_cts <- mkStrictSuperClasses gf ev [] [] cls tys
; emitWork sc_cts
- ; canClass ev cls tys False }
+ ; canClass ev cls tys doNotExpand }
| CtWanted { ctev_rewriters = rewriters } <- ev
, Just ip_name <- isCallStackPred cls tys
@@ -181,14 +184,16 @@ canClassNC ev cls tys
(ctLocSpan loc) (ctEvExpr new_ev)
; solveCallStack ev ev_cs
- ; canClass new_ev cls tys False -- No superclasses
+ ; canClass new_ev cls tys doNotExpand -- No superclasses
}
| otherwise
- = canClass ev cls tys (has_scs cls)
+ = canClass ev cls tys fuel
where
- has_scs cls = not (null (classSCTheta cls))
+ fuel | cls_has_scs = wantedsFuel dflags
+ | otherwise = doNotExpand
+ cls_has_scs = not (null (classSCTheta cls))
loc = ctEvLoc ev
orig = ctLocOrigin loc
pred = ctEvPred ev
@@ -205,7 +210,7 @@ solveCallStack ev ev_cs = do
canClass :: CtEvidence
-> Class -> [Type]
- -> Bool -- True <=> un-explored superclasses
+ -> ExpansionFuel -- n > 0 <=> un-explored superclasses
-> TcS (StopOrContinue Ct)
-- Precondition: EvVar is class evidence
@@ -492,39 +497,40 @@ makeSuperClasses :: [Ct] -> TcS [Ct]
-- class C [a] => D a
-- makeSuperClasses (C x) will return (D x, C [x])
--
--- NB: the incoming constraints have had their cc_pend_sc flag already
--- flipped to False, by isPendingScDict, so we are /obliged/ to at
--- least produce the immediate superclasses
+-- NB: the incoming constraints will be expanded only if the fuel is striclty > 0
+-- expansion will consume a unit of fuel
makeSuperClasses cts = concatMapM go cts
where
- go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
- = mkStrictSuperClasses ev [] [] cls tys
- go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev }))
+ go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys, cc_pend_sc = fuel })
+ = assertPpr (fuel > 0) (ppr cls) $ -- fuel needs to be more than 0 always
+ mkStrictSuperClasses (consumeFuel fuel) ev [] [] cls tys
+ go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev, qci_pend_sc = fuel }))
= assertPpr (isClassPred pred) (ppr pred) $ -- The cts should all have
-- class pred heads
- mkStrictSuperClasses ev tvs theta cls tys
+ assertPpr (fuel > 0) (ppr cls) $ -- fuel needs to be more than 0 always
+ mkStrictSuperClasses (consumeFuel fuel) ev tvs theta cls tys
where
(tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)
go ct = pprPanic "makeSuperClasses" (ppr ct)
mkStrictSuperClasses
- :: CtEvidence
+ :: ExpansionFuel -> CtEvidence
-> [TyVar] -> ThetaType -- These two args are non-empty only when taking
-- superclasses of a /quantified/ constraint
-> Class -> [Type] -> TcS [Ct]
-- Return constraints for the strict superclasses of
-- ev :: forall as. theta => cls tys
-mkStrictSuperClasses ev tvs theta cls tys
- = mk_strict_superclasses (unitNameSet (className cls))
+mkStrictSuperClasses fuel ev tvs theta cls tys
+ = mk_strict_superclasses fuel (unitNameSet (className cls))
ev tvs theta cls tys
-mk_strict_superclasses :: NameSet -> CtEvidence
+mk_strict_superclasses :: ExpansionFuel -> NameSet -> CtEvidence
-> [TyVar] -> ThetaType
-> Class -> [Type] -> TcS [Ct]
-- Always return the immediate superclasses of (cls tys);
-- and expand their superclasses, provided none of them are in rec_clss
-- nor are repeated
-mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })
+mk_strict_superclasses fuel rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })
tvs theta cls tys
= concatMapM do_one_given $
classSCSelIds cls
@@ -542,7 +548,7 @@ mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })
| otherwise
= do { given_ev <- newGivenEvVar sc_loc $
mk_given_desc sel_id sc_pred
- ; mk_superclasses rec_clss given_ev tvs theta sc_pred }
+ ; mk_superclasses fuel rec_clss given_ev tvs theta sc_pred }
where
sc_pred = classMethodInstTy sel_id tys
@@ -603,7 +609,7 @@ mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })
newly_blocked (InstSkol _ head_size) = isJust (this_size `ltPatersonSize` head_size)
newly_blocked _ = False
-mk_strict_superclasses rec_clss ev tvs theta cls tys
+mk_strict_superclasses fuel rec_clss ev tvs theta cls tys
| all noFreeVarsOfType tys
= return [] -- Wanteds with no variables yield no superclass constraints.
-- See Note [Improvement from Ground Wanteds]
@@ -618,7 +624,7 @@ mk_strict_superclasses rec_clss ev tvs theta cls tys
do_one sc_pred
= do { traceTcS "mk_strict_superclasses Wanted" (ppr (mkClassPred cls tys) $$ ppr sc_pred)
; sc_ev <- newWantedNC loc (ctEvRewriters ev) sc_pred
- ; mk_superclasses rec_clss sc_ev [] [] sc_pred }
+ ; mk_superclasses fuel rec_clss sc_ev [] [] sc_pred }
{- Note [Improvement from Ground Wanteds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -633,46 +639,49 @@ dependencies. See Note [Why adding superclasses can help] above.
But no variables means no improvement; case closed.
-}
-mk_superclasses :: NameSet -> CtEvidence
+mk_superclasses :: ExpansionFuel -> NameSet -> CtEvidence
-> [TyVar] -> ThetaType -> PredType -> TcS [Ct]
-- Return this constraint, plus its superclasses, if any
-mk_superclasses rec_clss ev tvs theta pred
+mk_superclasses fuel rec_clss ev tvs theta pred
| ClassPred cls tys <- classifyPredType pred
- = mk_superclasses_of rec_clss ev tvs theta cls tys
+ = mk_superclasses_of fuel rec_clss ev tvs theta cls tys
| otherwise -- Superclass is not a class predicate
= return [mkNonCanonical ev]
-mk_superclasses_of :: NameSet -> CtEvidence
+mk_superclasses_of :: ExpansionFuel -> NameSet -> CtEvidence
-> [TyVar] -> ThetaType -> Class -> [Type]
-> TcS [Ct]
-- Always return this class constraint,
-- and expand its superclasses
-mk_superclasses_of rec_clss ev tvs theta cls tys
+mk_superclasses_of fuel rec_clss ev tvs theta cls tys
| loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys)
- ; return [this_ct] } -- cc_pend_sc of this_ct = True
+ ; return [this_ct] } -- cc_pend_sc of this_ct = fuel
| otherwise = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys
, ppr (isCTupleClass cls)
, ppr rec_clss
])
- ; sc_cts <- mk_strict_superclasses rec_clss' ev tvs theta cls tys
+ ; sc_cts <- mk_strict_superclasses fuel rec_clss' ev tvs theta cls tys
; return (this_ct : sc_cts) }
- -- cc_pend_sc of this_ct = False
+ -- cc_pend_sc of this_ct = doNotExpand
where
cls_nm = className cls
loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss
-- Tuples never contribute to recursion, and can be nested
rec_clss' = rec_clss `extendNameSet` cls_nm
+ this_cc_pend | loop_found = fuel
+ | otherwise = 0
+
this_ct | null tvs, null theta
= CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys
- , cc_pend_sc = loop_found }
+ , cc_pend_sc = this_cc_pend }
-- NB: If there is a loop, we cut off, so we have not
-- added the superclasses, hence cc_pend_sc = True
| otherwise
= CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys
, qci_ev = ev
- , qci_pend_sc = loop_found })
+ , qci_pend_sc = this_cc_pend })
{- Note [Equality superclasses in quantified constraints]
@@ -723,6 +732,7 @@ canIrred :: CtEvidence -> TcS (StopOrContinue Ct)
-- Precondition: ty not a tuple and no other evidence form
canIrred ev
= do { let pred = ctEvPred ev
+ ; dflags <- getDynFlags
; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)
; (redn, rewriters) <- rewrite ev pred
; rewriteEvidence rewriters ev redn `andWhenContinue` \ new_ev ->
@@ -731,7 +741,7 @@ canIrred ev
-- Code is like the canNC, except
-- that the IrredPred branch stops work
; case classifyPredType (ctEvPred new_ev) of
- ClassPred cls tys -> canClassNC new_ev cls tys
+ ClassPred cls tys -> canClassNC dflags new_ev cls tys
EqPred eq_rel ty1 ty2 -> -- IrredPreds have kind Constraint, so
-- cannot become EqPreds
pprPanic "canIrred: EqPred"
@@ -740,7 +750,7 @@ canIrred ev
-- should never leave a meta-var filled
-- in with a polytype. This is #18987.
do traceTcS "canEvNC:forall" (ppr pred)
- canForAllNC ev tvs th p
+ canForAllNC dflags ev tvs th p
IrredPred {} -> continueWith $
mkIrredCt IrredShapeReason new_ev } }
@@ -822,24 +832,28 @@ type signature.
-}
-canForAllNC :: CtEvidence -> [TyVar] -> TcThetaType -> TcPredType
+canForAllNC :: DynFlags -> CtEvidence -> [TyVar] -> TcThetaType -> TcPredType
-> TcS (StopOrContinue Ct)
-canForAllNC ev tvs theta pred
+canForAllNC dflags ev tvs theta pred
| isGiven ev -- See Note [Eagerly expand given superclasses]
, Just (cls, tys) <- cls_pred_tys_maybe
- = do { sc_cts <- mkStrictSuperClasses ev tvs theta cls tys
+ = do { let gf = givensFuel dflags
+ ; sc_cts <- mkStrictSuperClasses gf ev tvs theta cls tys
; emitWork sc_cts
- ; canForAll ev False }
+ ; canForAll ev doNotExpand }
| otherwise
- = canForAll ev (isJust cls_pred_tys_maybe)
+ = do { let qcf = qcsFuel dflags
+ fuel | isJust cls_pred_tys_maybe = qcf
+ | otherwise = doNotExpand
+ ; canForAll ev fuel }
where
cls_pred_tys_maybe = getClassPredTys_maybe pred
-canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct)
+canForAll :: CtEvidence -> ExpansionFuel -> TcS (StopOrContinue Ct)
-- We have a constraint (forall as. blah => C tys)
-canForAll ev pend_sc
+canForAll ev fuel
= do { -- First rewrite it to apply the current substitution
let pred = ctEvPred ev
; (redn, rewriters) <- rewrite ev pred
@@ -849,14 +863,14 @@ canForAll ev pend_sc
-- (It takes a lot less code to rewrite before decomposing.)
; case classifyPredType (ctEvPred new_ev) of
ForAllPred tvs theta pred
- -> solveForAll new_ev tvs theta pred pend_sc
+ -> solveForAll new_ev tvs theta pred fuel
_ -> pprPanic "canForAll" (ppr new_ev)
} }
-solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> Bool
+solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> ExpansionFuel
-> TcS (StopOrContinue Ct)
solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc })
- tvs theta pred _pend_sc
+ tvs theta pred _fuel
= -- See Note [Solving a Wanted forall-constraint]
setLclEnv (ctLocEnv loc) $
-- This setLclEnv is important: the emitImplicationTcS uses that
@@ -902,12 +916,12 @@ solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_lo
_ -> pSizeType pred
-- See Note [Solving a Given forall-constraint]
-solveForAll ev@(CtGiven {}) tvs _theta pred pend_sc
+solveForAll ev@(CtGiven {}) tvs _theta pred fuel
= do { addInertForAll qci
; stopWith ev "Given forall-constraint" }
where
qci = QCI { qci_ev = ev, qci_tvs = tvs
- , qci_pred = pred, qci_pend_sc = pend_sc }
+ , qci_pred = pred, qci_pend_sc = fuel }
{- Note [Solving a Wanted forall-constraint]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -513,10 +513,13 @@ getInertGivens
; return (filter isGivenCt all_cts) }
getPendingGivenScs :: TcS [Ct]
--- Find all inert Given dictionaries, or quantified constraints,
--- whose cc_pend_sc flag is True
--- and that belong to the current level
--- Set their cc_pend_sc flag to False in the inert set, and return that Ct
+-- Find all inert Given dictionaries, or quantified constraints, such that
+-- 1. cc_pend_sc flag has fuel strictly > 0
+-- 2. belongs to the current level
+-- For each such dictionary:
+-- * Return it (with unmodified cc_pend_sc) in sc_pending
+-- * Modify the dict in the inert set to have cc_pend_sc = doNotExpand
+-- to record that we have expanded superclasses for this dict
getPendingGivenScs = do { lvl <- getTcLevel
; updRetInertCans (get_sc_pending lvl) }
@@ -530,29 +533,33 @@ get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })
sc_pending = sc_pend_insts ++ sc_pend_dicts
sc_pend_dicts = foldDicts get_pending dicts []
- dicts' = foldr add dicts sc_pend_dicts
+ dicts' = foldr exhaustAndAdd dicts sc_pend_dicts
(sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts
- get_pending :: Ct -> [Ct] -> [Ct] -- Get dicts with cc_pend_sc = True
- -- but flipping the flag
+ get_pending :: Ct -> [Ct] -> [Ct] -- Get dicts with cc_pend_sc > 0
get_pending dict dicts
- | Just dict' <- pendingScDict_maybe dict
+ | isPendingScDict dict
, belongs_to_this_level (ctEvidence dict)
- = dict' : dicts
+ = dict : dicts
| otherwise
= dicts
- add :: Ct -> DictMap Ct -> DictMap Ct
- add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts
- = addDict dicts cls tys ct
- add ct _ = pprPanic "getPendingScDicts" (ppr ct)
+ exhaustAndAdd :: Ct -> DictMap Ct -> DictMap Ct
+ exhaustAndAdd ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts
+ -- exhaust the fuel for this constraint before adding it as
+ -- we don't want to expand these constraints again
+ = addDict dicts cls tys (ct {cc_pend_sc = doNotExpand})
+ exhaustAndAdd ct _ = pprPanic "getPendingScDicts" (ppr ct)
get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)
get_pending_inst cts qci@(QCI { qci_ev = ev })
| Just qci' <- pendingScInst_maybe qci
, belongs_to_this_level ev
- = (CQuantCan qci' : cts, qci')
+ = (CQuantCan qci : cts, qci')
+ -- qci' have their fuel exhausted
+ -- we don't want to expand these constraints again
+ -- qci is expanded
| otherwise
= (cts, qci)
=====================================
compiler/GHC/Tc/Types/Constraint.hs
=====================================
@@ -11,6 +11,7 @@ module GHC.Tc.Types.Constraint (
-- Canonical constraints
Xi, Ct(..), Cts,
+ ExpansionFuel, doNotExpand, consumeFuel,
emptyCts, andCts, andManyCts, pprCts,
singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,
isEmptyCts,
@@ -138,8 +139,6 @@ import Data.Word ( Word8 )
import Data.List ( intersperse )
-
-
{-
************************************************************************
* *
@@ -191,6 +190,16 @@ type Xi = TcType
type Cts = Bag Ct
+-- | Says how many layers of superclasses can we expand.
+-- see Note [SimplifyInfer with UndecidableSuperClasses]
+type ExpansionFuel = Int
+
+doNotExpand :: ExpansionFuel -- Do not expand superclasses anymore
+doNotExpand = 0
+
+consumeFuel :: ExpansionFuel -> ExpansionFuel
+consumeFuel fuel = fuel - 1
+
data Ct
-- Atomic canonical constraints
= CDictCan { -- e.g. Num ty
@@ -199,11 +208,11 @@ data Ct
cc_class :: Class,
cc_tyargs :: [Xi], -- cc_tyargs are rewritten w.r.t. inerts, so Xi
- cc_pend_sc :: Bool
+ cc_pend_sc :: ExpansionFuel
-- See Note [The superclass story] in GHC.Tc.Solver.Canonical
- -- True <=> (a) cc_class has superclasses
- -- (b) we have not (yet) added those
- -- superclasses as Givens
+ -- See Note [SimplifyInfer with UndecidableSuperClasses] in GHC.Tc.Solver
+ -- n > 0 <=> (a) cc_class has superclasses
+ -- (b) we have not (yet) explored those superclasses
}
| CIrredCan { -- These stand for yet-unusable predicates
@@ -273,8 +282,11 @@ data QCInst -- A much simplified version of ClsInst
-- Always Given
, qci_tvs :: [TcTyVar] -- The tvs
, qci_pred :: TcPredType -- The ty
- , qci_pend_sc :: Bool -- Same as cc_pend_sc flag in CDictCan
- -- Invariant: True => qci_pred is a ClassPred
+ , qci_pend_sc :: ExpansionFuel -- Invariants: qci_pend_sc > 0 => qci_pred is a ClassPred
+ -- and the superclasses are unexplored
+ -- Same as cc_pend_sc flag in CDictCan
+ -- See Note [SimplifyInfer with UndecidableSuperClasses]
+ -- in GHC.Tc.Solver
}
instance Outputable QCInst where
@@ -673,11 +685,11 @@ instance Outputable Ct where
CEqCan {} -> text "CEqCan"
CNonCanonical {} -> text "CNonCanonical"
CDictCan { cc_pend_sc = psc }
- | psc -> text "CDictCan(psc)"
- | otherwise -> text "CDictCan"
+ | psc > 0 -> text "CDictCan" <> parens (text "psc" <+> ppr psc)
+ | otherwise -> text "CDictCan"
CIrredCan { cc_reason = reason } -> text "CIrredCan" <> ppr reason
- CQuantCan (QCI { qci_pend_sc = pend_sc })
- | pend_sc -> text "CQuantCan(psc)"
+ CQuantCan (QCI { qci_pend_sc = psc })
+ | psc > 0 -> text "CQuantCan" <> parens (text "psc" <+> ppr psc)
| otherwise -> text "CQuantCan"
-----------------------------------
@@ -893,23 +905,24 @@ isUserTypeError pred = case getUserTypeErrorMsg pred of
_ -> False
isPendingScDict :: Ct -> Bool
-isPendingScDict (CDictCan { cc_pend_sc = psc }) = psc
--- Says whether this is a CDictCan with cc_pend_sc is True;
+isPendingScDict (CDictCan { cc_pend_sc = psc }) = psc > 0
+-- Says whether this is a CDictCan with cc_pend_sc has positive fuel;
-- i.e. pending un-expanded superclasses
isPendingScDict _ = False
pendingScDict_maybe :: Ct -> Maybe Ct
--- Says whether this is a CDictCan with cc_pend_sc is True,
--- AND if so flips the flag
-pendingScDict_maybe ct@(CDictCan { cc_pend_sc = True })
- = Just (ct { cc_pend_sc = False })
+-- Says whether this is a CDictCan with cc_pend_sc has fuel left,
+-- AND if so exhausts the fuel so that they are not expanded again
+pendingScDict_maybe ct@(CDictCan { cc_pend_sc = n })
+ | n > 0 = Just (ct { cc_pend_sc = doNotExpand })
+ | otherwise = Nothing
pendingScDict_maybe _ = Nothing
pendingScInst_maybe :: QCInst -> Maybe QCInst
-- Same as isPendingScDict, but for QCInsts
-pendingScInst_maybe qci@(QCI { qci_pend_sc = True })
- = Just (qci { qci_pend_sc = False })
-pendingScInst_maybe _ = Nothing
+pendingScInst_maybe qci@(QCI { qci_pend_sc = n })
+ | n > 0 = Just (qci { qci_pend_sc = doNotExpand })
+ | otherwise = Nothing
superClassesMightHelp :: WantedConstraints -> Bool
-- ^ True if taking superclasses of givens, or of wanteds (to perhaps
@@ -928,11 +941,12 @@ superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics })
is_ip _ = False
getPendingWantedScs :: Cts -> ([Ct], Cts)
+-- in the return values [Ct] has original fuel while Cts has fuel exhausted
getPendingWantedScs simples
= mapAccumBagL get [] simples
where
- get acc ct | Just ct' <- pendingScDict_maybe ct
- = (ct':acc, ct')
+ get acc ct | Just ct_exhausted <- pendingScDict_maybe ct
+ = (ct:acc, ct_exhausted)
| otherwise
= (acc, ct)
=====================================
docs/users_guide/9.6.1-notes.rst
=====================================
@@ -191,10 +191,9 @@ Runtime system
``base`` library
~~~~~~~~~~~~~~~~
-- Exceptions thrown by weak pointer finalizers are now caught and reported
- via a global exception handler. By default this handler reports the error
- to ``stderr`` although this can be changed using
- ``GHC.Weak.Finalize.setFinalizerExceptionHandler``.
+- Exceptions thrown by weak pointer finalizers can now be reported by setting
+ a global exception handler, using ``GHC.Weak.Finalize.setFinalizerExceptionHandler``.
+ The default behaviour is unchanged (exceptions are ignored and not reported).
- GHC now provides a set of operations for introspecting on the threads of a
program, ``GHC.Conc.listThreads``, as well as operations for querying a thread's
=====================================
docs/users_guide/expected-undocumented-flags.txt
=====================================
@@ -33,6 +33,9 @@
-fbang-patterns
-fbuilding-cabal-package
-fconstraint-solver-iterations
+-fgivens-expansion-fuel
+-fwanteds-expansion-fuel
+-fqcs-expansion-fuel
-fcontext-stack
-fcross-module-specialize
-fdiagnostics-color=always
=====================================
libraries/base/GHC/TopHandler.hs
=====================================
@@ -83,7 +83,11 @@ runMainIO main =
do
main_thread_id <- myThreadId
weak_tid <- mkWeakThreadId main_thread_id
- setFinalizerExceptionHandler handleFinalizerException
+
+ --setFinalizerExceptionHandler printToStderrFinalizerExceptionHandler
+ -- For the time being, we don't install any exception handler for
+ -- Handle finalization. Instead, the user should set one manually.
+
case weak_tid of (Weak w) -> setMainThread w
install_interrupt_handler $ do
m <- deRefWeak weak_tid
@@ -253,13 +257,6 @@ flushStdHandles = do
-- Swallow any exceptions thrown by the finalizer exception handler
handleFinalizerExc se `catchException` (\(SomeException _) -> return ())
--- | See Note [Handling exceptions during Handle finalization] in
--- GHC.IO.Handle.Internals
-handleFinalizerException :: SomeException -> IO ()
-handleFinalizerException se =
- hPutStr stderr msg `catchException` (\(SomeException _) -> return ())
- where
- msg = "Exception during Weak# finalization (ignored): " ++ displayException se ++ "\n"
safeExit, fastExit :: Int -> IO a
safeExit = exitHelper useSafeExit
=====================================
libraries/base/GHC/Unicode/Internal/Char/UnicodeData/GeneralCategory.hs
=====================================
The diff for this file was not included because it is too large.
=====================================
libraries/base/changelog.md
=====================================
@@ -4,6 +4,8 @@
* Add `Data.List.!?` ([CLC proposal #110](https://github.com/haskell/core-libraries-committee/issues/110))
* `maximumBy`/`minimumBy` are now marked as `INLINE` improving performance for unpackable
types significantly.
+ * Refactor `generalCategory` to stop very large literal string being inlined to call-sites.
+ ([CLC proposal #130](https://github.com/haskell/core-libraries-committee/issues/130))
## 4.18.0.0 *TBA*
@@ -12,10 +14,9 @@
* Add `forall a. Functor (p a)` superclass for `Bifunctor p` ([CLC proposal #91](https://github.com/haskell/core-libraries-committee/issues/91))
* Add Functor instances for `(,,,,) a b c d`, `(,,,,,) a b c d e` and
`(,,,,,) a b c d e f`.
- * Exceptions thrown by weak pointer finalizers are now reported via a global
- exception handler.
- * Add `GHC.Weak.Finalize.{get,set}FinalizerExceptionHandler` which allows the
- user to override the above-mentioned handler.
+ * Exceptions thrown by weak pointer finalizers can now be reported by setting
+ a global exception handler, using `System.Mem.Weak.setFinalizerExceptionHandler`.
+ The default behaviour is unchanged (exceptions are ignored and not reported).
* `Numeric.Natural` re-exports `GHC.Natural.minusNaturalMaybe`
([CLC proposal #45](https://github.com/haskell/core-libraries-committee/issues/45))
* Add `Data.Foldable1` and `Data.Bifoldable1`
=====================================
libraries/base/tests/IO/T21336/FinalizerExceptionHandler.hs
=====================================
@@ -0,0 +1,21 @@
+module FinalizerExceptionHandler
+ ( setFinalizerExceptionHandler
+ , getFinalizerExceptionHandler
+ , printToStderrFinalizerExceptionHandler )
+ where
+
+import GHC.Exception ( SomeException(..), displayException )
+import GHC.IO ( catchException )
+import GHC.IO.Handle ( hPutStr )
+import GHC.IO.StdHandles ( stderr )
+import GHC.Weak.Finalize ( setFinalizerExceptionHandler, getFinalizerExceptionHandler )
+
+-- | An exception handler for Handle finalization that prints the error to
+-- stderr, but doesn't rethrow it.
+printToStderrFinalizerExceptionHandler :: SomeException -> IO ()
+-- See Note [Handling exceptions during Handle finalization] in
+-- GHC.IO.Handle.Internals
+printToStderrFinalizerExceptionHandler se =
+ hPutStr stderr msg `catchException` (\(SomeException _) -> return ())
+ where
+ msg = "Exception during weak pointer finalization (ignored): " ++ displayException se ++ "\n"
=====================================
libraries/base/tests/IO/T21336/T21336a.hs
=====================================
@@ -1,9 +1,10 @@
-import GHC.Weak
import System.IO
import System.Mem
+import FinalizerExceptionHandler
main :: IO ()
main = do
+ setFinalizerExceptionHandler printToStderrFinalizerExceptionHandler
f <- openFile "/dev/full" WriteMode
hPutStr f "hello"
-- Ensure that the Handle's finalizer is run
=====================================
libraries/base/tests/IO/T21336/T21336a.stderr
=====================================
@@ -1 +1 @@
-Exception during Weak# finalization (ignored): GHC.IO.FD.fdWrite: resource exhausted (No space left on device)
+Exception during weak pointer finalization (ignored): GHC.IO.FD.fdWrite: resource exhausted (No space left on device)
=====================================
libraries/base/tests/IO/T21336/T21336b.hs
=====================================
@@ -1,6 +1,9 @@
-import GHC.Weak
import System.IO
+import System.Mem
+import FinalizerExceptionHandler
main :: IO ()
-main = hPutStr stdout "hello"
+main = do
+ setFinalizerExceptionHandler printToStderrFinalizerExceptionHandler
+ hPutStr stdout "hello"
=====================================
libraries/base/tests/IO/T21336/T21336b.stderr
=====================================
@@ -1 +1 @@
-Exception during Weak# finalization (ignored): <stdout>: hFlush: resource exhausted (No space left on device)
+Exception during weak pointer finalization (ignored): <stdout>: hFlush: resource exhausted (No space left on device)
=====================================
libraries/base/tests/IO/T21336/T21336c.hs
=====================================
@@ -1,6 +1,9 @@
-import GHC.Weak
import System.IO
+import System.Mem
+import FinalizerExceptionHandler
main :: IO ()
-main = hPutStr stdout "hello"
+main = do
+ setFinalizerExceptionHandler printToStderrFinalizerExceptionHandler
+ hPutStr stdout "hello"
=====================================
libraries/base/tests/IO/T21336/all.T
=====================================
@@ -3,14 +3,18 @@ test('T21336a',
[ unless(opsys('linux') or opsys('freebsd'), skip)
, js_broken(22261)
, fragile(22022)
+ , extra_files(['FinalizerExceptionHandler.hs'])
],
compile_and_run, [''])
test('T21336b',
- [unless(opsys('linux') or opsys('freebsd'), skip), js_broken(22352)],
+ [ unless(opsys('linux') or opsys('freebsd'), skip)
+ , js_broken(22352)
+ , extra_files(['FinalizerExceptionHandler.hs'])
+ ],
makefile_test, [])
test('T21336c',
[ unless(opsys('linux') or opsys('freebsd'), skip)
, js_broken(22370)
+ , extra_files(['FinalizerExceptionHandler.hs'])
],
makefile_test, [])
-
=====================================
libraries/base/tests/T13167.stderr deleted
=====================================
@@ -1,4 +0,0 @@
-Exception during Weak# finalization (ignored): failed
-Exception during Weak# finalization (ignored): failed
-Exception during Weak# finalization (ignored): failed
-Exception during Weak# finalization (ignored): failed
=====================================
libraries/base/tools/ucd2haskell/exe/Parser/Text.hs
=====================================
@@ -205,7 +205,11 @@ genEnumBitmap funcName def as = unlines
<> show (length as)
<> " then "
<> show (fromEnum def)
- <> " else lookupIntN bitmap# n"
+ <> " else lookup_bitmap n"
+
+ , "{-# NOINLINE lookup_bitmap #-}"
+ , "lookup_bitmap :: Int -> Int"
+ , "lookup_bitmap n = lookupIntN bitmap# n"
, " where"
, " bitmap# = \"" <> enumMapToAddrLiteral as "\"#"
]
=====================================
testsuite/tests/typecheck/should_compile/T21909.hs
=====================================
@@ -0,0 +1,24 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+
+module T21909 where
+
+import Data.Kind
+
+class (Monad m, MyMonad (Inner m)) => MyMonad m where
+ type Inner m :: Type -> Type
+ foo :: m Int
+
+works :: MyMonad m => m String
+works = show <$> ((+ 1) <$> foo)
+
+fails :: MyMonad m => m String
+fails = show <$> fooPlusOne
+ where
+ fooPlusOne = (+ 1) <$> foo
+
+alsoFails :: MyMonad m => m String
+alsoFails =
+ let fooPlusOne = (+ 1) <$> foo
+ in show <$> fooPlusOne
=====================================
testsuite/tests/typecheck/should_compile/T21909b.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableSuperClasses, FunctionalDependencies, MultiParamTypeClasses, GADTs #-}
+
+module T21909b where
+
+class C [a] => C a where
+ foo :: a -> Int
+
+bar :: C a => a -> Int
+bar x = foolocal x
+ where
+ foolocal a = foo a
=====================================
testsuite/tests/typecheck/should_compile/T22985a.hs
=====================================
@@ -0,0 +1,6 @@
+module T22985a where
+
+type Phase n = n
+
+addExpr :: Eq a => Phase a -> ()
+addExpr _ = ()
=====================================
testsuite/tests/typecheck/should_compile/T22985b.hs
=====================================
@@ -0,0 +1,6 @@
+module T22985b where
+
+type Phase n = n
+
+addExpr :: Num a => Phase a -> a
+addExpr x = let t = asTypeOf x 0 in t
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -860,5 +860,6 @@ test('T21501', normal, compile, [''])
test('T20666b', normal, compile, [''])
test('T22891', normal, compile, [''])
test('T22912', normal, compile, [''])
-test('T22924', normal, compile, [''])
-
+test('T21909', normal, compile, [''])
+test('T21909b', normal, compile, [''])
+test('T22924', normal, compile, ['']),
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4c01659f039b4942e7f8c6930526291ed3d54099...2f0b717cb28fd8632626fe849cd1f71a900ae20d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4c01659f039b4942e7f8c6930526291ed3d54099...2f0b717cb28fd8632626fe849cd1f71a900ae20d
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/20230217/50c6b925/attachment-0001.html>
More information about the ghc-commits
mailing list