[Git][ghc/ghc][wip/backports-9.6] 7 commits: nonmoving: Disable slop-zeroing
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Tue May 16 02:00:00 UTC 2023
Ben Gamari pushed to branch wip/backports-9.6 at Glasgow Haskell Compiler / GHC
Commits:
7c376f27 by Ben Gamari at 2023-05-15T21:59:49-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)
- - - - -
ac3bd5b0 by Krzysztof Gogolewski at 2023-05-15T21:59:49-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)
- - - - -
eed419ae by Ben Gamari at 2023-05-15T21:59:49-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)
- - - - -
e03c5348 by Sylvain Henry at 2023-05-15T21:59:49-04:00
JS: fix thread-related primops
(cherry picked from commit d442ac053f9ac7dbcc32318802daf686f377fe3d)
- - - - -
a283de03 by Ben Gamari at 2023-05-15T21:59:49-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)
- - - - -
80cf7b21 by Ben Gamari at 2023-05-15T21:59:49-04:00
testsuite: Add test for #23071
(cherry picked from commit 1db30fe1dd38dd8ffedfadf3845706fcde02933b)
- - - - -
2855ecf2 by sheaf at 2023-05-15T21:59:49-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)
- - - - -
18 changed files:
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/StgToJS/Prim.hs
- compiler/GHC/Tc/Utils/TcType.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/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
=====================================
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/c923c1b983c717c7a6e2c16c6fe52ba0923eee20...2855ecf281173334b30007d3b568f9bafdc68fce
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/c923c1b983c717c7a6e2c16c6fe52ba0923eee20...2855ecf281173334b30007d3b568f9bafdc68fce
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/20230515/4ae36fe8/attachment-0001.html>
More information about the ghc-commits
mailing list