[Git][ghc/ghc][wip/backports-9.6] 9 commits: docs: Generate docs/index.html with version number
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Tue May 16 11:56:22 UTC 2023
Ben Gamari pushed to branch wip/backports-9.6 at Glasgow Haskell Compiler / GHC
Commits:
f70b9c49 by Matthew Pickering at 2023-05-16T07:56:09-04:00
docs: Generate docs/index.html with version number
* Generate docs/index.html to include the version of the ghc library
* This also fixes the packageVersions interpolations which were
- Missing an interpolation for `LIBRARY_ghc_VERSION`
- Double quoting the version so that "9.7" was being inserted.
Fixes #23121
(cherry picked from commit d7a768a415c3bd575a20b20ae9a3953aa5886ed7)
- - - - -
6cd0f807 by Simon Peyton Jones at 2023-05-16T07:56:09-04:00
Transfer DFunId_ness onto specialised bindings
Whether a binding is a DFunId or not has consequences for the `-fdicts-strict`
flag, essentially if we are doing demand analysis for a DFunId then `-fdicts-strict` does
not apply because the constraint solver can create recursive groups of dictionaries.
In #22549 this was fixed for the "normal" case, see
Note [Do not strictify the argument dictionaries of a dfun].
However the loop still existed if the DFunId was being specialised.
The problem was that the specialiser would specialise a DFunId and
turn it into a VanillaId and so the demand analyser didn't know to
apply special treatment to the binding anymore and the whole recursive
group was optimised to bottom.
The solution is to transfer over the DFunId-ness of the binding in the specialiser so
that the demand analyser knows not to apply the `-fstrict-dicts`.
Fixes #22549
(cherry picked from commit 3b0ea4809d92581a10e0e501a6fbd7339e8922bf)
- - - - -
5637364e by Ben Gamari at 2023-05-16T07:56:09-04:00
nonmoving: Disable slop-zeroing
As noted in #23170, the nonmoving GC can race with a mutator zeroing the
slop of an updated thunk (in much the same way that two mutators would
race). Consequently, we must disable slop-zeroing when the nonmoving GC
is in use.
Closes #23170
(cherry picked from commit d1bb16ed3e18a4f41fcfe31f0bf57dbaf589d6c5)
- - - - -
373ec872 by Krzysztof Gogolewski at 2023-05-16T07:56:09-04:00
Fix unification with oversaturated type families
unify_ty was incorrectly saying that F x y ~ T x are surely apart,
where F x y is an oversaturated type family and T x is a tyconapp.
As a result, the simplifier dropped a live case alternative (#23134).
(cherry picked from commit 7c16f3be6e1ac92f87d752f12ad6c6e7b7fd6207)
- - - - -
ab677901 by Ben Gamari at 2023-05-16T07:56:09-04:00
nativeGen/AArch64: Fix bitmask immediate predicate
Previously the predicate for determining whether a logical instruction
operand could be encoded as a bitmask immediate was far too
conservative. This meant that, e.g., pointer untagged required five
instructions whereas it should only require one.
Fixes #23030.
(cherry picked from commit b8d783d24b9a617ad1e3038abeb75d322703ef65)
- - - - -
7083db5a by Sylvain Henry at 2023-05-16T07:56:09-04:00
JS: fix thread-related primops
(cherry picked from commit d442ac053f9ac7dbcc32318802daf686f377fe3d)
- - - - -
35131c9d by Ben Gamari at 2023-05-16T07:56:09-04:00
rts: Initialize Array# header in listThreads#
Previously the implementation of listThreads# failed to initialize the
header of the created array, leading to various nastiness.
Fixes #23071
(cherry picked from commit 52d3e9b4189440d26bad9c5a15f9420b67b1ca5b)
- - - - -
ac639721 by Ben Gamari at 2023-05-16T07:56:09-04:00
testsuite: Add test for #23071
(cherry picked from commit 1db30fe1dd38dd8ffedfadf3845706fcde02933b)
- - - - -
1fdbbd8d by sheaf at 2023-05-16T07:56:09-04:00
Don't panic in ltPatersonSize
The function GHC.Tc.Utils.TcType.ltPatersonSize would panic when it
encountered a type family on the RHS, as usually these are not allowed
(type families are not allowed on the RHS of class instances or of
quantified constraints). However, it is possible to still encounter
type families on the RHS after doing a bit of constraint solving, as
seen in test case T23171. This could trigger the panic in the call to
ltPatersonSize in GHC.Tc.Solver.Canonical.mk_strict_superclasses, which
is involved in avoiding loopy superclass constraints.
This patch simply changes ltPatersonSize to return "I don't know, because
there's a type family involved" in these cases.
Fixes #23171
(cherry picked from commit df1a581188694479a583270548896245fc23b525)
- - - - -
22 changed files:
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/StgToJS/Prim.hs
- compiler/GHC/Tc/Utils/TcType.hs
- docs/index.html → docs/index.html.in
- hadrian/src/Rules/Documentation.hs
- hadrian/src/Rules/Generate.hs
- libraries/base/tests/all.T
- + libraries/base/tests/listThreads1.hs
- + libraries/base/tests/listThreads1.stdout
- rts/Threads.c
- rts/include/rts/storage/ClosureMacros.h
- rts/js/mem.js
- rts/js/thread.js
- + testsuite/tests/primops/should_run/T23071.hs
- testsuite/tests/primops/should_run/all.T
- + testsuite/tests/simplCore/should_run/T23134.hs
- + testsuite/tests/simplCore/should_run/T23134.stdout
- testsuite/tests/simplCore/should_run/all.T
- + testsuite/tests/typecheck/should_compile/T23171.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
=====================================
@@ -3,7 +3,6 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NumericUnderscores #-}
module GHC.CmmToAsm.AArch64.CodeGen (
cmmTopCodeGen
, generateJumpTableForInstr
@@ -773,12 +772,12 @@ getRegister' config plat expr
return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))
-- 3. Logic &&, ||
- CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (fromIntegral n) ->
+ CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (fromIntegral n) ->
return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))
where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))
r' = getRegisterReg plat reg
- CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (fromIntegral n) ->
+ CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (fromIntegral n) ->
return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORR (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))
where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))
r' = getRegisterReg plat reg
@@ -963,19 +962,6 @@ getRegister' config plat expr
where
isNbitEncodeable :: Int -> Integer -> Bool
isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)
- -- This needs to check if n can be encoded as a bitmask immediate:
- --
- -- See https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly
- --
- isBitMaskImmediate :: Integer -> Bool
- isBitMaskImmediate i = i `elem` [0b0000_0001, 0b0000_0010, 0b0000_0100, 0b0000_1000, 0b0001_0000, 0b0010_0000, 0b0100_0000, 0b1000_0000
- ,0b0000_0011, 0b0000_0110, 0b0000_1100, 0b0001_1000, 0b0011_0000, 0b0110_0000, 0b1100_0000
- ,0b0000_0111, 0b0000_1110, 0b0001_1100, 0b0011_1000, 0b0111_0000, 0b1110_0000
- ,0b0000_1111, 0b0001_1110, 0b0011_1100, 0b0111_1000, 0b1111_0000
- ,0b0001_1111, 0b0011_1110, 0b0111_1100, 0b1111_1000
- ,0b0011_1111, 0b0111_1110, 0b1111_1100
- ,0b0111_1111, 0b1111_1110
- ,0b1111_1111]
-- N.B. MUL does not set the overflow flag.
do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
@@ -1018,6 +1004,39 @@ getRegister' config plat expr
CMP (OpReg tmp_w tmp) (OpRegExt tmp_w tmp ext_mode 0) `snocOL`
CSET (OpReg w dst) NE)
+-- | Is a given number encodable as a bitmask immediate?
+--
+-- https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly
+isAArch64Bitmask :: Integer -> Bool
+-- N.B. zero and ~0 are not encodable as bitmask immediates
+isAArch64Bitmask 0 = False
+isAArch64Bitmask n
+ | n == bit 64 - 1 = False
+isAArch64Bitmask n =
+ check 64 || check 32 || check 16 || check 8
+ where
+ -- Check whether @n@ can be represented as a subpattern of the given
+ -- width.
+ check width
+ | hasOneRun subpat =
+ let n' = fromIntegral (mkPat width subpat)
+ in n == n'
+ | otherwise = False
+ where
+ subpat :: Word64
+ subpat = fromIntegral (n .&. (bit width - 1))
+
+ -- Construct a bit-pattern from a repeated subpatterns the given width.
+ mkPat :: Int -> Word64 -> Word64
+ mkPat width subpat =
+ foldl' (.|.) 0 [ subpat `shiftL` p | p <- [0, width..63] ]
+
+ -- Does the given number's bit representation match the regular expression
+ -- @0*1*0*@?
+ hasOneRun :: Word64 -> Bool
+ hasOneRun m =
+ 64 == popCount m + countLeadingZeros m + countTrailingZeros m
+
-- | Instructions to sign-extend the value in the given register from width @w@
-- up to width @w'@.
signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -48,10 +48,11 @@ import GHC.Types.Unique.DFM
import GHC.Types.Name
import GHC.Types.Tickish
import GHC.Types.Id.Make ( voidArgId, voidPrimId )
-import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg )
+import GHC.Types.Var ( PiTyBinder(..), isLocalVar, isInvisibleFunArg, mkLocalVar )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Types.Id
+import GHC.Types.Id.Info
import GHC.Types.Error
import GHC.Utils.Error ( mkMCDiagnostic )
@@ -59,6 +60,7 @@ import GHC.Utils.Monad ( foldlM )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
+import GHC.Utils.Panic.Plain( assert )
import GHC.Unit.Module( Module )
import GHC.Unit.Module.ModGuts
@@ -1748,12 +1750,44 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
| otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1)
join_arity_decr = length rule_lhs_args - length spec_bndrs
- spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn
- = Just (orig_join_arity - join_arity_decr)
- | otherwise
- = Nothing
- ; spec_fn <- newSpecIdSM fn spec_fn_ty spec_join_arity
+ --------------------------------------
+ -- Add a suitable unfolding; see Note [Inline specialisations]
+ -- The wrap_unf_body applies the original unfolding to the specialised
+ -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)
+ simpl_opts = initSimpleOpts dflags
+ wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds
+ spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body
+ rule_lhs_args fn_unf
+
+ --------------------------------------
+ -- Adding arity information just propagates it a bit faster
+ -- See Note [Arity decrease] in GHC.Core.Opt.Simplify
+ -- Copy InlinePragma information from the parent Id.
+ -- So if f has INLINE[1] so does spec_fn
+ arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs
+
+ spec_inl_prag
+ | not is_local -- See Note [Specialising imported functions]
+ , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal
+ = neverInlinePragma
+ | otherwise
+ = inl_prag
+
+ spec_fn_info
+ = vanillaIdInfo `setArityInfo` max 0 (fn_arity - arity_decr)
+ `setInlinePragInfo` spec_inl_prag
+ `setUnfoldingInfo` spec_unf
+
+ -- Compute the IdDetails of the specialise Id
+ -- See Note [Transfer IdDetails during specialisation]
+ spec_fn_details
+ = case idDetails fn of
+ JoinId join_arity _ -> JoinId (join_arity - join_arity_decr) Nothing
+ DFunId is_nt -> DFunId is_nt
+ _ -> VanillaId
+
+ ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty spec_fn_details spec_fn_info
; let
-- The rule to put in the function's specialisation is:
-- forall x @b d1' d2'.
@@ -1768,33 +1802,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
herald fn rule_bndrs rule_lhs_args
(mkVarApps (Var spec_fn) spec_bndrs)
- simpl_opts = initSimpleOpts dflags
-
- --------------------------------------
- -- Add a suitable unfolding; see Note [Inline specialisations]
- -- The wrap_unf_body applies the original unfolding to the specialised
- -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)
- wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds
- spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body
- rule_lhs_args fn_unf
-
- spec_inl_prag
- | not is_local -- See Note [Specialising imported functions]
- , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal
- = neverInlinePragma
- | otherwise
- = inl_prag
-
- --------------------------------------
- -- Adding arity information just propagates it a bit faster
- -- See Note [Arity decrease] in GHC.Core.Opt.Simplify
- -- Copy InlinePragma information from the parent Id.
- -- So if f has INLINE[1] so does spec_fn
- arity_decr = count isValArg rule_lhs_args - count isId spec_bndrs
- spec_f_w_arity = spec_fn `setIdArity` max 0 (fn_arity - arity_decr)
- `setInlinePragma` spec_inl_prag
- `setIdUnfolding` spec_unf
- `asJoinId_maybe` spec_join_arity
+ spec_f_w_arity = spec_fn
_rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type
, ppr spec_fn <+> dcolon <+> ppr spec_fn_ty
@@ -1824,7 +1832,7 @@ specLookupRule env fn args phase rules
{- Note [Specialising DFuns]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-DFuns have a special sort of unfolding (DFunUnfolding), and these are
+DFuns have a special sort of unfolding (DFunUnfolding), and it is
hard to specialise a DFunUnfolding to give another DFunUnfolding
unless the DFun is fully applied (#18120). So, in the case of DFunIds
we simply extend the CallKey with trailing UnspecTypes/UnspecArgs,
@@ -1833,6 +1841,36 @@ so that we'll generate a rule that completely saturates the DFun.
There is an ASSERT that checks this, in the DFunUnfolding case of
GHC.Core.Unfold.Make.specUnfolding.
+Note [Transfer IdDetails during specialisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When specialising a function, `newSpecIdSM` comes up with a fresh Id the
+specialised RHS will be bound to. It is critical that we get the `IdDetails` of
+the specialised Id correct:
+
+* JoinId: We want the specialised Id to be a join point, too. But
+ we have to carefully adjust the arity
+
+* DFunId: It is crucial that we also make the new Id a DFunId.
+ - First, because it obviously /is/ a DFun, having a DFunUnfolding and
+ all that; see Note [Specialising DFuns]
+
+ - Second, DFuns get very delicate special treatment in the demand analyser;
+ see GHC.Core.Opt.DmdAnal.enterDFun. If the specialised function isn't
+ also a DFunId, this special treatment doesn't happen, so the demand
+ analyser makes a too-strict DFun, and we get an infinite loop. See Note
+ [Do not strictify a DFun's parameter dictionaries] in GHC.Core.Opt.DmdAnal.
+ #22549 describes the loop, and (lower down) a case where a /specialised/
+ DFun caused a loop.
+
+* WorkerLikeId: Introduced by WW, so after Specialise. Nevertheless, they come
+ up when specialising imports. We must keep them as VanillaIds because WW
+ will detect them as WorkerLikeIds again. That is, unless specialisation
+ allows unboxing of all previous CBV args, in which case sticking to
+ VanillaIds was the only correct choice to begin with.
+
+* RecSelId, DataCon*Id, ClassOpId, PrimOpId, FCallId, CoVarId, TickBoxId:
+ Never specialised.
+
Note [Specialisation Must Preserve Sharing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a function:
@@ -3439,15 +3477,14 @@ newDictBndr env@(SE { se_subst = subst }) b
env' = env { se_subst = subst `Core.extendSubstInScope` b' }
; pure (env', b') }
-newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id
+newSpecIdSM :: Name -> Type -> IdDetails -> IdInfo -> SpecM Id
-- Give the new Id a similar occurrence name to the old one
-newSpecIdSM old_id new_ty join_arity_maybe
+newSpecIdSM old_name new_ty details info
= do { uniq <- getUniqueM
- ; let name = idName old_id
- new_occ = mkSpecOcc (nameOccName name)
- new_id = mkUserLocal new_occ uniq ManyTy new_ty (getSrcSpan name)
- `asJoinId_maybe` join_arity_maybe
- ; return new_id }
+ ; let new_occ = mkSpecOcc (nameOccName old_name)
+ new_name = mkInternalName uniq new_occ (getSrcSpan old_name)
+ ; return (assert (not (isCoVarType new_ty)) $
+ mkLocalVar details new_name ManyTy new_ty info) }
{-
Old (but interesting) stuff about unboxed bindings
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -1,6 +1,6 @@
-- (c) The University of Glasgow 2006
-{-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-}
+{-# LANGUAGE ScopedTypeVariables, PatternSynonyms, MultiWayIf #-}
{-# LANGUAGE DeriveFunctor #-}
@@ -47,6 +47,7 @@ import GHC.Types.Unique
import GHC.Types.Unique.FM
import GHC.Types.Unique.Set
import GHC.Exts( oneShot )
+import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Data.FastString
@@ -994,6 +995,59 @@ These two TyConApps have the same TyCon at the front but they
(legitimately) have different numbers of arguments. They
are surelyApart, so we can report that without looking any
further (see #15704).
+
+Note [Unifying type applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Unifying type applications is quite subtle, as we found
+in #23134 and #22647, when type families are involved.
+
+Suppose
+ type family F a :: Type -> Type
+ type family G k :: k = r | r -> k
+
+and consider these examples:
+
+* F Int ~ F Char, where F is injective
+ Since F is injective, we can reduce this to Int ~ Char,
+ therefore SurelyApart.
+
+* F Int ~ F Char, where F is not injective
+ Without injectivity, return MaybeApart.
+
+* G Type ~ G (Type -> Type) Int
+ Even though G is injective and the arguments to G are different,
+ we cannot deduce apartness because the RHS is oversaturated.
+ For example, G might be defined as
+ G Type = Maybe Int
+ G (Type -> Type) = Maybe
+ So we return MaybeApart.
+
+* F Int Bool ~ F Int Char -- SurelyApart (since Bool is apart from Char)
+ F Int Bool ~ Maybe a -- MaybeApart
+ F Int Bool ~ a b -- MaybeApart
+ F Int Bool ~ Char -> Bool -- MaybeApart
+ An oversaturated type family can match an application,
+ whether it's a TyConApp, AppTy or FunTy. Decompose.
+
+* F Int ~ a b
+ We cannot decompose a saturated, or under-saturated
+ type family application. We return MaybeApart.
+
+To handle all those conditions, unify_ty goes through
+the following checks in sequence, where Fn is a type family
+of arity n:
+
+* (C1) Fn x_1 ... x_n ~ Fn y_1 .. y_n
+ A saturated application.
+ Here we can unify arguments in which Fn is injective.
+* (C2) Fn x_1 ... x_n ~ anything, anything ~ Fn x_1 ... x_n
+ A saturated type family can match anything - we return MaybeApart.
+* (C3) Fn x_1 ... x_m ~ a b, a b ~ Fn x_1 ... x_m where m > n
+ An oversaturated type family can be decomposed.
+* (C4) Fn x_1 ... x_m ~ anything, anything ~ Fn x_1 ... x_m, where m > n
+ If we couldn't decompose in the previous step, we return SurelyApart.
+
+Afterwards, the rest of the code doesn't have to worry about type families.
-}
-------------- unify_ty: the main workhorse -----------
@@ -1035,31 +1089,63 @@ unify_ty env ty1 (TyVarTy tv2) kco
= uVar (umSwapRn env) tv2 ty1 (mkSymCo kco)
unify_ty env ty1 ty2 _kco
+
+ -- Handle non-oversaturated type families first
+ -- See Note [Unifying type applications]
+ --
+ -- (C1) If we have T x1 ... xn ~ T y1 ... yn, use injectivity information of T
+ -- Note that both sides must not be oversaturated
+ | Just (tc1, tys1) <- isSatTyFamApp mb_tc_app1
+ , Just (tc2, tys2) <- isSatTyFamApp mb_tc_app2
+ , tc1 == tc2
+ = do { let inj = case tyConInjectivityInfo tc1 of
+ NotInjective -> repeat False
+ Injective bs -> bs
+
+ (inj_tys1, noninj_tys1) = partitionByList inj tys1
+ (inj_tys2, noninj_tys2) = partitionByList inj tys2
+
+ ; unify_tys env inj_tys1 inj_tys2
+ ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification]
+ don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 }
+
+ | Just _ <- isSatTyFamApp mb_tc_app1 -- (C2) A (not-over-saturated) type-family application
+ = maybeApart MARTypeFamily -- behaves like a type variable; might match
+
+ | Just _ <- isSatTyFamApp mb_tc_app2 -- (C2) A (not-over-saturated) type-family application
+ -- behaves like a type variable; might unify
+ -- but doesn't match (as in the TyVarTy case)
+ = if um_unif env then maybeApart MARTypeFamily else surelyApart
+
+ -- Handle oversaturated type families.
+ --
+ -- They can match an application (TyConApp/FunTy/AppTy), this is handled
+ -- the same way as in the AppTy case below.
+ --
+ -- If there is no application, an oversaturated type family can only
+ -- match a type variable or a saturated type family,
+ -- both of which we handled earlier. So we can say surelyApart.
+ | Just (tc1, _) <- mb_tc_app1
+ , isTypeFamilyTyCon tc1
+ = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1
+ , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2
+ -> unify_ty_app env ty1a [ty1b] ty2a [ty2b] -- (C3)
+ | otherwise -> surelyApart -- (C4)
+
+ | Just (tc2, _) <- mb_tc_app2
+ , isTypeFamilyTyCon tc2
+ = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1
+ , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2
+ -> unify_ty_app env ty1a [ty1b] ty2a [ty2b] -- (C3)
+ | otherwise -> surelyApart -- (C4)
+
+ -- At this point, neither tc1 nor tc2 can be a type family.
| Just (tc1, tys1) <- mb_tc_app1
, Just (tc2, tys2) <- mb_tc_app2
, tc1 == tc2
- = if isInjectiveTyCon tc1 Nominal
- then unify_tys env tys1 tys2
- else do { let inj | isTypeFamilyTyCon tc1
- = case tyConInjectivityInfo tc1 of
- NotInjective -> repeat False
- Injective bs -> bs
- | otherwise
- = repeat False
-
- (inj_tys1, noninj_tys1) = partitionByList inj tys1
- (inj_tys2, noninj_tys2) = partitionByList inj tys2
-
- ; unify_tys env inj_tys1 inj_tys2
- ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification]
- don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 }
-
- | isTyFamApp mb_tc_app1 -- A (not-over-saturated) type-family application
- = maybeApart MARTypeFamily -- behaves like a type variable; might match
-
- | isTyFamApp mb_tc_app2 -- A (not-over-saturated) type-family application
- , um_unif env -- behaves like a type variable; might unify
- = maybeApart MARTypeFamily
+ = do { massertPpr (isInjectiveTyCon tc1 Nominal) (ppr tc1)
+ ; unify_tys env tys1 tys2
+ }
-- TYPE and CONSTRAINT are not Apart
-- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim
@@ -1160,16 +1246,16 @@ unify_tys env orig_xs orig_ys
-- Possibly different saturations of a polykinded tycon
-- See Note [Polykinded tycon applications]
-isTyFamApp :: Maybe (TyCon, [Type]) -> Bool
--- True if we have a saturated or under-saturated type family application
+isSatTyFamApp :: Maybe (TyCon, [Type]) -> Maybe (TyCon, [Type])
+-- Return the argument if we have a saturated type family application
-- If it is /over/ saturated then we return False. E.g.
-- unify_ty (F a b) (c d) where F has arity 1
-- we definitely want to decompose that type application! (#22647)
-isTyFamApp (Just (tc, tys))
- = not (isGenerativeTyCon tc Nominal) -- Type family-ish
+isSatTyFamApp tapp@(Just (tc, tys))
+ | isTypeFamilyTyCon tc
&& not (tys `lengthExceeds` tyConArity tc) -- Not over-saturated
-isTyFamApp Nothing
- = False
+ = tapp
+isSatTyFamApp _ = Nothing
---------------------------------
uVar :: UMEnv
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -921,7 +921,7 @@ genPrim prof bound ty op = case op of
IsCurrentThreadBoundOp -> \[r] [] -> PrimInline $ r |= one_
NoDuplicateOp -> \[] [] -> PrimInline mempty -- don't need to do anything as long as we have eager blackholing
ThreadStatusOp -> \[stat,cap,locked] [tid] -> PrimInline $ appT [stat, cap, locked] "h$threadStatus" [tid]
- ListThreadsOp -> \[r] [] -> PrimInline $ r |= var "h$threads"
+ ListThreadsOp -> \[r] [] -> PrimInline $ appT [r] "h$listThreads" []
GetThreadLabelOp -> \[r1, r2] [t] -> PrimInline $ appT [r1, r2] "h$getThreadLabel" [t]
LabelThreadOp -> \[] [t,l] -> PrimInline $ t .^ "label" |= l
=====================================
compiler/GHC/Tc/Utils/TcType.hs
=====================================
@@ -2387,22 +2387,32 @@ has a separate call to isStuckTypeFamily, so the `F` above will still be accepte
-}
+-- | Why was the LHS 'PatersonSize' not strictly smaller than the RHS 'PatersonSize'?
+--
+-- See Note [Paterson conditions] in GHC.Tc.Validity.
data PatersonSizeFailure
- = PSF_TyFam TyCon -- Type family
- | PSF_Size -- Too many type constructors/variables
- | PSF_TyVar [TyVar] -- These type variables appear more often than in instance head;
- -- no duplicates in this list
+ -- | Either side contains a type family.
+ = PSF_TyFam TyCon
+ -- | The size of the LHS is not strictly less than the size of the RHS.
+ | PSF_Size
+ -- | These type variables appear more often in the LHS than in the RHS.
+ | PSF_TyVar [TyVar] -- ^ no duplicates in this list
--------------------------------------
-data PatersonSize -- See Note [Paterson conditions] in GHC.Tc.Validity
- = PS_TyFam TyCon -- Mentions a type family; infinite size
-
- | PS_Vanilla { ps_tvs :: [TyVar] -- Free tyvars, including repetitions;
- , ps_size :: Int -- Number of type constructors and variables
+-- | The Paterson size of a given type, in the sense of
+-- Note [Paterson conditions] in GHC.Tc.Validity
+--
+-- - after expanding synonyms,
+-- - ignoring coercions (as they are not user written).
+data PatersonSize
+ -- | The type mentions a type family, so the size could be anything.
+ = PS_TyFam TyCon
+
+ -- | The type does not mention a type family.
+ | PS_Vanilla { ps_tvs :: [TyVar] -- ^ free tyvars, including repetitions;
+ , ps_size :: Int -- ^ number of type constructors and variables
}
- -- Always after expanding synonyms
- -- Always ignore coercions (not user written)
-- ToDo: ignore invisible arguments? See Note [Invisible arguments and termination]
instance Outputable PatersonSize where
@@ -2415,21 +2425,26 @@ pSizeZero, pSizeOne :: PatersonSize
pSizeZero = PS_Vanilla { ps_tvs = [], ps_size = 0 }
pSizeOne = PS_Vanilla { ps_tvs = [], ps_size = 1 }
-ltPatersonSize :: PatersonSize -- Size of constraint
- -> PatersonSize -- Size of instance head; never PS_TyFam
+-- | @ltPatersonSize ps1 ps2@ returns:
+--
+-- - @Nothing@ iff @ps1@ is definitely strictly smaller than @ps2@,
+-- - @Just ps_fail@ otherwise; @ps_fail@ says what went wrong.
+ltPatersonSize :: PatersonSize
+ -> PatersonSize
-> Maybe PatersonSizeFailure
--- (ps1 `ltPatersonSize` ps2) returns
--- Nothing iff ps1 is strictly smaller than p2
--- Just ps_fail says what went wrong
-ltPatersonSize (PS_TyFam tc) _ = Just (PSF_TyFam tc)
ltPatersonSize (PS_Vanilla { ps_tvs = tvs1, ps_size = s1 })
(PS_Vanilla { ps_tvs = tvs2, ps_size = s2 })
| s1 >= s2 = Just PSF_Size
| bad_tvs@(_:_) <- noMoreTyVars tvs1 tvs2 = Just (PSF_TyVar bad_tvs)
| otherwise = Nothing -- OK!
-ltPatersonSize (PS_Vanilla {}) (PS_TyFam tc)
- = pprPanic "ltPSize" (ppr tc)
- -- Impossible because we never have a type family in an instance head
+ltPatersonSize (PS_TyFam tc) _ = Just (PSF_TyFam tc)
+ltPatersonSize _ (PS_TyFam tc) = Just (PSF_TyFam tc)
+ -- NB: this last equation is never taken when checking instances, because
+ -- type families are disallowed in instance heads.
+ --
+ -- However, this function is also used in the logic for solving superclass
+ -- constraints (see Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance),
+ -- in which case we might well hit this case (see e.g. T23171).
noMoreTyVars :: [TyVar] -- Free vars (with repetitions) of the constraint C
-> [TyVar] -- Free vars (with repetitions) of the head H
=====================================
docs/index.html → docs/index.html.in
=====================================
@@ -39,7 +39,7 @@
<LI>
<P>
- <B><A HREF="libraries/ghc/index.html">GHC API</A></B>
+ <B><A HREF="libraries/ghc- at LIBRARY_ghc_VERSION@/index.html">GHC API</A></B>
</P>
<P>
Documentation for the GHC API.
=====================================
hadrian/src/Rules/Documentation.hs
=====================================
@@ -192,7 +192,7 @@ buildHtmlDocumentation = do
| SphinxHTML `Set.member` doctargets ]
need $ map ((root -/-) . pathIndex) targets
- copyFileUntracked "docs/index.html" file
+ copyFile "docs/index.html" file
-- | Compile a Sphinx ReStructured Text package to HTML.
buildSphinxHtml :: FilePath -> Rules ()
=====================================
hadrian/src/Rules/Generate.hs
=====================================
@@ -304,10 +304,10 @@ rtsCabalFlags = mconcat
flag = interpolateCabalFlag
packageVersions :: Interpolations
-packageVersions = foldMap f [ base, ghcPrim, ghc, cabal, templateHaskell, ghcCompact, array ]
+packageVersions = foldMap f [ base, ghcPrim, compiler, ghc, cabal, templateHaskell, ghcCompact, array ]
where
f :: Package -> Interpolations
- f pkg = interpolateVar var $ show . version <$> readPackageData pkg
+ f pkg = interpolateVar var $ version <$> readPackageData pkg
where var = "LIBRARY_" <> pkgName pkg <> "_VERSION"
templateRule :: FilePath -> Interpolations -> Rules ()
@@ -336,6 +336,7 @@ templateRules = do
templateRule "libraries/libiserv/libiserv.cabal" $ projectVersion
templateRule "libraries/template-haskell/template-haskell.cabal" $ projectVersion
templateRule "libraries/prologue.txt" $ packageVersions
+ templateRule "docs/index.html" $ packageVersions
-- Generators
=====================================
libraries/base/tests/all.T
=====================================
@@ -290,5 +290,6 @@ test('T19719', normal, compile_and_run, [''])
test('T20107', extra_run_opts('+RTS -M50M'), compile_and_run, ['-package bytestring'])
test('T22816', normal, compile_and_run, [''])
test('trace', normal, compile_and_run, [''])
-test('listThreads', js_broken(22261), compile_and_run, [''])
+test('listThreads', normal, compile_and_run, [''])
+test('listThreads1', normal, compile_and_run, [''])
test('inits1tails1', normal, compile_and_run, [''])
=====================================
libraries/base/tests/listThreads1.hs
=====================================
@@ -0,0 +1,6 @@
+module Main where
+
+import GHC.Conc.Sync
+
+main :: IO ()
+main = listThreads >>= print
=====================================
libraries/base/tests/listThreads1.stdout
=====================================
@@ -0,0 +1 @@
+[ThreadId 1]
=====================================
rts/Threads.c
=====================================
@@ -872,6 +872,7 @@ StgMutArrPtrs *listThreads(Capability *cap)
const StgWord size = n_threads + mutArrPtrsCardTableSize(n_threads);
StgMutArrPtrs *arr =
(StgMutArrPtrs *)allocate(cap, sizeofW(StgMutArrPtrs) + size);
+ SET_HDR(arr, &stg_MUT_ARR_PTRS_DIRTY_info, CCS_SYSTEM);
TICK_ALLOC_PRIM(sizeofW(StgMutArrPtrs), n, 0);
arr->ptrs = n_threads;
arr->size = size;
=====================================
rts/include/rts/storage/ClosureMacros.h
=====================================
@@ -479,11 +479,13 @@ EXTERN_INLINE StgWord8 *mutArrPtrsCard (StgMutArrPtrs *a, W_ n)
memory we're about to zero.
Thus, with the THREADED RTS and +RTS -N2 or greater we must not zero
- immutable closure's slop.
+ immutable closure's slop. Similarly, the concurrent GC's mark thread
+ may race when a mutator during slop-zeroing. Consequently, we also disable
+ zeroing when the non-moving GC is in use.
Hence, an immutable closure's slop is zeroed when either:
- - PROFILING && era > 0 (LDV is on) or
+ - PROFILING && era > 0 (LDV is on) && !nonmoving-gc-enabled or
- !THREADED && DEBUG
Additionally:
@@ -541,7 +543,8 @@ zeroSlop (StgClosure *p, uint32_t offset, uint32_t size, bool known_mutable)
const bool can_zero_immutable_slop =
// Only if we're running single threaded.
- RTS_DEREF(RtsFlags).ParFlags.nCapabilities <= 1;
+ RTS_DEREF(RtsFlags).ParFlags.nCapabilities <= 1
+ && !RTS_DEREF(RtsFlags).GcFlags.useNonmoving; // see #23170
const bool zero_slop_immutable =
want_to_zero_immutable_slop && can_zero_immutable_slop;
=====================================
rts/js/mem.js
=====================================
@@ -1455,11 +1455,3 @@ function h$pext64(src_b, src_a, mask_b, mask_a) {
}
RETURN_UBX_TUP2(dst_b, dst_a);
}
-
-function h$getThreadLabel(t) {
- if (t.label) {
- RETURN_UBX_TUP2(1, t.label);
- } else {
- RETURN_UBX_TUP2(0, 0);
- }
-}
=====================================
rts/js/thread.js
=====================================
@@ -106,8 +106,8 @@ function h$Thread() {
#endif
}
-function h$rts_getThreadId(t) {
- return t.tid;
+function h$rts_getThreadId(t) { // returns a CULLong
+ RETURN_UBX_TUP2((t.tid / Math.pow(2,32))>>>0, (t.tid & 0xFFFFFFFF)>>>0);
}
function h$cmp_thread(t1,t2) {
@@ -121,13 +121,35 @@ function h$threadString(t) {
if(t === null) {
return "<no thread>";
} else if(t.label) {
- var str = h$decodeUtf8z(t.label[0], t.label[1]);
+ var str = h$decodeUtf8z(t.label, 0);
return str + " (" + t.tid + ")";
} else {
return (""+t.tid);
}
}
+function h$getThreadLabel(t) {
+ if (t.label) {
+ RETURN_UBX_TUP2(1, t.label);
+ } else {
+ RETURN_UBX_TUP2(0, 0);
+ }
+}
+
+function h$listThreads() {
+ var r = h$newArray(0,null);
+
+ if (h$currentThread) r.push(h$currentThread);
+
+ var threads_iter = h$threads.iter();
+ while ((t = threads_iter()) !== null) r.push(t);
+
+ var blocked_iter = h$blocked.iter();
+ while ((t = blocked_iter.next()) !== null) r.push(t);
+
+ return r;
+}
+
function h$fork(a, inherit) {
h$r1 = h$forkThread(a, inherit);
return h$yield();
@@ -1134,7 +1156,7 @@ function h$main(a) {
t.stack[8] = a;
t.stack[9] = h$return;
t.sp = 9;
- t.label = [h$encodeUtf8("main"), 0];
+ t.label = h$encodeUtf8("main");
h$wakeupThread(t);
h$startMainLoop();
return t;
=====================================
testsuite/tests/primops/should_run/T23071.hs
=====================================
@@ -0,0 +1,5 @@
+import Control.Monad
+import GHC.Conc.Sync
+
+main = replicateM_ 1000000 $ listThreads >>= print
+
=====================================
testsuite/tests/primops/should_run/all.T
=====================================
@@ -60,3 +60,4 @@ test('UnliftedTVar2', normal, compile_and_run, [''])
test('UnliftedWeakPtr', normal, compile_and_run, [''])
test('T21624', normal, compile_and_run, [''])
+test('T23071', ignore_stdout, compile_and_run, [''])
=====================================
testsuite/tests/simplCore/should_run/T23134.hs
=====================================
@@ -0,0 +1,37 @@
+{-# LANGUAGE GHC2021, DataKinds, TypeFamilies #-}
+module Main where
+
+import Data.Maybe
+import Data.Kind
+
+main :: IO ()
+main = putStrLn str
+
+str :: String
+str = case runInstrImpl @(TOption TUnit) mm MAP of
+ C VOption -> "good"
+ C Unused -> "bad"
+
+runInstrImpl :: forall inp out. Value (MapOpRes inp TUnit) -> Instr inp out -> Rec out
+runInstrImpl m MAP = C m
+
+type MapOpRes :: T -> T -> T
+type family MapOpRes c :: T -> T
+type instance MapOpRes ('TOption x) = 'TOption
+
+mm :: Value (TOption TUnit)
+mm = VOption
+{-# NOINLINE mm #-}
+
+type Value :: T -> Type
+data Value t where
+ VOption :: Value ('TOption t)
+ Unused :: Value t
+
+data T = TOption T | TUnit
+
+data Instr (inp :: T) (out :: T) where
+ MAP :: Instr c (TOption (MapOpRes c TUnit))
+
+data Rec :: T -> Type where
+ C :: Value r -> Rec (TOption r)
=====================================
testsuite/tests/simplCore/should_run/T23134.stdout
=====================================
@@ -0,0 +1 @@
+good
=====================================
testsuite/tests/simplCore/should_run/all.T
=====================================
@@ -108,3 +108,4 @@ test('T21575', normal, compile_and_run, ['-O'])
test('T21575b', [], multimod_compile_and_run, ['T21575b', '-O'])
test('T20836', normal, compile_and_run, ['-O0']) # Should not time out; See #20836
test('T22998', normal, compile_and_run, ['-O0 -fspecialise -dcore-lint'])
+test('T23134', normal, compile_and_run, ['-O0 -fcatch-nonexhaustive-cases'])
=====================================
testsuite/tests/typecheck/should_compile/T23171.hs
=====================================
@@ -0,0 +1,43 @@
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module T23171 where
+
+import Data.Kind
+
+type C1 :: Type -> Type -> Constraint
+class C1 t m where
+
+type C2 :: Type -> Constraint
+class C2 a where
+
+type C3 :: Type -> Constraint
+class C2 a => C3 a where
+
+type D :: Type -> Constraint
+class D t where
+instance (forall m. C3 m => C1 t m) => D t where
+
+type T :: Type -> Type
+type family T a where
+
+try :: forall (e :: Type). D (T e) => e -> ()
+try _ = ()
+
+type C1T :: Type -> Type -> Constraint
+class C1 (T e) m => C1T e m
+
+tried :: forall (e :: Type). (forall m. C1T e m) => e -> ()
+tried = try @e
+
+-- From the call to "try", we get [W] D (T e).
+-- After using the instance for D, we get the QC [G] C3 m ==> [W] C1 (T e) m.
+--
+-- The Given "[G] C3 m" thus arises from superclass expansion
+-- from "D (T e)", which contains a type family application, T.
+-- So the logic in 'mkStrictSuperClasses' better be able to handle that when
+-- expanding the superclasses of C3 (in this case, C2); in particular
+-- ltPatersonSize needs to handle a type family in its second argument.
+
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -865,3 +865,4 @@ test('T22924', normal, compile, [''])
test('T22985a', normal, compile, ['-O'])
test('T22985b', normal, compile, [''])
test('T23018', normal, compile, [''])
+test('T23171', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2855ecf281173334b30007d3b568f9bafdc68fce...1fdbbd8d81b3b5e80e8997d279764f62cdcc3c26
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2855ecf281173334b30007d3b568f9bafdc68fce...1fdbbd8d81b3b5e80e8997d279764f62cdcc3c26
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/20230516/3ee64a0e/attachment-0001.html>
More information about the ghc-commits
mailing list