diff --git a/compiler/GHC/ByteCode/Linker.hs b/compiler/GHC/ByteCode/Linker.hs index 346d1f6122f95b9d3b1474ae5db660bf5b333265..9d09f9874f60c2c7294ba275d95b95530b7d5497 100644 --- a/compiler/GHC/ByteCode/Linker.hs +++ b/compiler/GHC/ByteCode/Linker.hs @@ -24,6 +24,7 @@ import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHC.Builtin.PrimOps +import GHC.Builtin.PrimOps.Ids import GHC.Builtin.Names import GHC.Unit.Types @@ -38,6 +39,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 @@ -52,16 +55,17 @@ import GHC.Exts linkBCO :: Interp + -> PkgsLoaded -> LinkerEnv -> NameEnv Int -> UnlinkedBCO -> IO ResolvedBCO -linkBCO interp le bco_ix +linkBCO interp pkgs_loaded le bco_ix (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 :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp le) (elemsFlatBag lits0) - ptrs <- mapM (resolvePtr interp le bco_ix) (elemsFlatBag ptrs0) + (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (elemsFlatBag lits0) + ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix) (elemsFlatBag ptrs0) let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits return (ResolvedBCO isLittleEndian arity insns @@ -69,17 +73,17 @@ linkBCO interp le bco_ix (mkBCOByteArray 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,34 +117,35 @@ 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 -> BCOPtr -> IO ResolvedBCOPtr -resolvePtr interp le bco_ix ptr = case ptr of +resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of BCOPtrName nm | Just ix <- lookupNameEnv bco_ix nm -> return (ResolvedBCORef ix) -- ref to another BCO in this group @@ -152,20 +157,42 @@ resolvePtr interp le bco_ix 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 bco + -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix bco BCOPtrBreakArray breakarray -> withForeignRef breakarray $ \ba -> return (ResolvedBCOPtrBreakArray ba) +-- | 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/Plugins.hs b/compiler/GHC/Driver/Plugins.hs index 5be8fe29ffdbc5b2c00787dfb67d825bb017bced..30bc5c1b95724f68fa8468eb834443568b60a7a5 100644 --- a/compiler/GHC/Driver/Plugins.hs +++ b/compiler/GHC/Driver/Plugins.hs @@ -420,12 +420,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 1f4215dba16fade5c2d09714d2cd00287da2ac3b..c7ce4ceef530a01781b717605bcd266a54a2a48b 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -55,6 +55,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 @@ -173,7 +174,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 = @@ -222,8 +223,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 @@ -513,25 +514,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 -> @@ -615,7 +616,7 @@ loadExpr interp hsc_env span root_ul_bco = do -- Load the necessary packages and linkables let le = linker_env pls bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)] - resolved <- linkBCO interp le bco_ix root_ul_bco + resolved <- linkBCO interp (pkgs_loaded pls) le bco_ix root_ul_bco [root_hvref] <- createBCOs interp [resolved] fhv <- mkFinalizedHValue interp root_hvref return (pls, fhv) @@ -678,7 +679,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 } } @@ -859,8 +860,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" @@ -900,7 +901,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 pls) le2 cbcs -- We only want to add the external ones to the ClosureEnv let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs @@ -915,6 +916,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)] @@ -922,7 +924,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 = inner (Foldable.toList bc_bcos : accum) @@ -932,7 +934,7 @@ linkSomeBCOs interp le mods = foldr fun do_link mods [] let flat = [ bco | bcos <- mods, bco <- bcos ] names = map unlinkedBCOName flat bco_ix = mkNameEnv (zip names [0..]) - resolved <- sequence [ linkBCO interp le bco_ix bco | bco <- flat ] + resolved <- sequence [ linkBCO interp pkgs_loaded le bco_ix bco | bco <- flat ] hvrefs <- createBCOs interp resolved return (zip names hvrefs) @@ -1094,18 +1096,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 @@ -1147,7 +1149,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 @@ -1168,10 +1172,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 @@ -1191,7 +1198,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)) @@ -1244,19 +1251,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 32886587f027e83461e83f043fdd6a20ad63a54d..6d8970e20c0a3b0d6bc7ca94842889230db81be7 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 c343537b08322f36b84494a7707b09a44df23514..adf2e63b500a1a1cedc5c5a93b2436007323c6d6 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 d5e2ff713984ef0d38d9623d59dccfb39d7c3d8d..6ca2be08041c2a60f22eaeb53a8d5a30fd21953c 100644 --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -35,6 +35,7 @@ module GHC.Runtime.Interpreter -- * The object-code linker , initObjLinker , lookupSymbol + , lookupSymbolInDLL , lookupClosure , loadDLL , loadArchive @@ -467,6 +468,13 @@ lookupSymbol interp str = case interpInstance interp of ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) +lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> FastString -> IO (Maybe (Ptr ())) +lookupSymbolInDLL interp dll str = case interpInstance interp of +#if defined(HAVE_INTERNAL_INTERPRETER) + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS str)) +#endif + ExternalInterp _ -> panic "lookupSymbolInDLL: not implemented for external interpreter" -- FIXME + lookupClosure :: Interp -> String -> IO (Maybe HValueRef) lookupClosure interp str = interpCmd interp (LookupClosure str) @@ -485,12 +493,7 @@ purgeLookupSymbolCache interp = case interpInstance interp of -- 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 () diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs index a903e7dc662df3540aa3d03f03af223b6bea63a6..8cf03d618f48898076a3c1723d124ab805416e8a 100644 --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -23,6 +23,7 @@ module GHCi.Message , getMessage, putMessage, getTHMessage, putTHMessage , Pipe(..), remoteCall, remoteTHCall, readPipe, writePipe , BreakModule + , LoadedDLL ) where import Prelude -- See note [Why do we import Prelude here?] @@ -73,8 +74,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? @@ -415,6 +417,9 @@ instance Binary a => Binary (EvalResult a) -- that type isn't available here. data BreakModule +-- | 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: @@ -544,6 +549,7 @@ getMessage = do 37 -> Msg <$> return RtsRevertCAFs 38 -> Msg <$> (ResumeSeq <$> get) 39 -> Msg <$> (NewBreakModule <$> get) + 40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get) _ -> error $ "Unknown Message code " ++ (show b) putMessage :: Message a -> Put @@ -588,7 +594,8 @@ putMessage m = case m of Seq a -> putWord8 36 >> put a RtsRevertCAFs -> putWord8 37 ResumeSeq a -> putWord8 38 >> put a - NewBreakModule name -> putWord8 39 >> put name + NewBreakModule name -> putWord8 39 >> put name + LookupSymbolInDLL dll str -> putWord8 40 >> put dll >> put str {- Note [Parallelize CreateBCOs serialization] diff --git a/libraries/ghci/GHCi/ObjLink.hs b/libraries/ghci/GHCi/ObjLink.hs index 8c9f75b9f9f4ec15329d3718e330806f2b301a8a..a0b006cdd4572b18f8385fff0d5b7c51330c1249 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_lookupSymbolInDLL 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,7 +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) +loadDLL :: String -> IO (Either String (Ptr LoadedDLL)) -- Nothing => success -- Just err_msg => failure loadDLL str0 = do @@ -101,12 +110,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_addDLL 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 +176,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 "addDLL" c_addDLL :: CFilePath -> Ptr CString -> IO (Ptr LoadedDLL) +foreign import ccall unsafe "lookupSymbolInDLL" c_lookupSymbolInDLL :: 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 80626338b7aa3b7704b9a106175321bfe5f968b9..18fd5e991be2b11c0cef403372402504bb5b0870 100644 --- a/libraries/ghci/GHCi/Run.hs +++ b/libraries/ghci/GHCi/Run.hs @@ -66,7 +66,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 @@ -81,6 +81,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 64f54cf0eaa2b4f92e821ba309a8569178022976..6f65ff91d3e4122d85c6034cb7d9115dbffedbd1 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -578,13 +578,11 @@ typedef /* A list thereof. */ static OpenedSO* openedSOs = NULL; -static const char * -internal_dlopen(const char *dll_name) +static void * +internal_dlopen(const char *dll_name, const char **errmsg_ptr) { 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 @@ -619,14 +617,13 @@ internal_dlopen(const char *dll_name) RELEASE_LOCK(&ccs_mutex); #endif - errmsg = NULL; if (hdl == NULL) { /* dlopen failed; return a ptr to the error msg. */ - errmsg = dlerror(); + char *errmsg = dlerror(); if (errmsg == NULL) errmsg = "addDLL: unknown error"; - errmsg_copy = stgMallocBytes(strlen(errmsg)+1, "addDLL"); + char *errmsg_copy = stgMallocBytes(strlen(errmsg)+1, "addDLL"); strcpy(errmsg_copy, errmsg); - errmsg = errmsg_copy; + *errmsg_ptr = errmsg_copy; } else { o_so = stgMallocBytes(sizeof(OpenedSO), "addDLL"); o_so->handle = hdl; @@ -637,7 +634,7 @@ internal_dlopen(const char *dll_name) RELEASE_LOCK(&dl_mutex); //--------------- End critical section ------------------- - return errmsg; + return hdl; } /* @@ -725,16 +722,29 @@ internal_dlsym(const char *symbol) { // we failed to find the symbol return NULL; } + +void *lookupSymbolInDLL(void *handle, const char *symbol_name) +{ +#if defined(OBJFORMAT_MACHO) + CHECK(symbol_name[0] == '_'); + symbol_name = symbol_name+1; +#endif + + ACQUIRE_LOCK(&dl_mutex); // dlsym alters dlerror + void *result = dlsym(handle, symbol_name); + RELEASE_LOCK(&dl_mutex); + return result; +} # endif -const char * -addDLL( pathchar *dll_name ) +void *addDLL(pathchar* dll_name, const char **errmsg_ptr) { # if defined(OBJFORMAT_ELF) || defined(OBJFORMAT_MACHO) /* ------------------- ELF DLL loader ------------------- */ #define NMATCH 5 regmatch_t match[NMATCH]; + void *handle; const char *errmsg; FILE* fp; size_t match_length; @@ -743,10 +753,10 @@ addDLL( pathchar *dll_name ) int result; IF_DEBUG(linker, debugBelch("addDLL: dll_name = '%s'\n", dll_name)); - errmsg = internal_dlopen(dll_name); + handle = internal_dlopen(dll_name, &errmsg); - if (errmsg == NULL) { - return NULL; + if (handle != NULL) { + return handle; } // GHC #2615 @@ -775,7 +785,8 @@ addDLL( pathchar *dll_name ) 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 + *errmsg_ptr = errmsg; // return original error if open fails + return NULL; } // try to find a GROUP or INPUT ( ... ) command while (fgets(line, MAXLINE, fp) != NULL) { @@ -785,7 +796,7 @@ addDLL( pathchar *dll_name ) 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); + handle = internal_dlopen(line+match[2].rm_so, errmsg_ptr); break; } // if control reaches here, no GROUP or INPUT ( ... ) directive @@ -794,9 +805,10 @@ addDLL( pathchar *dll_name ) } fclose(fp); } - return errmsg; + return handle; # elif defined(OBJFORMAT_PEi386) + // FIXME return addDLL_PEi386(dll_name, NULL); # else diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c index 285049a3066cc4cb2d401bfa463d16810924d88c..9c8270cf3c6dc216e17f052014d73d67e65647fe 100644 --- a/rts/RtsSymbols.c +++ b/rts/RtsSymbols.c @@ -621,6 +621,7 @@ extern char **environ; SymI_HasProto(purgeObj) \ SymI_HasProto(insertSymbol) \ SymI_HasProto(lookupSymbol) \ + SymI_HasProto(lookupSymbolInDLL) \ 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 ae463bc05ed73dd9df366c2e974fcdacbb254dd4..cd40479d1542ee3b8ae0b2bea368599f550ffb61 100644 --- a/rts/include/rts/Linker.h +++ b/rts/include/rts/Linker.h @@ -91,7 +91,9 @@ void *loadNativeObj( pathchar *path, char **errmsg ); HsInt unloadNativeObj( void *handle ); /* load a dynamic library */ -const char *addDLL( pathchar* dll_name ); +void *addDLL(pathchar* dll_name, const char **errmsg); + +void *lookupSymbolInDLL(void *handle, const char *symbol_name); /* add a path to the library search path */ HsPtr addLibrarySearchPath(pathchar* dll_path); diff --git a/testsuite/tests/rts/linker/T2615.hs b/testsuite/tests/rts/linker/T2615.hs index a7aa5dd40d9252e30eb6f48b7339f5f67ae93bc9..66bace833482042eb474882c30e4f2241a116d3f 100644 --- a/testsuite/tests/rts/linker/T2615.hs +++ b/testsuite/tests/rts/linker/T2615.hs @@ -6,5 +6,5 @@ main = do initObjLinker RetainCAFs result <- loadDLL library_name case result of - Nothing -> putStrLn (library_name ++ " loaded successfully") - Just x -> putStrLn ("error: " ++ x) + Right _ -> putStrLn (library_name ++ " loaded successfully") + Left x -> putStrLn ("error: " ++ x)