[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: FastString: Drop mkFastStringWith's constructor callback

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 7a108e43 by Simon Jakobi at 2026-09-12T18:35:59-04:00 FastString: Drop mkFastStringWith's constructor callback All three callers passed the same callback, a partial application of mkNewFastStringShortByteString to the string being interned. That partial application is allocated as a closure before the table lookup, on the common hit path too, although the callback is needed only after a miss. Drop the parameter and call mkNewFastStringShortByteString directly after a miss. Since nothing is passed "with" anymore, rename the function to internSB. Suggested by Simon PJ in #27528: https://gitlab.haskell.org/ghc/ghc/-/work_items/27528#note_687031 Assisted-by: Claude Fable 5 - - - - - 82c73b22 by Alan Zimmerman at 2026-09-12T18:36:38-04:00 EPA: More targeted HsDo exact print annotation HsDo is multi-purpose, as encoded in its HsDoFlavour field. Some of these are in a layout context (DoExpr, MDoExpr), others are not (ListComp, MonadComp). We are moving towards using AnnList only in layout contexts, so we switch the HsDo TTG annotation from holding an AnnList for this, to holding Either (EpToken "[", EpToken "]") AnnList This also allows us to trim down AnnListBrackets to only have braces or None, thereby opening the door for unification with the existing layout context data type EpLayout. - - - - - de75a9e9 by Luite Stegeman at 2026-09-14T10:12:51+02:00 rts: make stg_threadLabelzh return a valid pointer for unlabeled threads. This fixes a segfault in the GC caused by stg_threadLabelzh returning a 0 pointer in a GC pointer field. stg_threadLabelzh returns a tuple of type (# Int#, ByteArray# #). If a thread has no label, the second field is unused. We must still return a valid heap object pointer. Instead of returning 0, we now return stg_DEAD_SLOT_closure. fixes #27618 - - - - - 3b1f7b57 by Luite Stegeman at 2026-09-14T08:19:42-04:00 rts: initialise the stack frame header for mask_frame and apply_mask_frame We must leave the stack in consistent state before jumping to mask_frame or apply_mask_frame because they may result. Failing to do so could lead to a crash if there were waiting exceptions. Fixes #27651 - - - - - 23 changed files: - + changelog.d/fix-control0-mask-trampoline - + changelog.d/fix-threadlabel-segfault-27618 - compiler/GHC/Data/FastString.hs - compiler/GHC/Hs/Expr.hs - compiler/GHC/Hs/Utils.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Annotation.hs - compiler/GHC/Parser/PostProcess.hs - rts/ContinuationOps.cmm - rts/PrimOps.cmm - rts/StgMiscClosures.cmm - rts/include/stg/MiscClosures.h - testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr - testsuite/tests/parser/should_compile/DumpSemis.stderr - testsuite/tests/printer/Test20297.stdout - + testsuite/tests/rts/T27618.hs - + testsuite/tests/rts/T27618.stdout - testsuite/tests/rts/all.T - + testsuite/tests/rts/continuations/T27651.hs - + testsuite/tests/rts/continuations/T27651.stdout - testsuite/tests/rts/continuations/all.T - utils/check-exact/ExactPrint.hs - utils/check-exact/Utils.hs Changes: ===================================== changelog.d/fix-control0-mask-trampoline ===================================== @@ -0,0 +1,13 @@ +section: rts +synopsis: Fix a crash when capturing or resuming a delimited continuation that adjusts the async exception masking state +issues: #27651 +mrs: !16484 + +description: { +Capturing a continuation with ``control0#`` from inside ``mask`` or +``uninterruptibleMask`` left an uninitialised word on the stack while +restoring the masking state. When the thread had a pending asynchronous +exception (e.g. from ``throwTo``), raising it walked over that word and +crashed with a segmentation fault. Resuming such a continuation had the +same defect. +} ===================================== changelog.d/fix-threadlabel-segfault-27618 ===================================== @@ -0,0 +1,10 @@ +section: rts +synopsis: Fix a segfault that could occur when querying the label of an + unlabeled thread. +issues: #27618 +mrs: !16468 +description: { + The ``threadLabel#`` primop returned a null pointer in the ``ByteArray#`` + field of its result for threads that have no label. This could lead to a + crash during garbage collection. +} ===================================== compiler/GHC/Data/FastString.hs ===================================== @@ -320,7 +320,7 @@ data FastStringTable = FastStringTable -- ^ Number of computed z-encodings for all buckets. -- -- We mark this as 'NOUNPACK' as this 'FastMutInt' is retained by a thunk - -- in 'mkFastStringWith' and needs to be boxed any way. + -- in 'internSB' and needs to be boxed any way. -- If this is unpacked, then we box this single 'FastMutInt' once for each -- allocated FastString. (Array# (IORef FastStringTableSegment)) -- ^ concurrent segments @@ -474,9 +474,10 @@ The procedure goes like this: * Otherwise, insert and return the string we created. -} -mkFastStringWith - :: (Int -> FastMutInt-> IO FastString) -> ShortByteString -> IO FastString -mkFastStringWith mk_fs sbs = do +-- | Return the interned 'FastString' for the given bytes, creating and +-- inserting one on a table miss. +internSB :: ShortByteString -> IO FastString +internSB sbs = do FastStringTableSegment lock _ buckets# <- readIORef segmentRef let idx# = hashToIndex# buckets# hash# bucket <- IO $ readArray# buckets# idx# @@ -487,7 +488,7 @@ mkFastStringWith mk_fs sbs = do -- only run partially and putMVar is not called after takeMVar. noDuplicate n <- get_uid - new_fs <- mk_fs n n_zencs + new_fs <- mkNewFastStringShortByteString sbs n n_zencs withMVar lock $ \_ -> insert new_fs where !(FastStringTable uid n_zencs segments#) = stringTable @@ -523,11 +524,11 @@ bucket_match fs sbs = go fs mkFastStringBytes :: Ptr Word8 -> Int -> FastString mkFastStringBytes !ptr !len = - -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is + -- NB: Might as well use unsafeDupablePerformIO, since internSB is -- idempotent. unsafeDupablePerformIO $ do sbs <- newSBSFromPtr ptr len - mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + internSB sbs newSBSFromPtr :: Ptr a -> Int -> IO ShortByteString newSBSFromPtr (Ptr src#) (I# len#) = @@ -541,14 +542,13 @@ newSBSFromPtr (Ptr src#) (I# len#) = mkFastStringByteString :: ByteString -> FastString mkFastStringByteString bs = let sbs = SBS.toShort bs in - inlinePerformIO $ - mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + inlinePerformIO $ internSB sbs -- | Create a 'FastString' from an existing 'ShortByteString' without -- copying. mkFastStringShortByteString :: ShortByteString -> FastString mkFastStringShortByteString sbs = - inlinePerformIO $ mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + inlinePerformIO $ internSB sbs -- | Create a 'FastString' from an 'HText' mkFastStringShortText :: ShortText -> FastString @@ -560,7 +560,7 @@ mkFastString :: String -> FastString mkFastString str = inlinePerformIO $ do let !sbs = utf8EncodeShortByteString str - mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + internSB sbs -- The following rule is used to avoid polluting the non-reclaimable FastString -- table with transient strings when we only want their encoding. ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -290,10 +290,12 @@ type instance XLet GhcPs = (EpToken "let", EpToken "in") type instance XLet GhcRn = NoExtField type instance XLet GhcTc = NoExtField -type instance XDo GhcPs = (AnnList, EpaLocation) +type instance XDo GhcPs = DoAnn type instance XDo GhcRn = NoExtField type instance XDo GhcTc = Type +type DoAnn = (Either (EpToken "[", EpToken "]") AnnList, EpaLocation) + type instance XExplicitList GhcPs = (EpToken "[", EpToken "]") type instance XExplicitList GhcRn = NoExtField type instance XExplicitList GhcTc = Type @@ -1467,7 +1469,7 @@ type instance XCmdLet GhcPs = (EpToken "let", EpToken "in") type instance XCmdLet GhcRn = NoExtField type instance XCmdLet GhcTc = NoExtField -type instance XCmdDo GhcPs = (AnnList, EpaLocation) +type instance XCmdDo GhcPs = DoAnn type instance XCmdDo GhcRn = NoExtField type instance XCmdDo GhcTc = Type ===================================== compiler/GHC/Hs/Utils.hs ===================================== @@ -335,11 +335,10 @@ mkHsIntegral :: IntegralLit GhcPs -> HsOverLit GhcPs mkHsFractional :: FractionalLit GhcPs -> HsOverLit GhcPs mkHsIsString :: SourceText -> HText -> HsOverLit GhcPs mkHsDo :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> HsExpr GhcPs -mkHsDoAnns :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> (AnnList, EpaLocation) -> HsExpr GhcPs +mkHsDoAnns :: HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> DoAnn -> HsExpr GhcPs mkHsComp :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs -mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs - -> (AnnList, EpaLocation) +mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> DoAnn -> HsExpr GhcPs mkNPat :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpToken "-" ===================================== compiler/GHC/Parser.y ===================================== @@ -3152,19 +3152,15 @@ aexp :: { ECP } return $ ECP $ $2 >>= \ $2 -> mkHsDoPV (comb2 $1 $2) - (stmtlistAnns $2) + (Right $ stmtlistAnns $2, glR $1) (fmap mkModuleNameFS (getDO $1)) - (stmtlistStmts $2) - (glR $1) - (glR $2) } + (stmtlistStmts $2) } | MDO stmtlist {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 -> fmap ecpFromExp $ amsA' (L (comb2 $1 $2) - (mkMDo (stmtlistAnns $2) - (MDoExpr $ fmap mkModuleNameFS (getMDO $1)) - (stmtlistStmts $2) - (glR $1) - (glR $2))) } + (mkHsDoAnns (MDoExpr $ fmap mkModuleNameFS (getMDO $1)) + (stmtlistStmts $2) + (Right $ stmtlistAnns $2, glR $1))) } | 'proc' aexp '->' exp {% (checkPattern <=< runPV) (unECP $2) >>= \ p -> runPV (unECP $4) >>= \ $4@cmd -> @@ -3440,7 +3436,7 @@ list :: { forall b. DisambECP b => SrcSpan -> (EpaLocation, EpaLocation) -> PV ( { \loc (ao,ac) -> checkMonadComp >>= \ ctxt -> unECP $1 >>= \ $1 -> do { t <- addTrailingVbarA $1 (epTok $2) - ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (AnnList Nothing (ListSquare (EpTok ao) (EpTok ac)) [], noAnn)) + ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (Left $ (EpTok ao, EpTok ac), noAnn)) >>= ecpFromExp' } } lexps :: { forall b. DisambECP b => PV [LocatedA b] } @@ -3658,11 +3654,13 @@ apat : aexp {% (checkPattern <=< runPV) (unECP $1) } ----------------------------------------------------------------------------- -- Statement sequences -stmtlist :: { forall b. DisambECP b => PV (LocatedA ((EpToken "{", [EpToken ";"], EpToken "}"), Located [LocatedA (Stmt GhcPs (LocatedA b))])) } +stmtlist :: { forall b. DisambECP b => PV (LocatedA (AnnList, Located [LocatedA (Stmt GhcPs (LocatedA b))])) } : '{' stmts '}' { $2 >>= \ $2 -> - amsA' (sLL $1 $> ((epTok $1, fromOL $ fst $ unLoc $2, epTok $3), sL1 $2 $ reverse $ snd $ unLoc $2))} + amsA' (sLL $1 $> (AnnList (Just (spanAsAnchor $ stmtsLoc $2)) (ListBraces (epTok $1) (epTok $3)) (fromOL $ fst $ unLoc $2) + , sL1 $2 $ reverse $ snd $ unLoc $2))} | vocurly stmts close { $2 >>= \ $2 -> - amsA' (L (stmtsLoc $2) ((noEpTok, fromOL $ fst $ unLoc $2, noEpTok), sL1 $2 $ reverse $ snd $ unLoc $2))} + amsA' (L (stmtsLoc $2) (AnnList (Just (spanAsAnchor $ stmtsLoc $2)) ListNone (fromOL $ fst $ unLoc $2) + , sL1 $2 $ reverse $ snd $ unLoc $2))} -- do { ;; s ; s ; ; s ;; } -- The last Stmt should be an expression, but that's hard to enforce @@ -3704,7 +3702,7 @@ e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) } stmt :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) } : qual { $1 } | 'rec' stmtlist { $2 >>= \ $2 -> - amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn (epTok $1) (stmtlistAnns $2) $2) + amsA' (sLL $1 $> $ mkRecStmt (stmtlistAnns $2, epTok $1) (stmtlistStmts $2)) } qual :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) } @@ -4724,10 +4722,6 @@ commentsPA la@(L l a) = do !cs <- getPriorCommentsFor (getLocA la) return (L (addCommentsToEpAnn l cs) a) -hsDoAnn :: EpToken "rec" -> (EpToken "{", [EpToken ";"], EpToken "}") -> LocatedAn t b -> (AnnList, EpToken "rec") -hsDoAnn rec (ob, semis, cb) (L ll _) - = (AnnList (Just $ spanAsAnchor (locA ll)) (ListBraces ob cb) semis, rec) - listAsAnchorM :: [LocatedAn t a] -> Maybe EpaLocation listAsAnchorM [] = Nothing listAsAnchorM (L l _:_) = @@ -4757,8 +4751,7 @@ stmtlistStmts :: LocatedA (a, Located [LocatedA (Stmt GhcPs (LocatedA b))]) stmtlistStmts (L la (_,L l stmts)) = L ((noAnnSrcSpan l) {comments = comments la}) stmts -stmtlistAnns :: LocatedA ((EpToken "{", [EpToken ";"], EpToken "}"), a) - -> (EpToken "{", [EpToken ";"], EpToken "}") +stmtlistAnns :: LocatedA (AnnList, a) -> AnnList stmtlistAnns (L _ (an,_)) = an -- ------------------------------------- ===================================== compiler/GHC/Parser/Annotation.hs ===================================== @@ -519,8 +519,7 @@ data AnnList } deriving (Data,Eq) data AnnListBrackets - = ListBraces (EpToken "{") (EpToken "}") - | ListSquare (EpToken "[") (EpToken "]") + = ListBraces (EpToken "{") (EpToken "}") | ListNone deriving (Data,Eq) @@ -1093,7 +1092,6 @@ instance Outputable AnnList where instance Outputable AnnListBrackets where ppr (ListBraces o c) = text "ListBraces" <+> ppr o <+> ppr c - ppr (ListSquare o c) = text "ListSquare" <+> ppr o <+> ppr c ppr ListNone = text "ListNone" instance Outputable AnnCType where ===================================== compiler/GHC/Parser/PostProcess.hs ===================================== @@ -12,7 +12,7 @@ module GHC.Parser.PostProcess ( mkRdrGetField, mkRdrProjection, Fbind, -- RecordDot mkHsOpApp, mkHsIntegral, mkHsFractional, mkHsIsString, - mkHsDo, mkMDo, mkSpliceDecl, + mkHsDo, mkSpliceDecl, mkRoleAnnotDecl, mkClassDecl, mkTyData, mkDataFamInst, @@ -435,10 +435,6 @@ mkRoleAnnotDecl loc tycon roles anns addFatalError $ mkPlainErrorMsgEnvelope loc_role $ (PsErrIllegalRoleName role nearby) -mkMDo :: (EpToken "{", [EpToken ";"], EpToken "}") -> HsDoFlavour -> LocatedA [ExprLStmt GhcPs] -> EpaLocation -> EpaLocation -> HsExpr GhcPs -mkMDo (ob, semis, cb) ctxt stmts tok loc - = mkHsDoAnns ctxt stmts (AnnList (Just loc) (ListBraces ob cb) semis, tok) - -- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to -- binders without annotations. Only accepts specified variables, and errors if -- any of the provided binders has an 'InferredSpec' annotation. @@ -1804,12 +1800,7 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where -> PV (LocatedA b) -- | Disambiguate "do { ... }" (do notation) mkHsDoPV :: - SrcSpan -> - (EpToken "{", [EpToken ";"], EpToken "}") -> - Maybe ModuleName -> - LocatedA [LStmt GhcPs (LocatedA b)] -> - EpaLocation -> -- Token - EpaLocation -> -- Anchor + SrcSpan -> DoAnn -> Maybe ModuleName -> LocatedA [LStmt GhcPs (LocatedA b)] -> PV (LocatedA b) -- | Disambiguate "( ... )" (parentheses) mkHsParPV :: SrcSpan -> EpToken "(" -> LocatedA b -> EpToken ")" -> PV (LocatedA b) @@ -1959,10 +1950,10 @@ instance DisambECP (HsCmd GhcPs) where checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns) - mkHsDoPV l (ob,semis,cb) Nothing stmts tok_loc anc = do + mkHsDoPV l ann Nothing stmts = do !cs <- getCommentsFor l - return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo (AnnList (Just anc) (ListBraces ob cb) semis, tok_loc) stmts) - mkHsDoPV l _ (Just m) _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo ann stmts) + mkHsDoPV l _ (Just m) _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m mkHsParPV l lpar c rpar = do !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdPar (lpar, rpar) c) @@ -2058,9 +2049,9 @@ instance DisambECP (HsExpr GhcPs) where checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns) - mkHsDoPV l (ob,semis,cb) mod stmts loc_tok anc = do + mkHsDoPV l ann mod stmts = do !cs <- getCommentsFor l - return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo (AnnList (Just anc) (ListBraces ob cb) semis, loc_tok) (DoExpr mod) stmts) + return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo ann (DoExpr mod) stmts) mkHsParPV l lpar e rpar = do !cs <- getCommentsFor l return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e) @@ -2156,7 +2147,7 @@ instance DisambECP (PatBuilder GhcPs) where !cs <- getCommentsFor (locA l) return $ L (addCommentsToEpAnn l cs) (PatBuilderAppType p at (mkHsTyPat t)) mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat - mkHsDoPV l _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat + mkHsDoPV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat mkHsParPV l lpar p rpar = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar) mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v) mkHsLitPV lit@(L l a) = do ===================================== rts/ContinuationOps.cmm ===================================== @@ -148,6 +148,7 @@ stg_control0zh_ll // explicit stack // and jump to the frame’s entry code. Sp_adj(-3); // Note -3, not -2, because `mask_frame` will // try to pop itself off the stack when it returns! + Sp(0) = mask_frame; // Can't be omitted, see #27651 Sp(1) = stg_ap_pv_info; Sp(2) = cont; R1 = f; @@ -230,6 +231,7 @@ stg_CONTINUATION_apply // explicit stack // Now we just set up the stack so that `apply_mask_frame` will apply `io` // when it returns and jump to it. Sp_adj(-2); + Sp(0) = apply_mask_frame; // Can't be omitted, see #27651 Sp(1) = stg_ap_v_info; R1 = io; jump %ENTRY_CODE(apply_mask_frame) [R1]; ===================================== rts/PrimOps.cmm ===================================== @@ -1160,7 +1160,7 @@ stg_threadLabelzh ( gcptr tso ) W_ r; r = StgTSO_label(tso); if (r == 0) { - return (0, 0); + return (0, stg_DEAD_SLOT_closure); } else { return (1, r); } ===================================== rts/StgMiscClosures.cmm ===================================== @@ -726,6 +726,18 @@ INFO_TABLE_CONSTR(stg_NO_FINALIZER,0,0,0,CONSTR_NOCAF,"NO_FINALIZER","NO_FINALIZ CLOSURE(stg_NO_FINALIZER_closure,stg_NO_FINALIZER); +/* ---------------------------------------------------------------------------- + DEAD_SLOT + + A static nullary constructor for dead pointer-typed result slots + that must still hold a valid closure for the GC (see #27618). + ------------------------------------------------------------------------- */ + +INFO_TABLE_CONSTR(stg_DEAD_SLOT,0,0,0,CONSTR_NOCAF,"DEAD_SLOT","DEAD_SLOT") +{ ccall pbarf("DEAD_SLOT object (%p) entered!", R1 "ptr") never returns; } + +CLOSURE(stg_DEAD_SLOT_closure,stg_DEAD_SLOT); + /* ---------------------------------------------------------------------------- Stable Names are unlifted too. ------------------------------------------------------------------------- */ ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -200,6 +200,7 @@ RTS_ENTRY(stg_SRT_16); RTS_CLOSURE(stg_END_TSO_QUEUE_closure); RTS_CLOSURE(stg_NO_FINALIZER_closure); +RTS_CLOSURE(stg_DEAD_SLOT_closure); RTS_CLOSURE(stg_dummy_ret_closure); RTS_CLOSURE(stg_forceIO_closure); RTS_CLOSURE(stg_CLOSURE_TABLE_NULL_closure); @@ -211,6 +212,7 @@ RTS_CLOSURE(stg_END_STM_CHUNK_LIST_closure); RTS_CLOSURE(stg_NO_TREC_closure); RTS_ENTRY(stg_NO_FINALIZER); +RTS_ENTRY(stg_DEAD_SLOT); #if IN_STG_CODE extern StgWordArray stg_CHARLIKE_closure; ===================================== testsuite/tests/parser/should_compile/DumpParsedAstComments.stderr ===================================== @@ -289,13 +289,12 @@ { DumpParsedAstComments.hs:14:7-8 }))])) (HsDo ((,) - (AnnList - (Just - (EpaSpan { DumpParsedAstComments.hs:16:3 })) - (ListBraces - (EpTok (EpaSpan { <no location info> })) - (EpTok (EpaSpan { <no location info> }))) - []) + (Right + (AnnList + (Just + (EpaSpan { DumpParsedAstComments.hs:16:3 })) + (ListNone) + [])) (EpaSpan { DumpParsedAstComments.hs:14:7-8 })) (DoExpr (Nothing)) ===================================== testsuite/tests/parser/should_compile/DumpSemis.stderr ===================================== @@ -331,13 +331,12 @@ [])) (HsDo ((,) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:(11,3)-(12,3) })) - (ListBraces - (EpTok (EpaSpan { <no location info> })) - (EpTok (EpaSpan { <no location info> }))) - []) + (Right + (AnnList + (Just + (EpaSpan { DumpSemis.hs:(11,3)-(12,3) })) + (ListNone) + [])) (EpaSpan { DumpSemis.hs:10:7-8 })) (DoExpr (Nothing)) @@ -363,20 +362,21 @@ [])) (HsDo ((,) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:11:6-15 })) - (ListBraces - (EpTok (EpaSpan { DumpSemis.hs:11:6 })) - (EpTok (EpaSpan { DumpSemis.hs:11:15 }))) - [(EpTok - (EpaSpan { DumpSemis.hs:11:8 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:11:9 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:11:10 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:11:11 }))]) + (Right + (AnnList + (Just + (EpaSpan { DumpSemis.hs:11:8-13 })) + (ListBraces + (EpTok (EpaSpan { DumpSemis.hs:11:6 })) + (EpTok (EpaSpan { DumpSemis.hs:11:15 }))) + [(EpTok + (EpaSpan { DumpSemis.hs:11:8 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:11:9 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:11:10 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:11:11 }))])) (EpaSpan { DumpSemis.hs:11:3-4 })) (DoExpr (Nothing)) @@ -625,16 +625,17 @@ [])) (HsDo ((,) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:(16,3)-(19,3) })) - (ListBraces - (EpTok (EpaSpan { DumpSemis.hs:16:3 })) - (EpTok (EpaSpan { DumpSemis.hs:19:3 }))) - [(EpTok - (EpaSpan { DumpSemis.hs:16:5 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:16:8 }))]) + (Right + (AnnList + (Just + (EpaSpan { DumpSemis.hs:(16,5)-(18,5) })) + (ListBraces + (EpTok (EpaSpan { DumpSemis.hs:16:3 })) + (EpTok (EpaSpan { DumpSemis.hs:19:3 }))) + [(EpTok + (EpaSpan { DumpSemis.hs:16:5 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:16:8 }))])) (EpaSpan { DumpSemis.hs:15:7-8 })) (DoExpr (Nothing)) @@ -877,16 +878,17 @@ [])) (HsDo ((,) - (AnnList - (Just - (EpaSpan { DumpSemis.hs:22:10-30 })) - (ListBraces - (EpTok (EpaSpan { DumpSemis.hs:22:10 })) - (EpTok (EpaSpan { DumpSemis.hs:22:30 }))) - [(EpTok - (EpaSpan { DumpSemis.hs:22:12 })) - ,(EpTok - (EpaSpan { DumpSemis.hs:22:13 }))]) + (Right + (AnnList + (Just + (EpaSpan { DumpSemis.hs:22:12-28 })) + (ListBraces + (EpTok (EpaSpan { DumpSemis.hs:22:10 })) + (EpTok (EpaSpan { DumpSemis.hs:22:30 }))) + [(EpTok + (EpaSpan { DumpSemis.hs:22:12 })) + ,(EpTok + (EpaSpan { DumpSemis.hs:22:13 }))])) (EpaSpan { DumpSemis.hs:22:7-8 })) (DoExpr (Nothing)) ===================================== testsuite/tests/printer/Test20297.stdout ===================================== @@ -394,13 +394,12 @@ [])) (HsDo ((,) - (AnnList - (Just - (EpaSpan { Test20297.hs:11:22-26 })) - (ListBraces - (EpTok (EpaSpan { <no location info> })) - (EpTok (EpaSpan { <no location info> }))) - []) + (Right + (AnnList + (Just + (EpaSpan { Test20297.hs:11:22-26 })) + (ListNone) + [])) (EpaSpan { Test20297.hs:11:19-20 })) (DoExpr (Nothing)) @@ -820,13 +819,12 @@ [])) (HsDo ((,) - (AnnList - (Just - (EpaSpan { Test20297.ppr.hs:9:20-24 })) - (ListBraces - (EpTok (EpaSpan { <no location info> })) - (EpTok (EpaSpan { <no location info> }))) - []) + (Right + (AnnList + (Just + (EpaSpan { Test20297.ppr.hs:9:20-24 })) + (ListNone) + [])) (EpaSpan { Test20297.ppr.hs:9:17-18 })) (DoExpr (Nothing)) ===================================== testsuite/tests/rts/T27618.hs ===================================== @@ -0,0 +1,39 @@ +{-# LANGUAGE NumericUnderscores #-} + +-- Test for a major GC segfault triggered by threadLabel# returning NULL in +-- a GC pointer field on unlabeled threads. Run with -N4 -A32k. + +module Main (main) where + +import Control.Concurrent +import Control.Monad +import Data.IORef +import GHC.Conc.Sync (threadLabel) +import System.Mem (performMajorGC) + +{-# NOINLINE queryLabel #-} +queryLabel :: ThreadId -> IO (Maybe String) +queryLabel = threadLabel + +main :: IO () +main = do + stop <- newIORef False + _ <- forkIO $ forever performMajorGC + targets <- replicateM 8 $ forkIO $ forever (threadDelay 1_000_000) + dones <- forM [1 :: Int .. 8] $ \_ -> do + done <- newEmptyMVar + _ <- forkIO $ do + let loop = do + s <- readIORef stop + unless s $ do + forM_ targets $ \t -> do + r <- queryLabel t + r `seq` pure () + loop + loop + putMVar done () + pure done + threadDelay 2_000_000 + writeIORef stop True + mapM_ takeMVar dones + putStrLn "done" ===================================== testsuite/tests/rts/T27618.stdout ===================================== @@ -0,0 +1 @@ +done ===================================== testsuite/tests/rts/all.T ===================================== @@ -729,3 +729,7 @@ test('T27477', ], compile_and_run, ['-O2']) +test('T27618', + [req_target_smp, omit_ghci], + compile_and_run, ['-O2 -threaded -with-rtsopts "-N4 -A32k"']) + ===================================== testsuite/tests/rts/continuations/T27651.hs ===================================== @@ -0,0 +1,91 @@ +-- When capturing or resuming a continuation adjusts the async exception +-- masking state, the RTS trampolines through a mask/unmask frame, and the +-- stack must be well-formed at that point: with a blocked exception +-- pending, the eager raise in stg_unmaskAsyncExceptionszh_ret walks the +-- whole stack. +-- +-- Phase 1 exercises the capture side (stg_control0zh_ll): control0# runs +-- inside uninterruptibleMask_ while another thread has queued an +-- exception via throwTo, so the capture unmasks with the exception +-- pending. The frame evaluated between the unmask frame and the prompt +-- keeps raw Int# payload live so that a stale word on the stack cannot +-- masquerade as a valid frame by accident. +-- +-- Phase 2 exercises the resume side (stg_CONTINUATION_apply): the +-- continuation is captured while unmasked (inside mask/restore), so +-- resuming it unmasks, and it is applied from a thread that is masked +-- with an exception pending. +import Control.Concurrent +import Control.Exception +import Control.Monad + +import ContIO + +data Boom = Boom deriving Show +instance Exception Boom + +{-# NOINLINE useInts #-} +useInts :: Int -> Int -> Int -> Int -> Int -> Int +useInts a b c d e = a + b * c + d * e + +rounds :: Int +rounds = 150 + +phase1 :: Int -> IO () +phase1 i = do + mv <- newEmptyMVar + done <- newEmptyMVar + let !p = i * 7919 + 3 -- raw ints to live in the continuation frame + !q = i * 104729 + 7 + !u = i * 1299709 + 11 + !v = i * 15485863 + 13 + a <- forkIO $ + handle (\Boom -> void (tryPutMVar done (Left Boom))) $ do + tag <- newPromptTag + r <- prompt tag $ do + x <- uninterruptibleMask_ $ do + putMVar mv () + threadDelay 2000 -- let the thrower queue its exception + control0 tag (\_k -> pure (42 :: Int)) + -- continuation frame between the unmask frame and the + -- prompt frame, carrying raw Int# payload: + pure (useInts x p q u v) + void (tryPutMVar done (Right r)) + takeMVar mv + _ <- forkIO $ throwTo a Boom + void (takeMVar done) + +phase2 :: Int -> IO () +phase2 i = do + mv <- newEmptyMVar + done <- newEmptyMVar + kvar <- newEmptyMVar + let !p = i * 7919 + 3 + !q = i * 104729 + 7 + !u = i * 1299709 + 11 + !v = i * 15485863 + 13 + -- Capture a continuation whose resumption unmasks: the capture happens + -- inside restore, so its apply_mask_frame is the unmask frame. + _ <- forkIO $ do + tag <- newPromptTag + _ <- prompt tag $ mask $ \restore -> do + x <- restore (control0 tag (\k -> putMVar kvar k >> pure 0)) + pure (useInts x p q u v) + pure () + k <- takeMVar kvar + a <- forkIO $ + handle (\Boom -> void (tryPutMVar done (Left Boom))) $ do + r <- uninterruptibleMask_ $ do + putMVar mv () + threadDelay 2000 -- let the thrower queue its exception + k (pure 42) -- resuming unmasks with the exception pending + void (tryPutMVar done (Right r)) + takeMVar mv + _ <- forkIO $ throwTo a Boom + void (takeMVar done) + +main :: IO () +main = do + forM_ [1 .. rounds] phase1 + forM_ [1 .. rounds] phase2 + putStrLn "ok" ===================================== testsuite/tests/rts/continuations/T27651.stdout ===================================== @@ -0,0 +1 @@ +ok ===================================== testsuite/tests/rts/continuations/all.T ===================================== @@ -9,3 +9,4 @@ test('cont_nondet_handler', [extra_files(['ContIO.hs'])], multimod_compile_and_r test('cont_stack_overflow', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_stack_overflow', '-with-rtsopts "-ki1k -kc2k -kb256"']) test('T23513', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['T23513', '']) +test('T27651', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['T27651', '']) ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -980,9 +980,6 @@ markLensBracketsO' a l = ListBraces o c -> do o' <- markEpToken o return (set l (ListBraces o' c) a) - ListSquare o c -> do - o' <- markEpToken o - return (set l (ListSquare o' c) a) ListNone -> return (set l ListNone a) markLensBracketsC :: (Monad m, Monoid w) @@ -996,9 +993,6 @@ markLensBracketsC' a l = ListBraces o c -> do c' <- markEpToken c return (set l (ListBraces o c') a) - ListSquare o c -> do - c' <- markEpToken c - return (set l (ListSquare o c') a) ListNone -> return (set l ListNone a) -- ------------------------------------- @@ -1468,6 +1462,19 @@ markKwT (AddDarrowAnn tok) = AddDarrowAnn <$> markEpUniToken tok -- --------------------------------------------------------------------- +markAnnListD :: (Monad m, Monoid w) + => Either (EpToken "[", EpToken "]") AnnList + -> EP w m a + -> EP w m (Either (EpToken "[", EpToken "]") AnnList, a) +markAnnListD (Left (o,c)) action = do + o' <- markEpToken o + r <- action + c' <- markEpToken c + return (Left (o',c'), r) +markAnnListD (Right ann) action = do + (ann',r) <- markAnnList' ann action + return (Right ann',r) + markAnnList :: (Monad m, Monoid w) => EpAnn AnnList -> EP w m a -> EP w m (EpAnn AnnList, a) markAnnList ann action = do @@ -3115,10 +3122,10 @@ instance ExactPrint (HsExpr GhcPs) where e' <- markAnnotated e return (HsLet (tkLet',tkIn') binds' e') - exact (HsDo (an,l) do_or_list_comp stmts) = do + exact (HsDo an do_or_list_comp stmts) = do debugM $ "HsDo" - (an',l',stmts') <- exactDo (an,l) do_or_list_comp stmts - return (HsDo (an',l') do_or_list_comp stmts') + (an',stmts') <- exactDo an do_or_list_comp stmts + return (HsDo an' do_or_list_comp stmts') exact (ExplicitList (o,c) es) = do debugM $ "ExplicitList start" @@ -3290,8 +3297,8 @@ instance ExactPrint (HsExpr GhcPs) where -- --------------------------------------------------------------------- exactDo :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) - => (AnnList, EpaLocation) -> HsDoFlavour -> LocatedAn an a - -> EP w m (AnnList, EpaLocation, LocatedAn an a) + => DoAnn -> HsDoFlavour -> LocatedAn an a + -> EP w m (DoAnn, LocatedAn an a) exactDo (an,l) (DoExpr m) stmts = exactMdo l m "do" >>= \l0 -> markMaybeDodgyStmts (an,l0) stmts exactDo (an,l) GhciStmtCtxt stmts = printStringAtAA l "do" >>= @@ -3310,15 +3317,23 @@ exactMdo l (Just module_name) kw = printStringAtAA l n n = (moduleNameString module_name) ++ "." ++ kw markMaybeDodgyStmts :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) - => (AnnList, EpaLocation) -> LocatedAn an a -> EP w m (AnnList, EpaLocation, LocatedAn an a) + => DoAnn -> LocatedAn an a -> EP w m (DoAnn, LocatedAn an a) markMaybeDodgyStmts (an,l) stmts = if notDodgy stmts then do - (an0,stmts') <- markAnnListA' an $ \a -> do - r <- markAnnotatedWithLayout stmts - return (a, r) - return (an0, l, stmts') - else return (an, l, stmts) + (an0,stmts') <- case an of + Left (o,c) -> do + o' <- markEpToken o + r <- markAnnotated stmts + c' <- markEpToken c + return (Left (o',c'), r) + Right an' -> do + (an'',r') <- markAnnListA' an' $ \a -> do + r <- markAnnotatedWithLayout stmts + return (a, r) + return (Right an'',r') + return ((an0, l), stmts') + else return ((an, l), stmts) notDodgy :: GenLocated (EpAnn ann) a -> Bool notDodgy (L (EpAnn anc _ _) _) = notDodgyE anc @@ -3601,9 +3616,7 @@ instance ExactPrint (HsCmd GhcPs) where exact (HsCmdDo (an0,loc) es) = do debugM $ "HsCmdDo" loc' <- printStringAtAA loc "do" - (an1,es') <- markAnnList' an0 $ do - ee <- markAnnotated es - return ee + (an1,es') <- markAnnListD an0 $ do markAnnotated es return (HsCmdDo (an1,loc') es') -- --------------------------------------------------------------------- ===================================== utils/check-exact/Utils.hs ===================================== @@ -343,7 +343,6 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports annListBracketsLocs :: AnnListBrackets -> (EpaLocation,EpaLocation) annListBracketsLocs (ListBraces o c) = (getEpTokenLoc o, getEpTokenLoc c) -annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs ListNone = (noAnn, noAnn) data SplitWhere = Before | After View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/95d56c3329adb65eb345e3f22cf8d0a... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/95d56c3329adb65eb345e3f22cf8d0a... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help