Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: a1de535f by Luite Stegeman at 2025-09-30T18:40:28-04:00 rts: Fix lost wakeups in threadPaused for threads blocked on black holes The lazy blackholing code in threadPaused could overwrite closures that were already eagerly blackholed, and as such wouldn't have a marked update frame. If the black hole was overwritten by its original owner, this would lead to an undetected collision, and the contents of any existing blocking queue being lost. This adds a check for eagerly blackholed closures and avoids overwriting their contents. Fixes #26324 - - - - - b7e21e49 by Luite Stegeman at 2025-09-30T18:40:28-04:00 rts: push the correct update frame in stg_AP_STACK The frame contains an eager black hole (__stg_EAGER_BLACKHOLE_info) so we should push an stg_bh_upd_frame_info instead of an stg_upd_frame_info. - - - - - 02a7c18a by Cheng Shao at 2025-09-30T18:41:27-04:00 ghci: fix lookupSymbolInDLL behavior on wasm This patch fixes lookupSymbolInDLL behavior on wasm to return Nothing instead of throwing. On wasm, we only have lookupSymbol, and the driver would attempt to call lookupSymbolInDLL first before falling back to lookupSymbol, so lookupSymbolInDLL needs to return Nothing gracefully for the fallback behavior to work. - - - - - aa0ca5e3 by Cheng Shao at 2025-09-30T18:41:27-04:00 hadrian/compiler: enable internal-interpreter for ghc library in wasm stage1 This commit enables the internal-interpreter flag for ghc library in wasm stage1, as well as other minor adjustments to make it actually possible to launch a ghc api session that makes use of the internal interpreter. Closes #26431 #25400. - - - - - 69503668 by Cheng Shao at 2025-09-30T18:41:27-04:00 testsuite: add T26431 test case This commit adds T26431 to testsuite/tests/ghci-wasm which goes through the complete bytecode compilation/linking/running pipeline in wasm, so to witness that the ghc shared library in wasm have full support for internal-interpreter. - - - - - e9445c01 by Matthew Pickering at 2025-09-30T18:42:23-04:00 driver: Load bytecode static pointer entries during linking Previously the entries were loaded too eagerly, during upsweep, but we should delay loading them until we know that the relevant bytecode object is demanded. Towards #25230 - - - - - b8307eab by Cheng Shao at 2025-09-30T18:43:14-04:00 autoconf/ghc-toolchain: remove obsolete C99 check This patch removes obsolete c99 check from autoconf/ghc-toolchain. For all toolchain & platform combination we support, gnu11 or above is already supported without any -std flag required, and our RTS already required C11 quite a few years ago, so the C99 check is completely pointless. - - - - - 9c293544 by Simon Peyton Jones at 2025-10-01T09:36:10+01:00 Fix buglet in GHC.Core.Unify.uVarOrFam We were failing to match two totally-equal types! This led to #26457. - - - - - d21638e3 by Rodrigo Mesquita at 2025-10-01T18:03:13-04:00 cleanup: Drop obsolete comment about HsConDetails HsConDetails used to have an argument representing the type of the tyargs in a list: data HsConDetails tyarg arg rec = PrefixCon [tyarg] [arg] This datatype was shared across 3 synonyms: HsConPatDetails, HsConDeclH98Details, HsPatSynDetails. In the latter two cases, `tyarg` was instanced to `Void` meaning the list was always empty for these cases. In 7b84c58867edca57a45945a20a9391724db6d9e4, this was refactored such that HsConDetails no longer needs a type of tyargs by construction. The first case now represents the type arguments in the args type itself, with something like: ConPat "MkE" [InvisP tp1, InvisP tp2, p1, p2] So the deleted comment really is just obsolete. Fixes #26461 - - - - - 25 changed files: - compiler/GHC.hs - compiler/GHC/Cmm/Parser.y - compiler/GHC/Core/Unify.hs - compiler/GHC/Driver/Main.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Iface/Tidy/StaticPtrTable.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Interpreter/Types.hs - compiler/Language/Haskell/Syntax/Decls.hs - configure.ac - distrib/configure.ac.in - hadrian/src/Settings/Packages.hs - libraries/ghci/GHCi/ObjLink.hs - m4/fp_cmm_cpp_cmd_with_args.m4 - − m4/fp_set_cflags_c99.m4 - rts/Apply.cmm - rts/ThreadPaused.c - + testsuite/tests/ghci-wasm/T26431.hs - + testsuite/tests/ghci-wasm/T26431.stdout - testsuite/tests/ghci-wasm/all.T - + testsuite/tests/typecheck/should_compile/T26457.hs - testsuite/tests/typecheck/should_compile/all.T - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cc.hs - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -716,17 +716,14 @@ setTopSessionDynFlags dflags = do -- see Note [Target code interpreter] interp <- if +#if !defined(wasm32_HOST_ARCH) -- Wasm dynamic linker | ArchWasm32 <- platformArch $ targetPlatform dflags -> do s <- liftIO $ newMVar InterpPending loader <- liftIO Loader.uninitializedLoader dyld <- liftIO $ makeAbsolute $ topDir dflags "dyld.mjs" -#if defined(wasm32_HOST_ARCH) - let libdir = sorry "cannot spawn child process on wasm" -#else libdir <- liftIO $ last <$> Loader.getGccSearchDirectory logger dflags "libraries" -#endif let profiled = ways dflags `hasWay` WayProf way_tag = if profiled then "_p" else "" let cfg = @@ -747,6 +744,7 @@ setTopSessionDynFlags dflags = do wasmInterpUnitState = ue_homeUnitState $ hsc_unit_env hsc_env } pure $ Just $ Interp (ExternalInterp $ ExtWasm $ ExtInterpState cfg s) loader lookup_cache +#endif -- JavaScript interpreter | ArchJavaScript <- platformArch (targetPlatform dflags) ===================================== compiler/GHC/Cmm/Parser.y ===================================== @@ -1321,6 +1321,7 @@ stmtMacros = listToUFM [ ( fsLit "PROF_HEADER_CREATE", \[e] -> profHeaderCreate e ), ( fsLit "PUSH_UPD_FRAME", \[sp,e] -> emitPushUpdateFrame sp e ), + ( fsLit "PUSH_BH_UPD_FRAME", \[sp,e] -> emitPushBHUpdateFrame sp e ), ( fsLit "SET_HDR", \[ptr,info,ccs] -> emitSetDynHdr ptr info ccs ), ( fsLit "TICK_ALLOC_PRIM", \[hdr,goods,slop] -> @@ -1336,6 +1337,10 @@ emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode () emitPushUpdateFrame sp e = do emitUpdateFrame sp mkUpdInfoLabel e +emitPushBHUpdateFrame :: CmmExpr -> CmmExpr -> FCode () +emitPushBHUpdateFrame sp e = do + emitUpdateFrame sp mkBHUpdInfoLabel e + pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse () pushStackFrame fields body = do profile <- getProfile ===================================== compiler/GHC/Core/Unify.hs ===================================== @@ -288,10 +288,11 @@ Wrinkles (ATF3) What about foralls? For example, supppose we are unifying (forall a. F a) -> (forall a. F a) - Those two (F a) types are unrelated, bound by different foralls. + against some other type. Those two (F a) types are unrelated, bound by + different foralls; we cannot extend the um_fam_env with a binding [F a :-> blah] So to keep things simple, the entire family-substitution machinery is used - only if there are no enclosing foralls (see the (um_foralls env)) check in + only if there are no enclosing foralls (see the `under_forall` check in `uSatFamApp`). That's fine, because the apartness business is used only for reducing type-family applications, and class instances, and their arguments can't have foralls anyway. @@ -329,6 +330,8 @@ Wrinkles instance (Generic1 f, Ord (Rep1 f a)) => Ord (Generically1 f a) where ... -- The "..." gives rise to [W] Ord (Generically1 f a) + where Rep1 is a type family. + We must use the instance decl (recursively) to simplify the [W] constraint; we do /not/ want to worry that the `[G] Ord (Rep1 f a)` might be an alternative path. So `noMatchableGivenDicts` must return False; @@ -336,6 +339,12 @@ Wrinkles `DontBindMe`, the unifier must return `SurelyApart`, not `MaybeApart`. See `go` in `uVarOrFam` + This looks a bit sketchy, because they aren't SurelyApart, but see + Note [What might equal later?] in GHC.Tc.Utils.Unify, esp "Red Herring". + + If we are under a forall, we return `MaybeApart`; that seems more conservative, + and class constraints are on tau-types so it doesn't matter. + (ATF6) When /matching/ can we ever have a type-family application on the LHS, in the template? You might think not, because type-class-instance and type-family-instance heads can't include type families. E.g. @@ -344,12 +353,12 @@ Wrinkles But you'd be wrong: even when matching, we can see type families in the LHS template: * In `checkValidClass`, in `check_dm` we check that the default method has the right type, using matching, both ways. And that type may have type-family - applications in it. Example in test CoOpt_Singletons. + applications in it. Examples in test CoOpt_Singletons and T26457. * In the specialiser: see the call to `tcMatchTy` in `GHC.Core.Opt.Specialise.beats_or_same` - * With -fpolymorphic-specialsation, we might get a specialiation rule like + * With -fpolymorphic-specialisation, we might get a specialiation rule like RULE forall a (d :: Eq (Maybe (F a))) . f @(Maybe (F a)) d = ... See #25965. @@ -362,7 +371,7 @@ Wrinkles type variables/ that makes the match work. So we simply want to recurse into the arguments of the type family. E.g. Template: forall a. Maybe (F a) - Target: Mabybe (F Int) + Target: Maybe (F Int) We want to succeed with substitution [a :-> Int]. See (ATF9). Conclusion: where we enter via `tcMatchTy`, `tcMatchTys`, `tc_match_tys`, @@ -378,10 +387,10 @@ Wrinkles type family G6 a = r | r -> a type instance G6 [a] = [G a] type instance G6 Bool = Int - and suppose we haev a Wanted constraint + and suppose we have a Wanted constraint [W] G6 alpha ~ [Int] -. According to Section 5.2 of "Injective type families for Haskell", we /match/ - the RHS each type instance [Int]. So we try + According to Section 5.2 of "Injective type families for Haskell", we /match/ + the RHS each of type instance with [Int]. So we try Template: [G a] Target: [Int] and we want to succeed with MaybeApart, so that we can generate the improvement constraint @@ -401,15 +410,21 @@ Wrinkles (ATF9) Decomposition. Consider unifying F a ~ F Int - There is a unifying substitition [a :-> Int], and we want to find it, returning - Unifiable. (Remember, this is the Core unifier -- we are not doing type inference.) - So we should decompose to get (a ~ Int) + when `um_bind_fam_fun` says DontBindMe. There is a unifying substitition [a :-> Int], + and we want to find it, returning Unifiable. Why? + - Remember, this is the Core unifier -- we are not doing type inference + - When we have two equal types, like F a ~ F a, it is ridiculous to say that they + are MaybeApart. Example: the two-way tcMatchTy in `checkValidClass` and #26457. - But consider unifying + (ATF9-1) But consider unifying F Int ~ F Bool - Although Int and Bool are SurelyApart, we must return MaybeApart for the outer - unification. Hence the use of `don'tBeSoSure` in `go_fam_fam`; it leaves Unifiable - alone, but weakens `SurelyApart` to `MaybeApart`. + Although Int and Bool are SurelyApart, we must return MaybeApart for the outer + unification. Hence the use of `don'tBeSoSure` in `go_fam_fam`; it leaves Unifiable + alone, but weakens `SurelyApart` to `MaybeApart`. + + (ATF9-2) We want this decomposition to occur even under a forall (this was #26457). + E.g. (forall a. F Int) -> Int ~ (forall a. F Int) ~ Int + (ATF10) Injectivity. Consider (AFT9) where F is known to be injective. Then if we are unifying @@ -1815,6 +1830,9 @@ uVarOrFam env ty1 ty2 kco -- , text "fam_env" <+> ppr (um_fam_env substs) ]) $ ; go NotSwapped substs ty1 ty2 kco } where + foralld_tvs = um_foralls env + under_forall = not (isEmptyVarSet foralld_tvs) + -- `go` takes two bites at the cherry; if the first one fails -- it swaps the arguments and tries again; and then it fails. -- The SwapFlag argument tells `go` whether it is on the first @@ -1889,7 +1907,6 @@ uVarOrFam env ty1 ty2 kco | otherwise = False - foralld_tvs = um_foralls env occurs_check = um_unif env && uOccursCheck substs foralld_tvs lhs rhs -- Occurs check, only when unifying -- see Note [Infinitary substitutions] @@ -1899,14 +1916,11 @@ uVarOrFam env ty1 ty2 kco -- LHS is a saturated type-family application -- Invariant: ty2 is not a TyVarTy go swapped substs lhs@(TyFamLHS tc1 tys1) ty2 kco - -- If we are under a forall, just give up and return MaybeApart - -- see (ATF3) in Note [Apartness and type families] - | not (isEmptyVarSet (um_foralls env)) - = maybeApart MARTypeFamily - - -- We are not under any foralls, so the RnEnv2 is empty -- Check if we have an existing substitution for the LHS; if so, recurse - | Just ty1' <- lookupFamEnv (um_fam_env substs) tc1 tys1 + -- But not under a forall; see (ATF3) in Note [Apartness and type families] + -- Hence the RnEnv2 is empty + | not under_forall + , Just ty1' <- lookupFamEnv (um_fam_env substs) tc1 tys1 = if | um_unif env -> unify_ty env ty1' ty2 kco -- Below here we are matching -- The return () case deals with: @@ -1917,11 +1931,19 @@ uVarOrFam env ty1 ty2 kco | otherwise -> maybeApart MARTypeFamily -- Check for equality F tys1 ~ F tys2 + -- Very important that this can happen under a forall, so that we + -- successfully match (forall a. F a) ~ (forall b. F b) See (ATF9-2) | Just (tc2, tys2) <- isSatTyFamApp ty2 , tc1 == tc2 = go_fam_fam substs tc1 tys1 tys2 kco + -- If we are under a forall, just give up + -- see (ATF3) and (ATF5) in Note [Apartness and type families] + | under_forall + = maybeApart MARTypeFamily + -- Now check if we can bind the (F tys) to the RHS + -- Again, not under a forall; see (ATF3) -- This can happen even when matching: see (ATF7) | BindMe <- um_bind_fam_fun env tc1 tys1 rhs = if uOccursCheck substs emptyVarSet lhs rhs @@ -1935,6 +1957,7 @@ uVarOrFam env ty1 ty2 kco -- Maybe um_bind_fam_fun is False of (F a b) but true of (G c d e) -- NB: a type family can appear on the template when matching -- see (ATF6) in Note [Apartness and type families] + -- (Only worth doing this if we are not under a forall.) | um_unif env , NotSwapped <- swapped , Just lhs2 <- canEqLHS_maybe ty2 @@ -1949,7 +1972,6 @@ uVarOrFam env ty1 ty2 kco ----------------------------- -- go_fam_fam: LHS and RHS are both saturated type-family applications, -- for the same type-family F - -- Precondition: um_foralls is empty go_fam_fam substs tc tys1 tys2 kco -- Decompose (F tys1 ~ F tys2): (ATF9) -- Use injectivity information of F: (ATF10) @@ -1957,7 +1979,7 @@ uVarOrFam env ty1 ty2 kco = do { bind_fam_if_poss -- (ATF11) ; unify_tys env inj_tys1 inj_tys2 -- (ATF10) ; unless (um_inj_tf env) $ -- (ATF12) - don'tBeSoSure MARTypeFamily $ -- (ATF9) + don'tBeSoSure MARTypeFamily $ -- (ATF9-1) unify_tys env noninj_tys1 noninj_tys2 } where inj = case tyConInjectivityInfo tc of @@ -1970,6 +1992,8 @@ uVarOrFam env ty1 ty2 kco bind_fam_if_poss | not (um_unif env) -- Not when matching (ATF11-1) = return () + | under_forall -- Not under a forall (ATF3) + = return () | BindMe <- um_bind_fam_fun env tc tys1 rhs1 = unless (uOccursCheck substs emptyVarSet (TyFamLHS tc tys1) rhs1) $ extendFamEnv tc tys1 rhs1 ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -102,7 +102,6 @@ module GHC.Driver.Main , dumpIfaceStats , ioMsgMaybe , showModuleIndex - , hscAddSptEntries , writeInterfaceOnlyMode , loadByteCode , genModDetails @@ -2515,9 +2514,6 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do let src_span = srcLocSpan interactiveSrcLoc _ <- liftIO $ loadDecls interp hsc_env src_span linkable - {- Load static pointer table entries -} - liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg) - let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) patsyns = mg_patsyns simpl_mg @@ -2539,18 +2535,6 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do fam_insts defaults fix_env return (new_tythings, new_ictxt) --- | Load the given static-pointer table entries into the interpreter. --- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable". -hscAddSptEntries :: HscEnv -> [SptEntry] -> IO () -hscAddSptEntries hsc_env entries = do - let interp = hscInterp hsc_env - let add_spt_entry :: SptEntry -> IO () - add_spt_entry (SptEntry n fpr) = do - -- These are only names from the current module - (val, _, _) <- loadName interp hsc_env n - addSptEntry interp fpr val - mapM_ add_spt_entry entries - {- Note [Fixity declarations in GHCi] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -56,8 +56,6 @@ import GHC.Tc.Utils.Monad ( initIfaceCheck, concatMapM ) import GHC.Runtime.Interpreter import qualified GHC.Linker.Loader as Linker -import GHC.Linker.Types - import GHC.Driver.Config.Diagnostic import GHC.Driver.Pipeline @@ -72,8 +70,6 @@ import GHC.Driver.MakeSem import GHC.Driver.Downsweep import GHC.Driver.MakeAction -import GHC.ByteCode.Types - import GHC.Iface.Load ( cannotFindModule, readIface ) import GHC.IfaceToCore ( typecheckIface ) import GHC.Iface.Recomp ( RecompileRequired(..), CompileReason(..) ) @@ -1232,31 +1228,9 @@ upsweep_mod :: HscEnv upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods = do hmi <- compileOne' mHscMessage hsc_env summary mod_index nmods (hm_iface <$> old_hmi) (maybe emptyHomeModInfoLinkable hm_linkable old_hmi) - - -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module - -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I - -- am unsure if this is sound (wrt running TH splices for example). - -- This function only does anything if the linkable produced is a BCO, which - -- used to only happen with the bytecode backend, but with - -- @-fprefer-byte-code@, @HomeModInfo@ has bytecode even when generating - -- object code, see #25230. hscInsertHPT hmi hsc_env - addSptEntries (hsc_env) - (homeModInfoByteCode hmi) - return hmi --- | Add the entries from a BCO linkable to the SPT table, see --- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable. -addSptEntries :: HscEnv -> Maybe Linkable -> IO () -addSptEntries hsc_env mlinkable = - hscAddSptEntries hsc_env - [ spt - | linkable <- maybeToList mlinkable - , bco <- linkableBCOs linkable - , spt <- bc_spt_entries bco - ] - -- Note [When source is considered modified] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -3763,12 +3763,17 @@ makeDynFlagsConsistent dflags -- only supports dynamic code | LinkInMemory <- ghcLink dflags , sTargetRTSLinkerOnlySupportsSharedLibs $ settings dflags +#if defined(HAVE_INTERNAL_INTERPRETER) + , not (ways dflags `hasWay` WayDyn) +#else , not (ways dflags `hasWay` WayDyn && gopt Opt_ExternalInterpreter dflags) +#endif = flip loopNoWarn "Forcing dynamic way because target RTS linker only supports dynamic code" $ - -- See checkOptions, -fexternal-interpreter is - -- required when using --interactive with a non-standard - -- way (-prof, -static, or -dynamic). +#if !defined(HAVE_INTERNAL_INTERPRETER) + -- Force -fexternal-interpreter if internal-interpreter is not + -- available at this stage setGeneralFlag' Opt_ExternalInterpreter $ +#endif addWay' WayDyn dflags | LinkInMemory <- ghcLink dflags ===================================== compiler/GHC/Iface/Tidy/StaticPtrTable.hs ===================================== @@ -124,7 +124,7 @@ Here is a running example: * If we are compiling for the byte-code interpreter, we instead explicitly add the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter process' SPT table using the addSptEntry interpreter message. This happens - in upsweep after we have compiled the module (see GHC.Driver.Make.upsweep'). + when the bytecode object is linked in `dynLinkBCOs`. -} import GHC.Prelude ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -718,6 +718,7 @@ loadDecls interp hsc_env span linkable = do let ce2 = extendClosureEnv (closure_env le2) nms_fhvs !pls2 = pls { linker_env = le2 { closure_env = ce2 } , linked_breaks = lb2 } + mapM_ (linkSptEntry interp ce2) (concatMap bc_spt_entries cbcs) return (pls2, (nms_fhvs, links_needed, units_needed)) where cbcs = linkableBCOs linkable @@ -951,10 +952,28 @@ dynLinkBCOs interp pls bcos = do -- Wrap finalizers on the ones we want to keep new_binds <- makeForeignNamedHValueRefs interp to_add + let ce2 = extendClosureEnv (closure_env le2) new_binds + + -- Add SPT entries + mapM_ (linkSptEntry interp ce2) (concatMap bc_spt_entries cbcs) + return $! pls1 { linker_env = le2 { closure_env = ce2 } , linked_breaks = lb2 } +-- | Register SPT entries for this module in the interpreter +-- Assumes that the name from the SPT has already been loaded into the interpreter. +linkSptEntry :: Interp -> ClosureEnv -> SptEntry -> IO () +linkSptEntry interp ce (SptEntry name fpr) = do + case lookupNameEnv ce name of + -- The SPT entries only point to locally defined names, which should have already been + -- loaded into the interpreter before this function is called. + Nothing -> pprPanic "linkSptEntry" (ppr name) + Just (_, hval) -> addSptEntry interp fpr hval + + + + -- Link a bunch of BCOs and return references to their values linkSomeBCOs :: Interp -> PkgsLoaded @@ -1614,6 +1633,9 @@ gccSearchDirCache = unsafePerformIO $ newIORef [] -- which dominate a large percentage of startup time on Windows. getGccSearchDirectory :: Logger -> DynFlags -> String -> IO [FilePath] getGccSearchDirectory logger dflags key = do +#if defined(wasm32_HOST_ARCH) + pure [] +#else cache <- readIORef gccSearchDirCache case lookup key cache of Just x -> return x @@ -1640,6 +1662,7 @@ getGccSearchDirectory logger dflags key = do x:_ -> case break (=='=') x of (_ , []) -> [] (_, (_:xs)) -> xs +#endif -- | Get a list of system search directories, this to alleviate pressure on -- the findSysDll function. ===================================== compiler/GHC/Runtime/Interpreter/Types.hs ===================================== @@ -214,7 +214,7 @@ data JSInterpConfig = JSInterpConfig data WasmInterpConfig = WasmInterpConfig { wasmInterpDyLD :: !FilePath -- ^ Location of dyld.mjs script - , wasmInterpLibDir :: FilePath -- ^ wasi-sdk sysroot libdir containing libc.so, etc + , wasmInterpLibDir :: !FilePath -- ^ wasi-sdk sysroot libdir containing libc.so, etc , wasmInterpOpts :: ![String] -- ^ Additional command line arguments for iserv -- wasm ghci browser mode ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -1120,8 +1120,6 @@ or contexts in two parts: -- | The arguments in a Haskell98-style data constructor. type HsConDeclH98Details pass = HsConDetails (HsConDeclField pass) (XRec pass [LHsConDeclRecField pass]) --- The Void argument to HsConDetails here is a reflection of the fact that --- type applications are not allowed in data constructor declarations. -- | The arguments in a GADT constructor. Unlike Haskell98-style constructors, -- GADT constructors cannot be declared with infix syntax. As a result, we do ===================================== configure.ac ===================================== @@ -448,11 +448,6 @@ AC_SUBST([CmmCPPCmd]) AC_SUBST([CmmCPPArgs]) AC_SUBST([CmmCPPSupportsG0]) -FP_SET_CFLAGS_C99([CC],[CFLAGS],[CPPFLAGS]) -FP_SET_CFLAGS_C99([CC_STAGE0],[CONF_CC_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0]) -FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE1],[CONF_CPP_OPTS_STAGE1]) -FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2]) - dnl ** Do we have a compatible emsdk version? dnl -------------------------------------------------------------- EMSDK_VERSION("3.1.20", "", "") ===================================== distrib/configure.ac.in ===================================== @@ -163,11 +163,6 @@ AC_SUBST([CmmCPPCmd]) AC_SUBST([CmmCPPArgs]) AC_SUBST([CmmCPPSupportsG0]) -FP_SET_CFLAGS_C99([CC],[CFLAGS],[CPPFLAGS]) -dnl FP_SET_CFLAGS_C99([CC_STAGE0],[CONF_CC_OPTS_STAGE0],[CONF_CPP_OPTS_STAGE0]) -FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE1],[CONF_CPP_OPTS_STAGE1]) -FP_SET_CFLAGS_C99([CC],[CONF_CC_OPTS_STAGE2],[CONF_CPP_OPTS_STAGE2]) - dnl ** Which ld to use? dnl -------------------------------------------------------------- FIND_LD([$target],[GccUseLdOpt]) ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -82,15 +82,18 @@ packageArgs = do ] , builder (Cabal Flags) ? mconcat - -- For the ghc library, internal-interpreter only makes - -- sense when we're not cross compiling. For cross GHC, - -- external interpreter is used for loading target code - -- and internal interpreter is supposed to load native - -- code for plugins (!7377), however it's unfinished work - -- (#14335) and completely untested in CI for cross - -- backends at the moment, so we might as well disable it - -- for cross GHC. - [ andM [expr (ghcWithInterpreter stage), notCross] `cabalFlag` "internal-interpreter" + -- In order to enable internal-interpreter for the ghc + -- library: + -- + -- 1. ghcWithInterpreter must be True ("Use interpreter" = + -- "YES") + -- 2. For non-cross case it can be enabled + -- 3. For cross case, disable for stage0 since that runs + -- on the host and must rely on external interpreter to + -- load target code, otherwise enable for stage1 since + -- that runs on the target and can use target's own + -- ghci object linker + [ andM [expr (ghcWithInterpreter stage), orM [notCross, stage1]] `cabalFlag` "internal-interpreter" , orM [ notM cross, haveCurses ] `cabalFlag` "terminfo" , arg "-build-tool-depends" , flag UseLibzstd `cabalFlag` "with-libzstd" ===================================== libraries/ghci/GHCi/ObjLink.hs ===================================== @@ -113,8 +113,7 @@ foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbol($1)" js_lookupSymbol :: JSString -> IO (Ptr a) lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a)) -lookupSymbolInDLL _ sym = - throwIO $ ErrorCall $ "lookupSymbolInDLL: unsupported on wasm for " <> sym +lookupSymbolInDLL _ _ = pure Nothing resolveObjs :: IO Bool resolveObjs = pure True ===================================== m4/fp_cmm_cpp_cmd_with_args.m4 ===================================== @@ -56,27 +56,6 @@ else AC_MSG_RESULT([no]) fi -AC_MSG_CHECKING([the C-- preprocessor for C99 support]) -cat > conftest.c < -#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L -# error "Compiler does not advertise C99 conformance" -#endif -EOF -if "$CMM_CPP_CMD" $CMM_CPP_ARGS conftest.c -o conftest -g0 >/dev/null 2>&1; then - AC_MSG_RESULT([yes]) -else - # Try -std=gnu99 - if "$CMM_CPP_CMD" -std=gnu99 $CMM_CPP_ARGS conftest.c -o conftest -g0 >/dev/null 2>&1; then - $3="-std=gnu99 $$3" - AC_MSG_RESULT([needs -std=gnu99]) - else - AC_MSG_ERROR([C99-compatible compiler needed]) - fi -fi -rm -f conftest.c conftest.o conftest - - $2="$CMM_CPP_CMD" $3="$$3 $CMM_CPP_ARGS" @@ -85,4 +64,3 @@ unset CMM_CPP_CMD unset CMM_CPP_ARGS ]) - ===================================== m4/fp_set_cflags_c99.m4 deleted ===================================== @@ -1,38 +0,0 @@ -# FP_SET_CFLAGS_C99 -# ---------------------------------- -# figure out which CFLAGS are needed to place the compiler into C99 mode -# $1 is name of CC variable (unmodified) -# $2 is name of CC flags variable (augmented if needed) -# $3 is name of CPP flags variable (augmented if needed) -AC_DEFUN([FP_SET_CFLAGS_C99], -[ - dnl save current state of AC_PROG_CC_C99 - FP_COPY_SHELLVAR([CC],[fp_save_CC]) - FP_COPY_SHELLVAR([CFLAGS],[fp_save_CFLAGS]) - FP_COPY_SHELLVAR([CPPFLAGS],[fp_save_CPPFLAGS]) - FP_COPY_SHELLVAR([ac_cv_prog_cc_c99],[fp_save_cc_c99]) - dnl set local state - CC="$$1" - CFLAGS="$$2" - CPPFLAGS="$$3" - unset ac_cv_prog_cc_c99 - dnl perform detection - AC_PROG_CC_C99 - fp_cc_c99="$ac_cv_prog_cc_c99" - case "x$ac_cv_prog_cc_c99" in - x) ;; # noop - xno) AC_MSG_ERROR([C99-compatible compiler needed]) ;; - *) $2="$$2 $ac_cv_prog_cc_c99" - $3="$$3 $ac_cv_prog_cc_c99" - ;; - esac - dnl restore saved state - FP_COPY_SHELLVAR([fp_save_CC],[CC]) - FP_COPY_SHELLVAR([fp_save_CFLAGS],[CFLAGS]) - FP_COPY_SHELLVAR([fp_save_CPPFLAGS],[CPPFLAGS]) - FP_COPY_SHELLVAR([fp_save_cc_c99],[ac_cv_prog_cc_c99]) - dnl cleanup - unset fp_save_CC - unset fp_save_CFLAGS - unset fp_save_cc_c99 -]) ===================================== rts/Apply.cmm ===================================== @@ -699,7 +699,7 @@ INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK") /* ensure there is at least AP_STACK_SPLIM words of headroom available * after unpacking the AP_STACK. See bug #1466 */ - PUSH_UPD_FRAME(Sp - SIZEOF_StgUpdateFrame, R1); + PUSH_BH_UPD_FRAME(Sp - SIZEOF_StgUpdateFrame, R1); Sp = Sp - SIZEOF_StgUpdateFrame - WDS(Words); TICK_ENT_AP(); ===================================== rts/ThreadPaused.c ===================================== @@ -15,6 +15,7 @@ #include "RaiseAsync.h" #include "Trace.h" #include "Threads.h" +#include "Messages.h" #include "sm/NonMovingMark.h" #include // for memmove() @@ -314,52 +315,66 @@ threadPaused(Capability *cap, StgTSO *tso) continue; } - // an EAGER_BLACKHOLE or CAF_BLACKHOLE gets turned into a - // BLACKHOLE here. + // If we have a frame that is already eagerly blackholed, we + // shouldn't overwrite its payload: There may already be a blocking + // queue (see #26324). + if(frame_info == &stg_bh_upd_frame_info) { + // eager black hole: we do nothing + + // it should be a black hole that we own + ASSERT(bh_info == &stg_BLACKHOLE_info || + bh_info == &__stg_EAGER_BLACKHOLE_info || + bh_info == &stg_CAF_BLACKHOLE_info); + ASSERT(blackHoleOwner(bh) == tso || blackHoleOwner(bh) == NULL); + } else { + // lazy black hole + #if defined(THREADED_RTS) - // first we turn it into a WHITEHOLE to claim it, and if - // successful we write our TSO and then the BLACKHOLE info pointer. - cur_bh_info = (const StgInfoTable *) - cas((StgVolatilePtr)&bh->header.info, - (StgWord)bh_info, - (StgWord)&stg_WHITEHOLE_info); - - if (cur_bh_info != bh_info) { - bh_info = cur_bh_info; + // first we turn it into a WHITEHOLE to claim it, and if + // successful we write our TSO and then the BLACKHOLE info pointer. + cur_bh_info = (const StgInfoTable *) + cas((StgVolatilePtr)&bh->header.info, + (StgWord)bh_info, + (StgWord)&stg_WHITEHOLE_info); + + if (cur_bh_info != bh_info) { + bh_info = cur_bh_info; #if defined(PROF_SPIN) - NONATOMIC_ADD(&whitehole_threadPaused_spin, 1); + NONATOMIC_ADD(&whitehole_threadPaused_spin, 1); #endif - busy_wait_nop(); - goto retry; - } + busy_wait_nop(); + goto retry; + } #endif - - IF_NONMOVING_WRITE_BARRIER_ENABLED { - if (ip_THUNK(INFO_PTR_TO_STRUCT(bh_info))) { - // We are about to replace a thunk with a blackhole. - // Add the free variables of the closure we are about to - // overwrite to the update remembered set. - // N.B. We caught the WHITEHOLE case above. - updateRemembSetPushThunkEager(cap, - THUNK_INFO_PTR_TO_STRUCT(bh_info), - (StgThunk *) bh); + ASSERT(bh_info != &stg_WHITEHOLE_info); + + IF_NONMOVING_WRITE_BARRIER_ENABLED { + if (ip_THUNK(INFO_PTR_TO_STRUCT(bh_info))) { + // We are about to replace a thunk with a blackhole. + // Add the free variables of the closure we are about to + // overwrite to the update remembered set. + // N.B. We caught the WHITEHOLE case above. + updateRemembSetPushThunkEager(cap, + THUNK_INFO_PTR_TO_STRUCT(bh_info), + (StgThunk *) bh); + } } - } - // zero out the slop so that the sanity checker can tell - // where the next closure is. N.B. We mustn't do this until we have - // pushed the free variables to the update remembered set above. - OVERWRITING_CLOSURE_SIZE(bh, closure_sizeW_(bh, INFO_PTR_TO_STRUCT(bh_info))); + // zero out the slop so that the sanity checker can tell + // where the next closure is. N.B. We mustn't do this until we have + // pushed the free variables to the update remembered set above. + OVERWRITING_CLOSURE_SIZE(bh, closure_sizeW_(bh, INFO_PTR_TO_STRUCT(bh_info))); - // The payload of the BLACKHOLE points to the TSO - RELEASE_STORE(&((StgInd *)bh)->indirectee, (StgClosure *)tso); - SET_INFO_RELEASE(bh,&stg_BLACKHOLE_info); + // The payload of the BLACKHOLE points to the TSO + RELEASE_STORE(&((StgInd *)bh)->indirectee, (StgClosure *)tso); + SET_INFO_RELEASE(bh,&stg_BLACKHOLE_info); - // .. and we need a write barrier, since we just mutated the closure: - recordClosureMutated(cap,bh); + // .. and we need a write barrier, since we just mutated the closure: + recordClosureMutated(cap,bh); - // We pretend that bh has just been created. - LDV_RECORD_CREATE(bh); + // We pretend that bh has just been created. + LDV_RECORD_CREATE(bh); + } frame = (StgClosure *) ((StgUpdateFrame *)frame + 1); if (prev_was_update_frame) { ===================================== testsuite/tests/ghci-wasm/T26431.hs ===================================== @@ -0,0 +1,35 @@ +import Control.Exception +import Control.Monad.IO.Class +import Data.Maybe +import GHC +import GHC.Plugins +import GHC.Runtime.Interpreter +import System.Environment.Blank + +main :: IO () +main = do + [libdir] <- getArgs + defaultErrorHandler defaultFatalMessager defaultFlushOut $ + runGhc (Just libdir) $ + do + dflags0 <- getSessionDynFlags + let dflags1 = + dflags0 + { ghcMode = CompManager, + backend = interpreterBackend, + ghcLink = LinkInMemory + } + logger <- getLogger + (dflags2, _, _) <- + parseDynamicFlags logger dflags1 $ + map noLoc ["-package", "ghc"] + _ <- setSessionDynFlags dflags2 + addTarget =<< guessTarget "hello.hs" Nothing Nothing + _ <- load LoadAllTargets + setContext + [ IIDecl $ simpleImportDecl $ mkModuleName "Prelude", + IIDecl $ simpleImportDecl $ mkModuleName "Main" + ] + hsc_env <- getSession + fhv <- compileExprRemote "main" + liftIO $ evalIO (fromJust $ hsc_interp hsc_env) fhv ===================================== testsuite/tests/ghci-wasm/T26431.stdout ===================================== @@ -0,0 +1 @@ +main = putStrLn "hello world" ===================================== testsuite/tests/ghci-wasm/all.T ===================================== @@ -10,3 +10,11 @@ test('T26430', [ extra_hc_opts('-L. -lT26430B')] , compile_and_run, [''] ) + +test('T26431', [ + extra_files(['../../../.gitlab/hello.hs']), + extra_hc_opts('-package ghc'), + extra_run_opts(f'"{config.libdir}"'), + ignore_stderr] +, compile_and_run, [''] +) ===================================== testsuite/tests/typecheck/should_compile/T26457.hs ===================================== @@ -0,0 +1,18 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module T26457 where + +import Data.Kind +import Data.Proxy + +type family FC (be :: Type) (entity :: Type) :: Constraint + +class Database be where + fun :: Proxy be -> (forall tbl. FC be tbl => Proxy tbl -> ()) -> () + default fun :: Proxy be -> (forall tbl. FC be tbl => Proxy tbl -> ()) -> () + fun _ _ = undefined ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -952,4 +952,4 @@ test('T26346', normal, compile, ['']) test('T26358', expect_broken(26358), compile, ['']) test('T26345', normal, compile, ['']) test('T26376', normal, compile, ['']) - +test('T26457', normal, compile, ['']) ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cc.hs ===================================== @@ -11,7 +11,6 @@ module GHC.Toolchain.Tools.Cc , compileC , compileAsm , addPlatformDepCcFlags - , checkC99Support ) where import Control.Monad @@ -51,12 +50,8 @@ findCc archOs llvmTarget progOpt = do cc1 <- ignoreUnusedArgs cc0 cc2 <- ccSupportsTarget archOs llvmTarget cc1 checking "whether Cc works" $ checkCcWorks cc2 - cc3 <- oneOf "cc doesn't support C99" $ map checkC99Support - [ cc2 - , cc2 & _ccFlags %++ "-std=gnu99" - ] - checkCcSupportsExtraViaCFlags cc3 - return cc3 + checkCcSupportsExtraViaCFlags cc2 + return cc2 checkCcWorks :: Cc -> M () checkCcWorks cc = withTempDir $ \dir -> do @@ -88,17 +83,6 @@ ccSupportsTarget archOs target cc = checking "whether Cc supports --target" $ supportsTarget archOs _ccProgram checkCcWorks target cc -checkC99Support :: Cc -> M Cc -checkC99Support cc = checking "for C99 support" $ withTempDir $ \dir -> do - let test_o = dir "test.o" - compileC cc test_o $ unlines - [ "#include " - , "#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L" - , "# error \"Compiler does not advertise C99 conformance\"" - , "#endif" - ] - return cc - checkCcSupportsExtraViaCFlags :: Cc -> M () checkCcSupportsExtraViaCFlags cc = checking "whether cc supports extra via-c flags" $ withTempDir $ \dir -> do let test_o = dir "test.o" ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Cpp.hs ===================================== @@ -19,7 +19,7 @@ import GHC.Toolchain.Prelude import GHC.Toolchain.Program import GHC.Toolchain.Tools.Cc -import GHC.Toolchain.Utils (withTempDir, oneOf, expectFileExists) +import GHC.Toolchain.Utils (withTempDir, expectFileExists) newtype Cpp = Cpp { cppProgram :: Program } @@ -160,13 +160,7 @@ findJsCpp progOpt cc = checking "for JavaScript C preprocessor" $ do findCmmCpp :: ProgOpt -> Cc -> M CmmCpp findCmmCpp progOpt cc = checking "for a Cmm preprocessor" $ do -- Use the specified CPP or try to use the c compiler - foundCppProg <- findProgram "Cmm preprocessor" progOpt [] <|> pure (programFromOpt progOpt (prgPath $ ccProgram cc) []) - -- Check whether the C preprocessor needs -std=gnu99 (only very old toolchains need this) - Cc cpp <- oneOf "cc doesn't support C99" $ map checkC99Support - [ Cc foundCppProg - , Cc (foundCppProg & _prgFlags %++ "-std=gnu99") - ] - + cpp <- findProgram "Cmm preprocessor" progOpt [] <|> pure (programFromOpt progOpt (prgPath $ ccProgram cc) []) cmmCppSupportsG0 <- withTempDir $ \dir -> do let conftest = dir "conftest.c" writeFile conftest "int main(void) {}" @@ -181,14 +175,9 @@ findCmmCpp progOpt cc = checking "for a Cmm preprocessor" $ do findCpp :: ProgOpt -> Cc -> M Cpp findCpp progOpt cc = checking "for C preprocessor" $ do -- Use the specified CPP or try to use the c compiler - foundCppProg <- findProgram "C preprocessor" progOpt [] <|> pure (programFromOpt progOpt (prgPath $ ccProgram cc) []) - -- Check whether the C preprocessor needs -std=gnu99 (only very old toolchains need this) - Cc cpp2 <- oneOf "cc doesn't support C99" $ map checkC99Support - [ Cc foundCppProg - , Cc (foundCppProg & _prgFlags %++ "-std=gnu99") - ] + cpp <- findProgram "C preprocessor" progOpt [] <|> pure (programFromOpt progOpt (prgPath $ ccProgram cc) []) -- Always add the -E flag to the CPP, regardless of the user options - let cppProgram = addFlagIfNew "-E" cpp2 + let cppProgram = addFlagIfNew "-E" cpp return Cpp{cppProgram} -------------------------------------------------------------------------------- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/51c7def97769046572470271e97fade... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/51c7def97769046572470271e97fade... You're receiving this email because of your account on gitlab.haskell.org.