[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: th: Hide the Language.Haskell.TH.Lib.Internal module from haddock
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Apr 2 19:53:14 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
9e0e56ef by Rodrigo Mesquita at 2024-04-02T15:52:53-04:00
th: Hide the Language.Haskell.TH.Lib.Internal module from haddock
Fixes #24562
- - - - -
088d7cca by Sylvain Henry at 2024-04-02T15:52:56-04:00
JS: reenable h$appendToHsString optimization (#24495)
The optimization introducing h$appendToHsString wasn't kicking in
anymore (while it did in 9.8.1) because of the changes introduced in #23270 (7e0c8b3bab30).
This patch reenables the optimization by matching on case-expression, as
done in Cmm for unpackCString# standard thunks.
The test is also T24495 added in the next commits (two commits for ease
of backporting to 9.8).
- - - - -
beccd51a by Sylvain Henry at 2024-04-02T15:52:56-04:00
JS: fix h$appendToHsString implementation (#24495)
h$appendToHsString needs to wrap its argument in an updatable thunk
to behave like unpackAppendCString#. Otherwise if a SingleEntry thunk is
passed, it is stored as-is in a CONS cell, making the resulting list
impossible to deepseq (forcing the thunk doesn't update the contents of
the CONS cell)!
The added test checks that the optimization kicks in and that
h$appendToHsString works as intended.
Fix #24495
- - - - -
1e9737cd by Simon Peyton Jones at 2024-04-02T15:52:57-04:00
Deal with duplicate tyvars in type declarations
GHC was outright crashing before this fix: #24604
- - - - -
3dffa742 by Simon Peyton Jones at 2024-04-02T15:52:57-04:00
Try using MCoercion in exprIsConApp_maybe
This is just a simple refactor that makes exprIsConApp_maybe
a little bit more direct, simple, and efficient.
Metrics: compile_time/bytes allocated
geo. mean -0.1%
minimum -2.0%
maximum -0.0%
Not a big gain, but worthwhile given that the code is, if anything,
easier to grok.
- - - - -
26 changed files:
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/StgToJS/Apply.hs
- compiler/GHC/StgToJS/Expr.hs
- compiler/GHC/StgToJS/Linker/Utils.hs
- compiler/GHC/StgToJS/Rts/Rts.hs
- compiler/GHC/Tc/Gen/HsType.hs
- libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
- rts/js/string.js
- + testsuite/tests/javascript/Makefile
- + testsuite/tests/javascript/T24495.hs
- + testsuite/tests/javascript/T24495.stdout
- testsuite/tests/javascript/all.T
- testsuite/tests/saks/should_compile/saks018.hs
- testsuite/tests/saks/should_compile/saks021.hs
- testsuite/tests/saks/should_fail/all.T
- + testsuite/tests/saks/should_fail/saks018-fail.hs
- + testsuite/tests/saks/should_fail/saks018-fail.stderr
- + testsuite/tests/saks/should_fail/saks021-fail.hs
- + testsuite/tests/saks/should_fail/saks021-fail.stderr
- testsuite/tests/typecheck/should_compile/T24470b.hs
- + testsuite/tests/vdq-rta/should_fail/T24604.hs
- + testsuite/tests/vdq-rta/should_fail/T24604.stderr
- + testsuite/tests/vdq-rta/should_fail/T24604a.hs
- + testsuite/tests/vdq-rta/should_fail/T24604a.stderr
- testsuite/tests/vdq-rta/should_fail/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -3023,7 +3023,7 @@ pushCoercionIntoLambda in_scope x e co
| otherwise
= Nothing
-pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion
+pushCoDataCon :: DataCon -> [CoreExpr] -> MCoercion
-> Maybe (DataCon
, [Type] -- Universal type args
, [CoreExpr]) -- All other args incl existentials
@@ -3033,10 +3033,20 @@ pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion
-- where co :: (T t1 .. tn) ~ to_ty
-- The left-hand one must be a T, because exprIsConApp returned True
-- but the right-hand one might not be. (Though it usually will.)
-pushCoDataCon dc dc_args co
- | isReflCo co || from_ty `eqType` to_ty -- try cheap test first
- , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args
- = Just (dc, map exprToType univ_ty_args, rest_args)
+pushCoDataCon dc dc_args MRefl = Just $! (push_dc_refl dc dc_args)
+pushCoDataCon dc dc_args (MCo co) = push_dc_gen dc dc_args co (coercionKind co)
+
+push_dc_refl :: DataCon -> [CoreExpr] -> (DataCon, [Type], [CoreExpr])
+push_dc_refl dc dc_args
+ = (dc, map exprToType univ_ty_args, rest_args)
+ where
+ !(univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args
+
+push_dc_gen :: DataCon -> [CoreExpr] -> Coercion -> Pair Type
+ -> Maybe (DataCon, [Type], [CoreExpr])
+push_dc_gen dc dc_args co (Pair from_ty to_ty)
+ | from_ty `eqType` to_ty -- try cheap test first
+ = Just $! (push_dc_refl dc dc_args)
| Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty
, to_tc == dataConTyCon dc
@@ -3082,8 +3092,6 @@ pushCoDataCon dc dc_args co
| otherwise
= Nothing
- where
- Pair from_ty to_ty = coercionKind co
collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)
-- Collect lambda binders, pushing coercions inside if possible
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -1211,7 +1211,7 @@ data-con wrappers, and that cure would be worse than the disease.
This Note exists solely to document the problem.
-}
-data ConCont = CC [CoreExpr] Coercion
+data ConCont = CC [CoreExpr] MCoercion
-- Substitution already applied
-- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument
@@ -1233,7 +1233,7 @@ exprIsConApp_maybe :: HasDebugCallStack
=> InScopeEnv -> CoreExpr
-> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])
exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
- = go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr)))
+ = go (Left in_scope) [] expr (CC [] MRefl)
where
go :: Either InScopeSet Subst
-- Left in-scope means "empty substitution"
@@ -1246,14 +1246,12 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
go subst floats (Tick t expr) cont
| not (tickishIsCode t) = go subst floats expr cont
- go subst floats (Cast expr co1) (CC args co2)
+ go subst floats (Cast expr co1) (CC args m_co2)
| Just (args', m_co1') <- pushCoArgs (subst_co subst co1) args
-- See Note [Push coercions in exprIsConApp_maybe]
- = case m_co1' of
- MCo co1' -> go subst floats expr (CC args' (co1' `mkTransCo` co2))
- MRefl -> go subst floats expr (CC args' co2)
+ = go subst floats expr (CC args' (m_co1' `mkTransMCo` m_co2))
- go subst floats (App fun arg) (CC args co)
+ go subst floats (App fun arg) (CC args mco)
| let arg_type = exprType arg
, not (isTypeArg arg) && needsCaseBinding arg_type arg
-- An unlifted argument that’s not ok for speculation must not simply be
@@ -1276,17 +1274,17 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
bndr = uniqAway (subst_in_scope subst) (mkWildValBinder ManyTy arg_type)
float = FloatCase arg' bndr DEFAULT []
subst' = subst_extend_in_scope subst bndr
- in go subst' (float:floats) fun (CC (Var bndr : args) co)
+ in go subst' (float:floats) fun (CC (Var bndr : args) mco)
| otherwise
- = go subst floats fun (CC (subst_expr subst arg : args) co)
+ = go subst floats fun (CC (subst_expr subst arg : args) mco)
- go subst floats (Lam bndr body) (CC (arg:args) co)
+ go subst floats (Lam bndr body) (CC (arg:args) mco)
| do_beta_by_substitution bndr arg
- = go (extend subst bndr arg) floats body (CC args co)
+ = go (extend subst bndr arg) floats body (CC args mco)
| otherwise
= let (subst', bndr') = subst_bndr subst bndr
float = FloatLet (NonRec bndr' arg)
- in go subst' (float:floats) body (CC args co)
+ in go subst' (float:floats) body (CC args mco)
go subst floats (Let (NonRec bndr rhs) expr) cont
| not (isJoinId bndr)
@@ -1311,12 +1309,12 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
(lookupIdSubst sub v)
cont
- go (Left in_scope) floats (Var fun) cont@(CC args co)
+ go (Left in_scope) floats (Var fun) cont@(CC args mco)
| Just con <- isDataConWorkId_maybe fun
, count isValArg args == idArity fun
= succeedWith in_scope floats $
- pushCoDataCon con args co
+ pushCoDataCon con args mco
-- Look through data constructor wrappers: they inline late (See Note
-- [Activation for data constructor wrappers]) but we want to do
@@ -1336,7 +1334,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
-- simplOptExpr initialises the in-scope set with exprFreeVars,
-- but that doesn't account for DFun unfoldings
= succeedWith in_scope floats $
- pushCoDataCon con (map (substExpr subst) dfun_args) co
+ pushCoDataCon con (map (substExpr subst) dfun_args) mco
-- Look through unfoldings, but only arity-zero one;
-- if arity > 0 we are effectively inlining a function call,
@@ -1354,7 +1352,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
, [arg] <- args
, Just (LitString str) <- exprIsLiteral_maybe ise arg
= succeedWith in_scope floats $
- dealWithStringLiteral fun str co
+ dealWithStringLiteral fun str mco
where
unfolding = id_unf fun
extend_in_scope unf_fvs
@@ -1404,15 +1402,15 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr
-- See Note [exprIsConApp_maybe on literal strings]
-dealWithStringLiteral :: Var -> BS.ByteString -> Coercion
+dealWithStringLiteral :: Var -> BS.ByteString -> MCoercion
-> Maybe (DataCon, [Type], [CoreExpr])
-- This is not possible with user-supplied empty literals, GHC.Core.Make.mkStringExprFS
-- turns those into [] automatically, but just in case something else in GHC
-- generates a string literal directly.
-dealWithStringLiteral fun str co =
+dealWithStringLiteral fun str mco =
case utf8UnconsByteString str of
- Nothing -> pushCoDataCon nilDataCon [Type charTy] co
+ Nothing -> pushCoDataCon nilDataCon [Type charTy] mco
Just (char, charTail) ->
let char_expr = mkConApp charDataCon [mkCharLit char]
-- In singleton strings, just add [] instead of unpackCstring# ""#.
@@ -1421,7 +1419,7 @@ dealWithStringLiteral fun str co =
else App (Var fun)
(Lit (LitString charTail))
- in pushCoDataCon consDataCon [Type charTy, char_expr, rest] co
+ in pushCoDataCon consDataCon [Type charTy, char_expr, rest] mco
{-
Note [Unfolding DFuns]
=====================================
compiler/GHC/StgToJS/Apply.hs
=====================================
@@ -46,7 +46,6 @@ import GHC.StgToJS.Rts.Types
import GHC.StgToJS.Stack
import GHC.StgToJS.Ids
-import GHC.Types.Literal
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.CostCentre
@@ -60,7 +59,6 @@ import GHC.Core.TyCon
import GHC.Core.DataCon
import GHC.Core.Type hiding (typeSize)
-import GHC.Utils.Encoding
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Panic
@@ -100,22 +98,6 @@ genApp
-> G (JStgStat, ExprResult)
genApp ctx i args
- -- Case: unpackCStringAppend# "some string"# str
- --
- -- Generates h$appendToHsStringA(str, "some string"), which has a faster
- -- decoding loop.
- | [StgLitArg (LitString bs), x] <- args
- , [top] <- concatMap typex_expr (ctxTarget ctx)
- , getUnique i == unpackCStringAppendIdKey
- , d <- utf8DecodeByteString bs
- = do
- prof <- csProf <$> getSettings
- let profArg = if prof then [jCafCCS] else []
- a <- genArg x
- return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg)
- , ExprInline
- )
-
-- let-no-escape
| Just n <- ctxLneBindingStackSize ctx i
= do
=====================================
compiler/GHC/StgToJS/Expr.hs
=====================================
@@ -60,11 +60,13 @@ import GHC.Types.Var.Set
import GHC.Types.Id
import GHC.Types.Unique.FM
import GHC.Types.RepType
+import GHC.Types.Literal
import GHC.Stg.Syntax
import GHC.Stg.Utils
import GHC.Builtin.PrimOps
+import GHC.Builtin.Names
import GHC.Core hiding (Var)
import GHC.Core.TyCon
@@ -73,6 +75,7 @@ import GHC.Core.Opt.Arity (isOneShotBndr)
import GHC.Core.Type hiding (typeSize)
import GHC.Utils.Misc
+import GHC.Utils.Encoding
import GHC.Utils.Monad
import GHC.Utils.Panic
import GHC.Utils.Outputable (ppr, renderWithContext, defaultSDocContext)
@@ -555,6 +558,36 @@ genCase :: HasDebugCallStack
-> LiveVars
-> G (JStgStat, ExprResult)
genCase ctx bnd e at alts l
+ -- For: unpackCStringAppend# "some string"# str
+ -- Generate: h$appendToHsStringA(str, "some string")
+ --
+ -- The latter has a faster decoding loop.
+ --
+ -- Since #23270 and 7e0c8b3bab30, literals strings aren't STG atoms and we
+ -- need to match the following instead:
+ --
+ -- case "some string"# of b {
+ -- DEFAULT -> unpackCStringAppend# b str
+ -- }
+ --
+ -- Wrinkle: it doesn't kick in when literals are floated out to the top level.
+ --
+ | StgLit (LitString bs) <- e
+ , [GenStgAlt DEFAULT _ rhs] <- alts
+ , StgApp i args <- rhs
+ , getUnique i == unpackCStringAppendIdKey
+ , [StgVarArg b',x] <- args
+ , bnd == b'
+ , d <- utf8DecodeByteString bs
+ , [top] <- concatMap typex_expr (ctxTarget ctx)
+ = do
+ prof <- csProf <$> getSettings
+ let profArg = if prof then [jCafCCS] else []
+ a <- genArg x
+ return ( top |= app "h$appendToHsStringA" (toJExpr d : a ++ profArg)
+ , ExprInline
+ )
+
| isInlineExpr e = do
bndi <- identsForId bnd
let ctx' = ctxSetTop bnd
=====================================
compiler/GHC/StgToJS/Linker/Utils.hs
=====================================
@@ -191,6 +191,9 @@ genCommonCppDefs profiling = mconcat
-- resumable thunks
, "#define MAKE_RESUMABLE(closure,stack) { (closure).f = h$resume_e; (closure).d1 = (stack), (closure).d2 = null; }\n"
+ -- making a thunk
+ , "#define MK_UPD_THUNK(closure) h$c1(h$upd_thunk_e,(closure))\n"
+
-- general deconstruction
, "#define IS_THUNK(x) ((x).f.t === CLOSURE_TYPE_THUNK)\n"
, "#define CONSTR_TAG(x) ((x).f.a)\n"
=====================================
compiler/GHC/StgToJS/Rts/Rts.hs
=====================================
@@ -448,6 +448,19 @@ rts_gen s = do
, r4 |= d4
, returnS (app "h$ap_3_3_fast" [])
])
+ , closure (ClosureInfo (TxtI "h$upd_thunk_e") (CIRegs 0 [PtrV]) "updatable thunk" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
+ (jVar $ \t -> return $
+ mconcat [t |= closureField1 r1
+ , adjSp' 2
+ , stack .! (sp - 1) |= r1
+ , stack .! sp |= var "h$upd_frame"
+ , closureEntry r1 |= var "h$blackhole"
+ , closureField1 r1 |= var "h$currentThread"
+ , closureField2 r1 |= null_
+ , r1 |= t
+ , returnS (app "h$ap_0_0_fast" [])
+ ]
+ )
-- select first field
, closure (ClosureInfo (global "h$select1_e") (CIRegs 0 [PtrV]) "select1" (CILayoutFixed 1 [PtrV]) CIThunk mempty)
(jVar \t -> return $
=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -2570,9 +2570,11 @@ kcCheckDeclHeader_sig sig_kind name flav
; traceTc "kcCheckDeclHeader_sig {" $
vcat [ text "sig_kind:" <+> ppr sig_kind
, text "sig_tcbs:" <+> ppr sig_tcbs
- , text "sig_res_kind:" <+> ppr sig_res_kind ]
+ , text "sig_res_kind:" <+> ppr sig_res_kind
+ , text "implict_nms:" <+> ppr implicit_nms
+ , text "hs_tv_bndrs:" <+> ppr hs_tv_bndrs ]
- ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, (extra_tcbs, tycon_res_kind))))
+ ; (tclvl, wanted, (implicit_tvs, (skol_tcbs, skol_scoped_tvs, (extra_tcbs, tycon_res_kind))))
<- pushLevelAndSolveEqualitiesX "kcCheckDeclHeader_sig" $ -- #16687
bindImplicitTKBndrs_Q_Tv implicit_nms $ -- Q means don't clone
matchUpSigWithDecl name sig_tcbs sig_res_kind hs_tv_bndrs $ \ excess_sig_tcbs sig_res_kind ->
@@ -2615,9 +2617,18 @@ kcCheckDeclHeader_sig sig_kind name flav
-- Here p and q both map to the same kind variable k. We don't allow this
-- so we must check that they are distinct. A similar thing happens
-- in GHC.Tc.TyCl.swizzleTcTyConBinders during inference.
+ --
+ -- With visible dependent quantification, one of the binders involved
+ -- may be explicit. Consider #24604
+ -- type UF :: forall zk -> zk -> Constraint
+ -- class UF kk (xb :: k)
+ -- Here `k` and `kk` both denote the same variable; but only `k` is implicit
+ -- Hence we need to add skol_scoped_tvs
; implicit_tvs <- liftZonkM $ zonkTcTyVarsToTcTyVars implicit_tvs
; let implicit_prs = implicit_nms `zip` implicit_tvs
- ; checkForDuplicateScopedTyVars implicit_prs
+ dup_chk_prs = implicit_prs ++ mkTyVarNamePairs skol_scoped_tvs
+ ; unless (null implicit_nms) $ -- No need if no implicit tyvars
+ checkForDuplicateScopedTyVars dup_chk_prs
; checkForDisconnectedScopedTyVars name flav all_tcbs implicit_prs
-- Swizzle the Names so that the TyCon uses the user-declared implicit names
@@ -2686,6 +2697,7 @@ matchUpSigWithDecl
-> ([TcTyConBinder] -> TcKind -> TcM a) -- All user-written binders are in scope
-- Argument is excess TyConBinders and tail kind
-> TcM ( [TcTyConBinder] -- Skolemised binders, with TcTyVars
+ , [TcTyVar] -- Skolem tyvars brought into lexical scope by this matching-up
, a )
-- See Note [Matching a kind signature with a declaration]
-- Invariant: Length of returned TyConBinders + length of excess TyConBinders
@@ -2696,7 +2708,7 @@ matchUpSigWithDecl name sig_tcbs sig_res_kind hs_bndrs thing_inside
go subst tcbs []
= do { let (subst', tcbs') = substTyConBindersX subst tcbs
; res <- thing_inside tcbs' (substTy subst' sig_res_kind)
- ; return ([], res) }
+ ; return ([], [], res) }
go _ [] hs_bndrs
= failWithTc (TcRnTooManyBinders sig_res_kind hs_bndrs)
@@ -2712,17 +2724,22 @@ matchUpSigWithDecl name sig_tcbs sig_res_kind hs_bndrs thing_inside
-- that come from the type declaration, not the kind signature
subst' = extendTCvSubstWithClone subst tv tv'
; tc_hs_bndr (unLoc hs_bndr) (tyVarKind tv')
- ; (tcbs', res) <- tcExtendTyVarEnv [tv'] $
- go subst' tcbs' hs_bndrs'
- ; return (Bndr tv' vis : tcbs', res) }
+ ; traceTc "musd1" (ppr tcb $$ ppr hs_bndr $$ ppr tv')
+ ; (tcbs', tvs, res) <- tcExtendTyVarEnv [tv'] $
+ go subst' tcbs' hs_bndrs'
+ ; return (Bndr tv' vis : tcbs', tv':tvs, res) }
+ -- We do a tcExtendTyVarEnv [tv'], so we return tv' in
+ -- the list of lexically-scoped skolem type variables
| skippable (binderFlag tcb)
= -- Invisible TyConBinder, so do not consume one of the hs_bndrs
do { let (subst', tcb') = substTyConBinderX subst tcb
- ; (tcbs', res) <- go subst' tcbs' hs_bndrs
+ ; traceTc "musd2" (ppr tcb $$ ppr hs_bndr $$ ppr tcb')
+ ; (tcbs', tvs, res) <- go subst' tcbs' hs_bndrs
-- NB: pass on hs_bndrs unchanged; we do not consume a
-- HsTyVarBndr for an invisible TyConBinder
- ; return (tcb' : tcbs', res) }
+ ; return (tcb' : tcbs', tvs, res) }
+ -- Return `tvs`; no new lexically-scoped TyVars brought into scope
| otherwise =
-- At this point we conclude that:
@@ -2736,14 +2753,19 @@ matchUpSigWithDecl name sig_tcbs sig_res_kind hs_bndrs thing_inside
= return ()
tc_hs_bndr (KindedTyVar _ _ (L _ hs_nm) lhs_kind) expected_kind
= do { sig_kind <- tcLHsKindSig (TyVarBndrKindCtxt hs_nm) lhs_kind
+ ; traceTc "musd3:unifying" (ppr sig_kind $$ ppr expected_kind)
; discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]
unifyKind (Just (NameThing hs_nm)) sig_kind expected_kind }
-- See GHC Proposal #425, section "Kind checking",
-- where zippable and skippable are defined.
+ -- In particular: we match up if
+ -- (a) HsBndr looks like @k, and TyCon binder is forall k. (NamedTCB Specified)
+ -- (b) HsBndr looks like a, and TyCon binder is forall k -> (NamedTCB Required)
+ -- or k -> (AnonTCB)
zippable :: TyConBndrVis -> HsBndrVis GhcRn -> Bool
- zippable vis (HsBndrRequired _) = isVisibleTcbVis vis
- zippable vis (HsBndrInvisible _) = isInvisSpecTcbVis vis
+ zippable vis (HsBndrInvisible _) = isInvisSpecTcbVis vis -- (a)
+ zippable vis (HsBndrRequired _) = isVisibleTcbVis vis -- (b)
-- See GHC Proposal #425, section "Kind checking",
-- where zippable and skippable are defined.
@@ -3007,15 +3029,7 @@ checkForDisconnectedScopedTyVars name flav all_tcbs scoped_prs
checkForDuplicateScopedTyVars :: [(Name,TcTyVar)] -> TcM ()
-- Check for duplicates
--- E.g. data SameKind (a::k) (b::k)
--- data T (a::k1) (b::k2) c = MkT (SameKind a b) c
--- Here k1 and k2 start as TyVarTvs, and get unified with each other
--- If this happens, things get very confused later, so fail fast
---
--- In the CUSK case k1 and k2 are skolems so they won't unify;
--- but in the inference case (see generaliseTcTyCon),
--- and the type-sig case (see kcCheckDeclHeader_sig), they are
--- TcTyVars, so we must check.
+-- See Note [Aliasing in type and class declarations]
checkForDuplicateScopedTyVars scoped_prs
= unless (null err_prs) $
do { mapM_ report_dup err_prs; failM }
@@ -3035,8 +3049,43 @@ checkForDuplicateScopedTyVars scoped_prs
addErrTc $ TcRnDifferentNamesForTyVar n1 n2
-{- Note [Disconnected type variables]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Aliasing in type and class declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ data SameKind (a::k) (b::k)
+ data T1 (a::k1) (b::k2) c = MkT (SameKind a b) c
+We do not allow this, because `k1` and `k2` would both stand for the same type
+variable -- they are both aliases for `k`.
+
+Other examples
+ data T2 (a::k1) = MkT2 (SameKind a Int) -- k1 stands for Type
+ data T3 @k1 @k2 (a::k1) (b::k2) = MkT (SameKind a b) -- k1 and k2 are aliases
+
+ type UF :: forall zk. zk -> Constraint
+ class UF @kk (xb :: k) where -- kk and k are aliases
+ op :: (xs::kk) -> Bool
+
+See #24604 for an example that crashed GHC.
+
+There is a design choice here. It would be possible to allow implicit type variables
+like `k1` and `k2` in T1's declartion to stand for /abitrary kinds/. This is in fact
+the rule we use in /terms/ pattern signatures:
+ f :: [Int] -> Int
+ f ((x::a) : xs) = ...
+Here `a` stands for `Int`. But in type /signatures/ we make a different choice:
+ f1 :: forall (a::k1) (b::k2). SameKind a b -> blah
+ f2 :: forall (a::k). SameKind a Int -> blah
+
+Here f1's signature is rejected because `k1` and `k2` are aliased; and f2's is
+rejected because `k` stands for `Int`.
+
+Our current choice is that type and class declarations behave more like signatures;
+we do not allow aliasing. That is what `checkForDuplicateScopedTyVars` checks.
+See !12328 for some design discussion.
+
+
+Note [Disconnected type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This note applies when kind-checking the header of a type/class decl that has
a separate, standalone kind signature. See #24083.
=====================================
libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
=====================================
@@ -1,3 +1,4 @@
+{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE Trustworthy #-}
=====================================
rts/js/string.js
=====================================
@@ -723,7 +723,10 @@ function h$appendToHsStringA(str, appendTo, cc) {
function h$appendToHsStringA(str, appendTo) {
#endif
var i = str.length - 1;
- var r = appendTo;
+ // we need to make an updatable thunk here
+ // if we embed the given closure in a CONS cell.
+ // (#24495)
+ var r = i == 0 ? appendTo : MK_UPD_THUNK(appendTo);
while(i>=0) {
r = MK_CONS_CC(str.charCodeAt(i), r, cc);
--i;
=====================================
testsuite/tests/javascript/Makefile
=====================================
@@ -0,0 +1,9 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+T24495:
+ '$(TEST_HC)' $(TEST_HC_OPTS) T24495.hs -v0 -O1 -dsuppress-uniques -ddump-js -ddump-to-file
+ ./T24495
+ # check that the optimization occurred
+ grep -c appendToHsStringA T24495.dump-js
=====================================
testsuite/tests/javascript/T24495.hs
=====================================
@@ -0,0 +1,22 @@
+{-# LANGUAGE MagicHash #-}
+{-# OPTIONS_GHC -O1 #-}
+-- -O1 required to make "rest" thunk SingleEntry
+
+module Main where
+
+import GHC.CString
+import GHC.JS.Prim (JSVal, toJSString)
+
+foo :: Double -> IO ()
+foo x = debugString (toJSString ("2 " ++ s))
+ where
+ x' = if x == 0 then "b" else "c"
+ y' = if x == 0 then "b" else "c"
+ s = "a" ++ x' ++ " " ++ y' ++ "d"
+
+main :: IO ()
+main = foo 0
+
+
+foreign import javascript "((s) => { console.log(s); })"
+ debugString :: JSVal -> IO ()
=====================================
testsuite/tests/javascript/T24495.stdout
=====================================
@@ -0,0 +1,2 @@
+2 ab bd
+2
=====================================
testsuite/tests/javascript/all.T
=====================================
@@ -21,3 +21,4 @@ test('js-mk_tup', extra_files(['test-mk_tup.js']), compile_and_run, ['test-mk_tu
test('T23346', normal, compile_and_run, [''])
test('T22455', normal, compile_and_run, ['-ddisable-js-minifier'])
test('T23565', normal, compile_and_run, [''])
+test('T24495', normal, makefile_test, ['T24495'])
=====================================
testsuite/tests/saks/should_compile/saks018.hs
=====================================
@@ -6,4 +6,4 @@ module SAKS_018 where
import Data.Kind (Type)
type T :: forall k -> k -> Type
-data T k (x :: hk)
+data T j (x :: j)
=====================================
testsuite/tests/saks/should_compile/saks021.hs
=====================================
@@ -6,4 +6,4 @@ module SAKS_021 where
import Data.Kind (Type)
type T :: forall k -> forall (xx :: k) -> Type
-data T k (x :: hk)
+data T j (x :: j)
=====================================
testsuite/tests/saks/should_fail/all.T
=====================================
@@ -36,3 +36,5 @@ test('T18863b', normal, compile_fail, [''])
test('T18863c', normal, compile_fail, [''])
test('T18863d', normal, compile_fail, [''])
test('T20916', normal, compile_fail, [''])
+test('saks018-fail', normal, compile_fail, [''])
+test('saks021-fail', normal, compile_fail, [''])
=====================================
testsuite/tests/saks/should_fail/saks018-fail.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE PolyKinds, ExplicitForAll #-}
+
+module SAKS_018 where
+
+import Data.Kind (Type)
+
+type T :: forall k -> k -> Type
+data T k (x :: hk)
=====================================
testsuite/tests/saks/should_fail/saks018-fail.stderr
=====================================
@@ -0,0 +1,4 @@
+
+saks018-fail.hs:9:8: error: [GHC-17370]
+ • Different names for the same type variable: ‘hk’ and ‘k’
+ • In the data type declaration for ‘T’
=====================================
testsuite/tests/saks/should_fail/saks021-fail.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE PolyKinds, ExplicitForAll #-}
+
+module SAKS_021 where
+
+import Data.Kind (Type)
+
+type T :: forall k -> forall (xx :: k) -> Type
+data T k (x :: hk)
=====================================
testsuite/tests/saks/should_fail/saks021-fail.stderr
=====================================
@@ -0,0 +1,4 @@
+
+saks021-fail.hs:9:8: error: [GHC-17370]
+ • Different names for the same type variable: ‘hk’ and ‘k’
+ • In the data type declaration for ‘T’
=====================================
testsuite/tests/typecheck/should_compile/T24470b.hs
=====================================
@@ -7,4 +7,4 @@ import Data.Kind
import Data.Data
type SynOK :: forall k. k -> Type
-type SynOK @t = Proxy :: j -> Type
+type SynOK @j = Proxy :: j -> Type
=====================================
testsuite/tests/vdq-rta/should_fail/T24604.hs
=====================================
@@ -0,0 +1,7 @@
+module T24604 where
+
+import Data.Kind
+
+type UF :: forall zk -> zk -> Constraint
+class UF kk (xb :: k) where
+ op :: (xs::kk) -> Bool
=====================================
testsuite/tests/vdq-rta/should_fail/T24604.stderr
=====================================
@@ -0,0 +1,4 @@
+
+T24604.hs:6:10: error: [GHC-17370]
+ • Different names for the same type variable: ‘k’ and ‘kk’
+ • In the class declaration for ‘UF’
=====================================
testsuite/tests/vdq-rta/should_fail/T24604a.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeAbstractions #-}
+
+module T24604a where
+
+import Data.Kind
+
+type UF :: forall zk. zk -> Constraint
+class UF @kk (xb :: k) where
+ op :: (xs::kk) -> Bool
=====================================
testsuite/tests/vdq-rta/should_fail/T24604a.stderr
=====================================
@@ -0,0 +1,4 @@
+
+T24604a.hs:8:11: error: [GHC-17370]
+ • Different names for the same type variable: ‘k’ and ‘kk’
+ • In the class declaration for ‘UF’
=====================================
testsuite/tests/vdq-rta/should_fail/all.T
=====================================
@@ -17,4 +17,6 @@ test('T23738_fail_implicit_tv', normal, compile_fail, [''])
test('T23738_fail_var', normal, compile_fail, [''])
test('T24176', normal, compile_fail, [''])
test('T23739_fail_ret', normal, compile_fail, [''])
-test('T23739_fail_case', normal, compile_fail, [''])
\ No newline at end of file
+test('T23739_fail_case', normal, compile_fail, [''])
+test('T24604', normal, compile_fail, [''])
+test('T24604a', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2e84acd912d4db77a25cb68f434de8f41d30b455...3dffa74229386b4a9a8d4c0de2bee084bc53e0ac
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2e84acd912d4db77a25cb68f434de8f41d30b455...3dffa74229386b4a9a8d4c0de2bee084bc53e0ac
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/20240402/1795e2b6/attachment-0001.html>
More information about the ghc-commits
mailing list