\begin{code}
{-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-}
+{-# OPTIONS -fno-cse #-}
+-- -fno-cse is needed for GLOBAL_VAR's to behave properly
+
module Linker ( HValue, getHValue, showLinkerState,
- linkExpr, unload, extendLinkEnv, withExtendedLinkEnv,
- extendLoadedPkgs,
+ linkExpr, unload, withExtendedLinkEnv,
+ extendLinkEnv, deleteFromLinkEnv,
+ extendLoadedPkgs,
linkPackages,initDynLinker,
- recoverDataCon
+ dataConInfoPtrToName
) where
#include "HsVersions.h"
+import LoadIface
import ObjLink
import ByteCodeLink
import ByteCodeItbls
import ByteCodeAsm
-import RtClosureInspect
-import Var
+import CgInfoTbls
+import SMRep
import IfaceEnv
-import Config
-import OccName
import TcRnMonad
-import Constants
-import Encoding
import Packages
import DriverPhases
import Finder
import Name
import NameEnv
import NameSet
-import UniqFM
+import qualified OccName
+import LazyUniqFM
import Module
import ListSetOps
import DynFlags
import BasicTypes
import Outputable
-import PackageConfig
import Panic
import Util
import StaticFlags
import ErrUtils
-import DriverPhases
import SrcLoc
+import qualified Maybes
+import UniqSet
+import Constants
+import FastString
+import Config ( cProjectVersion )
-- Standard libraries
import Control.Monad
-import Control.Arrow ( second )
+import Data.Char
import Data.IORef
import Data.List
-import Foreign.Ptr
-import GHC.Exts
+import Foreign
+import System.FilePath
import System.IO
import System.Directory
-import Control.Exception
-import Data.Maybe
+import Distribution.Package hiding (depends, PackageId)
-#if __GLASGOW_HASKELL__ >= 503
-import GHC.IOBase ( IO(..) )
-#else
-import PrelIOBase ( IO(..) )
-#endif
+import Exception
\end{code}
-- 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
-emptyPLS dflags = PersistentLinkerState {
+emptyPLS _ = PersistentLinkerState {
closure_env = emptyNameEnv,
itbl_env = emptyNameEnv,
pkgs_loaded = init_pkgs,
bcos_loaded = [],
- objs_loaded = []
- , dtacons_env = emptyAddressEnv
- }
+ objs_loaded = [] }
+
-- Packages that don't need loading, because the compiler
-- shares them with the interpreted program.
--
new_pls = pls { closure_env = new_closure_env }
writeIORef v_PersistentLinkerState new_pls
+deleteFromLinkEnv :: [Name] -> IO ()
+deleteFromLinkEnv to_remove
+ = do pls <- readIORef v_PersistentLinkerState
+ let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
+ 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)
+-- | Given a data constructor in the heap, find its Name.
+-- The info tables for data constructors have a field which records
+-- the source name of the constructor as a Ptr Word8 (UTF-8 encoded
+-- string). The format is:
+--
+-- Package:Module.Name
+--
+-- We use this string to lookup the interpreter's internal representation of the name
+-- using the lookupOrig.
+
+dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
+dataConInfoPtrToName x = do
+ theString <- liftIO $ do
+ let ptr = castPtr x :: Ptr StgInfoTable
+ conDescAddress <- getConDescAddress ptr
+ peekArray0 0 conDescAddress
+ let (pkg, mod, occ) = parse theString
+ pkgFS = mkFastStringByteList pkg
+ modFS = mkFastStringByteList mod
+ occFS = mkFastStringByteList occ
+ occName = mkOccNameFS OccName.dataName occFS
+ modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS)
+ return (Left$ showSDoc$ ppr modName <> dot <> ppr occName )
+ `recoverM` (Right `fmap` lookupOrig modName occName)
+
+ where
--- | 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
+ {- To find the string in the constructor's info table we need to consider
+ the layout of info tables relative to the entry code for a closure.
+
+ An info table can be next to the entry code for the closure, or it can
+ be separate. The former (faster) is used in registerised versions of ghc,
+ and the latter (portable) is for non-registerised versions.
+
+ The diagrams below show where the string is to be found relative to
+ the normal info table of the closure.
+
+ 1) Code next to table:
+
+ --------------
+ | | <- pointer to the start of the string
+ --------------
+ | | <- the (start of the) info table structure
+ | |
+ | |
+ --------------
+ | entry code |
+ | .... |
+
+ In this case the pointer to the start of the string can be found in
+ the memory location _one word before_ the first entry in the normal info
+ table.
+
+ 2) Code NOT next to table:
+
+ --------------
+ info table structure -> | *------------------> --------------
+ | | | entry code |
+ | | | .... |
+ --------------
+ ptr to start of str -> | |
+ --------------
+
+ In this case the pointer to the start of the string can be found
+ in the memory location: info_table_ptr + info_table_size
+ -}
+
+ getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
+ getConDescAddress ptr
+ | ghciTablesNextToCode = do
+ offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
+ return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
+ | otherwise =
+ peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
+
+ -- parsing names is a little bit fiddly because we have a string in the form:
+ -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
+ -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
+ -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
+ -- this is not the conventional way of writing Haskell names. We stick with
+ -- convention, even though it makes the parsing code more troublesome.
+ -- Warning: this code assumes that the string is well formed.
+ parse :: [Word8] -> ([Word8], [Word8], [Word8])
+ parse input
+ = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
+ where
+ dot = fromIntegral (ord '.')
+ (pkg, rest1) = break (== fromIntegral (ord ':')) input
+ (mod, occ)
+ = (concat $ intersperse [dot] $ reverse modWords, occWord)
+ where
+ (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
+ parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
+ parseModOcc acc str
+ = case break (== dot) str of
+ (top, []) -> (acc, top)
+ (top, _:bot) -> parseModOcc (top : acc) bot
+
+
+getHValue :: HscEnv -> Name -> IO HValue
+getHValue hsc_env name = do
+ when (isExternalName name) $ do
+ ok <- linkDependencies hsc_env noSrcSpan [nameModule name]
+ when (failed ok) $ ghcError (ProgramError "")
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
-
-getHValue :: Name -> IO (Maybe HValue)
-getHValue name = do
- pls <- readIORef v_PersistentLinkerState
- case lookupNameEnv (closure_env pls) name of
- Just (_,x) -> return$ Just x
- _ -> return Nothing
-
-withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
+ lookupName (closure_env pls) name
+
+linkDependencies :: HscEnv -> SrcSpan -> [Module] -> IO SuccessFlag
+linkDependencies hsc_env span needed_mods = do
+ let hpt = hsc_HPT hsc_env
+ dflags = hsc_dflags hsc_env
+ -- 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)
+ maybe_normal_osuf span needed_mods
+
+ -- Link the packages and modules required
+ linkPackages dflags pkgs
+ linkModules dflags lnks
+
+
+-- | Temporarily extend the linker state.
+
+withExtendedLinkEnv :: (MonadIO m, ExceptionMonad m) =>
+ [(Name,HValue)] -> m a -> m a
withExtendedLinkEnv new_env action
- = bracket set_new_env
- reset_old_env
- (const action)
- where set_new_env = do pls <- readIORef v_PersistentLinkerState
- let new_closure_env = extendClosureEnv (closure_env pls) new_env
- new_pls = pls { closure_env = new_closure_env }
- writeIORef v_PersistentLinkerState new_pls
- return (closure_env pls)
- reset_old_env env = modifyIORef v_PersistentLinkerState (\pls -> pls{ closure_env = env })
+ = gbracket set_new_env
+ (\_ -> reset_old_env)
+ (\_ -> action)
+ where set_new_env = do
+ pls <- liftIO $ readIORef v_PersistentLinkerState
+ let new_closure_env = extendClosureEnv (closure_env pls) new_env
+ new_pls = pls { closure_env = new_closure_env }
+ liftIO $ writeIORef v_PersistentLinkerState new_pls
+ return ()
+
+ -- Remember that the linker state might be side-effected
+ -- during the execution of the IO action, and we don't want to
+ -- lose those changes (we might have linked a new module or
+ -- package), so the reset action only removes the names we
+ -- added earlier.
+ reset_old_env = liftIO $ do
+ modifyIORef v_PersistentLinkerState $ \pls ->
+ let cur = closure_env pls
+ new = delListFromNameEnv cur (map fst new_env)
+ in
+ pls{ closure_env = new }
-- filterNameMap removes from the environment all entries except
-- those for a given set of modules;
printDump (vcat [text "----- Linker state -----",
text "Pkgs:" <+> ppr (pkgs_loaded pls),
text "Objs:" <+> ppr (objs_loaded pls),
- text "BCOs:" <+> ppr (bcos_loaded pls),
- text "DataCons:" <+> ppr (dtacons_env pls)
- ])
+ text "BCOs:" <+> ppr (bcos_loaded pls)])
\end{code}
; reallyInitDynLinker dflags }
}
+reallyInitDynLinker :: DynFlags -> IO ()
reallyInitDynLinker dflags
= do { -- Initialise the linker state
; writeIORef v_PersistentLinkerState (emptyPLS dflags)
; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
-- (e) Link any MacOS frameworks
-#ifdef darwin_TARGET_OS
- ; let framework_paths = frameworkPaths dflags
- ; let frameworks = cmdlineFrameworks dflags
-#else
- ; let frameworks = []
- ; let framework_paths = []
-#endif
+ ; let framework_paths
+ | isDarwinTarget = frameworkPaths dflags
+ | otherwise = []
+ ; let frameworks
+ | isDarwinTarget = cmdlineFrameworks dflags
+ | otherwise = []
-- Finally do (c),(d),(e)
; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
++ map DLL minus_ls
; ok <- resolveObjs
; if succeeded ok then maybePutStrLn dflags "done"
- else throwDyn (InstallationError "linking extra libraries/objects failed")
+ else ghcError (ProgramError "linking extra libraries/objects failed")
}}
classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
Nothing -> maybePutStrLn dflags "done"
Just mm -> preloadFailed mm lib_paths lib_spec
-#ifdef darwin_TARGET_OS
Framework framework
+ | isDarwinTarget
-> do maybe_errstr <- loadFramework framework_paths framework
case maybe_errstr of
Nothing -> maybePutStrLn dflags "done"
Just mm -> preloadFailed mm framework_paths lib_spec
-#endif
+ | otherwise -> panic "preloadLib Framework"
+
where
preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
preloadFailed sys_errmsg paths spec
- = do maybePutStr dflags
- ("failed.\nDynamic linker error message was:\n "
- ++ sys_errmsg ++ "\nWhilst trying to load: "
- ++ showLS spec ++ "\nDirectories to search are:\n"
- ++ unlines (map (" "++) paths) )
- give_up
+ = do maybePutStr dflags "failed.\n"
+ ghcError $
+ CmdLineError (
+ "user specified .o/.so/.DLL could not be loaded ("
+ ++ sys_errmsg ++ ")\nWhilst trying to load: "
+ ++ showLS spec ++ "\nAdditional directories searched:"
+ ++ (if null paths then " (none)" else
+ (concat (intersperse "\n" (map (" "++) paths)))))
-- Not interested in the paths in the static case.
- preload_static paths name
+ preload_static _paths name
= do b <- doesFileExist name
if not b then return False
else loadObj name >> return True
-
- give_up = throwDyn $
- CmdLineError "user specified .o/.so/.DLL could not be loaded."
\end{code}
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)
- maybe_normal_osuf span needed_mods
-
-- Link the packages and modules required
- ; linkPackages dflags pkgs
- ; ok <- linkModules dflags lnks
+ ; ok <- linkDependencies hsc_env span needed_mods
; if failed ok then
- throwDyn (ProgramError "")
+ ghcError (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
- ; (_,de_out, (root_hval:_)) <- linkSomeBCOs False ie ce de [root_ul_bco]
- ; writeIORef v_PersistentLinkerState (pls{dtacons_env=de_out})
+ ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
; return root_hval
}}
where
- hpt = hsc_HPT 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 span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg)))
+dieWith :: SrcSpan -> Message -> IO a
+dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage span msg)))
checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
then failNonStd srcspan
else return (Just default_osuf)
+failNonStd :: SrcSpan -> IO (Maybe String)
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.")
+ 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
-> IO ([Linkable], [PackageId]) -- ... then link these first
-- Fails with an IO exception if it can't find enough files
-getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
+getLinkDeps hsc_env hpt _ maybe_normal_osuf span mods
-- Find all the packages and linkables that a set of modules depends on
= do { pls <- readIORef v_PersistentLinkerState ;
- let {
-- 1. Find the dependent home-pkg-modules/packages from each iface
- (mods_s, pkgs_s) = unzip (map get_deps mods) ;
+ (mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet;
+ let {
-- 2. Exclude ones already linked
-- Main reason: avoid findModule calls in get_linkable
- mods_needed = nub (concat mods_s) `minusList` linked_mods ;
- pkgs_needed = nub (concat pkgs_s) `minusList` pkgs_loaded pls ;
+ mods_needed = mods_s `minusList` linked_mods ;
+ pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
linked_mods = map (moduleName.linkableModule)
(objs_loaded pls ++ bcos_loaded pls)
} ;
+-- putStrLn (showSDoc (ppr mods_s)) ;
-- 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
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
- | pkg /= this_pkg
- = ([], pkg : dep_pkgs deps)
- | otherwise
- = (moduleName mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps)
- where
- pkg = modulePackageId mod
- deps = mi_deps (get_iface mod)
+ -- The ModIface contains the transitive closure of the module dependencies
+ -- within the current package, *except* for boot modules: if we encounter
+ -- a boot module, we have to find its real interface and discover the
+ -- dependencies of that. Hence we need to traverse the dependency
+ -- tree recursively. See bug #936, testcase ghci/prog007.
+ follow_deps :: [Module] -- modules to follow
+ -> UniqSet ModuleName -- accum. module dependencies
+ -> UniqSet PackageId -- accum. package dependencies
+ -> IO ([ModuleName], [PackageId]) -- result
+ follow_deps [] acc_mods acc_pkgs
+ = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
+ follow_deps (mod:mods) acc_mods acc_pkgs
+ = do
+ mb_iface <- initIfaceCheck hsc_env $
+ loadInterface msg mod (ImportByUser False)
+ iface <- case mb_iface of
+ Maybes.Failed err -> ghcError (ProgramError (showSDoc err))
+ Maybes.Succeeded iface -> return iface
+
+ when (mi_boot iface) $ link_boot_mod_error mod
+
+ let
+ pkg = modulePackageId mod
+ deps = mi_deps iface
+
+ pkg_deps = dep_pkgs deps
+ (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
+ where is_boot (m,True) = Left m
+ is_boot (m,False) = Right m
+
+ boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
+ acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
+ acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
+ --
+ if pkg /= this_pkg
+ then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
+ else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)
+ acc_mods' acc_pkgs'
+ where
+ msg = text "need to link module" <+> ppr mod <+>
+ text "due to use of Template Haskell"
- 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
+
+ link_boot_mod_error mod =
+ ghcError (ProgramError (showSDoc (
+ text "module" <+> ppr mod <+>
+ text "cannot be linked; it is only available as a boot module")))
no_obj mod = dieWith span $
- ptext SLIT("cannot find object file for module ") <>
+ ptext (sLit "cannot find object file for module ") <>
quotes (ppr mod) $$
while_linking_expr
- while_linking_expr = ptext SLIT("while linking an interpreted expression")
+ while_linking_expr = ptext (sLit "while linking an interpreted expression")
-- This one is a build-system bug
get_linkable maybe_normal_osuf mod_name -- A home-package module
| Just mod_info <- lookupUFM hpt mod_name
- = ASSERT(isJust (hm_linkable mod_info))
- adjust_linkable (fromJust (hm_linkable mod_info))
+ = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
| otherwise
= do -- It's not in the HPT because we are in one shot mode,
-- so use the Finder to get a ModLocation...
return lnk
adjust_ul osuf (DotO file) = do
- let new_file = replaceFilenameSuffix file osuf
+ let new_file = replaceExtension file osuf
ok <- doesFileExist new_file
if (not ok)
then dieWith span $
- ptext SLIT("cannot find normal object file ")
+ ptext (sLit "cannot find normal object file ")
<> quotes (text new_file) $$ while_linking_expr
else return (DotO new_file)
+ adjust_ul _ _ = panic "adjust_ul"
\end{code}
li_uls_bco = filter isInterpretable li_uls
in
case (li_uls_obj, li_uls_bco) of
- (objs@(_:_), bcos@(_:_))
- -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
- other
- -> [li]
+ (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
+ li {linkableUnlinked=li_uls_bco}]
+ _ -> [li]
findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
findModuleLinkable_maybe lis mod
= case [LM time nm us | LM time nm us <- lis, nm == mod] of
[] -> Nothing
[li] -> Just li
- many -> pprPanic "findModuleLinkable" (ppr mod)
+ _ -> pprPanic "findModuleLinkable" (ppr mod)
linkableInSet :: Linkable -> [Linkable] -> Bool
linkableInSet l objs_loaded =
pls1 = pls { objs_loaded = objs_loaded' }
unlinkeds = concatMap linkableUnlinked new_objs
- mapM loadObj (map nameOfObject unlinkeds)
+ mapM_ loadObj (map nameOfObject unlinkeds)
-- Link the all together
ok <- resolveObjs
gce = closure_env pls
final_ie = foldr plusNameEnv (itbl_env pls) ies
- (final_gce, final_de, linked_bcos) <- linkSomeBCOs True final_ie gce (dtacons_env pls) ul_bcos
- -- What happens to these linked_bcos?
+ (final_gce, _linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
+ -- XXX 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, DataConEnv, [HValue])
+ -> IO (ClosureEnv, [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 de_in ul_bcos
+linkSomeBCOs toplevs_only ie ce_in ul_bcos
= do let nms = map unlinkedBCOName ul_bcos
hvals <- fixIO
( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
-- closure environment, which leads to trouble.
ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
extendClosureEnv ce_in ce_additions
- 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
+ return (ce_out, hvals)
+
\end{code}
-- Does the core unload business
-- (the wrapper blocks exceptions and deals with the PLS get and put)
-unload_wkr dflags linkables pls
+unload_wkr _ linkables pls
= do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
where
maybeUnload :: [Linkable] -> Linkable -> IO Bool
maybeUnload keep_linkables lnk
- | linkableInSet lnk linkables = return True
+ | linkableInSet lnk keep_linkables = return True
| otherwise
= do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
-- The components of a BCO linkable may contain
-- of DLL handles that rts/Linker.c maintains, and that in turn is
-- used by lookupSymbol. So we must call addDLL for each library
-- just to get the DLL handle into the list.
+partOfGHCi :: [PackageName]
partOfGHCi
-# if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS)
- = [ ]
-# else
- = [ "base", "haskell98", "template-haskell", "readline" ]
-# endif
+ | isWindowsTarget || isDarwinTarget = []
+ | otherwise = map PackageName
+ ["base", "haskell98", "template-haskell", "editline"]
+showLS :: LibrarySpec -> String
showLS (Object nm) = "(static) " ++ nm
showLS (DLL nm) = "(dynamic) " ++ nm
showLS (DLLPath nm) = "(dynamic) " ++ nm
; return (new_pkg : pkgs') }
| otherwise
- = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
+ = ghcError (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
linkPackage :: DynFlags -> PackageConfig -> IO ()
let dlls = [ dll | DLL dll <- classifieds ]
objs = [ obj | Object obj <- classifieds ]
- maybePutStr dflags ("Loading package " ++ showPackageId (package pkg) ++ " ... ")
+ maybePutStr dflags ("Loading package " ++ display (package pkg) ++ " ... ")
-- See comments with partOfGHCi
- when (pkgName (package pkg) `notElem` partOfGHCi) $ do
+ when (packageName pkg `notElem` partOfGHCi) $ do
loadFrameworks pkg
-- When a library A needs symbols from a library B, the order in
-- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
maybePutStr dflags "linking ... "
ok <- resolveObjs
if succeeded ok then maybePutStrLn dflags "done."
- else throwDyn (InstallationError ("unable to load package `" ++ showPackageId (package pkg) ++ "'"))
+ else ghcError (InstallationError ("unable to load package `" ++ display (package pkg) ++ "'"))
+load_dyn :: [FilePath] -> FilePath -> IO ()
load_dyn dirs dll = do r <- loadDynamic dirs dll
case r of
Nothing -> return ()
- Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
+ Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: "
++ dll ++ " (" ++ err ++ ")" ))
-#ifndef darwin_TARGET_OS
-loadFrameworks pkg = return ()
-#else
-loadFrameworks pkg = mapM_ load frameworks
+
+loadFrameworks :: InstalledPackageInfo_ ModuleName -> IO ()
+loadFrameworks pkg
+ | isDarwinTarget = mapM_ load frameworks
+ | otherwise = return ()
where
fw_dirs = Packages.frameworkDirs pkg
frameworks = Packages.frameworks pkg
load fw = do r <- loadFramework fw_dirs fw
case r of
Nothing -> return ()
- Just err -> throwDyn (CmdLineError ("can't load framework: "
+ Just err -> ghcError (CmdLineError ("can't load framework: "
++ fw ++ " (" ++ err ++ ")" ))
-#endif
-- Try to find an object file for a given library in the given paths.
-- If it isn't present, we assume it's a dynamic library.
locateOneObj :: [FilePath] -> String -> IO LibrarySpec
locateOneObj dirs lib
+ | not picIsOn
+ -- When the GHC package was not compiled as dynamic library
+ -- (=__PIC__ not set), we search for .o libraries first.
= do { mb_obj_path <- findFile mk_obj_path dirs
; case mb_obj_path of
Just obj_path -> return (Object obj_path)
Nothing ->
do { mb_lib_path <- findFile mk_dyn_lib_path dirs
; case mb_lib_path of
- Just lib_path -> return (DLL (lib ++ "_dyn"))
+ Just _ -> return (DLL dyn_lib_name)
+ Nothing -> return (DLL lib) }} -- We assume
+ | otherwise
+ -- When the GHC package was compiled as dynamic library (=__PIC__ set),
+ -- we search for .so libraries first.
+ = do { mb_lib_path <- findFile mk_dyn_lib_path dirs
+ ; case mb_lib_path of
+ Just _ -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
+ Nothing ->
+ do { mb_obj_path <- findFile mk_obj_path dirs
+ ; case mb_obj_path of
+ Just obj_path -> return (Object obj_path)
Nothing -> return (DLL lib) }} -- We assume
where
- mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o")
- mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "_dyn")
-
+ mk_obj_path dir = dir </> (lib <.> "o")
+ dyn_lib_name = lib ++ "-ghc" ++ cProjectVersion
+ mk_dyn_lib_path dir = dir </> mkSOName dyn_lib_name
-- ----------------------------------------------------------------------------
-- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
-- return Nothing == success, else Just error message from dlopen
+loadDynamic :: [FilePath] -> FilePath -> IO (Maybe String)
loadDynamic paths rootname
= do { mb_dll <- findFile mk_dll_path paths
; case mb_dll of
-- Tried all our known library paths, so let
-- dlopen() search its own builtin paths now.
where
- mk_dll_path dir = dir `joinFileName` mkSOName rootname
-
-#if defined(darwin_TARGET_OS)
-mkSOName root = ("lib" ++ root) `joinFileExt` "dylib"
-#elif defined(mingw32_TARGET_OS)
--- Win32 DLLs have no .dll extension here, because addDLL tries
--- both foo.dll and foo.drv
-mkSOName root = root
-#else
-mkSOName root = ("lib" ++ root) `joinFileExt` "so"
-#endif
+ mk_dll_path dir = dir </> mkSOName rootname
+
+mkSOName :: FilePath -> FilePath
+mkSOName root
+ | isDarwinTarget = ("lib" ++ root) <.> "dylib"
+ | isWindowsTarget = -- Win32 DLLs have no .dll extension here, because
+ -- addDLL tries both foo.dll and foo.drv
+ root
+ | otherwise = ("lib" ++ root) <.> "so"
-- Darwin / MacOS X only: load a framework
-- a framework is a dynamic library packaged inside a directory of the same
-- name. They are searched for in different paths than normal libraries.
-#ifdef darwin_TARGET_OS
+loadFramework :: [FilePath] -> FilePath -> IO (Maybe String)
loadFramework extraPaths rootname
- = do { mb_fwk <- findFile mk_fwk (extraPaths ++ defaultFrameworkPaths)
- ; case mb_fwk of
- Just fwk_path -> loadDLL fwk_path
- Nothing -> return (Just "not found") }
- -- Tried all our known library paths, but dlopen()
- -- has no built-in paths for frameworks: give up
+ = do { either_dir <- tryIO getHomeDirectory
+ ; let homeFrameworkPath = case either_dir of
+ Left _ -> []
+ Right dir -> [dir ++ "/Library/Frameworks"]
+ ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
+ ; mb_fwk <- findFile mk_fwk ps
+ ; case mb_fwk of
+ Just fwk_path -> loadDLL fwk_path
+ Nothing -> return (Just "not found") }
+ -- Tried all our known library paths, but dlopen()
+ -- has no built-in paths for frameworks: give up
where
- mk_fwk dir = dir `joinFileName` (rootname ++ ".framework/" ++ rootname)
- -- sorry for the hardcoded paths, I hope they won't change anytime soon:
+ mk_fwk dir = dir </> (rootname ++ ".framework/" ++ rootname)
+ -- sorry for the hardcoded paths, I hope they won't change anytime soon:
defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
-#endif
\end{code}
%************************************************************************
findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
-> [FilePath] -- Directories to look in
-> IO (Maybe FilePath) -- The first file path to match
-findFile mk_file_path []
+findFile _ []
= return Nothing
findFile mk_file_path (dir:dirs)
= do { let file_path = mk_file_path dir
\end{code}
\begin{code}
+maybePutStr :: DynFlags -> String -> IO ()
maybePutStr dflags s | verbosity dflags > 0 = putStr s
| otherwise = return ()
+maybePutStrLn :: DynFlags -> String -> IO ()
maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
| otherwise = return ()
\end{code}
projects / ghc-hetmet.git / blobdiff