X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FLinker.lhs;h=26f40ebbe4e13bea04ed7d03cef4a999fc7d6fa3;hp=3a5ecf8a6d62f508d37cd0449d162112dcaedfcc;hb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 3a5ecf8..26f40eb 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -30,20 +30,26 @@ import ByteCodeAsm ( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..)) import Packages import DriverPhases ( isObjectFilename, isDynLibFilename ) -import Finder ( findModule, findObjectLinkableMaybe, FindResult(..) ) +import Finder ( findHomeModule, findObjectLinkableMaybe, + FindResult(..) ) import HscTypes import Name ( Name, nameModule, isExternalName, isWiredInName ) import NameEnv import NameSet ( nameSetToList ) +import UniqFM ( lookupUFM ) import Module import ListSetOps ( minusList ) import DynFlags ( DynFlags(..), getOpts ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Outputable +import PackageConfig ( rtsPackageId ) import Panic ( GhcException(..) ) -import Util ( zipLazy, global, joinFileExt, joinFileName, suffixOf ) -import StaticFlags ( v_Ld_inputs ) -import ErrUtils ( debugTraceMsg ) +import Util ( zipLazy, global, joinFileExt, joinFileName, suffixOf, + replaceFilenameSuffix ) +import StaticFlags ( v_Ld_inputs, v_Build_tag ) +import ErrUtils ( debugTraceMsg, mkLocMessage ) +import DriverPhases ( phaseInputExt, Phase(..) ) +import SrcLoc ( SrcSpan ) -- Standard libraries import Control.Monad ( when, filterM, foldM ) @@ -55,7 +61,10 @@ import System.IO ( putStr, putStrLn, hPutStrLn, stderr, fixIO ) import System.Directory ( doesFileExist ) import Control.Exception ( block, throwDyn, bracket ) -import Maybe ( isJust, fromJust ) +import Maybe ( fromJust ) +#ifdef DEBUG +import Maybe ( isJust ) +#endif #if __GLASGOW_HASKELL__ >= 503 import GHC.IOBase ( IO(..) ) @@ -119,9 +128,7 @@ emptyPLS dflags = PersistentLinkerState { -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details. - where init_pkgs - | ExtPackage rts_id <- rtsPackageId (pkgState dflags) = [rts_id] - | otherwise = [] + where init_pkgs = [rtsPackageId] \end{code} \begin{code} @@ -146,8 +153,8 @@ withExtendedLinkEnv new_env action let new_closure_env = extendClosureEnv (closure_env pls) new_env new_pls = pls { closure_env = new_closure_env } writeIORef v_PersistentLinkerState new_pls - return pls - reset_old_env pls = writeIORef v_PersistentLinkerState pls + return (closure_env pls) + reset_old_env env = modifyIORef v_PersistentLinkerState (\pls -> pls{ closure_env = env }) -- filterNameMap removes from the environment all entries except -- those for a given set of modules; @@ -317,7 +324,7 @@ preloadLib dflags lib_paths framework_paths lib_spec %************************************************************************ \begin{code} -linkExpr :: HscEnv -> UnlinkedBCO -> IO HValue +linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue -- Link a single expression, *including* first linking packages and -- modules that this expression depends on. @@ -325,21 +332,28 @@ linkExpr :: HscEnv -> UnlinkedBCO -> IO HValue -- Raises an IO exception if it can't find a compiled version of the -- dependents to link. -linkExpr hsc_env root_ul_bco +linkExpr hsc_env span root_ul_bco = do { -- Initialise the linker (if it's not been done already) let dflags = hsc_dflags hsc_env ; initDynLinker dflags + -- The interpreter and dynamic linker can only handle object code built + -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky. + -- So here we check the build tag: if we're building a non-standard way + -- then we need to find & link object files built the "normal" way. + ; maybe_normal_osuf <- checkNonStdWay dflags span + -- Find what packages and linkables are required ; eps <- readIORef (hsc_EPS hsc_env) - ; (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps) needed_mods + ; (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps) + maybe_normal_osuf span needed_mods -- Link the packages and modules required ; linkPackages dflags pkgs ; ok <- linkModules dflags lnks ; if failed ok then - dieWith empty + throwDyn (ProgramError "") else do { -- Link the expression itself @@ -353,7 +367,6 @@ linkExpr hsc_env root_ul_bco }} where hpt = hsc_HPT hsc_env - dflags = hsc_dflags hsc_env free_names = nameSetToList (bcoFreeNames root_ul_bco) needed_mods :: [Module] @@ -366,14 +379,32 @@ linkExpr hsc_env root_ul_bco -- All wired-in names are in the base package, which we link -- by default, so we can safely ignore them here. -dieWith msg = throwDyn (ProgramError (showSDoc msg)) +dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg))) + + +checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String) +checkNonStdWay dflags srcspan = do + tag <- readIORef v_Build_tag + if null tag then return Nothing else do + let default_osuf = phaseInputExt StopLn + if objectSuf dflags == default_osuf + then failNonStd srcspan + else return (Just default_osuf) + +failNonStd srcspan = dieWith srcspan $ + ptext SLIT("Dynamic linking required, but this is a non-standard build (eg. prof).") $$ + ptext SLIT("You need to build the program twice: once the normal way, and then") $$ + ptext SLIT("in the desired way using -osuf to set the object file suffix.") + getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable + -> Maybe String -- the "normal" object suffix + -> SrcSpan -- for error messages -> [Module] -- If you need these -> IO ([Linkable], [PackageId]) -- ... then link these first -- Fails with an IO exception if it can't find enough files -getLinkDeps hsc_env hpt pit mods +getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods -- Find all the packages and linkables that a set of modules depends on = do { pls <- readIORef v_PersistentLinkerState ; let { @@ -385,57 +416,82 @@ getLinkDeps hsc_env hpt pit mods mods_needed = nub (concat mods_s) `minusList` linked_mods ; pkgs_needed = nub (concat pkgs_s) `minusList` pkgs_loaded pls ; - linked_mods = map linkableModule (objs_loaded pls ++ bcos_loaded pls) + linked_mods = map (moduleName.linkableModule) + (objs_loaded pls ++ bcos_loaded pls) } ; -- 3. For each dependent module, find its linkable -- This will either be in the HPT or (in the case of one-shot -- compilation) we may need to use maybe_getFileLinkable - lnks_needed <- mapM get_linkable mods_needed ; + lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ; return (lnks_needed, pkgs_needed) } where - get_deps :: Module -> ([Module],[PackageId]) + dflags = hsc_dflags hsc_env + this_pkg = thisPackage dflags + + get_deps :: Module -> ([ModuleName],[PackageId]) -- Get the things needed for the specified module -- This is rather similar to the code in RnNames.importsFromImportDecl get_deps mod - | ExtPackage p <- mi_package iface - = ([], p : dep_pkgs deps) + | pkg /= this_pkg + = ([], pkg : dep_pkgs deps) | otherwise - = (mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps) + = (moduleName mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps) where - iface = get_iface mod - deps = mi_deps iface + pkg = modulePackageId mod + deps = mi_deps (get_iface mod) - get_iface mod = case lookupIface hpt pit mod of + get_iface mod = case lookupIfaceByModule dflags hpt pit mod of Just iface -> iface Nothing -> pprPanic "getLinkDeps" (no_iface mod) no_iface mod = ptext SLIT("No iface for") <+> ppr mod -- This one is a GHC bug - no_obj mod = dieWith (ptext SLIT("No compiled code for") <+> ppr mod) + no_obj mod = dieWith span $ + ptext SLIT("cannot find object file for module ") <> + quotes (ppr mod) $$ + while_linking_expr + + while_linking_expr = ptext SLIT("while linking an interpreted expression") + -- This one is a build-system bug - get_linkable mod_name -- A home-package module - | Just mod_info <- lookupModuleEnv hpt mod_name + get_linkable maybe_normal_osuf mod_name -- A home-package module + | Just mod_info <- lookupUFM hpt mod_name = ASSERT(isJust (hm_linkable mod_info)) - return (fromJust (hm_linkable mod_info)) + adjust_linkable (fromJust (hm_linkable mod_info)) | otherwise - = -- It's not in the HPT because we are in one shot mode, + = do -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation... - do { mb_stuff <- findModule hsc_env mod_name False ; - case mb_stuff of { - Found loc _ -> found loc mod_name ; + mb_stuff <- findHomeModule hsc_env mod_name + case mb_stuff of + Found loc mod -> found loc mod _ -> no_obj mod_name - }} - found loc mod_name = do { + found loc mod = do { -- ...and then find the linkable for it - mb_lnk <- findObjectLinkableMaybe mod_name loc ; + mb_lnk <- findObjectLinkableMaybe mod loc ; case mb_lnk of { - Nothing -> no_obj mod_name ; - Just lnk -> return lnk + Nothing -> no_obj mod ; + Just lnk -> adjust_linkable lnk }} + + adjust_linkable lnk + | Just osuf <- maybe_normal_osuf = do + new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk) + return lnk{ linkableUnlinked=new_uls } + | otherwise = + return lnk + + adjust_ul osuf (DotO file) = do + let new_file = replaceFilenameSuffix file osuf + ok <- doesFileExist new_file + if (not ok) + then dieWith span $ + ptext SLIT("cannot find normal object file ") + <> quotes (text new_file) $$ while_linking_expr + else return (DotO new_file) \end{code}