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
import BasicTypes ( SuccessFlag(..), succeeded, failed )
import Outputable
import Panic ( GhcException(..) )
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 )
-- Standard libraries
import Control.Monad ( when, filterM, foldM )
%************************************************************************
\begin{code}
%************************************************************************
\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.
-- Link a single expression, *including* first linking packages and
-- modules that this expression depends on.
-- Raises an IO exception if it can't find a compiled version of the
-- dependents to link.
-- 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
= 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)
-- 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
-- Link the packages and modules required
; linkPackages dflags pkgs
; ok <- linkModules dflags lnks
; if failed ok then
+ throwDyn (ProgramError "")
else do {
-- Link the expression itself
else do {
-- Link the expression itself
-- All wired-in names are in the base package, which we link
-- by default, so we can safely ignore them here.
-- 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
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
-> [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 {
-- Find all the packages and linkables that a set of modules depends on
= do { pls <- readIORef v_PersistentLinkerState ;
let {
-- 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
-- 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
return (lnks_needed, pkgs_needed) }
where
no_iface mod = ptext SLIT("No iface for") <+> ppr mod
-- This one is a GHC bug
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
-- 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))
| 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...
| otherwise
= -- It's not in the HPT because we are in one shot mode,
-- so use the Finder to get a ModLocation...
Found loc _ -> found loc mod_name ;
_ -> no_obj mod_name
}}
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 ;
-- ...and then find the linkable for it
mb_lnk <- findObjectLinkableMaybe mod_name loc ;
case mb_lnk of {
Nothing -> no_obj mod_name ;
+ 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)
import Kind ( Kind )
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
import Kind ( Kind )
import CoreLint ( lintUnfolding )
import DsMeta ( templateHaskellNames )
-import SrcLoc ( noSrcLoc )
+import SrcLoc ( noSrcLoc, getLoc )
import VarEnv ( emptyTidyEnv )
#endif
import VarEnv ( emptyTidyEnv )
#endif
compileExpr hsc_env this_mod rdr_env type_env tc_expr
= do { let { dflags = hsc_dflags hsc_env ;
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
-- Desugar it
; ds_expr <- deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
; bcos <- coreExprToBCOs dflags prepd_expr
-- link it
; bcos <- coreExprToBCOs dflags prepd_expr
-- link it
- ; hval <- linkExpr hsc_env bcos
+ ; hval <- linkExpr hsc_env srcspan bcos