Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 42724462 by Simon Hengel at 2025-08-21T17:52:11-04:00 Serialize wired-in names as external names when creating HIE files Note that the domain of de-serialized names stays the same. Specifically, for known-key names, before `lookupKnownKeyName` was used, while now this is handled by `lookupOrigNameCache` which captures the same range provided that the OrigNameCache has been initialized with `knownKeyNames` (which is the case by default). (fixes #26238) - - - - - 6a43f8ec by Cheng Shao at 2025-08-21T17:52:52-04:00 compiler: fix closure C type in SPT init code This patch fixes the closure C type in SPT init code to StgClosure, instead of the previously incorrect StgPtr. Having an incorrect C type makes SPT init code not compatible with other foreign stub generation logic, which may also emit their own extern declarations for the same closure symbols and thus will clash with the incorrect prototypes in SPT init code. - - - - - 0e575bfe by Ben Gamari at 2025-08-25T10:29:17-04:00 Revert "STM: don't create a transaction in the rhs of catchRetry# (#26028)" This reverts commit 0a5836891ca29836a24c306d2a364c2e4b5377fd - - - - - b69a9c35 by Cheng Shao at 2025-08-25T10:29:17-04:00 wasm: ensure setKeepCAFs() is called in ghci This patch is a critical bugfix for #26106, see comment and linked issue for details. - - - - - 12 changed files: - compiler/GHC/Iface/Ext/Binary.hs - compiler/GHC/Iface/Ext/Types.hs - compiler/GHC/Iface/Tidy/StaticPtrTable.hs - compiler/GHC/Types/Name/Cache.hs - rts/PrimOps.cmm - rts/RaiseAsync.c - rts/STM.c - − testsuite/tests/lib/stm/T26028.hs - − testsuite/tests/lib/stm/T26028.stdout - − testsuite/tests/lib/stm/all.T - utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs - utils/jsffi/dyld.mjs Changes: ===================================== compiler/GHC/Iface/Ext/Binary.hs ===================================== @@ -17,7 +17,6 @@ where import GHC.Prelude -import GHC.Builtin.Utils import GHC.Settings.Utils ( maybeRead ) import GHC.Settings.Config ( cProjectVersion ) import GHC.Utils.Binary @@ -28,10 +27,8 @@ import GHC.Iface.Binary ( putAllTables ) import GHC.Types.Name import GHC.Types.Name.Cache import GHC.Types.SrcLoc as SrcLoc -import GHC.Types.Unique import GHC.Types.Unique.FM import qualified GHC.Utils.Binary as Binary -import GHC.Utils.Outputable import GHC.Utils.Panic import qualified Data.Array as A @@ -290,6 +287,9 @@ fromHieName nc hie_name = do case hie_name of ExternalName mod occ span -> updateNameCache nc mod occ $ \cache -> do case lookupOrigNameCache cache mod occ of + -- Note that this may be a wired-in name (provided that the NameCache + -- was initialized with known-key names, which is always the case if you + -- use `newNameCache`). Just name -> pure (cache, name) Nothing -> do uniq <- takeUniqFromNameCache nc @@ -302,11 +302,6 @@ fromHieName nc hie_name = do -- don't update the NameCache for local names pure $ mkInternalName uniq occ span - KnownKeyName u -> case lookupKnownKeyName u of - Nothing -> pprPanic "fromHieName:unknown known-key unique" - (ppr u) - Just n -> pure n - -- ** Reading and writing `HieName`'s putHieName :: WriteBinHandle -> HieName -> IO () @@ -316,9 +311,6 @@ putHieName bh (ExternalName mod occ span) = do putHieName bh (LocalName occName span) = do putByte bh 1 put_ bh (occName, BinSrcSpan span) -putHieName bh (KnownKeyName uniq) = do - putByte bh 2 - put_ bh $ unpkUnique uniq getHieName :: ReadBinHandle -> IO HieName getHieName bh = do @@ -330,7 +322,4 @@ getHieName bh = do 1 -> do (occ, span) <- get bh return $ LocalName occ $ unBinSrcSpan span - 2 -> do - (c,i) <- get bh - return $ KnownKeyName $ mkUnique c i _ -> panic "GHC.Iface.Ext.Binary.getHieName: invalid tag" ===================================== compiler/GHC/Iface/Ext/Types.hs ===================================== @@ -19,14 +19,12 @@ import GHC.Prelude import GHC.Settings.Config import GHC.Utils.Binary import GHC.Data.FastString -import GHC.Builtin.Utils import GHC.Iface.Type import GHC.Unit.Module ( ModuleName, Module ) import GHC.Types.Name import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Types.SrcLoc import GHC.Types.Avail -import GHC.Types.Unique import qualified GHC.Utils.Outputable as O ( (<>) ) import GHC.Utils.Panic import GHC.Core.ConLike ( ConLike(..) ) @@ -766,7 +764,6 @@ instance Binary TyVarScope where data HieName = ExternalName !Module !OccName !SrcSpan | LocalName !OccName !SrcSpan - | KnownKeyName !Unique deriving (Eq) instance Ord HieName where @@ -774,34 +771,28 @@ instance Ord HieName where -- TODO (int-index): Perhaps use RealSrcSpan in HieName? compare (LocalName a b) (LocalName c d) = compare a c S.<> leftmost_smallest b d -- TODO (int-index): Perhaps use RealSrcSpan in HieName? - compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b - -- Not actually non deterministic as it is a KnownKey compare ExternalName{} _ = LT compare LocalName{} ExternalName{} = GT - compare LocalName{} _ = LT - compare KnownKeyName{} _ = GT instance Outputable HieName where ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp - ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u hieNameOcc :: HieName -> OccName hieNameOcc (ExternalName _ occ _) = occ hieNameOcc (LocalName occ _) = occ -hieNameOcc (KnownKeyName u) = - case lookupKnownKeyName u of - Just n -> nameOccName n - Nothing -> pprPanic "hieNameOcc:unknown known-key unique" - (ppr u) toHieName :: Name -> HieName -toHieName name - | isKnownKeyName name = KnownKeyName (nameUnique name) - | isExternalName name = ExternalName (nameModule name) - (nameOccName name) - (removeBufSpan $ nameSrcSpan name) - | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name) +toHieName name = + case nameModule_maybe name of + Nothing -> LocalName occName span + Just m -> ExternalName m occName span + where + occName :: OccName + occName = nameOccName name + + span :: SrcSpan + span = removeBufSpan $ nameSrcSpan name {- Note [Capture Entity Information] ===================================== compiler/GHC/Iface/Tidy/StaticPtrTable.hs ===================================== @@ -17,18 +17,18 @@ -- > static void hs_hpc_init_Main(void) { -- > -- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; --- > extern StgPtr Main_r2wb_closure; +-- > extern StgClosure Main_r2wb_closure; -- > hs_spt_insert(k0, &Main_r2wb_closure); -- > -- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; --- > extern StgPtr Main_r2wc_closure; +-- > extern StgClosure Main_r2wc_closure; -- > hs_spt_insert(k1, &Main_r2wc_closure); -- > -- > } -- -- where the constants are fingerprints produced from the static forms. -- --- The linker must find the definitions matching the @extern StgPtr <name>@ +-- The linker must find the definitions matching the @extern StgClosure <name>@ -- declarations. For this to work, the identifiers of static pointers need to be -- exported. This is done in 'GHC.Core.Opt.SetLevels.newLvlVar'. -- @@ -263,7 +263,7 @@ sptModuleInitCode platform this_mod entries -- CLabel. Regardless, MayHaveCafRefs/NoCafRefs wouldn't make -- any difference here, they would pretty-print to the same -- foreign stub content. - $$ text "extern StgPtr " + $$ text "extern StgClosure " <> (pprCLabel platform $ mkClosureLabel n MayHaveCafRefs) <> semi $$ text "hs_spt_insert" <> parens (hcat $ punctuate comma ===================================== compiler/GHC/Types/Name/Cache.hs ===================================== @@ -101,9 +101,14 @@ OrigNameCache at all? Good question; after all, 3) Loading of interface files encodes names via Uniques, as detailed in Note [Symbol table representation of names] in GHC.Iface.Binary -It turns out that we end up looking up built-in syntax in the cache when we -generate Haddock documentation. E.g. if we don't find tuple data constructors -there, hyperlinks won't work as expected. Test case: haddockHtmlTest (Bug923.hs) + +However note that: + 1) It turns out that we end up looking up built-in syntax in the cache when + we generate Haddock documentation. E.g. if we don't find tuple data + constructors there, hyperlinks won't work as expected. Test case: + haddockHtmlTest (Bug923.hs) + 2) HIE de-serialization relies on wired-in names, including built-in syntax, + being present in the OrigNameCache. -} -- | The NameCache makes sure that there is just one Unique assigned for ===================================== rts/PrimOps.cmm ===================================== @@ -1211,27 +1211,16 @@ INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME, gcptr trec, outer, arg; trec = StgTSO_trec(CurrentTSO); - if (running_alt_code != 1) { - // When exiting the lhs code of catchRetry# lhs rhs, we need to cleanup - // the nested transaction. - // See Note [catchRetry# implementation] - outer = StgTRecHeader_enclosing_trec(trec); - (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr"); - if (r != 0) { - // Succeeded in first branch - StgTSO_trec(CurrentTSO) = outer; - return (ret); - } else { - // Did not commit: abort and restart. - StgTSO_trec(CurrentTSO) = outer; - jump stg_abort(); - } - } - else { - // nothing to do in the rhs code of catchRetry# lhs rhs, it's already - // using the parent transaction (not a nested one). - // See Note [catchRetry# implementation] - return (ret); + outer = StgTRecHeader_enclosing_trec(trec); + (r) = ccall stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr"); + if (r != 0) { + // Succeeded (either first branch or second branch) + StgTSO_trec(CurrentTSO) = outer; + return (ret); + } else { + // Did not commit: abort and restart. + StgTSO_trec(CurrentTSO) = outer; + jump stg_abort(); } } @@ -1464,26 +1453,21 @@ retry_pop_stack: outer = StgTRecHeader_enclosing_trec(trec); if (frame_type == CATCH_RETRY_FRAME) { - // The retry reaches a CATCH_RETRY_FRAME before the ATOMICALLY_FRAME - + // The retry reaches a CATCH_RETRY_FRAME before the atomic frame + ASSERT(outer != NO_TREC); + // Abort the transaction attempting the current branch + ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr"); + ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr"); if (!StgCatchRetryFrame_running_alt_code(frame) != 0) { - // Retrying in the lhs of catchRetry# lhs rhs, i.e. in a nested - // transaction. See Note [catchRetry# implementation] - - // check that we have a parent transaction - ASSERT(outer != NO_TREC); - - // Abort the nested transaction - ccall stmAbortTransaction(MyCapability() "ptr", trec "ptr"); - ccall stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr"); - - // As we are retrying in the lhs code, we must now try the rhs code - StgTSO_trec(CurrentTSO) = outer; + // Retry in the first branch: try the alternative + ("ptr" trec) = ccall stmStartTransaction(MyCapability() "ptr", outer "ptr"); + StgTSO_trec(CurrentTSO) = trec; StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true; R1 = StgCatchRetryFrame_alt_code(frame); jump stg_ap_v_fast [R1]; } else { - // Retry in the rhs code: propagate the retry + // Retry in the alternative code: propagate the retry + StgTSO_trec(CurrentTSO) = outer; Sp = Sp + SIZEOF_StgCatchRetryFrame; goto retry_pop_stack; } ===================================== rts/RaiseAsync.c ===================================== @@ -1043,7 +1043,8 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, } case CATCH_STM_FRAME: - // CATCH_STM frame within an atomically block: abort the + case CATCH_RETRY_FRAME: + // CATCH frames within an atomically block: abort the // inner transaction and continue. Eventually we will // hit the outer transaction that will get frozen (see // above). @@ -1055,40 +1056,14 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, { StgTRecHeader *trec = tso -> trec; StgTRecHeader *outer = trec -> enclosing_trec; - debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_STM frame"); + debugTraceCap(DEBUG_stm, cap, + "found atomically block delivering async exception"); stmAbortTransaction(cap, trec); stmFreeAbortedTRec(cap, trec); tso -> trec = outer; break; }; - case CATCH_RETRY_FRAME: - // CATCH_RETY frame within an atomically block: if we're executing - // the lhs code, abort the inner transaction and continue; if we're - // executing thr rhs, continue (no nested transaction to abort. See - // Note [catchRetry# implementation]). Eventually we will hit the - // outer transaction that will get frozen (see above). - // - // As for the CATCH_STM_FRAME case above, we do not care - // whether the transaction is valid or not because its - // possible validity cannot have caused the exception - // and will not be visible after the abort. - { - if (!((StgCatchRetryFrame *)frame) -> running_alt_code) { - debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (lhs)"); - StgTRecHeader *trec = tso -> trec; - StgTRecHeader *outer = trec -> enclosing_trec; - stmAbortTransaction(cap, trec); - stmFreeAbortedTRec(cap, trec); - tso -> trec = outer; - } - else - { - debugTraceCap(DEBUG_stm, cap, "raiseAsync: traversing CATCH_RETRY frame (rhs)"); - } - break; - }; - default: // see Note [Update async masking state on unwind] in Schedule.c if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) { ===================================== rts/STM.c ===================================== @@ -1505,30 +1505,3 @@ void stmWriteTVar(Capability *cap, } /*......................................................................*/ - - - -/* - -Note [catchRetry# implementation] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -catchRetry# creates a nested transaction for its lhs: -- if the lhs transaction succeeds: - - the lhs transaction is committed - - its read-variables are merged with those of the parent transaction - - the rhs code is ignored -- if the lhs transaction retries: - - the lhs transaction is aborted - - its read-variables are merged with those of the parent transaction - - the rhs code is executed directly in the parent transaction (see #26028). - -So note that: -- lhs code uses a nested transaction -- rhs code doesn't use a nested transaction - -We have to take which case we're in into account (using the running_alt_code -field of the catchRetry frame) in catchRetry's entry code, in retry# -implementation, and also when an async exception is received (to cleanup the -right number of transactions). - -*/ ===================================== testsuite/tests/lib/stm/T26028.hs deleted ===================================== @@ -1,23 +0,0 @@ -module Main where - -import GHC.Conc - -forever :: IO String -forever = delay 10 >> forever - -terminates :: IO String -terminates = delay 1 >> pure "terminates" - -delay s = threadDelay (1000000 * s) - -async :: IO a -> IO (STM a) -async a = do - var <- atomically (newTVar Nothing) - forkIO (a >>= atomically . writeTVar var . Just) - pure (readTVar var >>= maybe retry pure) - -main :: IO () -main = do - x <- mapM async $ terminates : replicate 50000 forever - r <- atomically (foldr1 orElse x) - print r ===================================== testsuite/tests/lib/stm/T26028.stdout deleted ===================================== @@ -1 +0,0 @@ -"terminates" ===================================== testsuite/tests/lib/stm/all.T deleted ===================================== @@ -1 +0,0 @@ -test('T26028', only_ways(['threaded1']), compile_and_run, ['-O2']) ===================================== utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs ===================================== @@ -229,10 +229,7 @@ writeInterfaceFile filename iface = do return () freshNameCache :: IO NameCache -freshNameCache = - initNameCache - 'a' -- ?? - [] +freshNameCache = newNameCache -- | Read a Haddock (@.haddock@) interface file. Return either an -- 'InterfaceFile' or an error message. ===================================== utils/jsffi/dyld.mjs ===================================== @@ -1105,6 +1105,20 @@ class DyLD { if (/libHSghc-internal-\d+(\.\d+)*/i.test(soname)) { this.rts_init(); delete this.rts_init; + + // At this point the RTS symbols in linear memory are fixed + // and constructors are run, especially the one in JSFFI.c + // that does GHC RTS initialization for any code that links + // JSFFI.o. Luckily no Haskell computation or gc has taken + // place yet, so we must set keepCAFs=1 right now! Otherwise, + // any BCO created by later TH splice or ghci expression may + // refer to any CAF that's not reachable from GC roots (here + // our only entry point is defaultServer) and the CAF could + // have been GC'ed! (#26106) + // + // We call it here instead of in RTS C code, since we only + // want keepCAFs=1 for ghci, not user code. + this.exportFuncs.setKeepCAFs(); } init(); } View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b5431ced6b0693ba980140b15207e30... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/b5431ced6b0693ba980140b15207e30... You're receiving this email because of your account on gitlab.haskell.org.