From 6f5d77444aec9d84d9af59315c6c7885de33ed55 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Wed, 21 Jun 2006 11:04:36 +0000 Subject: [PATCH] Allow Template Haskell to be used with -prof In order for this to work, you need to build the program first in the normal way (without -prof), and then again with -prof and a suitable -osuf (eg. -osuf p_o). The compiler will pick up the object files from the normal way for running TH expressions, when it sees -prof together with -osuf. If you omit the -osuf, you get an error message: TH_genEx.hs:12:2: Dynamic linking required, but this is a non-standard build (eg. prof). You need to build the program twice: once the normal way, and then in the desired way using -osuf to set the object file suffix. If you use -osuf, but haven't built the program the normal way first, then you see: TH_genEx.hs:12:2: cannot find normal object file `TH_genExLib.o' while linking an interpreted expression Documentation to follow. Fixes: #651 --- compiler/ghci/Linker.lhs | 82 ++++++++++++++++++++++++++++++++++++--------- compiler/main/HscMain.lhs | 7 ++-- 2 files changed, 70 insertions(+), 19 deletions(-) diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index c97f942..cec1047 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -41,9 +41,12 @@ import DynFlags ( DynFlags(..), getOpts ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Outputable 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 ) @@ -317,7 +320,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 +328,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 @@ -366,14 +376,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 { @@ -391,7 +419,7 @@ getLinkDeps hsc_env hpt pit mods -- 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 @@ -413,13 +441,19 @@ getLinkDeps hsc_env hpt pit mods 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 + get_linkable maybe_normal_osuf mod_name -- A home-package module | Just mod_info <- lookupModuleEnv 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, -- so use the Finder to get a ModLocation... @@ -428,14 +462,30 @@ getLinkDeps hsc_env hpt pit mods Found loc _ -> found loc mod_name ; _ -> no_obj mod_name }} - - found loc mod_name = do { + where + found loc mod_name = do { -- ...and then find the linkable for it mb_lnk <- findObjectLinkableMaybe mod_name loc ; case mb_lnk of { Nothing -> no_obj mod_name ; - Just lnk -> return lnk + 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} diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index d5d920d..d25202f 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -41,7 +41,7 @@ import PrelNames ( iNTERACTIVE ) import Kind ( Kind ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) -import SrcLoc ( noSrcLoc ) +import SrcLoc ( noSrcLoc, getLoc ) import VarEnv ( emptyTidyEnv ) #endif @@ -901,7 +901,8 @@ compileExpr :: HscEnv compileExpr hsc_env this_mod rdr_env type_env tc_expr = do { let { dflags = hsc_dflags hsc_env ; - lint_on = dopt Opt_DoCoreLinting dflags } + lint_on = dopt Opt_DoCoreLinting dflags ; + !srcspan = getLoc tc_expr } -- Desugar it ; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr @@ -931,7 +932,7 @@ compileExpr hsc_env this_mod rdr_env type_env tc_expr ; bcos <- coreExprToBCOs dflags prepd_expr -- link it - ; hval <- linkExpr hsc_env bcos + ; hval <- linkExpr hsc_env srcspan bcos ; return hval } -- 1.7.10.4