%
-% (c) The University of Glasgow 2005
+% (c) The University of Glasgow 2005-2006
%
-- --------------------------------------
\begin{code}
-
{-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-}
module Linker ( HValue, showLinkerState,
linkExpr, unload, extendLinkEnv, withExtendedLinkEnv,
extendLoadedPkgs,
linkPackages,initDynLinker
+ ,recoverDataCon
) where
#include "HsVersions.h"
-import ObjLink ( loadDLL, loadObj, unloadObj, resolveObjs, initObjLinker )
-import ByteCodeLink ( HValue, ClosureEnv, extendClosureEnv, linkBCO )
-import ByteCodeItbls ( ItblEnv )
-import ByteCodeAsm ( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..))
-
+import ObjLink
+import ByteCodeLink
+import ByteCodeItbls
+import ByteCodeAsm
+import RtClosureInspect
+import Var
+import IfaceEnv
+import Config
+import OccName
+import TcRnMonad
+import Constants
+import Encoding
import Packages
-import DriverPhases ( isObjectFilename, isDynLibFilename )
-import Finder ( findModule, findObjectLinkableMaybe, FindResult(..) )
+import DriverPhases
+import Finder
import HscTypes
-import Name ( Name, nameModule, isExternalName, isWiredInName )
+import Name
import NameEnv
-import NameSet ( nameSetToList )
+import NameSet
+import UniqFM
import Module
-import ListSetOps ( minusList )
-import DynFlags ( DynFlags(..), getOpts )
-import BasicTypes ( SuccessFlag(..), succeeded, failed )
+import ListSetOps
+import DynFlags
+import BasicTypes
import Outputable
-import Panic ( GhcException(..) )
-import Util ( zipLazy, global, joinFileExt, joinFileName, suffixOf )
-import StaticFlags ( v_Ld_inputs )
-import ErrUtils ( debugTraceMsg )
+import PackageConfig
+import Panic
+import Util
+import StaticFlags
+import ErrUtils
+import DriverPhases
+import SrcLoc
-- Standard libraries
-import Control.Monad ( when, filterM, foldM )
+import Control.Monad
+import Control.Arrow ( second )
-import Data.IORef ( IORef, readIORef, writeIORef, modifyIORef )
-import Data.List ( partition, nub )
+import Data.IORef
+import Data.List
+import Foreign.Ptr
+import GHC.Exts
-import System.IO ( putStr, putStrLn, hPutStrLn, stderr, fixIO )
-import System.Directory ( doesFileExist )
+import System.IO
+import System.Directory
-import Control.Exception ( block, throwDyn, bracket )
-import Maybe ( isJust, fromJust )
+import Control.Exception
+import Data.Maybe
#if __GLASGOW_HASKELL__ >= 503
import GHC.IOBase ( IO(..) )
-- Held, as usual, in dependency order; though I am not sure if
-- that is really important
pkgs_loaded :: [PackageId]
+ ,dtacons_env :: DataConEnv
}
emptyPLS :: DynFlags -> PersistentLinkerState
itbl_env = emptyNameEnv,
pkgs_loaded = init_pkgs,
bcos_loaded = [],
- objs_loaded = [] }
+ objs_loaded = []
+ , dtacons_env = emptyAddressEnv
+ }
-- Packages that don't need loading, because the compiler
-- shares them with the interpreted program.
--
-- 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}
new_pls = pls { closure_env = new_closure_env }
writeIORef v_PersistentLinkerState new_pls
+
+recoverDataCon :: a -> TcM Name
+recoverDataCon a = recoverDCInRTS a `recoverM` ioToTcRn (do
+ mb_name <- recoverDCInDynEnv a
+ maybe (fail "Linker.recoverDatacon: Name not found in Dyn Env")
+ return
+ mb_name)
+
+-- | If a is a Constr closure, lookupDC returns either the Name of the DataCon or the
+-- symbol if it is a nullary constructor
+-- For instance, for a closure containing 'Just x' it would return the Name for Data.Maybe.Just
+-- For a closure containing 'Nothing' it would return the String "DataziMaybe_Nothing_static_info"
+recoverDCInDynEnv :: a -> IO (Maybe Name)
+recoverDCInDynEnv a = do
+ pls <- readIORef v_PersistentLinkerState
+ let de = dtacons_env pls
+ ctype <- getClosureType a
+ if not (isConstr ctype)
+ then putStrLn ("Not a Constr (" ++ show ctype ++ ")") >>
+ return Nothing
+ else do let infot = getInfoTablePtr a
+ name = lookupAddressEnv de (castPtr$ infot `plusPtr` (wORD_SIZE*2))
+ return name
+
+
+recoverDCInRTS :: a -> TcM Name
+recoverDCInRTS a = do
+ ctype <- ioToTcRn$ getClosureType a
+ if (not$ isConstr ctype)
+ then fail "not Constr"
+ else do
+ Just symbol <- ioToTcRn$ lookupDataCon (getInfoTablePtr a)
+ let (occ,mod) = (parse . lex) symbol
+ lookupOrig mod occ
+ where lex x = map zDecodeString . init . init . split '_' . removeLeadingUnderscore $ x
+ parse [pkg, modName, occ] = (mkOccName OccName.dataName occ,
+ mkModule (stringToPackageId pkg) (mkModuleName modName))
+ parse [modName, occ] = (mkOccName OccName.dataName occ,
+ mkModule mainPackageId (mkModuleName modName))
+ split delim = let
+ helper [] = Nothing
+ helper x = Just . second (drop 1) . break (==delim) $ x
+ in unfoldr helper
+
+removeLeadingUnderscore = if cLeadingUnderscore=="YES"
+ then tail
+ else id
+
+
+
withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
withExtendedLinkEnv new_env action
= bracket set_new_env
printDump (vcat [text "----- Linker state -----",
text "Pkgs:" <+> ppr (pkgs_loaded pls),
text "Objs:" <+> ppr (objs_loaded pls),
- text "BCOs:" <+> ppr (bcos_loaded pls)])
+ text "BCOs:" <+> ppr (bcos_loaded pls),
+ text "DataCons:" <+> ppr (dtacons_env pls)
+ ])
\end{code}
a) calling the C initialisation procedure
b) Loading any packages specified on the command line,
- now held in v_ExplicitPackages
c) Loading any packages specified on the command line,
now held in the -l options in v_Opt_l
; initObjLinker
-- (b) Load packages from the command-line
- ; linkPackages dflags (explicitPackages (pkgState dflags))
+ ; linkPackages dflags (preloadPackages (pkgState dflags))
-- (c) Link libraries from the command-line
; let optl = getOpts dflags opt_l
%************************************************************************
\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.
--
-- Raises an IO exception if it can't find a compiled version of the
-- dependents to link.
+--
+-- Note: This function side-effects the linker state (Pepe)
-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
pls <- readIORef v_PersistentLinkerState
; let ie = itbl_env pls
ce = closure_env pls
+ de = dtacons_env pls
-- Link the necessary packages and linkables
- ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
+ ; (_,de_out, (root_hval:_)) <- linkSomeBCOs False ie ce de [root_ul_bco]
+ ; writeIORef v_PersistentLinkerState (pls{dtacons_env=de_out})
; return root_hval
}}
where
hpt = hsc_HPT hsc_env
- dflags = hsc_dflags hsc_env
free_names = nameSetToList (bcoFreeNames root_ul_bco)
needed_mods :: [Module]
-- 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 {
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 {
+ where
+ 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}
gce = closure_env pls
final_ie = foldr plusNameEnv (itbl_env pls) ies
- (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
+ (final_gce, final_de, linked_bcos) <- linkSomeBCOs True final_ie gce (dtacons_env pls) ul_bcos
-- What happens to these linked_bcos?
let pls2 = pls1 { closure_env = final_gce,
+ dtacons_env = final_de,
itbl_env = final_ie }
writeIORef v_PersistentLinkerState pls2
-- True <=> add only toplevel BCOs to closure env
-> ItblEnv
-> ClosureEnv
+ -> DataConEnv
-> [UnlinkedBCO]
- -> IO (ClosureEnv, [HValue])
+ -> IO (ClosureEnv, DataConEnv, [HValue])
-- The returned HValues are associated 1-1 with
-- the incoming unlinked BCOs. Each gives the
-- value of the corresponding unlinked BCO
-
-linkSomeBCOs toplevs_only ie ce_in ul_bcos
+linkSomeBCOs toplevs_only ie ce_in de_in ul_bcos
= do let nms = map unlinkedBCOName ul_bcos
hvals <- fixIO
( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
in mapM (linkBCO ie ce_out) ul_bcos )
-
let ce_all_additions = zip nms hvals
ce_top_additions = filter (isExternalName.fst) ce_all_additions
ce_additions = if toplevs_only then ce_top_additions
-- closure environment, which leads to trouble.
ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
extendClosureEnv ce_in ce_additions
- return (ce_out, hvals)
-
+ refs = goForRefs ul_bcos
+ names = nub$ concatMap (ssElts . unlinkedBCOItbls) (ul_bcos ++ refs)
+ addresses <- mapM (lookupIE ie) names
+ let de_additions = [(address, name) | (address, name) <- zip addresses names
+ , not(address `elemAddressEnv` de_in)
+ ]
+ de_out = extendAddressEnvList' de_in de_additions
+ return ( ce_out, de_out, hvals)
+ where
+ goForRefs = getRefs []
+ getRefs acc [] = acc
+ getRefs acc new = getRefs (new++acc)
+ [bco | BCOPtrBCO bco <- concatMap (ssElts . unlinkedBCOPtrs) new
+ , notElemBy bco (new ++ acc) nameEq]
+ ul1 `nameEq` ul2 = unlinkedBCOName ul1 == unlinkedBCOName ul2
+ (x1 `notElemBy` x2) eq = null$ intersectBy eq [x1] x2
\end{code}
projects / ghc-hetmet.git / blobdiff