diff --git a/NixSupport/ghc-12264.patch b/NixSupport/ghc-12264.patch new file mode 100644 index 000000000..894ea9085 --- /dev/null +++ b/NixSupport/ghc-12264.patch @@ -0,0 +1,2153 @@ +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 0053f0746..0eb97a3f9 100644 --- a/NixSupport/mkGhcCompiler.nix +++ b/NixSupport/mkGhcCompiler.nix @@ -39,6 +39,9 @@ let ihpDoJailbreakPackages = ["microlens-th"]; ihpDontHaddockPackages = []; in ghcCompiler.override { + ghc = ghcCompiler.ghc.overrideAttrs (oldAttrs: { + patches = [ ./ghc-12264.patch ] ++ (oldAttrs.patches or []); + }); overrides = composeExtensionsList [ generatedOverrides