Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
a00840ea by Simon Peyton Jones at 2025-11-14T15:23:56+00:00
Make TYPE and CONSTRAINT apart again
This patch finally fixes #24279.
* The story started with #11715
* Then #21623 articulated a plan, which made Type and Constraint
not-apart; a horrible hack but it worked. The main patch was
commit 778c6adca2c995cd8a1b84394d4d5ca26b915dac
Author: Simon Peyton Jones
Date: Wed Nov 9 10:33:22 2022 +0000
Type vs Constraint: finally nailed
* #24279 reported a bug in the above big commit; this small patch fixes it
commit af6932d6c068361c6ae300d52e72fbe13f8e1f18
Author: Simon Peyton Jones
Date: Mon Jan 8 10:49:49 2024 +0000
Make TYPE and CONSTRAINT not-apart
Issue #24279 showed up a bug in the logic in GHC.Core.Unify.unify_ty
which is supposed to make TYPE and CONSTRAINT be not-apart.
* Then !10479 implemented "unary classes".
* That change in turn allows us to make Type and Constraint apart again,
cleaning up the compiler and allowing a little bit more expressiveness.
It fixes the original hope in #24279, namely that `Type` and `Constraint`
should be distinct throughout.
- - - - -
b674971c by Georgios Karachalias at 2025-11-14T20:12:40-05:00
Report all missing modules with -M
We now report all missing modules at once in GHC.Driver.Makefile.processDeps,
as opposed to only reporting a single missing module. Fixes #26551.
- - - - -
23c9ebc9 by Sylvain Henry at 2025-11-14T20:13:08-05:00
JS: fix array index for registers
We used to store R32 in h$regs[-1]. While it's correct in JavaScript,
fix this to store R32 in h$regs[0] instead.
- - - - -
d43cc50d by Sylvain Henry at 2025-11-14T20:13:08-05:00
JS: support more than 128 registers (#26558)
The JS backend only supported 128 registers (JS variables/array slots
used to pass function arguments). It failed in T26537 when 129
registers were required.
This commit adds support for more than 128 registers: it is now limited to
maxBound :: Int (compiler's Int). If we ever go above this threshold the
compiler now panics with a more descriptive message.
A few built-in JS functions were assuming 128 registers and have been
rewritten to use loops. Note that loops are only used for "high"
registers that are stored in an array: the 31 "low" registers are still
handled with JS global variables and with explicit switch-cases to
maintain good performance in the most common cases (i.e. few registers
used). Adjusting the number of low registers is now easy: just one
constant to adjust (GHC.StgToJS.Regs.lowRegsCount).
No new test added: T26537 is used as a regression test instead.
- - - - -
25 changed files:
- compiler/GHC/Builtin/Types/Prim.hs
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/RoughMap.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/Driver/MakeFile.hs
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Regs.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- compiler/GHC/StgToJS/Rts/Types.hs
- compiler/GHC/Tc/Instance/Class.hs
- docs/users_guide/9.16.1-notes.rst
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/driver/Makefile
- + testsuite/tests/driver/T26551.hs
- + testsuite/tests/driver/T26551.stderr
- testsuite/tests/driver/all.T
- testsuite/tests/indexed-types/should_fail/T21092.hs
- − testsuite/tests/indexed-types/should_fail/T21092.stderr
- testsuite/tests/indexed-types/should_fail/all.T
- testsuite/tests/typecheck/should_fail/T24279.hs
- − testsuite/tests/typecheck/should_fail/T24279.stderr
- testsuite/tests/typecheck/should_fail/all.T
Changes:
=====================================
compiler/GHC/Builtin/Types/Prim.hs
=====================================
@@ -752,8 +752,9 @@ Specifically (a ~# b) :: CONSTRAINT (TupleRep [])
Wrinkles
-(W1) Type and Constraint are considered distinct throughout GHC. But they
- are not /apart/: see Note [Type and Constraint are not apart]
+(W1) Type and Constraint are considered distinct throughout GHC.
+ That wasn't always the case:
+ see Historical Note [Type and Constraint are not apart]
(W2) We need two absent-error Ids, aBSENT_ERROR_ID for types of kind Type, and
aBSENT_CONSTRAINT_ERROR_ID for types of kind Constraint.
@@ -768,8 +769,24 @@ Wrinkles
of type TYPE rr. See (CPR2) in Note [Which types are unboxed?] in
GHC.Core.Opt.WorkWrap.Utils.
-Note [Type and Constraint are not apart]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-------------------------------------------------------------
+Historical Note [Type and Constraint are not apart]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Nov 2025:
+ In the past, Type and Constraint were carefully coonsiderd to be
+ not /apart/. But the necessity for that vanished with unary classes
+ (see Note [Unary class magic]), done in
+
+ commit 9bd7fcc518111a1549c98720c222cdbabd32ed46
+ Author: Simon Peyton Jones
+ Date: Tue Apr 15 17:43:46 2025 +0100
+ Implement unary classes
+
+ So now Type and Constraint are simply distinct type constructors, just as
+ much as Int and Bool.
+
+ The rest of this Note is preserved for historical interest.
+
Type and Constraint are not equal (eqType) but they are not /apart/
either. Reason (c.f. #7451):
@@ -841,6 +858,9 @@ Wrinkles
So in GHC.Tc.Instance.Class.matchTypeable, Type and Constraint are
treated as separate TyCons; i.e. given no special treatment.
+End of Historical Note
+-------------------------------------------------------------
+
Note [RuntimeRep polymorphism]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Generally speaking, you can't be polymorphic in `RuntimeRep`. E.g
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -641,11 +641,6 @@ eqTyConRole tc
-- | Given a coercion `co :: (t1 :: TYPE r1) ~ (t2 :: TYPE r2)`
-- produce a coercion `rep_co :: r1 ~ r2`
--- But actually it is possible that
--- co :: (t1 :: CONSTRAINT r1) ~ (t2 :: CONSTRAINT r2)
--- or co :: (t1 :: TYPE r1) ~ (t2 :: CONSTRAINT r2)
--- or co :: (t1 :: CONSTRAINT r1) ~ (t2 :: TYPE r2)
--- See Note [mkRuntimeRepCo]
mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion
mkRuntimeRepCo co
= assert (isTYPEorCONSTRAINT k1 && isTYPEorCONSTRAINT k2) $
@@ -654,26 +649,6 @@ mkRuntimeRepCo co
kind_co = mkKindCo co -- kind_co :: TYPE r1 ~ TYPE r2
Pair k1 k2 = coercionKind kind_co
-{- Note [mkRuntimeRepCo]
-~~~~~~~~~~~~~~~~~~~~~~~~
-Given
- class C a where { op :: Maybe a }
-we will get an axiom
- axC a :: (C a :: CONSTRAINT r1) ~ (Maybe a :: TYPE r2)
-(See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim.)
-
-Then we may call mkRuntimeRepCo on (axC ty), and that will return
- mkSelCo (SelTyCon 0 Nominal) (Kind (axC ty)) :: r1 ~ r2
-
-So mkSelCo needs to be happy with decomposing a coercion of kind
- CONSTRAINT r1 ~ TYPE r2
-
-Hence the use of `tyConIsTYPEorCONSTRAINT` in the assertion `good_call`
-in `mkSelCo`. See #23018 for a concrete example. (In this context it's
-important that TYPE and CONSTRAINT have the same arity and kind, not
-merely that they are not-apart; otherwise SelCo would not make sense.)
--}
-
isReflCoVar_maybe :: Var -> Maybe Coercion
-- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t)
-- Works on all kinds of Vars, not just CoVars
@@ -1305,8 +1280,7 @@ mkSelCo_maybe cs co
, Just (tc2, tys2) <- splitTyConApp_maybe ty2
, let { len1 = length tys1
; len2 = length tys2 }
- = (tc1 == tc2 || (tyConIsTYPEorCONSTRAINT tc1 && tyConIsTYPEorCONSTRAINT tc2))
- -- tyConIsTYPEorCONSTRAINT: see Note [mkRuntimeRepCo]
+ = tc1 == tc2
&& len1 == len2
&& n < len1
&& r == tyConRole (coercionRole co) tc1 n
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -2891,13 +2891,9 @@ lint_branch ax_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
hang (text "Inhomogeneous axiom")
2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$
text "rhs:" <+> ppr rhs <+> dcolon <+> ppr rhs_kind) }
- -- Type and Constraint are not Apart, so this test allows
- -- the newtype axiom for a single-method class. Indeed the
- -- whole reason Type and Constraint are not Apart is to allow
- -- such axioms!
--- these checks do not apply to newtype axioms
lint_family_branch :: TyCon -> CoAxBranch -> LintM ()
+-- These checks do not apply to newtype axioms
lint_family_branch fam_tc br@(CoAxBranch { cab_tvs = tvs
, cab_eta_tvs = eta_tvs
, cab_cvs = cvs
=====================================
compiler/GHC/Core/RoughMap.hs
=====================================
@@ -36,7 +36,6 @@ import GHC.Core.Type
import GHC.Utils.Outputable
import GHC.Types.Name
import GHC.Types.Name.Env
-import GHC.Builtin.Types.Prim( cONSTRAINTTyConName, tYPETyConName )
import Control.Monad (join)
import Data.Data (Data)
@@ -347,16 +346,7 @@ typeToRoughMatchTc ty
roughMatchTyConName :: TyCon -> Name
roughMatchTyConName tc
- | tc_name == cONSTRAINTTyConName
- = tYPETyConName -- TYPE and CONSTRAINT are not apart, so they must use
- -- the same rough-map key. We arbitrarily use TYPE.
- -- See Note [Type and Constraint are not apart]
- -- wrinkle (W1) in GHC.Builtin.Types.Prim
- | otherwise
- = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc) tc_name
- where
- tc_name = tyConName tc
-
+ = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc) (tyConName tc)
-- | Trie of @[RoughMatchTc]@
--
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -1421,8 +1421,6 @@ piResultTy ty arg = case piResultTy_maybe ty arg of
Nothing -> pprPanic "piResultTy" (ppr ty $$ ppr arg)
piResultTy_maybe :: Type -> Type -> Maybe Type
--- We don't need a 'tc' version, because
--- this function behaves the same for Type and Constraint
piResultTy_maybe ty arg = case coreFullView ty of
FunTy { ft_res = res } -> Just res
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -27,7 +27,6 @@ import GHC.Prelude
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
-import GHC.Builtin.Names( tYPETyConKey, cONSTRAINTTyConKey )
import GHC.Core.Type hiding ( getTvSubstEnv )
import GHC.Core.Coercion hiding ( getCvSubstEnv )
import GHC.Core.Predicate( scopedSort )
@@ -98,8 +97,6 @@ of ways. Here we summarise, but see Note [Specification of unification].
See Note [Apartness and type families]
* MARInfinite (occurs check):
See Note [Infinitary substitutions]
- * MARTypeVsConstraint:
- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim
* MARCast (obscure):
See (KCU2) in Note [Kind coercions in Unify]
@@ -997,16 +994,12 @@ data UnifyResultM a = Unifiable a -- the subst that unifies the types
-- | Why are two types 'MaybeApart'? 'MARInfinite' takes precedence:
-- This is used (only) in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv
--- As of Feb 2022, we never differentiate between MARTypeFamily and MARTypeVsConstraint;
--- it's really only MARInfinite that's interesting here.
+-- It's really only MARInfinite that's interesting here.
data MaybeApartReason
= MARTypeFamily -- ^ matching e.g. F Int ~? Bool
| MARInfinite -- ^ matching e.g. a ~? Maybe a
- | MARTypeVsConstraint -- ^ matching Type ~? Constraint or the arrow types
- -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim
-
| MARCast -- ^ Very obscure.
-- See (KCU2) in Note [Kind coercions in Unify]
@@ -1015,13 +1008,11 @@ combineMAR :: MaybeApartReason -> MaybeApartReason -> MaybeApartReason
-- See (UR1) in Note [Unification result] for why MARInfinite wins
combineMAR MARInfinite _ = MARInfinite -- MARInfinite wins
combineMAR MARTypeFamily r = r -- Otherwise it doesn't really matter
-combineMAR MARTypeVsConstraint r = r
combineMAR MARCast r = r
instance Outputable MaybeApartReason where
ppr MARTypeFamily = text "MARTypeFamily"
ppr MARInfinite = text "MARInfinite"
- ppr MARTypeVsConstraint = text "MARTypeVsConstraint"
ppr MARCast = text "MARCast"
instance Semigroup MaybeApartReason where
@@ -1729,30 +1720,6 @@ unify_ty env ty1 ty2 kco
; unify_tc_app env tc1 tys1 tys2
}
- -- TYPE and CONSTRAINT are not Apart
- -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim
- -- NB: at this point we know that the two TyCons do not match
- | Just (tc1,_) <- mb_tc_app1, let u1 = tyConUnique tc1
- , Just (tc2,_) <- mb_tc_app2, let u2 = tyConUnique tc2
- , (u1 == tYPETyConKey && u2 == cONSTRAINTTyConKey) ||
- (u2 == tYPETyConKey && u1 == cONSTRAINTTyConKey)
- = maybeApart MARTypeVsConstraint
- -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim
- -- Note [Type and Constraint are not apart]
-
- -- The arrow types are not Apart
- -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim
- -- wrinkle (W2)
- -- NB1: at this point we know that the two TyCons do not match
- -- NB2: In the common FunTy/FunTy case you might wonder if we want to go via
- -- splitTyConApp_maybe. But yes we do: we need to look at those implied
- -- kind argument in order to satisfy (Unification Kind Invariant)
- | FunTy {} <- ty1
- , FunTy {} <- ty2
- = maybeApart MARTypeVsConstraint
- -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim
- -- Note [Type and Constraint are not apart]
-
where
mb_tc_app1 = splitTyConApp_maybe ty1
mb_tc_app2 = splitTyConApp_maybe ty2
=====================================
compiler/GHC/Driver/MakeFile.hs
=====================================
@@ -55,6 +55,7 @@ import Data.IORef
import qualified Data.Set as Set
import GHC.Iface.Errors.Types
import Data.Either
+import GHC.Data.Bag (listToBag)
-----------------------------------------------------------------
--
@@ -237,19 +238,6 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ (ModuleN
obj_file = msObjFilePath node
obj_files = insertSuffixes obj_file extra_suffixes
- do_imp loc is_boot pkg_qual imp_mod
- = do { mb_hi <- findDependency hsc_env loc pkg_qual imp_mod
- is_boot include_pkg_deps
- ; case mb_hi of {
- Nothing -> return () ;
- Just hi_file -> do
- { let hi_files = insertSuffixes hi_file extra_suffixes
- write_dep (obj,hi) = writeDependency root hdl [obj] hi
-
- -- Add one dependency for each suffix;
- -- e.g. A.o : B.hi
- -- A.x_o : B.x_hi
- ; mapM_ write_dep (obj_files `zip` hi_files) }}}
-- Emit std dependency of the object(s) on the source file
@@ -280,15 +268,33 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ (ModuleN
-- Emit a dependency for each import
- ; let do_imps is_boot idecls = sequence_
- [ do_imp loc is_boot mb_pkg mod
+ ; let find_dep loc is_boot pkg_qual imp_mod = findDependency hsc_env loc pkg_qual imp_mod is_boot include_pkg_deps
+
+ find_deps is_boot idecls = sequence
+ [ find_dep loc is_boot mb_pkg mod
| (_lvl, mb_pkg, L loc mod) <- idecls,
mod `notElem` excl_mods ]
- ; do_imps IsBoot (map ((,,) NormalLevel NoPkgQual) (ms_srcimps node))
- ; do_imps NotBoot (ms_imps node)
- }
+ do_imp hi_file = do
+ let hi_files = insertSuffixes hi_file extra_suffixes
+ write_dep (obj,hi) = writeDependency root hdl [obj] hi
+
+ -- Add one dependency for each suffix;
+ -- e.g. A.o : B.hi
+ -- A.x_o : B.x_hi
+ mapM_ write_dep (obj_files `zip` hi_files)
+ ; (missing_boot_dep_errs, boot_deps) <- partitionEithers <$> find_deps IsBoot (map ((,,) NormalLevel NoPkgQual) (ms_srcimps node))
+ ; (missing_not_boot_dep_errs, not_boot_deps) <- partitionEithers <$> find_deps NotBoot (ms_imps node)
+
+ ; let all_missing_errors = missing_boot_dep_errs ++ missing_not_boot_dep_errs
+
+ ; if null all_missing_errors
+ then mapM_ (mapM_ do_imp) (boot_deps ++ not_boot_deps)
+ else do
+ let sec = initSourceErrorContext (hsc_dflags hsc_env)
+ throwErrors sec (mkMessages (listToBag all_missing_errors))
+ }
findDependency :: HscEnv
-> SrcSpan
@@ -296,7 +302,7 @@ findDependency :: HscEnv
-> ModuleName -- Imported module
-> IsBootInterface -- Source import
-> Bool -- Record dependency on package modules
- -> IO (Maybe FilePath) -- Interface file
+ -> IO (Either (MsgEnvelope GhcMessage) (Maybe FilePath)) -- Interface file
findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
-- Find the module; this will be fast because
-- we've done it once during downsweep
@@ -305,16 +311,15 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
Found loc _
-- Home package: just depend on the .hi or hi-boot file
| isJust (ml_hs_file loc) || include_pkg_deps
- -> return (Just (ml_hi_file loc))
+ -> return (Right (Just (ml_hi_file loc)))
-- Not in this package: we don't need a dependency
| otherwise
- -> return Nothing
+ -> return (Right Nothing)
fail ->
- let sec = initSourceErrorContext (hsc_dflags hsc_env)
- in
- throwOneError sec $
+ return $
+ Left $
mkPlainErrorMsgEnvelope srcloc $
GhcDriverMessage $ DriverInterfaceError $
(Can'tFindInterface (cannotFindModule hsc_env imp fail) (LookingForModule imp is_boot))
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -185,7 +185,7 @@ genApp ctx i args
as' <- concatMapM genArg args
ei <- varForEntryId i
let ra = mconcat . reverse $
- zipWith (\r a -> toJExpr r |= a) [R1 ..] as'
+ zipWith (\r a -> toJExpr r |= a) regsFromR1 as'
p <- pushLneFrame n ctx
a <- adjSp 1 -- for the header (which will only be written when the thread is suspended)
return (ra <> p <> a <> returnS ei, ExprCont)
@@ -464,42 +464,31 @@ specTag spec = Bits.shiftL (specVars spec) 8 Bits..|. specArgs spec
specTagExpr :: ApplySpec -> JStgExpr
specTagExpr = toJExpr . specTag
--- | Build arrays to quickly lookup apply functions
+-- | Build functions to quickly lookup apply functions
--
--- h$apply[r << 8 | n] = function application for r regs, n args
--- h$paps[r] = partial application for r registers (number of args is in the object)
+-- h$apply(r << 8 | n) = function application for r regs, n args
+-- h$paps(r) = partial application for r registers (number of args is in the object)
mkApplyArr :: JSM JStgStat
mkApplyArr =
- do mk_ap_gens <- jFor (|= zero_) (.<. Int 65536) preIncrS
- \j -> hdApply .! j |= hdApGen
- mk_pap_gens <- jFor (|= zero_) (.<. Int 128) preIncrS
- \j -> hdPaps .! j |= hdPapGen
+ do paps_fun <- jFunction (name hdPapsStr) \(MkSolo i) -> pure $ SwitchStat i (map case_pap specPap) (returnS hdPapGen)
+ apply_fun <- jFunction (name hdApplyStr) \(MkSolo i) -> pure $ SwitchStat i (mapMaybe' case_apply applySpec) (returnS hdApGen)
return $ mconcat
- [ name hdApplyStr ||= toJExpr (JList [])
- , name hdPapsStr ||= toJExpr (JList [])
- , ApplStat (hdInitStatic .^ "push")
- [ jLam' $
- mconcat
- [ mk_ap_gens
- , mk_pap_gens
- , mconcat (map assignSpec applySpec)
- , mconcat (map assignPap specPap)
- ]
- ]
+ [ paps_fun
+ , apply_fun
]
where
- assignSpec :: ApplySpec -> JStgStat
- assignSpec spec = case specConv spec of
+ case_apply :: ApplySpec -> Maybe (JStgExpr,JStgStat)
+ case_apply spec = case specConv spec of
-- both fast/slow (regs/stack) specialized apply functions have the same
-- tags. We store the stack ones in the array because they are used as
-- continuation stack frames.
- StackConv -> hdApply .! specTagExpr spec |= specApplyExpr spec
- RegsConv -> mempty
+ StackConv -> Just (specTagExpr spec, returnS (specApplyExpr spec))
+ RegsConv -> Nothing
hdPap_ = unpackFS hdPapStr_
- assignPap :: Int -> JStgStat
- assignPap p = hdPaps .! toJExpr p |= global (mkFastString (hdPap_ ++ show p))
+ case_pap :: Int -> (JStgExpr, JStgStat)
+ case_pap p = (toJExpr p, returnS $ global (mkFastString (hdPap_ ++ show p)))
-- | Push a continuation on the stack
--
@@ -619,7 +608,7 @@ genericStackApply cfg = closure info body
-- compute new tag with consumed register values and args removed
, newTag |= ((given_regs-needed_regs).<<.8) .|. (given_args - needed_args)
-- find application function for the remaining regs/args
- , newAp |= hdApply .! newTag
+ , newAp |= ApplExpr hdApply [newTag]
, traceRts cfg (jString "h$ap_gen: next: " + (newAp .^ "n"))
-- Drop used registers from the stack.
@@ -643,7 +632,7 @@ genericStackApply cfg = closure info body
-----------------------------
[ traceRts cfg (jString "h$ap_gen: undersat")
-- find PAP entry function corresponding to given_regs count
- , p |= hdPaps .! given_regs
+ , p |= ApplExpr hdPaps [given_regs]
-- build PAP payload: R1 + tag + given register values
, newTag |= ((needed_regs-given_regs) .<<. 8) .|. (needed_args-given_args)
@@ -716,7 +705,7 @@ genericFastApply s =
do push_all_regs <- pushAllRegs tag
return $ mconcat $
[ push_all_regs
- , ap |= hdApply .! tag
+ , ap |= ApplExpr hdApply [tag]
, ifS (ap .===. hdApGen)
((sp |= sp + 2) <> (stack .! (sp-1) |= tag))
(sp |= sp + 1)
@@ -750,7 +739,7 @@ genericFastApply s =
, traceRts s (jString "h$ap_gen_fast: oversat " + sp)
, push_args
, newTag |= ((myRegs-( arity.>>.8)).<<.8).|.myAr-ar
- , newAp |= hdApply .! newTag
+ , newAp |= ApplExpr hdApply [newTag]
, ifS (newAp .===. hdApGen)
((sp |= sp + 2) <> (stack .! (sp - 1) |= newTag))
(sp |= sp + 1)
@@ -761,7 +750,7 @@ genericFastApply s =
-- else
[traceRts s (jString "h$ap_gen_fast: undersat: " + myRegs + jString " " + tag)
, jwhenS (tag .!=. 0) $ mconcat
- [ p |= hdPaps .! myRegs
+ [ p |= ApplExpr hdPaps [myRegs]
, dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr]
, get_regs
, r1 |= initClosure s p dat jCurrentCCS
@@ -773,14 +762,24 @@ genericFastApply s =
pushAllRegs :: JStgExpr -> JSM JStgStat
pushAllRegs tag =
jVar \regs ->
- return $ mconcat $
- [ regs |= tag .>>. 8
- , sp |= sp + regs
- , SwitchStat regs (map pushReg [65,64..2]) mempty
- ]
- where
- pushReg :: Int -> (JStgExpr, JStgStat)
- pushReg r = (toJExpr (r-1), stack .! (sp - toJExpr (r - 2)) |= jsReg r)
+ let max_low_reg = regNumber maxLowReg
+ low_regs = [max_low_reg, max_low_reg-1..2] -- R1 isn't used for arguments
+ pushReg :: Int -> (JStgExpr, JStgStat)
+ pushReg r = (toJExpr r, stack .! (sp - toJExpr (r - 2)) |= jsReg r)
+ in return $ mconcat $
+ [ regs |= tag .>>. 8
+ , sp |= sp + regs
+ -- increment the number of regs by 1, so that it matches register
+ -- numbers (R1 is not used for args)
+ , postIncrS regs
+ -- copy high registers with a loop
+ , WhileStat False (regs .>. toJExpr max_low_reg) $ mconcat
+ -- rN stored in stack[sp - N - 2] so that r2 is stored in stack[sp], etc.
+ [ stack .! (sp - regs - 2) |= highReg_expr regs
+ , postDecrS regs
+ ]
+ , SwitchStat regs (map pushReg low_regs) mempty
+ ]
pushArgs :: JStgExpr -> JStgExpr -> JSM JStgStat
pushArgs start end =
@@ -906,7 +905,7 @@ stackApply s fun_name nargs nvars =
[ rs |= (arity .>>. 8)
, loadRegs rs
, sp |= sp - rs
- , newAp |= (hdApply .! ((toJExpr nargs-arity0).|.((toJExpr nvars-rs).<<.8)))
+ , newAp |= ApplExpr hdApply [(toJExpr nargs-arity0).|.((toJExpr nvars-rs).<<.8)]
, stack .! sp |= newAp
, profStat s pushRestoreCCS
, traceRts s (toJExpr (fun_name <> ": new stack frame: ") + (newAp .^ "n"))
@@ -989,7 +988,7 @@ fastApply s fun_name nargs nvars = if nargs == 0 && nvars == 0
+ rsRemain)
, saveRegs rs
, sp |= sp + rsRemain + 1
- , stack .! sp |= hdApply .! ((rsRemain.<<.8).|. (toJExpr nargs - mask8 arity))
+ , stack .! sp |= ApplExpr hdApply [(rsRemain.<<.8).|. (toJExpr nargs - mask8 arity)]
, profStat s pushRestoreCCS
, returnS c
]
@@ -1238,14 +1237,30 @@ pap s r = closure (ClosureInfo
, profStat s (enterCostCentreFun currentCCS)
, extra |= (funOrPapArity c (Just f) .>>. 8) - toJExpr r
, traceRts s (toJExpr (funcName <> ": pap extra args moving: ") + extra)
- , moveBy extra
+ , case r of
+ 0 -> mempty -- in pap_0 we don't shift any register
+ _ -> moveBy extra
, loadOwnArgs d
, r1 |= c
, returnS f
]
- moveBy extra = SwitchStat extra
- (reverse $ map moveCase [1..maxReg-r-1]) mempty
- moveCase m = (toJExpr m, jsReg (m+r+1) |= jsReg (m+1))
+ moveBy extra =
+ let max_low_reg = regNumber maxLowReg
+ low_regs = [max_low_reg, max_low_reg-1..2] -- R1 isn't used for arguments
+ move_case m = (toJExpr m, jsReg (m+r) |= jsReg m)
+ in mconcat
+ [ -- increment the number of args by 1, so that it matches register
+ -- numbers (R1 is not used for args)
+ postIncrS extra
+ -- copy high registers with a loop
+ , WhileStat False (extra .>. toJExpr max_low_reg) $ mconcat
+ [ highReg_expr (extra + toJExpr r) |= highReg_expr extra
+ , postDecrS extra
+ ]
+ -- then copy low registers with a case
+ , SwitchStat extra (map move_case low_regs) mempty
+ ]
+
loadOwnArgs d = mconcat $ map (\r ->
jsReg (r+1) |= dField d (r+2)) [1..r]
dField d n = SelExpr d (name . mkFastString $ ('d':show (n-1)))
@@ -1274,7 +1289,9 @@ papGen cfg =
(jString "h$pap_gen: expected function or pap")
, profStat cfg (enterCostCentreFun currentCCS)
, traceRts cfg (jString "h$pap_gen: generic pap extra args moving: " + or)
+ -- shift newly applied arguments into appropriate registers
, appS hdMoveRegs2 [or, r]
+ -- load stored arguments into lowest argument registers (i.e. starting from R2)
, loadOwnArgs d r
, r1 |= c
, returnS f
@@ -1285,9 +1302,22 @@ papGen cfg =
funcIdent = name funcName
funcName = hdPapGenStr
loadOwnArgs d r =
- let prop n = d .^ ("d" <> mkFastString (show $ n+1))
- loadOwnArg n = (toJExpr n, jsReg (n+1) |= prop n)
- in SwitchStat r (map loadOwnArg [127,126..1]) mempty
+ let prop n = d .^ (mkFastString ("d" ++ show n))
+ loadOwnArg n = (toJExpr n, jsReg n |= prop n)
+ max_low_reg = regNumber maxLowReg
+ low_regs = [max_low_reg, max_low_reg-1..2] -- R1 isn't used for arguments
+ in mconcat
+ [ -- increment the number of args by 1, so that it matches register
+ -- numbers (R1 is not used for args) and PAP fields (starting from d2)
+ postIncrS r
+ -- copy high registers with a loop
+ , WhileStat False (r .>. toJExpr max_low_reg) $ mconcat
+ [ highReg_expr r |= (d .! (jString (fsLit "d") + r))
+ , postDecrS r
+ ]
+ -- then copy low registers with a case.
+ , SwitchStat r (map loadOwnArg low_regs) mempty
+ ]
-- general utilities
-- move the first n registers, starting at R2, m places up (do not use with negative m)
@@ -1301,7 +1331,7 @@ moveRegs2 = jFunction (name hdMoveRegs2) moveSwitch
switchCase n m = (toJExpr $
(n `Bits.shiftL` 8) Bits..|. m
, mconcat (map (`moveRegFast` m) [n+1,n..2])
- <> BreakStat Nothing {-[j| break; |]-})
+ <> BreakStat Nothing)
moveRegFast n m = jsReg (n+m) |= jsReg n
-- fallback
defaultCase n m =
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -312,7 +312,7 @@ genBody ctx startReg args e typ = do
-- load arguments into local variables
la <- do
args' <- concatMapM genIdArgI args
- return (declAssignAll args' (fmap toJExpr [startReg..]))
+ return (declAssignAll args' (jsRegsFrom startReg))
-- assert that arguments have valid runtime reps
lav <- verifyRuntimeReps args
@@ -665,7 +665,7 @@ genCase ctx bnd e at alts l
| otherwise = do
rj <- genRet ctx bnd at alts l
let ctx' = ctxSetTop bnd
- $ ctxSetTarget (assocIdExprs bnd (map toJExpr [R1 ..]))
+ $ ctxSetTarget (assocIdExprs bnd jsRegsFromR1)
$ ctx
(ej, _r) <- genExpr ctx' e
return (rj <> ej, ExprCont)
@@ -730,7 +730,7 @@ genRet ctx e at as l = freshIdent >>= f
fun free = resetSlots $ do
decs <- declVarsForId e
- load <- flip assignAll (map toJExpr [R1 ..]) . map toJExpr <$> identsForId e
+ load <- flip assignAll jsRegsFromR1 . map toJExpr <$> identsForId e
loadv <- verifyRuntimeReps [e]
ras <- loadRetArgs free
rasv <- verifyRuntimeReps (map (\(x,_,_)->x) free)
=====================================
compiler/GHC/StgToJS/Regs.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
module GHC.StgToJS.Regs
( StgReg (..)
@@ -6,17 +7,25 @@ module GHC.StgToJS.Regs
, sp
, stack
, r1, r2, r3, r4
+ , pattern R1, pattern R2, pattern R3, pattern R4
, regsFromR1
, regsFromR2
+ , regsFromTo
+ , jsRegsFrom
, jsRegsFromR1
, jsRegsFromR2
, StgRet (..)
- , jsRegToInt
- , intToJSReg
+ , regNumber
, jsReg
+ , highReg
+ , highReg_expr
, maxReg
+ , maxLowReg
, minReg
+ , minHighReg
, lowRegs
+ , lowRegsCount
+ , lowRegsIdents
, retRegs
, register
, foreignRegister
@@ -32,6 +41,7 @@ import GHC.JS.Make
import GHC.StgToJS.Symbols
import GHC.Data.FastString
+import GHC.Utils.Panic.Plain
import Data.Array
import qualified Data.ByteString.Char8 as BSC
@@ -39,26 +49,15 @@ import Data.Char
import Data.Semigroup ((<>))
-- | General purpose "registers"
---
--- The JS backend arbitrarily supports 128 registers
-data StgReg
- = R1 | R2 | R3 | R4 | R5 | R6 | R7 | R8
- | R9 | R10 | R11 | R12 | R13 | R14 | R15 | R16
- | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24
- | R25 | R26 | R27 | R28 | R29 | R30 | R31 | R32
- | R33 | R34 | R35 | R36 | R37 | R38 | R39 | R40
- | R41 | R42 | R43 | R44 | R45 | R46 | R47 | R48
- | R49 | R50 | R51 | R52 | R53 | R54 | R55 | R56
- | R57 | R58 | R59 | R60 | R61 | R62 | R63 | R64
- | R65 | R66 | R67 | R68 | R69 | R70 | R71 | R72
- | R73 | R74 | R75 | R76 | R77 | R78 | R79 | R80
- | R81 | R82 | R83 | R84 | R85 | R86 | R87 | R88
- | R89 | R90 | R91 | R92 | R93 | R94 | R95 | R96
- | R97 | R98 | R99 | R100 | R101 | R102 | R103 | R104
- | R105 | R106 | R107 | R108 | R109 | R110 | R111 | R112
- | R113 | R114 | R115 | R116 | R117 | R118 | R119 | R120
- | R121 | R122 | R123 | R124 | R125 | R126 | R127 | R128
- deriving (Eq, Ord, Show, Enum, Bounded, Ix)
+newtype StgReg
+ = StgReg Int
+ deriving (Eq,Ord,Ix)
+
+pattern R1, R2, R3, R4 :: StgReg
+pattern R1 = StgReg 0
+pattern R2 = StgReg 1
+pattern R3 = StgReg 2
+pattern R4 = StgReg 3
-- | Stack registers
data Special
@@ -78,7 +77,7 @@ instance ToJExpr Special where
toJExpr Sp = hdStackPtr
instance ToJExpr StgReg where
- toJExpr r = registers ! r
+ toJExpr r = register r
instance ToJExpr StgRet where
toJExpr r = rets ! r
@@ -99,25 +98,42 @@ r2 = toJExpr R2
r3 = toJExpr R3
r4 = toJExpr R4
+-- | 1-indexed register number (R1 has index 1)
+regNumber :: StgReg -> Int
+regNumber (StgReg r) = r+1
-jsRegToInt :: StgReg -> Int
-jsRegToInt = (+1) . fromEnum
+-- | StgReg from 1-indexed number
+regFromNumber :: Int -> StgReg
+regFromNumber r = assert (r >= 1) $ StgReg (r-1)
-intToJSReg :: Int -> StgReg
-intToJSReg r = toEnum (r - 1)
+regsFromTo :: StgReg -> StgReg -> [StgReg]
+regsFromTo (StgReg x) (StgReg y) = map StgReg [x .. y]
+-- | Register expression from its 1-indexed index
jsReg :: Int -> JStgExpr
-jsReg r = toJExpr (intToJSReg r)
+jsReg r = toJExpr (regFromNumber r)
+
+minReg :: StgReg
+minReg = R1
-maxReg :: Int
-maxReg = jsRegToInt maxBound
+maxReg :: StgReg
+maxReg = regFromNumber maxBound
-minReg :: Int
-minReg = jsRegToInt minBound
+lowRegsCount :: Int
+lowRegsCount = 31
+
+maxLowReg :: StgReg
+maxLowReg = regFromNumber lowRegsCount
+
+-- | First register stored in h$regs array instead of having its own top-level
+-- variable
+minHighReg :: StgReg
+minHighReg = case maxLowReg of
+ StgReg r -> StgReg (r+1)
-- | List of registers, starting from R1
regsFromR1 :: [StgReg]
-regsFromR1 = enumFrom R1
+regsFromR1 = regsFromTo R1 maxReg ++ repeat (panic "StgToJS: code requires too many registers")
-- | List of registers, starting from R2
regsFromR2 :: [StgReg]
@@ -131,35 +147,59 @@ jsRegsFromR1 = fmap toJExpr regsFromR1
jsRegsFromR2 :: [JStgExpr]
jsRegsFromR2 = tail jsRegsFromR1
+-- | List of registers, starting from given reg as JExpr
+jsRegsFrom :: StgReg -> [JStgExpr]
+jsRegsFrom (StgReg n) = drop n jsRegsFromR1
+
+-- | High register
+highReg :: Int -> JStgExpr
+highReg r = assert (r >= regNumber minHighReg) $ IdxExpr hdRegs (toJExpr (r - regNumber minHighReg))
+
+-- | High register indexing with a JS expression
+highReg_expr :: JStgExpr -> JStgExpr
+highReg_expr r = IdxExpr hdRegs (r - toJExpr (regNumber minHighReg))
+
+
---------------------------------------------------
-- caches
---------------------------------------------------
-lowRegs :: [Ident]
-lowRegs = map reg_to_ident [R1 .. R31]
- where reg_to_ident = name . mkFastString . (unpackFS hdStr ++) . map toLower . show
+lowRegs :: [StgReg]
+lowRegs = regsFromTo minReg maxLowReg
+
+lowRegsIdents :: [Ident]
+lowRegsIdents = map reg_to_ident lowRegs
+ where
+ -- low regs are named h$r1, h$r2, etc.
+ reg_to_ident r = name (mkFastString (unpackFS hdStr ++ "r" ++ show (regNumber r)))
retRegs :: [Ident]
retRegs = [name . mkFastStringByteString
$ hdB <> BSC.pack (map toLower $ show n) | n <- enumFrom Ret1]
--- cache JExpr representing StgReg
-registers :: Array StgReg JStgExpr
-registers = listArray (minBound, maxBound) (map (global . identFS) lowRegs ++ map regN [R32 .. R128])
- where
- regN :: StgReg -> JStgExpr
- regN r = IdxExpr hdRegs (toJExpr (fromEnum r - 32))
-
-- cache JExpr representing StgRet
rets :: Array StgRet JStgExpr
rets = listArray (minBound, maxBound) (map retN (enumFrom Ret1))
where
retN = global . mkFastString . (unpackFS hdStr ++) . map toLower . show
--- | Given a register, return the JS syntax object representing that register
-register :: StgReg -> JStgExpr
-register i = registers ! i
-
-- | Given a register, return the JS syntax object representing that register
foreignRegister :: StgRet -> JStgExpr
foreignRegister i = rets ! i
+
+-- | Given a register, return the JS syntax object representing that register
+register :: StgReg -> JStgExpr
+register i
+ | i <= maxCachedReg = register_cache ! i -- Expressions of common registers are cached.
+ | otherwise = make_high_reg i -- Expression of higher registers are made on the fly
+
+maxCachedReg :: StgReg
+maxCachedReg = regFromNumber 128
+
+-- cache JExpr representing StgReg
+register_cache :: Array StgReg JStgExpr
+register_cache = listArray (minReg, maxCachedReg) (map (global . identFS) lowRegsIdents ++ map make_high_reg (regsFromTo minHighReg maxCachedReg))
+
+-- | Make h$regs[XXX] expression for the register
+make_high_reg :: StgReg -> JStgExpr
+make_high_reg r = highReg (regNumber r)
=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -54,7 +54,12 @@ import qualified Data.Bits as Bits
-- | The garbageCollector resets registers and result variables.
garbageCollector :: JSM JStgStat
garbageCollector = jBlock
- [ jFunction' hdResetRegisters (return $ mconcat $ map resetRegister [minBound..maxBound])
+ [ jFunction' hdResetRegisters $ return $ mconcat
+ [ -- reset low registers explicitly
+ mconcat (map resetRegister lowRegs)
+ -- reset the whole h$regs array with h$regs.fill(null)
+ , toStat $ ApplExpr (hdRegs .^ "fill") [null_]
+ ]
, jFunction' hdResetResultVars (return $ mconcat $ map resetResultVar [minBound..maxBound])
]
@@ -249,7 +254,7 @@ declRegs = do
loaders <- loadRegs
return $
mconcat [ hdRegsStr ||= toJExpr (JList [])
- , mconcat (map declReg lowRegs)
+ , mconcat (map declReg lowRegsIdents)
, getters_setters
, loaders
]
@@ -259,15 +264,15 @@ declRegs = do
-- | JS payload to define getters and setters on the registers.
regGettersSetters :: JSM JStgStat
regGettersSetters =
- do setters <- jFunction (name hdGetRegStr) (\(MkSolo n) -> return $ SwitchStat n getRegCases mempty)
- getters <- jFunction (name hdSetRegStr) (\(n,v) -> return $ SwitchStat n (setRegCases v) mempty)
+ do getters <- jFunction (name hdGetRegStr) (\(MkSolo n) -> return $ SwitchStat n getRegCases (defaultGetRegCase n))
+ setters <- jFunction (name hdSetRegStr) (\(n,v) -> return $ SwitchStat n (setRegCases v) (defaultSetRegCase n v))
return $ setters <> getters
where
- getRegCases =
- map (\r -> (toJExpr (jsRegToInt r) , returnS (toJExpr r))) regsFromR1
- setRegCases :: JStgExpr -> [(JStgExpr,JStgStat)]
- setRegCases v =
- map (\r -> (toJExpr (jsRegToInt r), (toJExpr r |= toJExpr v) <> returnS undefined_)) regsFromR1
+ getRegCases = map (\r -> (toJExpr (regNumber r) , returnS (toJExpr r))) lowRegs
+ defaultGetRegCase n = returnS (highReg_expr n)
+
+ setRegCases v = map (\r -> (toJExpr (regNumber r), (toJExpr r |= v) <> BreakStat Nothing)) lowRegs
+ defaultSetRegCase n v = highReg_expr n |= v
-- | JS payload that defines the functions to load each register
loadRegs :: JSM JStgStat
=====================================
compiler/GHC/StgToJS/Rts/Types.hs
=====================================
@@ -69,12 +69,3 @@ stackFrameSize tgt f =
(tgt |= mask8 tag + 1) -- else set to mask'd tag + 1
]
))
-
- --------------------------------------------------------------------------------
--- Register utilities
---------------------------------------------------------------------------------
-
--- | Perform the computation 'f', on the range of registers bounded by 'start'
--- and 'end'.
-withRegs :: StgReg -> StgReg -> (StgReg -> JStgStat) -> JStgStat
-withRegs start end f = mconcat $ fmap f [start..end]
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -963,11 +963,6 @@ matchTypeable clas [k,t] -- clas = Typeable
| k `eqType` naturalTy = doTyLit knownNatClassName t
| k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t
| k `eqType` charTy = doTyLit knownCharClassName t
-
- -- TyCon applied to its kind args
- -- No special treatment of Type and Constraint; they get distinct TypeReps
- -- see wrinkle (W4) of Note [Type and Constraint are not apart]
- -- in GHC.Builtin.Types.Prim.
| Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)]
, onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks
=====================================
docs/users_guide/9.16.1-notes.rst
=====================================
@@ -16,6 +16,17 @@ Language
result, you may need to enable :extension:`DataKinds` in code that did not
previously require it.
+- ``Type`` and ``Constraint`` are now (at last) completely distinct types, just as much
+ as ``Int`` and ``Bool``. For example, you can now
+ write::
+
+ type family F a
+
+ type instance F Type = Int
+ type instance F Constraint = Bool
+
+ which was previously rejected with "Conflicting family instance declarations".
+
Compiler
~~~~~~~~
=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -256,4 +256,4 @@ test('T24893', normal, compile_and_run, ['-O'])
test('CCallConv', [req_c], compile_and_run, ['CCallConv_c.c'])
test('T25364', normal, compile_and_run, [''])
test('T26061', normal, compile_and_run, [''])
-test('T26537', js_broken(26558), compile_and_run, ['-O2 -fregs-graph'])
+test('T26537', normal, compile_and_run, ['-O2 -fregs-graph'])
=====================================
testsuite/tests/driver/Makefile
=====================================
@@ -415,6 +415,10 @@ test200:
"$(TEST_HC)" $(TEST_HC_OPTS) -M -dep-suffix "" -dep-makefile $(DEPFILE200) D200.hs B200/C.hs A200.hs
test -f $(DEPFILE200)
+# Test that we produce "could not find module" errors for _all_ missing imports.
+T26551:
+ "$(TEST_HC)" $(TEST_HC_OPTS) -M T26551.hs || true
+
# -----------------------------------------------------------------------------
T2566::
=====================================
testsuite/tests/driver/T26551.hs
=====================================
@@ -0,0 +1,5 @@
+module Main where
+
+import Foo
+import Bar
+import Baz
=====================================
testsuite/tests/driver/T26551.stderr
=====================================
@@ -0,0 +1,11 @@
+T26551.hs:3:8: [GHC-87110]
+ Could not find module ‘Foo’.
+ Use -v to see a list of the files searched for.
+
+T26551.hs:4:8: [GHC-87110]
+ Could not find module ‘Bar’.
+ Use -v to see a list of the files searched for.
+
+T26551.hs:5:8: [GHC-87110]
+ Could not find module ‘Baz’.
+ Use -v to see a list of the files searched for.
=====================================
testsuite/tests/driver/all.T
=====================================
@@ -332,3 +332,4 @@ test('t25150', [extra_files(["t25150"])], multimod_compile, ['Main.hs', '-v0 -wo
test('T25382', normal, makefile_test, [])
test('T26018', req_c, makefile_test, [])
test('T24120', normal, compile, ['-Wunused-packages -hide-all-packages -package base -package system-cxx-std-lib'])
+test('T26551', [extra_files(['T26551.hs'])], makefile_test, [])
=====================================
testsuite/tests/indexed-types/should_fail/T21092.hs
=====================================
@@ -7,3 +7,5 @@ type family F a
type instance F Type = Int
type instance F Constraint = Bool
+
+-- Nov 2025: Type and Constraint are now Apart (#24279)
=====================================
testsuite/tests/indexed-types/should_fail/T21092.stderr deleted
=====================================
@@ -1,5 +0,0 @@
-
-T21092.hs:8:15: error: [GHC-34447]
- Conflicting family instance declarations:
- F (*) = Int -- Defined at T21092.hs:8:15
- F Constraint = Bool -- Defined at T21092.hs:9:15
=====================================
testsuite/tests/indexed-types/should_fail/all.T
=====================================
@@ -107,7 +107,7 @@ test('T8368', normal, compile_fail, [''])
test('T8368a', normal, compile_fail, [''])
test('T8518', normal, compile_fail, [''])
test('T9036', normal, compile_fail, [''])
-test('T21092', normal, compile_fail, [''])
+test('T21092', normal, compile, ['']) # Now compiles fine
test('T9167', normal, compile_fail, [''])
test('T9171', normal, compile_fail, [''])
test('T9097', normal, compile_fail, [''])
=====================================
testsuite/tests/typecheck/should_fail/T24279.hs
=====================================
@@ -13,7 +13,7 @@ type G :: Type -> RuntimeRep -> Type
type family G a where
G (a b) = a
--- Should be rejected
+-- Now (Nov 2025) accepted
foo :: (F (G Constraint)) -> Bool
foo x = x
@@ -22,10 +22,10 @@ type family H a b where
H a a = Int
H a b = Bool
--- Should be rejected
-bar1 :: H TYPE CONSTRAINT -> Int
+-- Now (Nov 2025) accepted
+bar1 :: H TYPE CONSTRAINT -> Bool
bar1 x = x
--- Should be rejected
-bar2 :: H Type Constraint -> Int
+-- Now (Nov 2025) accepted
+bar2 :: H Type Constraint -> Bool
bar2 x = x
=====================================
testsuite/tests/typecheck/should_fail/T24279.stderr deleted
=====================================
@@ -1,19 +0,0 @@
-
-T24279.hs:18:9: error: [GHC-83865]
- • Couldn't match type ‘F CONSTRAINT’ with ‘Bool’
- Expected: Bool
- Actual: F (G Constraint)
- • In the expression: x
- In an equation for ‘foo’: foo x = x
-
-T24279.hs:27:10: error: [GHC-83865]
- • Couldn't match expected type ‘Int’
- with actual type ‘H TYPE CONSTRAINT’
- • In the expression: x
- In an equation for ‘bar1’: bar1 x = x
-
-T24279.hs:31:10: error: [GHC-83865]
- • Couldn't match expected type ‘Int’
- with actual type ‘H (*) Constraint’
- • In the expression: x
- In an equation for ‘bar2’: bar2 x = x
=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -718,7 +718,7 @@ test('T24064', normal, compile_fail, [''])
test('T24090a', normal, compile_fail, [''])
test('T24090b', normal, compile, ['']) # scheduled to become an actual error in GHC 9.16
test('T24298', normal, compile_fail, [''])
-test('T24279', normal, compile_fail, [''])
+test('T24279', normal, compile, ['']) # Now accepted (Nov 2025)
test('T24318', normal, compile_fail, [''])
# all the various do expansion fail messages
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a604dd877075ec803abb2f0f2869053...
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a604dd877075ec803abb2f0f2869053...
You're receiving this email because of your account on gitlab.haskell.org.