diff --git a/NixSupport/ghc-12264.patch b/NixSupport/ghc-12264.patch deleted file mode 100644 index 894ea9085..000000000 --- a/NixSupport/ghc-12264.patch +++ /dev/null @@ -1,2153 +0,0 @@ -diff --git a/compiler/GHC.hs b/compiler/GHC.hs -index b657e2b6e58..ffaf405f43f 100644 ---- a/compiler/GHC.hs -+++ b/compiler/GHC.hs -@@ -397,6 +397,7 @@ import GHC.Types.Name.Ppr - import GHC.Types.TypeEnv - import GHC.Types.BreakInfo - import GHC.Types.PkgQual -+import GHC.Types.Unique.FM - - import GHC.Unit - import GHC.Unit.Env -@@ -676,6 +677,7 @@ setTopSessionDynFlags :: GhcMonad m => DynFlags -> m () - setTopSessionDynFlags dflags = do - hsc_env <- getSession - logger <- getLogger -+ lookup_cache <- liftIO $ newMVar emptyUFM - - -- Interpreter - interp <- if -@@ -705,7 +707,7 @@ setTopSessionDynFlags dflags = do - } - s <- liftIO $ newMVar InterpPending - loader <- liftIO Loader.uninitializedLoader -- return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader)) -+ return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache)) - - -- JavaScript interpreter - | ArchJavaScript <- platformArch (targetPlatform dflags) -@@ -723,7 +725,7 @@ setTopSessionDynFlags dflags = do - , jsInterpFinderOpts = initFinderOpts dflags - , jsInterpFinderCache = hsc_FC hsc_env - } -- return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader)) -+ return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache)) - - -- Internal interpreter - | otherwise -@@ -731,7 +733,7 @@ setTopSessionDynFlags dflags = do - #if defined(HAVE_INTERNAL_INTERPRETER) - do - loader <- liftIO Loader.uninitializedLoader -- return (Just (Interp InternalInterp loader)) -+ return (Just (Interp InternalInterp loader lookup_cache)) - #else - return Nothing - #endif -diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs -index 44193097889..14a43121d00 100644 ---- a/compiler/GHC/ByteCode/Linker.hs -+++ b/compiler/GHC/ByteCode/Linker.hs -@@ -25,6 +25,7 @@ import GHCi.ResolvedBCO - import GHCi.BreakArray - - import GHC.Builtin.PrimOps -+import GHC.Builtin.PrimOps.Ids - import GHC.Builtin.Names - - import GHC.Unit.Types -@@ -40,6 +41,8 @@ import GHC.Utils.Outputable - - import GHC.Types.Name - import GHC.Types.Name.Env -+import qualified GHC.Types.Id as Id -+import GHC.Types.Unique.DFM - - import Language.Haskell.Syntax.Module.Name - -@@ -54,32 +57,33 @@ import GHC.Exts - - linkBCO - :: Interp -+ -> PkgsLoaded - -> LinkerEnv - -> NameEnv Int - -> RemoteRef BreakArray - -> UnlinkedBCO - -> IO ResolvedBCO --linkBCO interp le bco_ix breakarray -+linkBCO interp pkgs_loaded le bco_ix breakarray - (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do - -- fromIntegral Word -> Word64 should be a no op if Word is Word64 - -- otherwise it will result in a cast to longlong on 32bit systems. -- lits <- mapM (fmap fromIntegral . lookupLiteral interp le) (ssElts lits0) -- ptrs <- mapM (resolvePtr interp le bco_ix breakarray) (ssElts ptrs0) -+ lits <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (ssElts lits0) -+ ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix breakarray) (ssElts ptrs0) - return (ResolvedBCO isLittleEndian arity insns bitmap - (listArray (0, fromIntegral (sizeSS lits0)-1) lits) - (addListToSS emptySS ptrs)) - --lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word --lookupLiteral interp le ptr = case ptr of -+lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word -+lookupLiteral interp pkgs_loaded le ptr = case ptr of - BCONPtrWord lit -> return lit - BCONPtrLbl sym -> do - Ptr a# <- lookupStaticPtr interp sym - return (W# (int2Word# (addr2Int# a#))) - BCONPtrItbl nm -> do -- Ptr a# <- lookupIE interp (itbl_env le) nm -+ Ptr a# <- lookupIE interp pkgs_loaded (itbl_env le) nm - return (W# (int2Word# (addr2Int# a#))) - BCONPtrAddr nm -> do -- Ptr a# <- lookupAddr interp (addr_env le) nm -+ Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm - return (W# (int2Word# (addr2Int# a#))) - BCONPtrStr _ -> - -- should be eliminated during assembleBCOs -@@ -93,19 +97,19 @@ lookupStaticPtr interp addr_of_label_string = do - Nothing -> linkFail "GHC.ByteCode.Linker: can't find label" - (unpackFS addr_of_label_string) - --lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ()) --lookupIE interp ie con_nm = -+lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ()) -+lookupIE interp pkgs_loaded ie con_nm = - case lookupNameEnv ie con_nm of - Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a)) - Nothing -> do -- try looking up in the object files. - let sym_to_find1 = nameToCLabel con_nm "con_info" -- m <- lookupSymbol interp sym_to_find1 -+ m <- lookupHsSymbol interp pkgs_loaded con_nm "con_info" - case m of - Just addr -> return addr - Nothing - -> do -- perhaps a nullary constructor? - let sym_to_find2 = nameToCLabel con_nm "static_info" -- n <- lookupSymbol interp sym_to_find2 -+ n <- lookupHsSymbol interp pkgs_loaded con_nm "static_info" - case n of - Just addr -> return addr - Nothing -> linkFail "GHC.ByteCode.Linker.lookupIE" -@@ -113,35 +117,36 @@ lookupIE interp ie con_nm = - unpackFS sym_to_find2) - - -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode --lookupAddr :: Interp -> AddrEnv -> Name -> IO (Ptr ()) --lookupAddr interp ae addr_nm = do -+lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ()) -+lookupAddr interp pkgs_loaded ae addr_nm = do - case lookupNameEnv ae addr_nm of - Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr) - Nothing -> do -- try looking up in the object files. - let sym_to_find = nameToCLabel addr_nm "bytes" - -- see Note [Bytes label] in GHC.Cmm.CLabel -- m <- lookupSymbol interp sym_to_find -+ m <- lookupHsSymbol interp pkgs_loaded addr_nm "bytes" - case m of - Just ptr -> return ptr - Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr" - (unpackFS sym_to_find) - --lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ()) --lookupPrimOp interp primop = do -+lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ()) -+lookupPrimOp interp pkgs_loaded primop = do - let sym_to_find = primopToCLabel primop "closure" -- m <- lookupSymbol interp (mkFastString sym_to_find) -+ m <- lookupHsSymbol interp pkgs_loaded (Id.idName $ primOpId primop) "closure" - case m of - Just p -> return (toRemotePtr p) - Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find - - resolvePtr - :: Interp -+ -> PkgsLoaded - -> LinkerEnv - -> NameEnv Int - -> RemoteRef BreakArray - -> BCOPtr - -> IO ResolvedBCOPtr --resolvePtr interp le bco_ix breakarray ptr = case ptr of -+resolvePtr interp pkgs_loaded le bco_ix breakarray ptr = case ptr of - BCOPtrName nm - | Just ix <- lookupNameEnv bco_ix nm - -> return (ResolvedBCORef ix) -- ref to another BCO in this group -@@ -153,20 +158,42 @@ resolvePtr interp le bco_ix breakarray ptr = case ptr of - -> assertPpr (isExternalName nm) (ppr nm) $ - do - let sym_to_find = nameToCLabel nm "closure" -- m <- lookupSymbol interp sym_to_find -+ m <- lookupHsSymbol interp pkgs_loaded nm "closure" - case m of - Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p)) - Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find) - - BCOPtrPrimOp op -- -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op -+ -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op - - BCOPtrBCO bco -- -> ResolvedBCOPtrBCO <$> linkBCO interp le bco_ix breakarray bco -+ -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix breakarray bco - - BCOPtrBreakArray - -> return (ResolvedBCOPtrBreakArray breakarray) - -+-- | Look up the address of a Haskell symbol in the currently -+-- loaded units. -+-- -+-- See Note [Looking up symbols in the relevant objects]. -+lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ())) -+lookupHsSymbol interp pkgs_loaded nm sym_suffix = do -+ massertPpr (isExternalName nm) (ppr nm) -+ let sym_to_find = nameToCLabel nm sym_suffix -+ pkg_id = moduleUnitId $ nameModule nm -+ loaded_dlls = maybe [] loaded_pkg_hs_dlls $ lookupUDFM pkgs_loaded pkg_id -+ -+ go (dll:dlls) = do -+ mb_ptr <- lookupSymbolInDLL interp dll sym_to_find -+ case mb_ptr of -+ Just ptr -> pure (Just ptr) -+ Nothing -> go dlls -+ go [] = -+ -- See Note [Symbols may not be found in pkgs_loaded] in GHC.Linker.Types -+ lookupSymbol interp sym_to_find -+ -+ go loaded_dlls -+ - linkFail :: String -> String -> IO a - linkFail who what - = throwGhcExceptionIO (ProgramError $ -diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs -index e3d00b5a0d1..8206835a27b 100644 ---- a/compiler/GHC/Driver/Main.hs -+++ b/compiler/GHC/Driver/Main.hs -@@ -2647,7 +2647,7 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do - - case interp of - -- always generate JS code for the JS interpreter (no bytecode!) -- Interp (ExternalInterp (ExtJS i)) _ -> -+ Interp (ExternalInterp (ExtJS i)) _ _ -> - jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id - - _ -> do -diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs -index ddf47c05ce4..823ecd92d30 100644 ---- a/compiler/GHC/Driver/Plugins.hs -+++ b/compiler/GHC/Driver/Plugins.hs -@@ -405,12 +405,12 @@ loadExternalPluginLib :: FilePath -> IO () - loadExternalPluginLib path = do - -- load library - loadDLL path >>= \case -- Just errmsg -> pprPanic "loadExternalPluginLib" -- (vcat [ text "Can't load plugin library" -- , text " Library path: " <> text path -- , text " Error : " <> text errmsg -- ]) -- Nothing -> do -+ Left errmsg -> pprPanic "loadExternalPluginLib" -+ (vcat [ text "Can't load plugin library" -+ , text " Library path: " <> text path -+ , text " Error : " <> text errmsg -+ ]) -+ Right _ -> do - -- resolve objects - resolveObjs >>= \case - True -> return () -diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs -index fe19df150b9..9431a7968d1 100644 ---- a/compiler/GHC/Linker/Loader.hs -+++ b/compiler/GHC/Linker/Loader.hs -@@ -56,6 +56,7 @@ import GHC.Tc.Utils.Monad - import GHC.Runtime.Interpreter - import GHCi.RemoteTypes - import GHC.Iface.Load -+import GHCi.Message (LoadedDLL) - - import GHC.ByteCode.Linker - import GHC.ByteCode.Asm -@@ -145,7 +146,7 @@ emptyLoaderState = LoaderState - -- - -- The linker's symbol table is populated with RTS symbols using an - -- explicit list. See rts/Linker.c for details. -- where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] emptyUniqDSet) -+ where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] [] emptyUniqDSet) - - extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () - extendLoadedEnv interp new_bindings = -@@ -194,8 +195,8 @@ loadDependencies - -> SrcSpan - -> [Module] - -> IO (LoaderState, SuccessFlag, [Linkable], PkgsLoaded) -- ^ returns the set of linkables required -+-- When called, the loader state must have been initialized (see `initLoaderState`) - loadDependencies interp hsc_env pls span needed_mods = do ---- initLoaderState (hsc_dflags hsc_env) dl - let opts = initLinkDepsOpts hsc_env - - -- Find what packages and linkables are required -@@ -205,7 +206,7 @@ loadDependencies interp hsc_env pls span needed_mods = do - - -- Link the packages and modules required - pls1 <- loadPackages' interp hsc_env (ldUnits deps) pls -- (pls2, succ) <- loadModuleLinkables interp hsc_env pls1 (ldNeededLinkables deps) -+ (pls2, succ) <- loadModuleLinkables interp (pkgs_loaded pls) hsc_env pls1 (ldNeededLinkables deps) - let this_pkgs_loaded = udfmRestrictKeys all_pkgs_loaded $ getUniqDSet trans_pkgs_needed - all_pkgs_loaded = pkgs_loaded pls2 - trans_pkgs_needed = unionManyUniqDSets (this_pkgs_needed : [ loaded_pkg_trans_deps pkg -@@ -485,25 +486,25 @@ preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do - DLL dll_unadorned -> do - maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned) - case maybe_errstr of -- Nothing -> maybePutStrLn logger "done" -- Just mm | platformOS platform /= OSDarwin -> -+ Right _ -> maybePutStrLn logger "done" -+ Left mm | platformOS platform /= OSDarwin -> - preloadFailed mm lib_paths lib_spec -- Just mm | otherwise -> do -+ Left mm | otherwise -> do - -- As a backup, on Darwin, try to also load a .so file - -- since (apparently) some things install that way - see - -- ticket #8770. - let libfile = ("lib" ++ dll_unadorned) <.> "so" - err2 <- loadDLL interp libfile - case err2 of -- Nothing -> maybePutStrLn logger "done" -- Just _ -> preloadFailed mm lib_paths lib_spec -+ Right _ -> maybePutStrLn logger "done" -+ Left _ -> preloadFailed mm lib_paths lib_spec - return pls - - DLLPath dll_path -> do - do maybe_errstr <- loadDLL interp dll_path - case maybe_errstr of -- Nothing -> maybePutStrLn logger "done" -- Just mm -> preloadFailed mm lib_paths lib_spec -+ Right _ -> maybePutStrLn logger "done" -+ Left mm -> preloadFailed mm lib_paths lib_spec - return pls - - Framework framework -> -@@ -588,7 +589,7 @@ loadExpr interp hsc_env span root_ul_bco = do - let le = linker_env pls - nobreakarray = error "no break array" - bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)] -- resolved <- linkBCO interp le bco_ix nobreakarray root_ul_bco -+ resolved <- linkBCO interp (pkgs_loaded pls) le bco_ix nobreakarray root_ul_bco - [root_hvref] <- createBCOs interp [resolved] - fhv <- mkFinalizedHValue interp root_hvref - return (pls, fhv) -@@ -651,7 +652,7 @@ loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do - , addr_env = plusNameEnv (addr_env le) bc_strs } - - -- Link the necessary packages and linkables -- new_bindings <- linkSomeBCOs interp le2 [cbc] -+ new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 [cbc] - nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings - let ce2 = extendClosureEnv (closure_env le2) nms_fhvs - !pls2 = pls { linker_env = le2 { closure_env = ce2 } } -@@ -693,8 +694,8 @@ loadModule interp hsc_env mod = do - - ********************************************************************* -} - --loadModuleLinkables :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag) --loadModuleLinkables interp hsc_env pls linkables -+loadModuleLinkables :: Interp -> PkgsLoaded -> HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag) -+loadModuleLinkables interp pkgs_loaded hsc_env pls linkables - = mask_ $ do -- don't want to be interrupted by ^C in here - - let (objs, bcos) = partition isObjectLinkable -@@ -706,7 +707,7 @@ loadModuleLinkables interp hsc_env pls linkables - if failed ok_flag then - return (pls1, Failed) - else do -- pls2 <- dynLinkBCOs interp pls1 bcos -+ pls2 <- dynLinkBCOs interp pkgs_loaded pls1 bcos - return (pls2, Succeeded) - - -@@ -832,8 +833,8 @@ dynLoadObjs interp hsc_env pls@LoaderState{..} objs = do - changeTempFilesLifetime tmpfs TFL_GhcSession [soFile] - m <- loadDLL interp soFile - case m of -- Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos } -- Just err -> linkFail msg err -+ Right _ -> return $! pls { temp_sos = (libPath, libName) : temp_sos } -+ Left err -> linkFail msg err - where - msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed" - -@@ -856,8 +857,8 @@ rmDupLinkables already ls - ********************************************************************* -} - - --dynLinkBCOs :: Interp -> LoaderState -> [Linkable] -> IO LoaderState --dynLinkBCOs interp pls bcos = do -+dynLinkBCOs :: Interp -> PkgsLoaded -> LoaderState -> [Linkable] -> IO LoaderState -+dynLinkBCOs interp pkgs_loaded pls bcos = do - - let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos - pls1 = pls { bcos_loaded = bcos_loaded' } -@@ -873,7 +874,7 @@ dynLinkBCOs interp pls bcos = do - ae2 = foldr plusNameEnv (addr_env le1) (map bc_strs cbcs) - le2 = le1 { itbl_env = ie2, addr_env = ae2 } - -- names_and_refs <- linkSomeBCOs interp le2 cbcs -+ names_and_refs <- linkSomeBCOs interp pkgs_loaded le2 cbcs - - -- We only want to add the external ones to the ClosureEnv - let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs -@@ -888,6 +889,7 @@ dynLinkBCOs interp pls bcos = do - - -- Link a bunch of BCOs and return references to their values - linkSomeBCOs :: Interp -+ -> PkgsLoaded - -> LinkerEnv - -> [CompiledByteCode] - -> IO [(Name,HValueRef)] -@@ -895,7 +897,7 @@ linkSomeBCOs :: Interp - -- the incoming unlinked BCOs. Each gives the - -- value of the corresponding unlinked BCO - --linkSomeBCOs interp le mods = foldr fun do_link mods [] -+linkSomeBCOs interp pkgs_loaded le mods = foldr fun do_link mods [] - where - fun CompiledByteCode{..} inner accum = - case bc_breaks of -@@ -908,7 +910,7 @@ linkSomeBCOs interp le mods = foldr fun do_link mods [] - let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ] - names = map (unlinkedBCOName . snd) flat - bco_ix = mkNameEnv (zip names [0..]) -- resolved <- sequence [ linkBCO interp le bco_ix breakarray bco -+ resolved <- sequence [ linkBCO interp pkgs_loaded le bco_ix breakarray bco - | (breakarray, bco) <- flat ] - hvrefs <- createBCOs interp resolved - return (zip names hvrefs) -@@ -1071,18 +1073,18 @@ loadPackages' interp hsc_env new_pks pls = do - -- Link dependents first - ; pkgs' <- link pkgs deps - -- Now link the package itself -- ; (hs_cls, extra_cls) <- loadPackage interp hsc_env pkg_cfg -+ ; (hs_cls, extra_cls, loaded_dlls) <- loadPackage interp hsc_env pkg_cfg - ; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg - | dep_pkg <- deps - , Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg) - ] -- ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls trans_deps)) } -+ ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls loaded_dlls trans_deps)) } - - | otherwise - = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg))) - - --loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec]) -+loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL]) - loadPackage interp hsc_env pkg - = do - let dflags = hsc_dflags hsc_env -@@ -1124,7 +1126,9 @@ loadPackage interp hsc_env pkg - let classifieds = hs_classifieds ++ extra_classifieds - - -- Complication: all the .so's must be loaded before any of the .o's. -- let known_dlls = [ dll | DLLPath dll <- classifieds ] -+ let known_hs_dlls = [ dll | DLLPath dll <- hs_classifieds ] -+ known_extra_dlls = [ dll | DLLPath dll <- extra_classifieds ] -+ known_dlls = known_hs_dlls ++ known_extra_dlls - #if defined(CAN_LOAD_DLL) - dlls = [ dll | DLL dll <- classifieds ] - #endif -@@ -1145,10 +1149,13 @@ loadPackage interp hsc_env pkg - loadFrameworks interp platform pkg - -- See Note [Crash early load_dyn and locateLib] - -- Crash early if can't load any of `known_dlls` -- mapM_ (load_dyn interp hsc_env True) known_dlls -+ mapM_ (load_dyn interp hsc_env True) known_extra_dlls -+ loaded_dlls <- mapMaybeM (load_dyn interp hsc_env True) known_hs_dlls - -- For remaining `dlls` crash early only when there is surely - -- no package's DLL around ... (not is_dyn) - mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls -+#else -+ let loaded_dlls = [] - #endif - -- After loading all the DLLs, we can load the static objects. - -- Ordering isn't important here, because we do one final link -@@ -1168,7 +1175,7 @@ loadPackage interp hsc_env pkg - if succeeded ok - then do - maybePutStrLn logger "done." -- return (hs_classifieds, extra_classifieds) -+ return (hs_classifieds, extra_classifieds, loaded_dlls) - else let errmsg = text "unable to load unit `" - <> pprUnitInfoForUser pkg <> text "'" - in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg)) -@@ -1221,19 +1228,20 @@ restriction very easily. - -- can be passed directly to loadDLL. They are either fully-qualified - -- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, - -- loadDLL is going to search the system paths to find the library. --load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO () -+load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO (Maybe (RemotePtr LoadedDLL)) - load_dyn interp hsc_env crash_early dll = do - r <- loadDLL interp dll - case r of -- Nothing -> return () -- Just err -> -+ Right loaded_dll -> pure (Just loaded_dll) -+ Left err -> - if crash_early - then cmdLineErrorIO err -- else -+ else do - when (diag_wopt Opt_WarnMissedExtraSharedLib diag_opts) - $ logMsg logger - (mkMCDiagnostic diag_opts (WarningWithFlag Opt_WarnMissedExtraSharedLib) Nothing) - noSrcSpan $ withPprStyle defaultUserStyle (note err) -+ pure Nothing - where - diag_opts = initDiagOpts (hsc_dflags hsc_env) - logger = hsc_logger hsc_env -diff --git a/compiler/GHC/Linker/MacOS.hs b/compiler/GHC/Linker/MacOS.hs -index 32886587f02..6d8970e20c0 100644 ---- a/compiler/GHC/Linker/MacOS.hs -+++ b/compiler/GHC/Linker/MacOS.hs -@@ -172,6 +172,6 @@ loadFramework interp extraPaths rootname - findLoadDLL (p:ps) errs = - do { dll <- loadDLL interp (p fwk_file) - ; case dll of -- Nothing -> return Nothing -- Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs) -+ Right _ -> return Nothing -+ Left err -> findLoadDLL ps ((p ++ ": " ++ err):errs) - } -diff --git a/compiler/GHC/Linker/Types.hs b/compiler/GHC/Linker/Types.hs -index c343537b083..adf2e63b500 100644 ---- a/compiler/GHC/Linker/Types.hs -+++ b/compiler/GHC/Linker/Types.hs -@@ -40,7 +40,8 @@ import GHC.Prelude - import GHC.Unit ( UnitId, Module ) - import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode ) - import GHC.Fingerprint.Type ( Fingerprint ) --import GHCi.RemoteTypes ( ForeignHValue ) -+import GHCi.RemoteTypes ( ForeignHValue, RemotePtr ) -+import GHCi.Message ( LoadedDLL ) - - import GHC.Types.Var ( Id ) - import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv ) -@@ -75,6 +76,53 @@ initialised. - - The LinkerEnv maps Names to actual closures (for interpreted code only), for - use during linking. -+ -+Note [Looking up symbols in the relevant objects] -+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -+In #23415, we determined that a lot of time (>10s, or even up to >35s!) was -+being spent on dynamically loading symbols before actually interpreting code -+when `:main` was run in GHCi. The root cause was that for each symbol we wanted -+to lookup, we would traverse the list of loaded objects and try find the symbol -+in each of them with dlsym (i.e. looking up a symbol was, worst case, linear in -+the amount of loaded objects). -+ -+To drastically improve load time (from +-38 seconds down to +-2s), we now: -+ -+1. For every of the native objects loaded for a given unit, store the handles returned by `dlopen`. -+ - In `pkgs_loaded` of the `LoaderState`, which maps `UnitId`s to -+ `LoadedPkgInfo`s, where the handles live in its field `loaded_pkg_hs_dlls`. -+ -+2. When looking up a Name (e.g. `lookupHsSymbol`), find that name's `UnitId` in -+ the `pkgs_loaded` mapping, -+ -+3. And only look for the symbol (with `dlsym`) on the /handles relevant to that -+ unit/, rather than in every loaded object. -+ -+Note [Symbols may not be found in pkgs_loaded] -+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -+Currently the `pkgs_loaded` mapping only contains the dynamic objects -+associated with loaded units. Symbols defined in a static object (e.g. from a -+statically-linked Haskell library) are found via the generic `lookupSymbol` -+function call by `lookupHsSymbol` when the symbol is not found in any of the -+dynamic objects of `pkgs_loaded`. -+ -+The rationale here is two-fold: -+ -+ * we have only observed major link-time issues in dynamic linking; lookups in -+ the RTS linker's static symbol table seem to be fast enough -+ -+ * allowing symbol lookups restricted to a single ObjectCode would require the -+ maintenance of a symbol table per `ObjectCode`, which would introduce time and -+ space overhead -+ -+This fallback is further needed because we don't look in the haskell objects -+loaded for the home units (see the call to `loadModuleLinkables` in -+`loadDependencies`, as opposed to the call to `loadPackages'` in the same -+function which updates `pkgs_loaded`). We should ultimately keep track of the -+objects loaded (probably in `objs_loaded`, for which `LinkableSet` is a bit -+unsatisfactory, see a suggestion in 51c5c4eb1f2a33e4dc88e6a37b7b7c135234ce9b) -+and be able to lookup symbols specifically in them too (similarly to -+`lookupSymbolInDLL`). - -} - - newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) } -@@ -146,11 +194,13 @@ data LoadedPkgInfo - { loaded_pkg_uid :: !UnitId - , loaded_pkg_hs_objs :: ![LibrarySpec] - , loaded_pkg_non_hs_objs :: ![LibrarySpec] -+ , loaded_pkg_hs_dlls :: ![RemotePtr LoadedDLL] -+ -- ^ See Note [Looking up symbols in the relevant objects] - , loaded_pkg_trans_deps :: UniqDSet UnitId - } - - instance Outputable LoadedPkgInfo where -- ppr (LoadedPkgInfo uid hs_objs non_hs_objs trans_deps) = -+ ppr (LoadedPkgInfo uid hs_objs non_hs_objs _ trans_deps) = - vcat [ppr uid - , ppr hs_objs - , ppr non_hs_objs -@@ -159,10 +209,10 @@ instance Outputable LoadedPkgInfo where - - -- | Information we can use to dynamically link modules into the compiler - data Linkable = LM { -- linkableTime :: !UTCTime, -- ^ Time at which this linkable was built -+ linkableTime :: !UTCTime, -- ^ Time at which this linkable was built - -- (i.e. when the bytecodes were produced, - -- or the mod date on the files) -- linkableModule :: !Module, -- ^ The linkable module itself -+ linkableModule :: !Module, -- ^ The linkable module itself - linkableUnlinked :: [Unlinked] - -- ^ Those files and chunks of code we have yet to link. - -- -diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs -index 554f86bef40..20b98865b4c 100644 ---- a/compiler/GHC/Runtime/Interpreter.hs -+++ b/compiler/GHC/Runtime/Interpreter.hs -@@ -37,6 +37,7 @@ module GHC.Runtime.Interpreter - -- * The object-code linker - , initObjLinker - , lookupSymbol -+ , lookupSymbolInDLL - , lookupClosure - , loadDLL - , loadArchive -@@ -158,22 +159,22 @@ The main pieces are: - - implementation of Template Haskell (GHCi.TH) - - a few other things needed to run interpreted code - --- top-level iserv directory, containing the codefor the external -- server. This is a fairly simple wrapper, most of the functionality -+- top-level iserv directory, containing the code for the external -+ server. This is a fairly simple wrapper, most of the functionality - is provided by modules in libraries/ghci. - - - This module which provides the interface to the server used - by the rest of GHC. - --GHC works with and without -fexternal-interpreter. With the flag, all --interpreted code is run by the iserv binary. Without the flag, -+GHC works with and without -fexternal-interpreter. With the flag, all -+interpreted code is run by the iserv binary. Without the flag, - interpreted code is run in the same process as GHC. - - Things that do not work with -fexternal-interpreter - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - dynCompileExpr cannot work, because we have no way to run code of an --unknown type in the remote process. This API fails with an error -+unknown type in the remote process. This API fails with an error - message if it is used with -fexternal-interpreter. - - Other Notes on Remote GHCi -@@ -451,57 +452,78 @@ initObjLinker :: Interp -> IO () - initObjLinker interp = interpCmd interp InitLinker - - lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ())) --lookupSymbol interp str = case interpInstance interp of -+lookupSymbol interp str = withSymbolCache interp str $ -+ case interpInstance interp of - #if defined(HAVE_INTERNAL_INTERPRETER) -- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) -+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) - #endif -- -- ExternalInterp ext -> case ext of -- ExtIServ i -> withIServ i $ \inst -> do -- -- Profiling of GHCi showed a lot of time and allocation spent -- -- making cross-process LookupSymbol calls, so I added a GHC-side -- -- cache which sped things up quite a lot. We have to be careful -- -- to purge this cache when unloading code though. -- cache <- readMVar (instLookupSymbolCache inst) -- case lookupUFM cache str of -- Just p -> return (Just p) -- Nothing -> do -- m <- uninterruptibleMask_ $ -- sendMessage inst (LookupSymbol (unpackFS str)) -- case m of -- Nothing -> return Nothing -- Just r -> do -- let p = fromRemotePtr r -- cache' = addToUFM cache str p -- modifyMVar_ (instLookupSymbolCache inst) (const (pure cache')) -- return (Just p) -- -- ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) -+ ExternalInterp ext -> case ext of -+ ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do -+ uninterruptibleMask_ $ -+ sendMessage inst (LookupSymbol (unpackFS str)) -+ ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) -+ -+lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ())) -+lookupSymbolInDLL interp dll str = withSymbolCache interp str $ -+ case interpInstance interp of -+#if defined(HAVE_INTERNAL_INTERPRETER) -+ InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str)) -+#endif -+ ExternalInterp ext -> case ext of -+ ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do -+ uninterruptibleMask_ $ -+ sendMessage inst (LookupSymbolInDLL dll (unpackFS str)) -+ ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) - - lookupClosure :: Interp -> String -> IO (Maybe HValueRef) - lookupClosure interp str = - interpCmd interp (LookupClosure str) - -+-- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache' -+-- which maps symbols to the address where they are loaded. -+-- When there's a cache hit we simply return the cached address, when there is -+-- a miss we run the action which determines the symbol's address and populate -+-- the cache with the answer. -+withSymbolCache :: Interp -+ -> FastString -+ -- ^ The symbol we are looking up in the cache -+ -> IO (Maybe (Ptr ())) -+ -- ^ An action which determines the address of the symbol we -+ -- are looking up in the cache, which is run if there is a -+ -- cache miss. The result will be cached. -+ -> IO (Maybe (Ptr ())) -+withSymbolCache interp str determine_addr = do -+ -+ -- Profiling of GHCi showed a lot of time and allocation spent -+ -- making cross-process LookupSymbol calls, so I added a GHC-side -+ -- cache which sped things up quite a lot. We have to be careful -+ -- to purge this cache when unloading code though. -+ -- -+ -- The analysis in #23415 further showed this cache should also benefit the -+ -- internal interpreter's loading times, and needn't be used by the external -+ -- interpreter only. -+ cache <- readMVar (interpLookupSymbolCache interp) -+ case lookupUFM cache str of -+ Just p -> return (Just p) -+ Nothing -> do -+ -+ maddr <- determine_addr -+ case maddr of -+ Nothing -> return Nothing -+ Just p -> do -+ let upd_cache cache' = addToUFM cache' str p -+ modifyMVar_ (interpLookupSymbolCache interp) (pure . upd_cache) -+ return (Just p) -+ - purgeLookupSymbolCache :: Interp -> IO () --purgeLookupSymbolCache interp = case interpInstance interp of --#if defined(HAVE_INTERNAL_INTERPRETER) -- InternalInterp -> pure () --#endif -- ExternalInterp ext -> withExtInterpMaybe ext $ \case -- Nothing -> pure () -- interpreter stopped, nothing to do -- Just inst -> modifyMVar_ (instLookupSymbolCache inst) (const (pure emptyUFM)) -+purgeLookupSymbolCache interp = modifyMVar_ (interpLookupSymbolCache interp) (const (pure emptyUFM)) - - -- | loadDLL loads a dynamic library using the OS's native linker - -- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either - -- an absolute pathname to the file, or a relative filename - -- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL - -- searches the standard locations for the appropriate library. ---- ---- Returns: ---- ---- Nothing => success ---- Just err_msg => failure --loadDLL :: Interp -> String -> IO (Maybe String) -+loadDLL :: Interp -> String -> IO (Either String (RemotePtr LoadedDLL)) - loadDLL interp str = interpCmd interp (LoadDLL str) - - loadArchive :: Interp -> String -> IO () -@@ -560,11 +582,9 @@ spawnIServ conf = do - } - - pending_frees <- newMVar [] -- lookup_cache <- newMVar emptyUFM - let inst = ExtInterpInstance - { instProcess = process - , instPendingFrees = pending_frees -- , instLookupSymbolCache = lookup_cache - , instExtra = () - } - pure inst -diff --git a/compiler/GHC/Runtime/Interpreter/JS.hs b/compiler/GHC/Runtime/Interpreter/JS.hs -index 3dce1204fa4..871cc4c82d8 100644 ---- a/compiler/GHC/Runtime/Interpreter/JS.hs -+++ b/compiler/GHC/Runtime/Interpreter/JS.hs -@@ -41,7 +41,6 @@ import GHC.Utils.Panic - import GHC.Utils.Error (logInfo) - import GHC.Utils.Outputable (text) - import GHC.Data.FastString --import GHC.Types.Unique.FM - - import Control.Concurrent - import Control.Monad -@@ -178,11 +177,9 @@ spawnJSInterp cfg = do - } - - pending_frees <- newMVar [] -- lookup_cache <- newMVar emptyUFM - let inst = ExtInterpInstance - { instProcess = proc - , instPendingFrees = pending_frees -- , instLookupSymbolCache = lookup_cache - , instExtra = extra - } - -diff --git a/compiler/GHC/Runtime/Interpreter/Types.hs b/compiler/GHC/Runtime/Interpreter/Types.hs -index 962c21491fd..53575f164d4 100644 ---- a/compiler/GHC/Runtime/Interpreter/Types.hs -+++ b/compiler/GHC/Runtime/Interpreter/Types.hs -@@ -51,6 +51,9 @@ data Interp = Interp - - , interpLoader :: !Loader - -- ^ Interpreter loader -+ -+ , interpLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ()))) -+ -- ^ LookupSymbol cache - } - - data InterpInstance -@@ -108,9 +111,6 @@ data ExtInterpInstance c = ExtInterpInstance - -- Finalizers for ForeignRefs can append values to this list - -- asynchronously. - -- , instLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ()))) -- -- ^ LookupSymbol cache -- - , instExtra :: !c - -- ^ Instance specific extra fields - } -diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T -index f77e4436c96..d6c0e4126a0 100644 ---- a/libraries/base/tests/all.T -+++ b/libraries/base/tests/all.T -@@ -232,8 +232,12 @@ test('T9681', normal, compile_fail, ['']) - # Probably something like 1s is already enough, but I don't know enough to - # make an educated guess how long it needs to be guaranteed to reach the C - # call." -+# -+# We ignore stderr since the test itself may print "Killed: 9" (see #24361); -+# all we care about is that the test timed out, for which the -+# exit_code check is sufficient. - test('T8089', -- [exit_code(99), run_timeout_multiplier(0.01)], -+ [exit_code(99), ignore_stderr, run_timeout_multiplier(0.01)], - compile_and_run, ['']) - test('T8684', expect_broken(8684), compile_and_run, ['']) - test('hWaitForInput-accurate-stdin', [js_broken(22349), expect_broken_for(16535, threaded_ways), req_process], compile_and_run, ['']) -diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs -index d660c109326..5e2fb167add 100644 ---- a/libraries/ghci/GHCi/Message.hs -+++ b/libraries/ghci/GHCi/Message.hs -@@ -21,6 +21,7 @@ module GHCi.Message - , QState(..) - , getMessage, putMessage, getTHMessage, putTHMessage - , Pipe(..), remoteCall, remoteTHCall, readPipe, writePipe -+ , LoadedDLL - ) where - - import Prelude -- See note [Why do we import Prelude here?] -@@ -69,8 +70,9 @@ data Message a where - -- These all invoke the corresponding functions in the RTS Linker API. - InitLinker :: Message () - LookupSymbol :: String -> Message (Maybe (RemotePtr ())) -+ LookupSymbolInDLL :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ())) - LookupClosure :: String -> Message (Maybe HValueRef) -- LoadDLL :: String -> Message (Maybe String) -+ LoadDLL :: String -> Message (Either String (RemotePtr LoadedDLL)) - LoadArchive :: String -> Message () -- error? - LoadObj :: String -> Message () -- error? - UnloadObj :: String -> Message () -- error? -@@ -394,6 +396,9 @@ data EvalResult a - - instance Binary a => Binary (EvalResult a) - -+-- | A dummy type that tags pointers returned by 'LoadDLL'. -+data LoadedDLL -+ - -- SomeException can't be serialized because it contains dynamic - -- types. However, we do very limited things with the exceptions that - -- are thrown by interpreted computations: -@@ -521,6 +526,7 @@ getMessage = do - 36 -> Msg <$> (Seq <$> get) - 37 -> Msg <$> return RtsRevertCAFs - 38 -> Msg <$> (ResumeSeq <$> get) -+ 40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get) - _ -> error $ "Unknown Message code " ++ (show b) - - putMessage :: Message a -> Put -@@ -564,6 +570,7 @@ putMessage m = case m of - Seq a -> putWord8 36 >> put a - RtsRevertCAFs -> putWord8 37 - ResumeSeq a -> putWord8 38 >> put a -+ LookupSymbolInDLL dll str -> putWord8 40 >> put dll >> put str - - -- ----------------------------------------------------------------------------- - -- Reading/writing messages -diff --git a/libraries/ghci/GHCi/ObjLink.hs b/libraries/ghci/GHCi/ObjLink.hs -index 8c9f75b9f9f..83d3d02912f 100644 ---- a/libraries/ghci/GHCi/ObjLink.hs -+++ b/libraries/ghci/GHCi/ObjLink.hs -@@ -18,6 +18,7 @@ module GHCi.ObjLink - , unloadObj - , purgeObj - , lookupSymbol -+ , lookupSymbolInDLL - , lookupClosure - , resolveObjs - , addLibrarySearchPath -@@ -27,18 +28,17 @@ module GHCi.ObjLink - - import Prelude -- See note [Why do we import Prelude here?] - import GHCi.RemoteTypes -+import GHCi.Message (LoadedDLL) - import Control.Exception (throwIO, ErrorCall(..)) - import Control.Monad ( when ) - import Foreign.C --import Foreign.Marshal.Alloc ( free ) --import Foreign ( nullPtr ) -+import Foreign.Marshal.Alloc ( alloca, free ) -+import Foreign ( nullPtr, peek ) - import GHC.Exts - import System.Posix.Internals ( CFilePath, withFilePath, peekFilePath ) - import System.FilePath ( dropExtension, normalise ) - - -- -- - -- --------------------------------------------------------------------------- - -- RTS Linker Interface - -- --------------------------------------------------------------------------- -@@ -70,6 +70,15 @@ lookupSymbol str_in = do - then return Nothing - else return (Just addr) - -+lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a)) -+lookupSymbolInDLL dll str_in = do -+ let str = prefixUnderscore str_in -+ withCAString str $ \c_str -> do -+ addr <- c_lookupSymbolInNativeObj dll c_str -+ if addr == nullPtr -+ then return Nothing -+ else return (Just addr) -+ - lookupClosure :: String -> IO (Maybe HValueRef) - lookupClosure str = do - m <- lookupSymbol str -@@ -89,9 +98,7 @@ prefixUnderscore - -- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL - -- searches the standard locations for the appropriate library. - -- --loadDLL :: String -> IO (Maybe String) ---- Nothing => success ---- Just err_msg => failure -+loadDLL :: String -> IO (Either String (Ptr LoadedDLL)) - loadDLL str0 = do - let - -- On Windows, addDLL takes a filename without an extension, because -@@ -101,12 +108,16 @@ loadDLL str0 = do - str | isWindowsHost = dropExtension str0 - | otherwise = str0 - -- -- maybe_errmsg <- withFilePath (normalise str) $ \dll -> c_addDLL dll -- if maybe_errmsg == nullPtr -- then return Nothing -- else do str <- peekCString maybe_errmsg -- free maybe_errmsg -- return (Just str) -+ (maybe_handle, maybe_errmsg) <- withFilePath (normalise str) $ \dll -> -+ alloca $ \errmsg_ptr -> (,) -+ <$> c_loadNativeObj dll errmsg_ptr -+ <*> peek errmsg_ptr -+ -+ if maybe_handle == nullPtr -+ then do str <- peekCString maybe_errmsg -+ free maybe_errmsg -+ return (Left str) -+ else return (Right maybe_handle) - - loadArchive :: String -> IO () - loadArchive str = do -@@ -163,7 +174,8 @@ resolveObjs = do - -- Foreign declarations to RTS entry points which does the real work; - -- --------------------------------------------------------------------------- - --foreign import ccall unsafe "addDLL" c_addDLL :: CFilePath -> IO CString -+foreign import ccall unsafe "loadNativeObj" c_loadNativeObj :: CFilePath -> Ptr CString -> IO (Ptr LoadedDLL) -+foreign import ccall unsafe "lookupSymbolInNativeObj" c_lookupSymbolInNativeObj :: Ptr LoadedDLL -> CString -> IO (Ptr a) - foreign import ccall unsafe "initLinker_" c_initLinker_ :: CInt -> IO () - foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a) - foreign import ccall unsafe "loadArchive" c_loadArchive :: CFilePath -> IO Int -diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs -index cae13010fe8..a5fcd869582 100644 ---- a/libraries/ghci/GHCi/Run.hs -+++ b/libraries/ghci/GHCi/Run.hs -@@ -68,7 +68,7 @@ run m = case m of - LookupClosure str -> lookupJSClosure str - #else - InitLinker -> initObjLinker RetainCAFs -- LoadDLL str -> loadDLL str -+ LoadDLL str -> fmap toRemotePtr <$> loadDLL str - LoadArchive str -> loadArchive str - LoadObj str -> loadObj str - UnloadObj str -> unloadObj str -@@ -83,6 +83,8 @@ run m = case m of - #endif - RtsRevertCAFs -> rts_revertCAFs - LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str -+ LookupSymbolInDLL dll str -> -+ fmap toRemotePtr <$> lookupSymbolInDLL (fromRemotePtr dll) str - FreeHValueRefs rs -> mapM_ freeRemoteRef rs - AddSptEntry fpr r -> localRef r >>= sptAddEntry fpr - EvalStmt opts r -> evalStmt opts r -diff --git a/rts/Linker.c b/rts/Linker.c -index 59e2ff9397a..78ed09ea357 100644 ---- a/rts/Linker.c -+++ b/rts/Linker.c -@@ -77,10 +77,16 @@ - # include - #endif - -+#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO) -+# include "linker/LoadNativeObjPosix.h" -+#endif -+ - #if defined(dragonfly_HOST_OS) - #include - #endif - -+#define UNUSED(x) (void)(x) -+ - /* - * Note [iconv and FreeBSD] - * ~~~~~~~~~~~~~~~~~~~~~~~~ -@@ -130,7 +136,7 @@ extern void iconv(); - - Indexing (e.g. ocVerifyImage and ocGetNames) - - Initialization (e.g. ocResolve) - - RunInit (e.g. ocRunInit) -- - Lookup (e.g. lookupSymbol) -+ - Lookup (e.g. lookupSymbol/lookupSymbolInNativeObj) - - This is to enable lazy loading of symbols. Eager loading is problematic - as it means that all symbols must be available, even those which we will -@@ -417,11 +423,8 @@ static int linker_init_done = 0 ; - - #if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO) - static void *dl_prog_handle; --static regex_t re_invalid; --static regex_t re_realso; --#if defined(THREADED_RTS) --Mutex dl_mutex; // mutex to protect dlopen/dlerror critical section --#endif -+regex_t re_invalid; -+regex_t re_realso; - #endif - - void initLinker (void) -@@ -455,9 +458,6 @@ initLinker_ (int retain_cafs) - - #if defined(THREADED_RTS) - initMutex(&linker_mutex); --#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO) -- initMutex(&dl_mutex); --#endif - #endif - - symhash = allocStrHashTable(); -@@ -520,9 +520,6 @@ exitLinker( void ) { - if (linker_init_done == 1) { - regfree(&re_invalid); - regfree(&re_realso); --#if defined(THREADED_RTS) -- closeMutex(&dl_mutex); --#endif - } - #endif - if (linker_init_done == 1) { -@@ -556,71 +553,6 @@ exitLinker( void ) { - - # if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO) - --/* Suppose in ghci we load a temporary SO for a module containing -- f = 1 -- and then modify the module, recompile, and load another temporary -- SO with -- f = 2 -- Then as we don't unload the first SO, dlsym will find the -- f = 1 -- symbol whereas we want the -- f = 2 -- symbol. We therefore need to keep our own SO handle list, and -- try SOs in the right order. */ -- --typedef -- struct _OpenedSO { -- struct _OpenedSO* next; -- void *handle; -- } -- OpenedSO; -- --/* A list thereof. */ --static OpenedSO* openedSOs = NULL; -- --static const char * --internal_dlopen(const char *dll_name) --{ -- OpenedSO* o_so; -- void *hdl; -- const char *errmsg; -- char *errmsg_copy; -- -- // omitted: RTLD_NOW -- // see http://www.haskell.org/pipermail/cvs-ghc/2007-September/038570.html -- IF_DEBUG(linker, -- debugBelch("internal_dlopen: dll_name = '%s'\n", dll_name)); -- -- //-------------- Begin critical section ------------------ -- // This critical section is necessary because dlerror() is not -- // required to be reentrant (see POSIX -- IEEE Std 1003.1-2008) -- // Also, the error message returned must be copied to preserve it -- // (see POSIX also) -- -- ACQUIRE_LOCK(&dl_mutex); -- hdl = dlopen(dll_name, RTLD_LAZY|RTLD_LOCAL); /* see Note [RTLD_LOCAL] */ -- -- errmsg = NULL; -- if (hdl == NULL) { -- /* dlopen failed; return a ptr to the error msg. */ -- errmsg = dlerror(); -- if (errmsg == NULL) errmsg = "addDLL: unknown error"; -- errmsg_copy = stgMallocBytes(strlen(errmsg)+1, "addDLL"); -- strcpy(errmsg_copy, errmsg); -- errmsg = errmsg_copy; -- } else { -- o_so = stgMallocBytes(sizeof(OpenedSO), "addDLL"); -- o_so->handle = hdl; -- o_so->next = openedSOs; -- openedSOs = o_so; -- } -- -- RELEASE_LOCK(&dl_mutex); -- //--------------- End critical section ------------------- -- -- return errmsg; --} -- - /* - Note [RTLD_LOCAL] - ~~~~~~~~~~~~~~~~~ -@@ -641,11 +573,10 @@ internal_dlopen(const char *dll_name) - - static void * - internal_dlsym(const char *symbol) { -- OpenedSO* o_so; - void *v; - -- // We acquire dl_mutex as concurrent dl* calls may alter dlerror -- ACQUIRE_LOCK(&dl_mutex); -+ // concurrent dl* calls may alter dlerror -+ ASSERT_LOCK_HELD(&linker_mutex); - - // clears dlerror - dlerror(); -@@ -653,20 +584,19 @@ internal_dlsym(const char *symbol) { - // look in program first - v = dlsym(dl_prog_handle, symbol); - if (dlerror() == NULL) { -- RELEASE_LOCK(&dl_mutex); - IF_DEBUG(linker, debugBelch("internal_dlsym: found symbol '%s' in program\n", symbol)); - return v; - } - -- for (o_so = openedSOs; o_so != NULL; o_so = o_so->next) { -- v = dlsym(o_so->handle, symbol); -- if (dlerror() == NULL) { -+ for (ObjectCode *nc = loaded_objects; nc; nc = nc->next_loaded_object) { -+ if (nc->type == DYNAMIC_OBJECT) { -+ v = dlsym(nc->dlopen_handle, symbol); -+ if (dlerror() == NULL) { - IF_DEBUG(linker, debugBelch("internal_dlsym: found symbol '%s' in shared object\n", symbol)); -- RELEASE_LOCK(&dl_mutex); - return v; -+ } - } - } -- RELEASE_LOCK(&dl_mutex); - - IF_DEBUG(linker, debugBelch("internal_dlsym: looking for symbol '%s' in special cases\n", symbol)); - # define SPECIAL_SYMBOL(sym) \ -@@ -708,81 +638,40 @@ internal_dlsym(const char *symbol) { - } - # endif - --const char * --addDLL( pathchar *dll_name ) -+void *lookupSymbolInNativeObj(void *handle, const char *symbol_name) - { --# if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO) -- /* ------------------- ELF DLL loader ------------------- */ -- --#define NMATCH 5 -- regmatch_t match[NMATCH]; -- const char *errmsg; -- FILE* fp; -- size_t match_length; --#define MAXLINE 1000 -- char line[MAXLINE]; -- int result; -+ ACQUIRE_LOCK(&linker_mutex); - -- IF_DEBUG(linker, debugBelch("addDLL: dll_name = '%s'\n", dll_name)); -- errmsg = internal_dlopen(dll_name); -+#if defined(OBJFORMAT_MACHO) -+ // The Mach-O standard says ccall symbols representing a function are prefixed with _ -+ // https://math-atlas.sourceforge.net/devel/assembly/MachORuntime.pdf -+ CHECK(symbol_name[0] == '_'); -+ symbol_name = symbol_name+1; -+#endif -+#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO) -+ void *result = dlsym(handle, symbol_name); -+#elif defined(OBJFORMAT_PEi386) -+ void *result = lookupSymbolInDLL_PEi386(symbol_name, handle, NULL, NULL); -+#else -+ void* result; -+ UNUSED(handle); -+ UNUSED(symbol_name); -+ barf("lookupSymbolInNativeObj: Unsupported platform"); -+#endif - -- if (errmsg == NULL) { -- return NULL; -- } -+ RELEASE_LOCK(&linker_mutex); -+ return result; -+} - -- // GHC #2615 -- // On some systems (e.g., Gentoo Linux) dynamic files (e.g. libc.so) -- // contain linker scripts rather than ELF-format object code. This -- // code handles the situation by recognizing the real object code -- // file name given in the linker script. -- // -- // If an "invalid ELF header" error occurs, it is assumed that the -- // .so file contains a linker script instead of ELF object code. -- // In this case, the code looks for the GROUP ( ... ) linker -- // directive. If one is found, the first file name inside the -- // parentheses is treated as the name of a dynamic library and the -- // code attempts to dlopen that file. If this is also unsuccessful, -- // an error message is returned. -- -- // see if the error message is due to an invalid ELF header -- IF_DEBUG(linker, debugBelch("errmsg = '%s'\n", errmsg)); -- result = regexec(&re_invalid, errmsg, (size_t) NMATCH, match, 0); -- IF_DEBUG(linker, debugBelch("result = %i\n", result)); -- if (result == 0) { -- // success -- try to read the named file as a linker script -- match_length = (size_t) stg_min((match[1].rm_eo - match[1].rm_so), -- MAXLINE-1); -- strncpy(line, (errmsg+(match[1].rm_so)),match_length); -- line[match_length] = '\0'; // make sure string is null-terminated -- IF_DEBUG(linker, debugBelch("file name = '%s'\n", line)); -- if ((fp = __rts_fopen(line, "r")) == NULL) { -- return errmsg; // return original error if open fails -- } -- // try to find a GROUP or INPUT ( ... ) command -- while (fgets(line, MAXLINE, fp) != NULL) { -- IF_DEBUG(linker, debugBelch("input line = %s", line)); -- if (regexec(&re_realso, line, (size_t) NMATCH, match, 0) == 0) { -- // success -- try to dlopen the first named file -- IF_DEBUG(linker, debugBelch("match%s\n","")); -- line[match[2].rm_eo] = '\0'; -- stgFree((void*)errmsg); // Free old message before creating new one -- errmsg = internal_dlopen(line+match[2].rm_so); -- break; -- } -- // if control reaches here, no GROUP or INPUT ( ... ) directive -- // was found and the original error message is returned to the -- // caller -- } -- fclose(fp); -+const char *addDLL(pathchar* dll_name) -+{ -+ char *errmsg; -+ if (loadNativeObj(dll_name, &errmsg)) { -+ return NULL; -+ } else { -+ ASSERT(errmsg != NULL); -+ return errmsg; - } -- return errmsg; -- --# elif defined(OBJFORMAT_PEi386) -- return addDLL_PEi386(dll_name, NULL); -- --# else -- barf("addDLL: not implemented on this platform"); --# endif - } - - /* ----------------------------------------------------------------------------- -@@ -1215,10 +1104,10 @@ void freeObjectCode (ObjectCode *oc) - } - - if (oc->type == DYNAMIC_OBJECT) { --#if defined(OBJFORMAT_ELF) -- ACQUIRE_LOCK(&dl_mutex); -- freeNativeCode_ELF(oc); -- RELEASE_LOCK(&dl_mutex); -+#if defined(OBJFORMAT_ELF) || defined(darwin_HOST_OS) -+ ACQUIRE_LOCK(&linker_mutex); -+ freeNativeCode_POSIX(oc); -+ RELEASE_LOCK(&linker_mutex); - #else - barf("freeObjectCode: This shouldn't happen"); - #endif -@@ -1880,12 +1769,20 @@ HsInt purgeObj (pathchar *path) - return r; - } - -+ObjectCode *lookupObjectByPath(pathchar *path) { -+ for (ObjectCode *o = objects; o; o = o->next) { -+ if (0 == pathcmp(o->fileName, path)) { -+ return o; -+ } -+ } -+ return NULL; -+} -+ - OStatus getObjectLoadStatus_ (pathchar *path) - { -- for (ObjectCode *o = objects; o; o = o->next) { -- if (0 == pathcmp(o->fileName, path)) { -- return o->status; -- } -+ ObjectCode *oc = lookupObjectByPath(path); -+ if (oc) { -+ return oc->status; - } - return OBJECT_NOT_LOADED; - } -@@ -1970,27 +1867,35 @@ addSection (Section *s, SectionKind kind, SectionAlloc alloc, - size, kind )); - } - --#define UNUSED(x) (void)(x) -- --#if defined(OBJFORMAT_ELF) - void * loadNativeObj (pathchar *path, char **errmsg) - { -+ IF_DEBUG(linker, debugBelch("loadNativeObj: path = '%" PATH_FMT "'\n", path)); - ACQUIRE_LOCK(&linker_mutex); -- void *r = loadNativeObj_ELF(path, errmsg); -- RELEASE_LOCK(&linker_mutex); -- return r; --} -+ -+#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO) -+ void *r = loadNativeObj_POSIX(path, errmsg); -+#elif defined(OBJFORMAT_PEi386) -+ void *r = NULL; -+ *errmsg = (char*)addDLL_PEi386(path, (HINSTANCE*)&r); - #else --void * STG_NORETURN --loadNativeObj (pathchar *path, char **errmsg) --{ -- UNUSED(path); -+ void *r; - UNUSED(errmsg); - barf("loadNativeObj: not implemented on this platform"); --} - #endif - --HsInt unloadNativeObj (void *handle) -+#if defined(OBJFORMAT_ELF) -+ if (!r) { -+ // Check if native object may be a linker script and try loading a native -+ // object from it -+ r = loadNativeObjFromLinkerScript_ELF(errmsg); -+ } -+#endif -+ -+ RELEASE_LOCK(&linker_mutex); -+ return r; -+} -+ -+static HsInt unloadNativeObj_(void *handle) - { - bool unloadedAnyObj = false; - -@@ -2023,11 +1928,18 @@ HsInt unloadNativeObj (void *handle) - if (unloadedAnyObj) { - return 1; - } else { -- errorBelch("unloadObjNativeObj_ELF: can't find `%p' to unload", handle); -+ errorBelch("unloadObjNativeObj_: can't find `%p' to unload", handle); - return 0; - } - } - -+HsInt unloadNativeObj(void *handle) { -+ ACQUIRE_LOCK(&linker_mutex); -+ HsInt r = unloadNativeObj_(handle); -+ RELEASE_LOCK(&linker_mutex); -+ return r; -+} -+ - /* ----------------------------------------------------------------------------- - * Segment management - */ -diff --git a/rts/LinkerInternals.h b/rts/LinkerInternals.h -index 271611a249d..3fd772047a2 100644 ---- a/rts/LinkerInternals.h -+++ b/rts/LinkerInternals.h -@@ -404,10 +404,6 @@ extern Elf_Word shndx_table_uninit_label; - - #if defined(THREADED_RTS) - extern Mutex linker_mutex; -- --#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO) --extern Mutex dl_mutex; --#endif - #endif /* THREADED_RTS */ - - /* Type of an initializer */ -@@ -507,9 +503,9 @@ HsInt loadArchive_ (pathchar *path); - #define USE_CONTIGUOUS_MMAP 0 - #endif - -- - HsInt isAlreadyLoaded( pathchar *path ); - OStatus getObjectLoadStatus_ (pathchar *path); -+ObjectCode *lookupObjectByPath(pathchar *path); - HsInt loadOc( ObjectCode* oc ); - ObjectCode* mkOc( ObjectType type, pathchar *path, char *image, int imageSize, - bool mapped, pathchar *archiveMemberName, -diff --git a/rts/Profiling.c b/rts/Profiling.c -index 9dde1f28604..c3408fb8098 100644 ---- a/rts/Profiling.c -+++ b/rts/Profiling.c -@@ -58,7 +58,7 @@ CostCentre *CC_LIST = NULL; - static CostCentreStack *CCS_LIST = NULL; - - #if defined(THREADED_RTS) --static Mutex ccs_mutex; -+Mutex ccs_mutex; - #endif - - /* -diff --git a/rts/Profiling.h b/rts/Profiling.h -index b3724c3c881..d91e2cc9c1b 100644 ---- a/rts/Profiling.h -+++ b/rts/Profiling.h -@@ -55,6 +55,10 @@ extern Arena *prof_arena; - void debugCCS( CostCentreStack *ccs ); - #endif - -+#if defined(THREADED_RTS) -+extern Mutex ccs_mutex; -+#endif -+ - #endif - - #include "EndPrivate.h" -diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c -index cb03af8fb43..1937d7ee186 100644 ---- a/rts/RtsSymbols.c -+++ b/rts/RtsSymbols.c -@@ -508,6 +508,7 @@ extern char **environ; - SymI_HasDataProto(stg_block_putmvar) \ - MAIN_CAP_SYM \ - SymI_HasProto(addDLL) \ -+ SymI_HasProto(loadNativeObj) \ - SymI_HasProto(addLibrarySearchPath) \ - SymI_HasProto(removeLibrarySearchPath) \ - SymI_HasProto(findSystemLibrary) \ -@@ -618,6 +619,7 @@ extern char **environ; - SymI_HasProto(purgeObj) \ - SymI_HasProto(insertSymbol) \ - SymI_HasProto(lookupSymbol) \ -+ SymI_HasProto(lookupSymbolInNativeObj) \ - SymI_HasDataProto(stg_makeStablePtrzh) \ - SymI_HasDataProto(stg_mkApUpd0zh) \ - SymI_HasDataProto(stg_labelThreadzh) \ -diff --git a/rts/include/rts/Linker.h b/rts/include/rts/Linker.h -index ae463bc05ed..6e5b1f938d8 100644 ---- a/rts/include/rts/Linker.h -+++ b/rts/include/rts/Linker.h -@@ -90,8 +90,10 @@ void *loadNativeObj( pathchar *path, char **errmsg ); - Takes the handle returned from loadNativeObj() as an argument. */ - HsInt unloadNativeObj( void *handle ); - -+void *lookupSymbolInNativeObj(void *handle, const char *symbol_name); -+ - /* load a dynamic library */ --const char *addDLL( pathchar* dll_name ); -+const char *addDLL(pathchar* dll_name); - - /* add a path to the library search path */ - HsPtr addLibrarySearchPath(pathchar* dll_path); -diff --git a/rts/linker/Elf.c b/rts/linker/Elf.c -index bab2ca30412..e619c14cdf3 100644 ---- a/rts/linker/Elf.c -+++ b/rts/linker/Elf.c -@@ -27,11 +27,15 @@ - #include "sm/OSMem.h" - #include "linker/util.h" - #include "linker/elf_util.h" -+#include "linker/LoadNativeObjPosix.h" - -+#include - #include - #include - #include - #include -+#include // regex is already used by dlopen() so this is OK -+ // to use here without requiring an additional lib - #if defined(HAVE_DLFCN_H) - #include - #endif -@@ -2073,155 +2077,6 @@ int ocRunFini_ELF( ObjectCode *oc ) - return true; - } - --/* -- * Shared object loading -- */ -- --#if defined(HAVE_DLINFO) --struct piterate_cb_info { -- ObjectCode *nc; -- void *l_addr; /* base virtual address of the loaded code */ --}; -- --static int loadNativeObjCb_(struct dl_phdr_info *info, -- size_t _size STG_UNUSED, void *data) { -- struct piterate_cb_info *s = (struct piterate_cb_info *) data; -- -- // This logic mimicks _dl_addr_inside_object from glibc -- // For reference: -- // int -- // internal_function -- // _dl_addr_inside_object (struct link_map *l, const ElfW(Addr) addr) -- // { -- // int n = l->l_phnum; -- // const ElfW(Addr) reladdr = addr - l->l_addr; -- // -- // while (--n >= 0) -- // if (l->l_phdr[n].p_type == PT_LOAD -- // && reladdr - l->l_phdr[n].p_vaddr >= 0 -- // && reladdr - l->l_phdr[n].p_vaddr < l->l_phdr[n].p_memsz) -- // return 1; -- // return 0; -- // } -- -- if ((void*) info->dlpi_addr == s->l_addr) { -- int n = info->dlpi_phnum; -- while (--n >= 0) { -- if (info->dlpi_phdr[n].p_type == PT_LOAD) { -- NativeCodeRange* ncr = -- stgMallocBytes(sizeof(NativeCodeRange), "loadNativeObjCb_"); -- ncr->start = (void*) ((char*) s->l_addr + info->dlpi_phdr[n].p_vaddr); -- ncr->end = (void*) ((char*) ncr->start + info->dlpi_phdr[n].p_memsz); -- -- ncr->next = s->nc->nc_ranges; -- s->nc->nc_ranges = ncr; -- } -- } -- } -- return 0; --} --#endif /* defined(HAVE_DLINFO) */ -- --static void copyErrmsg(char** errmsg_dest, char* errmsg) { -- if (errmsg == NULL) errmsg = "loadNativeObj_ELF: unknown error"; -- *errmsg_dest = stgMallocBytes(strlen(errmsg)+1, "loadNativeObj_ELF"); -- strcpy(*errmsg_dest, errmsg); --} -- --// need dl_mutex --void freeNativeCode_ELF (ObjectCode *nc) { -- dlclose(nc->dlopen_handle); -- -- NativeCodeRange *ncr = nc->nc_ranges; -- while (ncr) { -- NativeCodeRange* last_ncr = ncr; -- ncr = ncr->next; -- stgFree(last_ncr); -- } --} -- --void * loadNativeObj_ELF (pathchar *path, char **errmsg) --{ -- ObjectCode* nc; -- void *hdl, *retval; -- -- IF_DEBUG(linker, debugBelch("loadNativeObj_ELF %" PATH_FMT "\n", path)); -- -- retval = NULL; -- ACQUIRE_LOCK(&dl_mutex); -- -- /* Loading the same object multiple times will lead to chaos -- * as we will have two ObjectCodes but one underlying dlopen -- * handle. Fail if this happens. -- */ -- if (getObjectLoadStatus_(path) != OBJECT_NOT_LOADED) { -- copyErrmsg(errmsg, "loadNativeObj_ELF: Already loaded"); -- goto dlopen_fail; -- } -- -- nc = mkOc(DYNAMIC_OBJECT, path, NULL, 0, false, NULL, 0); -- -- foreignExportsLoadingObject(nc); -- hdl = dlopen(path, RTLD_NOW|RTLD_LOCAL); -- nc->dlopen_handle = hdl; -- foreignExportsFinishedLoadingObject(); -- if (hdl == NULL) { -- /* dlopen failed; save the message in errmsg */ -- copyErrmsg(errmsg, dlerror()); -- goto dlopen_fail; -- } -- --#if defined(HAVE_DLINFO) -- struct link_map *map; -- if (dlinfo(hdl, RTLD_DI_LINKMAP, &map) == -1) { -- /* dlinfo failed; save the message in errmsg */ -- copyErrmsg(errmsg, dlerror()); -- goto dlinfo_fail; -- } -- -- hdl = NULL; // pass handle ownership to nc -- -- struct piterate_cb_info piterate_info = { -- .nc = nc, -- .l_addr = (void *) map->l_addr -- }; -- dl_iterate_phdr(loadNativeObjCb_, &piterate_info); -- if (!nc->nc_ranges) { -- copyErrmsg(errmsg, "dl_iterate_phdr failed to find obj"); -- goto dl_iterate_phdr_fail; -- } --#endif /* defined (HAVE_DLINFO) */ -- -- insertOCSectionIndices(nc); -- -- nc->next_loaded_object = loaded_objects; -- loaded_objects = nc; -- -- retval = nc->dlopen_handle; -- --#if defined(PROFILING) -- // collect any new cost centres that were defined in the loaded object. -- refreshProfilingCCSs(); --#endif -- -- goto success; -- --dl_iterate_phdr_fail: -- // already have dl_mutex -- freeNativeCode_ELF(nc); --dlinfo_fail: -- if (hdl) dlclose(hdl); --dlopen_fail: --success: -- -- RELEASE_LOCK(&dl_mutex); -- -- IF_DEBUG(linker, debugBelch("loadNativeObj_ELF result=%p\n", retval)); -- -- return retval; --} -- -- - /* - * PowerPC & X86_64 ELF specifics - */ -@@ -2271,4 +2126,79 @@ int ocAllocateExtras_ELF( ObjectCode *oc ) - - #endif /* NEED_SYMBOL_EXTRAS */ - -+extern regex_t re_invalid; -+extern regex_t re_realso; -+ -+// Try interpreting an object which couldn't be loaded as a linker script and -+// load the first object in the linker GROUP ( ... ) directive (see comment below). -+// -+// Receives the non-NULL error message outputted from an attempt to load an -+// object (eg `loadNativeObj_POSIX` ). -+// -+// Returns the handle to the loaded object first mentioned in the linker script. -+// If this process fails at any point, the function returns NULL and outputs a -+// new error message. -+void * loadNativeObjFromLinkerScript_ELF(char **errmsg) -+{ -+ // GHC #2615 -+ // On some systems (e.g., Gentoo Linux) dynamic files (e.g. libc.so) -+ // contain linker scripts rather than ELF-format object code. This -+ // code handles the situation by recognizing the real object code -+ // file name given in the linker script. -+ // -+ // If an "invalid ELF header" error occurs, it is assumed that the -+ // .so file contains a linker script instead of ELF object code. -+ // In this case, the code looks for the GROUP ( ... ) linker -+ // directive. If one is found, the first file name inside the -+ // parentheses is treated as the name of a dynamic library and the -+ // code attempts to dlopen that file. If this is also unsuccessful, -+ // an error message is returned. -+ -+#define NMATCH 5 -+ regmatch_t match[NMATCH]; -+ FILE* fp; -+ size_t match_length; -+#define MAXLINE 1000 -+ char line[MAXLINE]; -+ int result; -+ void* r = NULL; -+ -+ ASSERT_LOCK_HELD(&linker_mutex); -+ -+ // see if the error message is due to an invalid ELF header -+ IF_DEBUG(linker, debugBelch("errmsg = '%s'\n", *errmsg)); -+ result = regexec(&re_invalid, *errmsg, (size_t) NMATCH, match, 0); -+ IF_DEBUG(linker, debugBelch("result = %i\n", result)); -+ if (result == 0) { -+ // success -- try to read the named file as a linker script -+ match_length = (size_t) stg_min((match[1].rm_eo - match[1].rm_so), -+ MAXLINE-1); -+ strncpy(line, (*errmsg+(match[1].rm_so)),match_length); -+ line[match_length] = '\0'; // make sure string is null-terminated -+ IF_DEBUG(linker, debugBelch("file name = '%s'\n", line)); -+ if ((fp = __rts_fopen(line, "r")) == NULL) { -+ // return original error if open fails -+ return NULL; -+ } -+ // try to find a GROUP or INPUT ( ... ) command -+ while (fgets(line, MAXLINE, fp) != NULL) { -+ IF_DEBUG(linker, debugBelch("input line = %s", line)); -+ if (regexec(&re_realso, line, (size_t) NMATCH, match, 0) == 0) { -+ // success -- try to dlopen the first named file -+ IF_DEBUG(linker, debugBelch("match%s\n","")); -+ line[match[2].rm_eo] = '\0'; -+ stgFree((void*)*errmsg); // Free old message before creating new one -+ r = loadNativeObj_POSIX(line+match[2].rm_so, errmsg); -+ break; -+ } -+ // if control reaches here, no GROUP or INPUT ( ... ) directive -+ // was found and the original error message is returned to the -+ // caller -+ } -+ fclose(fp); -+ } -+ -+ return r; -+} -+ - #endif /* elf */ -diff --git a/rts/linker/Elf.h b/rts/linker/Elf.h -index 2b9ad87aee8..bee7526205d 100644 ---- a/rts/linker/Elf.h -+++ b/rts/linker/Elf.h -@@ -14,7 +14,6 @@ int ocResolve_ELF ( ObjectCode* oc ); - int ocRunInit_ELF ( ObjectCode* oc ); - int ocRunFini_ELF ( ObjectCode* oc ); - int ocAllocateExtras_ELF ( ObjectCode *oc ); --void freeNativeCode_ELF ( ObjectCode *nc ); --void *loadNativeObj_ELF ( pathchar *path, char **errmsg ); -+void *loadNativeObjFromLinkerScript_ELF( char **errmsg ); - - #include "EndPrivate.h" -diff --git a/rts/linker/LoadNativeObjPosix.c b/rts/linker/LoadNativeObjPosix.c -new file mode 100644 -index 00000000000..9e748a2a6e6 ---- /dev/null -+++ b/rts/linker/LoadNativeObjPosix.c -@@ -0,0 +1,210 @@ -+#include "LinkerInternals.h" -+#include "Rts.h" -+ -+#if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO) -+ -+#include "CheckUnload.h" -+#include "ForeignExports.h" -+#include "RtsUtils.h" -+#include "Profiling.h" -+ -+#include "linker/LoadNativeObjPosix.h" -+ -+#if defined(HAVE_DLFCN_H) -+#include -+#endif -+ -+#if defined(HAVE_DLINFO) -+#include -+#endif -+ -+#include -+ -+/* -+ * Shared object loading -+ */ -+ -+#if defined(HAVE_DLINFO) -+struct piterate_cb_info { -+ ObjectCode *nc; -+ void *l_addr; /* base virtual address of the loaded code */ -+}; -+ -+static int loadNativeObjCb_(struct dl_phdr_info *info, -+ size_t _size STG_UNUSED, void *data) { -+ struct piterate_cb_info *s = (struct piterate_cb_info *) data; -+ -+ // This logic mimicks _dl_addr_inside_object from glibc -+ // For reference: -+ // int -+ // internal_function -+ // _dl_addr_inside_object (struct link_map *l, const ElfW(Addr) addr) -+ // { -+ // int n = l->l_phnum; -+ // const ElfW(Addr) reladdr = addr - l->l_addr; -+ // -+ // while (--n >= 0) -+ // if (l->l_phdr[n].p_type == PT_LOAD -+ // && reladdr - l->l_phdr[n].p_vaddr >= 0 -+ // && reladdr - l->l_phdr[n].p_vaddr < l->l_phdr[n].p_memsz) -+ // return 1; -+ // return 0; -+ // } -+ -+ if ((void*) info->dlpi_addr == s->l_addr) { -+ int n = info->dlpi_phnum; -+ while (--n >= 0) { -+ if (info->dlpi_phdr[n].p_type == PT_LOAD) { -+ NativeCodeRange* ncr = -+ stgMallocBytes(sizeof(NativeCodeRange), "loadNativeObjCb_"); -+ ncr->start = (void*) ((char*) s->l_addr + info->dlpi_phdr[n].p_vaddr); -+ ncr->end = (void*) ((char*) ncr->start + info->dlpi_phdr[n].p_memsz); -+ -+ ncr->next = s->nc->nc_ranges; -+ s->nc->nc_ranges = ncr; -+ } -+ } -+ } -+ return 0; -+} -+#endif /* defined(HAVE_DLINFO) */ -+ -+static void copyErrmsg(char** errmsg_dest, char* errmsg) { -+ if (errmsg == NULL) errmsg = "loadNativeObj_POSIX: unknown error"; -+ *errmsg_dest = stgMallocBytes(strlen(errmsg)+1, "loadNativeObj_POSIX"); -+ strcpy(*errmsg_dest, errmsg); -+} -+ -+void freeNativeCode_POSIX (ObjectCode *nc) { -+ ASSERT_LOCK_HELD(&linker_mutex); -+ -+ dlclose(nc->dlopen_handle); -+ -+ NativeCodeRange *ncr = nc->nc_ranges; -+ while (ncr) { -+ NativeCodeRange* last_ncr = ncr; -+ ncr = ncr->next; -+ stgFree(last_ncr); -+ } -+} -+ -+void * loadNativeObj_POSIX (pathchar *path, char **errmsg) -+{ -+ ObjectCode* nc; -+ void *hdl, *retval; -+ -+ ASSERT_LOCK_HELD(&linker_mutex); -+ -+ IF_DEBUG(linker, debugBelch("loadNativeObj_POSIX %" PATH_FMT "\n", path)); -+ -+ retval = NULL; -+ -+ -+ /* If we load the same object multiple times, just return the -+ * already-loaded handle. Note that this is broken if unloadNativeObj -+ * is used, as we don’t do any reference counting; see #24345. -+ */ -+ ObjectCode *existing_oc = lookupObjectByPath(path); -+ if (existing_oc && existing_oc->status != OBJECT_UNLOADED) { -+ if (existing_oc->type == DYNAMIC_OBJECT) { -+ retval = existing_oc->dlopen_handle; -+ goto success; -+ } -+ copyErrmsg(errmsg, "loadNativeObj_POSIX: already loaded as non-dynamic object"); -+ goto dlopen_fail; -+ } -+ -+ nc = mkOc(DYNAMIC_OBJECT, path, NULL, 0, false, NULL, 0); -+ -+ foreignExportsLoadingObject(nc); -+ -+ // When dlopen() loads a profiled dynamic library, it calls the ctors which -+ // will call registerCcsList() to append the defined CostCentreStacks to -+ // CCS_LIST. However, another thread may be doing other things with the RTS -+ // linker that transitively calls refreshProfilingCCSs() which also accesses -+ // CCS_LIST. So there's a risk of data race that may lead to segfaults -+ // (#24423), and we need to ensure the ctors are also protected by -+ // ccs_mutex. -+#if defined(PROFILING) -+ ACQUIRE_LOCK(&ccs_mutex); -+#endif -+ -+ // If we HAVE_DLINFO, we use RTLD_NOW rather than RTLD_LAZY because we want -+ // to learn eagerly about all external functions. Otherwise, there is no -+ // additional advantage to being eager, so it is better to be lazy and only bind -+ // functions when needed for better performance. -+ int dlopen_mode; -+#if defined(HAVE_DLINFO) -+ dlopen_mode = RTLD_NOW; -+#else -+ dlopen_mode = RTLD_LAZY; -+#endif -+ -+ hdl = dlopen(path, dlopen_mode|RTLD_LOCAL); /* see Note [RTLD_LOCAL] */ -+ nc->dlopen_handle = hdl; -+ nc->status = OBJECT_READY; -+ -+#if defined(PROFILING) -+ RELEASE_LOCK(&ccs_mutex); -+#endif -+ -+ foreignExportsFinishedLoadingObject(); -+ -+ if (hdl == NULL) { -+ /* dlopen failed; save the message in errmsg */ -+ copyErrmsg(errmsg, dlerror()); -+ goto dlopen_fail; -+ } -+ -+#if defined(HAVE_DLINFO) -+ struct link_map *map; -+ if (dlinfo(hdl, RTLD_DI_LINKMAP, &map) == -1) { -+ /* dlinfo failed; save the message in errmsg */ -+ copyErrmsg(errmsg, dlerror()); -+ goto dlinfo_fail; -+ } -+ -+ hdl = NULL; // pass handle ownership to nc -+ -+ struct piterate_cb_info piterate_info = { -+ .nc = nc, -+ .l_addr = (void *) map->l_addr -+ }; -+ dl_iterate_phdr(loadNativeObjCb_, &piterate_info); -+ if (!nc->nc_ranges) { -+ copyErrmsg(errmsg, "dl_iterate_phdr failed to find obj"); -+ goto dl_iterate_phdr_fail; -+ } -+#endif /* defined (HAVE_DLINFO) */ -+ -+ insertOCSectionIndices(nc); -+ -+ nc->next_loaded_object = loaded_objects; -+ loaded_objects = nc; -+ -+ retval = nc->dlopen_handle; -+ -+#if defined(PROFILING) -+ // collect any new cost centres that were defined in the loaded object. -+ refreshProfilingCCSs(); -+#endif -+ -+ goto success; -+ -+#if defined(HAVE_DLINFO) -+dl_iterate_phdr_fail: -+#endif -+ freeNativeCode_POSIX(nc); -+#if defined(HAVE_DLINFO) -+dlinfo_fail: -+#endif -+ if (hdl) dlclose(hdl); -+dlopen_fail: -+success: -+ -+ IF_DEBUG(linker, debugBelch("loadNativeObj_POSIX result=%p\n", retval)); -+ -+ return retval; -+} -+ -+#endif /* elf + macho */ -diff --git a/rts/linker/LoadNativeObjPosix.h b/rts/linker/LoadNativeObjPosix.h -new file mode 100644 -index 00000000000..9708816c892 ---- /dev/null -+++ b/rts/linker/LoadNativeObjPosix.h -@@ -0,0 +1,11 @@ -+#pragma once -+ -+#include "Rts.h" -+#include "LinkerInternals.h" -+ -+#include "BeginPrivate.h" -+ -+void freeNativeCode_POSIX ( ObjectCode *nc ); -+void *loadNativeObj_POSIX ( pathchar *path, char **errmsg ); -+ -+#include "EndPrivate.h" -diff --git a/rts/linker/PEi386.c b/rts/linker/PEi386.c -index 7db6157fa6b..3d6024ef57d 100644 ---- a/rts/linker/PEi386.c -+++ b/rts/linker/PEi386.c -@@ -867,6 +867,7 @@ error: - stgFree(buf); - - char* errormsg = stgMallocBytes(sizeof(char) * 80, "addDLL_PEi386"); -+ if (loaded) *loaded = NULL; - snprintf(errormsg, 80, "addDLL: %" PATH_FMT " or dependencies not loaded. (Win32 error %lu)", dll_name, GetLastError()); - /* LoadLibrary failed; return a ptr to the error msg. */ - return errormsg; -@@ -1014,7 +1015,10 @@ bool checkAndLoadImportLibrary( pathchar* arch_name, char* member_name, FILE* f - stgFree(dllName); - - IF_DEBUG(linker, debugBelch("loadArchive: read symbol %s from lib `%" PATH_FMT "'\n", symbol, dll)); -- const char* result = addDLL(dll); -+ // We must call `addDLL_PEi386` directly rather than `addDLL` because `addDLL` -+ // is now a wrapper around `loadNativeObj` which acquires a lock which we -+ // already have here. -+ const char* result = addDLL_PEi386(dll, NULL); - - stgFree(image); - -@@ -1138,47 +1142,57 @@ SymbolAddr* - lookupSymbolInDLLs ( const SymbolName* lbl, ObjectCode *dependent ) - { - OpenedDLL* o_dll; -- SymbolAddr* sym; -+ SymbolAddr* res; - -- for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) { -- /* debugBelch("look in %ls for %s\n", o_dll->name, lbl); */ -+ for (o_dll = opened_dlls; o_dll != NULL; o_dll = o_dll->next) -+ if ((res = lookupSymbolInDLL_PEi386(lbl, o_dll->instance, o_dll->name, dependent))) -+ return res; -+ return NULL; -+} - -- sym = GetProcAddress(o_dll->instance, lbl+STRIP_LEADING_UNDERSCORE); -- if (sym != NULL) { -- /*debugBelch("found %s in %s\n", lbl+1,o_dll->name);*/ -- return sym; -- } -+SymbolAddr* -+lookupSymbolInDLL_PEi386 ( const SymbolName* lbl, HINSTANCE instance, pathchar* dll_name STG_UNUSED, ObjectCode *dependent) -+{ -+ SymbolAddr* sym; - -- // TODO: Drop this -- /* Ticket #2283. -- Long description: http://support.microsoft.com/kb/132044 -- tl;dr: -- If C/C++ compiler sees __declspec(dllimport) ... foo ... -- it generates call *__imp_foo, and __imp_foo here has exactly -- the same semantics as in __imp_foo = GetProcAddress(..., "foo") -- */ -- if (sym == NULL && strncmp (lbl, "__imp_", 6) == 0) { -- sym = GetProcAddress(o_dll->instance, -- lbl + 6 + STRIP_LEADING_UNDERSCORE); -- if (sym != NULL) { -- SymbolAddr** indirect = m32_alloc(dependent->rw_m32, sizeof(SymbolAddr*), 8); -- if (indirect == NULL) { -- barf("lookupSymbolInDLLs: Failed to allocation indirection"); -- } -- *indirect = sym; -- IF_DEBUG(linker, -- debugBelch("warning: %s from %S is linked instead of %s\n", -- lbl+6+STRIP_LEADING_UNDERSCORE, o_dll->name, lbl)); -- return (void*) indirect; -- } -- } -+ /* debugBelch("look in %ls for %s\n", dll_name, lbl); */ - -- sym = GetProcAddress(o_dll->instance, lbl); -+ sym = GetProcAddress(instance, lbl+STRIP_LEADING_UNDERSCORE); -+ if (sym != NULL) { -+ /*debugBelch("found %s in %ls\n", lbl+STRIP_LEADING_UNDERSCORE,dll_name);*/ -+ return sym; -+ } -+ -+ // TODO: Drop this -+ /* Ticket #2283. -+ Long description: http://support.microsoft.com/kb/132044 -+ tl;dr: -+ If C/C++ compiler sees __declspec(dllimport) ... foo ... -+ it generates call *__imp_foo, and __imp_foo here has exactly -+ the same semantics as in __imp_foo = GetProcAddress(..., "foo") -+ */ -+ if (sym == NULL && strncmp (lbl, "__imp_", 6) == 0) { -+ sym = GetProcAddress(instance, -+ lbl + 6 + STRIP_LEADING_UNDERSCORE); - if (sym != NULL) { -- /*debugBelch("found %s in %s\n", lbl,o_dll->name);*/ -- return sym; -+ SymbolAddr** indirect = m32_alloc(dependent->rw_m32, sizeof(SymbolAddr*), 8); -+ if (indirect == NULL) { -+ barf("lookupSymbolInDLLs: Failed to allocation indirection"); -+ } -+ *indirect = sym; -+ IF_DEBUG(linker, -+ debugBelch("warning: %s from %S is linked instead of %s\n", -+ lbl+6+STRIP_LEADING_UNDERSCORE, dll_name, lbl)); -+ return (void*) indirect; - } - } -+ -+ sym = GetProcAddress(instance, lbl); -+ if (sym != NULL) { -+ /*debugBelch("found %s in %s\n", lbl,dll_name);*/ -+ return sym; -+ } -+ - return NULL; - } - -@@ -1862,6 +1876,7 @@ ocGetNames_PEi386 ( ObjectCode* oc ) - if (result != NULL || dllInstance == 0) { - errorBelch("Could not load `%s'. Reason: %s\n", - (char*)dllName, result); -+ stgFree((void*)result); - return false; - } - -diff --git a/rts/linker/PEi386.h b/rts/linker/PEi386.h -index a3b05e30cb4..384c50aee3d 100644 ---- a/rts/linker/PEi386.h -+++ b/rts/linker/PEi386.h -@@ -60,6 +60,7 @@ bool ocRunFini_PEi386 ( ObjectCode *oc ); - bool ocGetNames_PEi386 ( ObjectCode* oc ); - bool ocVerifyImage_PEi386 ( ObjectCode* oc ); - SymbolAddr *lookupSymbol_PEi386(SymbolName *lbl, ObjectCode *dependent, SymType *type); -+SymbolAddr *lookupSymbolInDLL_PEi386 (const SymbolName* lbl, HINSTANCE instance, pathchar* dll_name, ObjectCode *dependent); - - /* See Note [mingw-w64 name decoration scheme] */ - /* We use myindex to calculate array addresses, rather than -diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in -index 82102a63720..bd2a5f4261e 100644 ---- a/rts/rts.cabal.in -+++ b/rts/rts.cabal.in -@@ -624,6 +624,7 @@ library - linker/Elf.c - linker/InitFini.c - linker/LoadArchive.c -+ linker/LoadNativeObjPosix.c - linker/M32Alloc.c - linker/MMap.c - linker/MachO.c diff --git a/NixSupport/mkGhcCompiler.nix b/NixSupport/mkGhcCompiler.nix index a6f576a17..0053f0746 100644 --- a/NixSupport/mkGhcCompiler.nix +++ b/NixSupport/mkGhcCompiler.nix @@ -39,9 +39,6 @@ let ihpDoJailbreakPackages = ["microlens-th"]; ihpDontHaddockPackages = []; in ghcCompiler.override { - ghc = if pkgs.stdenv.isDarwin - then ghcCompiler.ghc.overrideAttrs (oldAttrs: { patches = [ ./ghc-12264.patch ./scav-bco.patch ] ++ (oldAttrs.patches or []); }) - else ghcCompiler.ghc; overrides = composeExtensionsList [ generatedOverrides diff --git a/NixSupport/scav-bco.patch b/NixSupport/scav-bco.patch deleted file mode 100644 index 721c4f28a..000000000 --- a/NixSupport/scav-bco.patch +++ /dev/null @@ -1,27 +0,0 @@ -commit 1ed6e300d57a48129786ba2dfbda6da1e233a454 (HEAD -> wip/T23415-9.8) -Author: Ian-Woo Kim -Date: Mon May 22 12:22:33 2023 -0700 - - Add missing BCO handling in scavenge_one. - - (cherry picked from commit 902ebcc2b95707319d37a19d6b23c342cc14b162) - -diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c -index 8debec6a666..9bbe069d875 100644 ---- a/rts/sm/Scav.c -+++ b/rts/sm/Scav.c -@@ -1593,6 +1593,14 @@ scavenge_one(StgPtr p) - #endif - break; - -+ case BCO: { -+ StgBCO *bco = (StgBCO *)p; -+ evacuate((StgClosure **)&bco->instrs); -+ evacuate((StgClosure **)&bco->literals); -+ evacuate((StgClosure **)&bco->ptrs); -+ break; -+ } -+ - case COMPACT_NFDATA: - scavenge_compact((StgCompactNFData*)p); - break; diff --git a/flake.lock b/flake.lock index 05ead6bf6..2f682c3a3 100644 --- a/flake.lock +++ b/flake.lock @@ -343,11 +343,11 @@ ] }, "locked": { - "lastModified": 1719994518, - "narHash": "sha256-pQMhCCHyQGRzdfAkdJ4cIWiw+JNuWsTX7f0ZYSyz0VY=", + "lastModified": 1727826117, + "narHash": "sha256-K5ZLCyfO/Zj9mPFldf3iwS6oZStJcU4tSpiXTMYaaL0=", "owner": "hercules-ci", "repo": "flake-parts", - "rev": "9227223f6d922fee3c7b190b2cc238a99527bbb7", + "rev": "3d04084d54bedc3d6b8b736c70ef449225c361b1", "type": "github" }, "original": { @@ -668,11 +668,11 @@ ] }, "locked": { - "lastModified": 1714870368, - "narHash": "sha256-40eI5uHSTrKgHX6qJz4muP3MVjg2Zhxt3fIktqsx7GU=", + "lastModified": 1723099683, + "narHash": "sha256-x9s9jLdbW6RCIF0zU/MSc1yOIX2dI/X+wKVKsTn6qMM=", "owner": "digitallyinduced", "repo": "ihp-boilerplate", - "rev": "68eb3debd8e353653391214a658deafa6f72d91c", + "rev": "bb89c616788160fca842c377994bcca4ef2c660d", "type": "github" }, "original": { @@ -1419,17 +1419,17 @@ }, "nixpkgs_6": { "locked": { - "lastModified": 1714864423, - "narHash": "sha256-Wx3Y6arRJD1pd3c8SnD7dfW7KWuCr/r248P/5XLaMdM=", + "lastModified": 1735561296, + "narHash": "sha256-WnsX2qe3IVMKh3bZVKy9EpvXf4OG0YyxoHueM4Yxf/o=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "54b4bb956f9891b872904abdb632cea85a033ff2", + "rev": "3a08f5ea2c51f9ccf9e94c5ce6753d75aa542790", "type": "github" }, "original": { "owner": "NixOS", + "ref": "haskell-updates", "repo": "nixpkgs", - "rev": "54b4bb956f9891b872904abdb632cea85a033ff2", "type": "github" } }, diff --git a/flake.nix b/flake.nix index 3301cee59..0254732fd 100644 --- a/flake.nix +++ b/flake.nix @@ -2,7 +2,7 @@ description = "IHP is a modern batteries-included haskell web framework, built on top of Haskell and Nix."; inputs = { - nixpkgs.url = "github:NixOS/nixpkgs?rev=54b4bb956f9891b872904abdb632cea85a033ff2"; + nixpkgs.url = "github:NixOS/nixpkgs/haskell-updates"; # pre-defined set of default target systems systems.url = "github:nix-systems/default";