2 % (c) The University of Glasgow 2005-2006
5 -- --------------------------------------
6 -- The dynamic linker for GHCi
7 -- --------------------------------------
9 This module deals with the top-level issues of dynamic linking,
10 calling the object-code linker and the byte-code linker where
15 {-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-}
18 -- The above warning supression flag is a temporary kludge.
19 -- While working on this module you are encouraged to remove it and fix
20 -- any warnings in the module. See
21 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
24 module Linker ( HValue, getHValue, showLinkerState,
25 linkExpr, unload, withExtendedLinkEnv,
26 extendLinkEnv, deleteFromLinkEnv,
28 linkPackages,initDynLinker,
32 #include "HsVersions.h"
50 import qualified OccName
64 import qualified Maybes
68 import Config ( cProjectVersion )
78 import System.FilePath
80 import System.Directory
82 import Control.Exception
87 %************************************************************************
91 %************************************************************************
93 The persistent linker state *must* match the actual state of the
94 C dynamic linker at all times, so we keep it in a private global variable.
97 The PersistentLinkerState maps Names to actual closures (for
98 interpreted code only), for use during linking.
101 GLOBAL_VAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState)
102 GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
104 data PersistentLinkerState
105 = PersistentLinkerState {
107 -- Current global mapping from Names to their true values
108 closure_env :: ClosureEnv,
110 -- The current global mapping from RdrNames of DataCons to
111 -- info table addresses.
112 -- When a new Unlinked is linked into the running image, or an existing
113 -- module in the image is replaced, the itbl_env must be updated
117 -- The currently loaded interpreted modules (home package)
118 bcos_loaded :: [Linkable],
120 -- And the currently-loaded compiled modules (home package)
121 objs_loaded :: [Linkable],
123 -- The currently-loaded packages; always object code
124 -- Held, as usual, in dependency order; though I am not sure if
125 -- that is really important
126 pkgs_loaded :: [PackageId]
129 emptyPLS :: DynFlags -> PersistentLinkerState
130 emptyPLS dflags = PersistentLinkerState {
131 closure_env = emptyNameEnv,
132 itbl_env = emptyNameEnv,
133 pkgs_loaded = init_pkgs,
137 -- Packages that don't need loading, because the compiler
138 -- shares them with the interpreted program.
140 -- The linker's symbol table is populated with RTS symbols using an
141 -- explicit list. See rts/Linker.c for details.
142 where init_pkgs = [rtsPackageId]
146 extendLoadedPkgs :: [PackageId] -> IO ()
147 extendLoadedPkgs pkgs
148 = modifyIORef v_PersistentLinkerState (\s -> s{pkgs_loaded = pkgs ++ pkgs_loaded s})
150 extendLinkEnv :: [(Name,HValue)] -> IO ()
151 -- Automatically discards shadowed bindings
152 extendLinkEnv new_bindings
153 = do pls <- readIORef v_PersistentLinkerState
154 let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
155 new_pls = pls { closure_env = new_closure_env }
156 writeIORef v_PersistentLinkerState new_pls
158 deleteFromLinkEnv :: [Name] -> IO ()
159 deleteFromLinkEnv to_remove
160 = do pls <- readIORef v_PersistentLinkerState
161 let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
162 new_pls = pls { closure_env = new_closure_env }
163 writeIORef v_PersistentLinkerState new_pls
165 -- | Given a data constructor in the heap, find its Name.
166 -- The info tables for data constructors have a field which records
167 -- the source name of the constructor as a Ptr Word8 (UTF-8 encoded
168 -- string). The format is:
170 -- Package:Module.Name
172 -- We use this string to lookup the interpreter's internal representation of the name
173 -- using the lookupOrig.
175 dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
176 dataConInfoPtrToName x = do
177 theString <- liftIO $ do
178 let ptr = castPtr x :: Ptr StgInfoTable
179 conDescAddress <- getConDescAddress ptr
180 peekArray0 0 conDescAddress
181 let (pkg, mod, occ) = parse theString
182 pkgFS = mkFastStringByteList pkg
183 modFS = mkFastStringByteList mod
184 occFS = mkFastStringByteList occ
185 occName = mkOccNameFS OccName.dataName occFS
186 modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS)
187 return (Left$ showSDoc$ ppr modName <> dot <> ppr occName )
188 `recoverM` (Right `fmap` lookupOrig modName occName)
192 {- To find the string in the constructor's info table we need to consider
193 the layout of info tables relative to the entry code for a closure.
195 An info table can be next to the entry code for the closure, or it can
196 be separate. The former (faster) is used in registerised versions of ghc,
197 and the latter (portable) is for non-registerised versions.
199 The diagrams below show where the string is to be found relative to
200 the normal info table of the closure.
202 1) Code next to table:
205 | | <- pointer to the start of the string
207 | | <- the (start of the) info table structure
214 In this case the pointer to the start of the string can be found in
215 the memory location _one word before_ the first entry in the normal info
218 2) Code NOT next to table:
221 info table structure -> | *------------------> --------------
225 ptr to start of str -> | |
228 In this case the pointer to the start of the string can be found
229 in the memory location: info_table_ptr + info_table_size
232 getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
233 getConDescAddress ptr = do
234 #ifdef GHCI_TABLES_NEXT_TO_CODE
235 offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
236 return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
238 peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
241 -- parsing names is a little bit fiddly because we have a string in the form:
242 -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
243 -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
244 -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
245 -- this is not the conventional way of writing Haskell names. We stick with
246 -- convention, even though it makes the parsing code more troublesome.
247 -- Warning: this code assumes that the string is well formed.
248 parse :: [Word8] -> ([Word8], [Word8], [Word8])
250 = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
252 dot = fromIntegral (ord '.')
253 (pkg, rest1) = break (== fromIntegral (ord ':')) input
255 = (concat $ intersperse [dot] $ reverse modWords, occWord)
257 (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
258 parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
260 = case break (== dot) str of
261 (top, []) -> (acc, top)
262 (top, _:bot) -> parseModOcc (top : acc) bot
265 getHValue :: HscEnv -> Name -> IO HValue
266 getHValue hsc_env name = do
267 when (isExternalName name) $ do
268 ok <- linkDependencies hsc_env noSrcSpan [nameModule name]
269 when (failed ok) $ throwDyn (ProgramError "")
270 pls <- readIORef v_PersistentLinkerState
271 lookupName (closure_env pls) name
273 linkDependencies :: HscEnv -> SrcSpan -> [Module] -> IO SuccessFlag
274 linkDependencies hsc_env span needed_mods = do
275 let hpt = hsc_HPT hsc_env
276 dflags = hsc_dflags hsc_env
277 -- The interpreter and dynamic linker can only handle object code built
278 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
279 -- So here we check the build tag: if we're building a non-standard way
280 -- then we need to find & link object files built the "normal" way.
281 maybe_normal_osuf <- checkNonStdWay dflags span
283 -- Find what packages and linkables are required
284 eps <- readIORef (hsc_EPS hsc_env)
285 (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
286 maybe_normal_osuf span needed_mods
288 -- Link the packages and modules required
289 linkPackages dflags pkgs
290 linkModules dflags lnks
293 -- | Temporarily extend the linker state.
295 withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
296 withExtendedLinkEnv new_env action
297 = bracket set_new_env
300 where set_new_env = do
301 pls <- readIORef v_PersistentLinkerState
302 let new_closure_env = extendClosureEnv (closure_env pls) new_env
303 new_pls = pls { closure_env = new_closure_env }
304 writeIORef v_PersistentLinkerState new_pls
305 return (closure_env pls)
307 -- Remember that the linker state might be side-effected
308 -- during the execution of the IO action, and we don't want to
309 -- lose those changes (we might have linked a new module or
310 -- package), so the reset action only removes the names we
312 reset_old_env env = do
313 modifyIORef v_PersistentLinkerState $ \pls ->
314 let cur = closure_env pls
315 new = delListFromNameEnv cur (map fst new_env)
317 pls{ closure_env = new }
319 -- filterNameMap removes from the environment all entries except
320 -- those for a given set of modules;
321 -- Note that this removes all *local* (i.e. non-isExternal) names too
322 -- (these are the temporary bindings from the command line).
323 -- Used to filter both the ClosureEnv and ItblEnv
325 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
326 filterNameMap mods env
327 = filterNameEnv keep_elt env
329 keep_elt (n,_) = isExternalName n
330 && (nameModule n `elem` mods)
335 showLinkerState :: IO ()
336 -- Display the persistent linker state
338 = do pls <- readIORef v_PersistentLinkerState
339 printDump (vcat [text "----- Linker state -----",
340 text "Pkgs:" <+> ppr (pkgs_loaded pls),
341 text "Objs:" <+> ppr (objs_loaded pls),
342 text "BCOs:" <+> ppr (bcos_loaded pls)])
348 %************************************************************************
350 \subsection{Initialisation}
352 %************************************************************************
354 We initialise the dynamic linker by
356 a) calling the C initialisation procedure
358 b) Loading any packages specified on the command line,
360 c) Loading any packages specified on the command line,
361 now held in the -l options in v_Opt_l
363 d) Loading any .o/.dll files specified on the command line,
364 now held in v_Ld_inputs
366 e) Loading any MacOS frameworks
369 initDynLinker :: DynFlags -> IO ()
370 -- This function is idempotent; if called more than once, it does nothing
371 -- This is useful in Template Haskell, where we call it before trying to link
373 = do { done <- readIORef v_InitLinkerDone
374 ; if done then return ()
375 else do { writeIORef v_InitLinkerDone True
376 ; reallyInitDynLinker dflags }
379 reallyInitDynLinker dflags
380 = do { -- Initialise the linker state
381 ; writeIORef v_PersistentLinkerState (emptyPLS dflags)
383 -- (a) initialise the C dynamic linker
386 -- (b) Load packages from the command-line
387 ; linkPackages dflags (preloadPackages (pkgState dflags))
389 -- (c) Link libraries from the command-line
390 ; let optl = getOpts dflags opt_l
391 ; let minus_ls = [ lib | '-':'l':lib <- optl ]
393 -- (d) Link .o files from the command-line
394 ; let lib_paths = libraryPaths dflags
395 ; cmdline_ld_inputs <- readIORef v_Ld_inputs
397 ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
399 -- (e) Link any MacOS frameworks
400 #ifdef darwin_TARGET_OS
401 ; let framework_paths = frameworkPaths dflags
402 ; let frameworks = cmdlineFrameworks dflags
404 ; let frameworks = []
405 ; let framework_paths = []
407 -- Finally do (c),(d),(e)
408 ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
410 ++ map Framework frameworks
411 ; if null cmdline_lib_specs then return ()
414 { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
415 ; maybePutStr dflags "final link ... "
418 ; if succeeded ok then maybePutStrLn dflags "done"
419 else throwDyn (InstallationError "linking extra libraries/objects failed")
422 classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
424 | isObjectFilename f = return (Just (Object f))
425 | isDynLibFilename f = return (Just (DLLPath f))
427 hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
430 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
431 preloadLib dflags lib_paths framework_paths lib_spec
432 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
435 -> do b <- preload_static lib_paths static_ish
436 maybePutStrLn dflags (if b then "done"
440 -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
442 Nothing -> maybePutStrLn dflags "done"
443 Just mm -> preloadFailed mm lib_paths lib_spec
446 -> do maybe_errstr <- loadDLL dll_path
448 Nothing -> maybePutStrLn dflags "done"
449 Just mm -> preloadFailed mm lib_paths lib_spec
451 #ifdef darwin_TARGET_OS
453 -> do maybe_errstr <- loadFramework framework_paths framework
455 Nothing -> maybePutStrLn dflags "done"
456 Just mm -> preloadFailed mm framework_paths lib_spec
459 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
460 preloadFailed sys_errmsg paths spec
461 = do maybePutStr dflags
462 ("failed.\nDynamic linker error message was:\n "
463 ++ sys_errmsg ++ "\nWhilst trying to load: "
464 ++ showLS spec ++ "\nDirectories to search are:\n"
465 ++ unlines (map (" "++) paths) )
468 -- Not interested in the paths in the static case.
469 preload_static paths name
470 = do b <- doesFileExist name
471 if not b then return False
472 else loadObj name >> return True
475 CmdLineError "user specified .o/.so/.DLL could not be loaded."
479 %************************************************************************
481 Link a byte-code expression
483 %************************************************************************
486 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
488 -- Link a single expression, *including* first linking packages and
489 -- modules that this expression depends on.
491 -- Raises an IO exception if it can't find a compiled version of the
492 -- dependents to link.
494 -- Note: This function side-effects the linker state (Pepe)
496 linkExpr hsc_env span root_ul_bco
498 -- Initialise the linker (if it's not been done already)
499 let dflags = hsc_dflags hsc_env
500 ; initDynLinker dflags
502 -- Link the packages and modules required
503 ; ok <- linkDependencies hsc_env span needed_mods
505 throwDyn (ProgramError "")
508 -- Link the expression itself
509 pls <- readIORef v_PersistentLinkerState
510 ; let ie = itbl_env pls
513 -- Link the necessary packages and linkables
514 ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
518 free_names = nameSetToList (bcoFreeNames root_ul_bco)
520 needed_mods :: [Module]
521 needed_mods = [ nameModule n | n <- free_names,
522 isExternalName n, -- Names from other modules
523 not (isWiredInName n) -- Exclude wired-in names
524 ] -- (see note below)
525 -- Exclude wired-in names because we may not have read
526 -- their interface files, so getLinkDeps will fail
527 -- All wired-in names are in the base package, which we link
528 -- by default, so we can safely ignore them here.
530 dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg)))
533 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
534 checkNonStdWay dflags srcspan = do
535 tag <- readIORef v_Build_tag
536 if null tag then return Nothing else do
537 let default_osuf = phaseInputExt StopLn
538 if objectSuf dflags == default_osuf
539 then failNonStd srcspan
540 else return (Just default_osuf)
542 failNonStd srcspan = dieWith srcspan $
543 ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$
544 ptext (sLit "You need to build the program twice: once the normal way, and then") $$
545 ptext (sLit "in the desired way using -osuf to set the object file suffix.")
548 getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable
549 -> Maybe String -- the "normal" object suffix
550 -> SrcSpan -- for error messages
551 -> [Module] -- If you need these
552 -> IO ([Linkable], [PackageId]) -- ... then link these first
553 -- Fails with an IO exception if it can't find enough files
555 getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
556 -- Find all the packages and linkables that a set of modules depends on
557 = do { pls <- readIORef v_PersistentLinkerState ;
558 -- 1. Find the dependent home-pkg-modules/packages from each iface
559 (mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet;
562 -- 2. Exclude ones already linked
563 -- Main reason: avoid findModule calls in get_linkable
564 mods_needed = mods_s `minusList` linked_mods ;
565 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
567 linked_mods = map (moduleName.linkableModule)
568 (objs_loaded pls ++ bcos_loaded pls)
571 -- putStrLn (showSDoc (ppr mods_s)) ;
572 -- 3. For each dependent module, find its linkable
573 -- This will either be in the HPT or (in the case of one-shot
574 -- compilation) we may need to use maybe_getFileLinkable
575 lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
577 return (lnks_needed, pkgs_needed) }
579 dflags = hsc_dflags hsc_env
580 this_pkg = thisPackage dflags
582 -- The ModIface contains the transitive closure of the module dependencies
583 -- within the current package, *except* for boot modules: if we encounter
584 -- a boot module, we have to find its real interface and discover the
585 -- dependencies of that. Hence we need to traverse the dependency
586 -- tree recursively. See bug #936, testcase ghci/prog007.
587 follow_deps :: [Module] -- modules to follow
588 -> UniqSet ModuleName -- accum. module dependencies
589 -> UniqSet PackageId -- accum. package dependencies
590 -> IO ([ModuleName], [PackageId]) -- result
591 follow_deps [] acc_mods acc_pkgs
592 = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
593 follow_deps (mod:mods) acc_mods acc_pkgs
595 mb_iface <- initIfaceCheck hsc_env $
596 loadInterface msg mod (ImportByUser False)
597 iface <- case mb_iface of
598 Maybes.Failed err -> ghcError (ProgramError (showSDoc err))
599 Maybes.Succeeded iface -> return iface
601 when (mi_boot iface) $ link_boot_mod_error mod
604 pkg = modulePackageId mod
607 pkg_deps = dep_pkgs deps
608 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
609 where is_boot (m,True) = Left m
610 is_boot (m,False) = Right m
612 boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
613 acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
614 acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
617 then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
618 else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)
621 msg = text "need to link module" <+> ppr mod <+>
622 text "due to use of Template Haskell"
625 link_boot_mod_error mod =
626 throwDyn (ProgramError (showSDoc (
627 text "module" <+> ppr mod <+>
628 text "cannot be linked; it is only available as a boot module")))
630 no_obj mod = dieWith span $
631 ptext (sLit "cannot find object file for module ") <>
635 while_linking_expr = ptext (sLit "while linking an interpreted expression")
637 -- This one is a build-system bug
639 get_linkable maybe_normal_osuf mod_name -- A home-package module
640 | Just mod_info <- lookupUFM hpt mod_name
641 = ASSERT(isJust (hm_linkable mod_info))
642 adjust_linkable (fromJust (hm_linkable mod_info))
644 = do -- It's not in the HPT because we are in one shot mode,
645 -- so use the Finder to get a ModLocation...
646 mb_stuff <- findHomeModule hsc_env mod_name
648 Found loc mod -> found loc mod
652 -- ...and then find the linkable for it
653 mb_lnk <- findObjectLinkableMaybe mod loc ;
655 Nothing -> no_obj mod ;
656 Just lnk -> adjust_linkable lnk
660 | Just osuf <- maybe_normal_osuf = do
661 new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
662 return lnk{ linkableUnlinked=new_uls }
666 adjust_ul osuf (DotO file) = do
667 let new_file = replaceExtension file osuf
668 ok <- doesFileExist new_file
671 ptext (sLit "cannot find normal object file ")
672 <> quotes (text new_file) $$ while_linking_expr
673 else return (DotO new_file)
677 %************************************************************************
680 The linkables may consist of a mixture of
681 byte-code modules and object modules
683 %************************************************************************
686 linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
687 linkModules dflags linkables
688 = block $ do -- don't want to be interrupted by ^C in here
690 let (objs, bcos) = partition isObjectLinkable
691 (concatMap partitionLinkable linkables)
693 -- Load objects first; they can't depend on BCOs
694 ok_flag <- dynLinkObjs dflags objs
696 if failed ok_flag then
703 -- HACK to support f-x-dynamic in the interpreter; no other purpose
704 partitionLinkable :: Linkable -> [Linkable]
706 = let li_uls = linkableUnlinked li
707 li_uls_obj = filter isObject li_uls
708 li_uls_bco = filter isInterpretable li_uls
710 case (li_uls_obj, li_uls_bco) of
711 (objs@(_:_), bcos@(_:_))
712 -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
716 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
717 findModuleLinkable_maybe lis mod
718 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
721 many -> pprPanic "findModuleLinkable" (ppr mod)
723 linkableInSet :: Linkable -> [Linkable] -> Bool
724 linkableInSet l objs_loaded =
725 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
727 Just m -> linkableTime l == linkableTime m
731 %************************************************************************
733 \subsection{The object-code linker}
735 %************************************************************************
738 dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
739 -- Side-effects the PersistentLinkerState
741 dynLinkObjs dflags objs
742 = do pls <- readIORef v_PersistentLinkerState
744 -- Load the object files and link them
745 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
746 pls1 = pls { objs_loaded = objs_loaded' }
747 unlinkeds = concatMap linkableUnlinked new_objs
749 mapM loadObj (map nameOfObject unlinkeds)
751 -- Link the all together
754 -- If resolving failed, unload all our
755 -- object modules and carry on
756 if succeeded ok then do
757 writeIORef v_PersistentLinkerState pls1
760 pls2 <- unload_wkr dflags [] pls1
761 writeIORef v_PersistentLinkerState pls2
765 rmDupLinkables :: [Linkable] -- Already loaded
766 -> [Linkable] -- New linkables
767 -> ([Linkable], -- New loaded set (including new ones)
768 [Linkable]) -- New linkables (excluding dups)
769 rmDupLinkables already ls
772 go already extras [] = (already, extras)
773 go already extras (l:ls)
774 | linkableInSet l already = go already extras ls
775 | otherwise = go (l:already) (l:extras) ls
778 %************************************************************************
780 \subsection{The byte-code linker}
782 %************************************************************************
785 dynLinkBCOs :: [Linkable] -> IO ()
786 -- Side-effects the persistent linker state
788 = do pls <- readIORef v_PersistentLinkerState
790 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
791 pls1 = pls { bcos_loaded = bcos_loaded' }
792 unlinkeds :: [Unlinked]
793 unlinkeds = concatMap linkableUnlinked new_bcos
795 cbcs :: [CompiledByteCode]
796 cbcs = map byteCodeOfObject unlinkeds
799 ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
800 ies = [ie | ByteCode _ ie <- cbcs]
801 gce = closure_env pls
802 final_ie = foldr plusNameEnv (itbl_env pls) ies
804 (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
805 -- What happens to these linked_bcos?
807 let pls2 = pls1 { closure_env = final_gce,
808 itbl_env = final_ie }
810 writeIORef v_PersistentLinkerState pls2
813 -- Link a bunch of BCOs and return them + updated closure env.
814 linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
815 -- True <=> add only toplevel BCOs to closure env
819 -> IO (ClosureEnv, [HValue])
820 -- The returned HValues are associated 1-1 with
821 -- the incoming unlinked BCOs. Each gives the
822 -- value of the corresponding unlinked BCO
824 linkSomeBCOs toplevs_only ie ce_in ul_bcos
825 = do let nms = map unlinkedBCOName ul_bcos
827 ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
828 in mapM (linkBCO ie ce_out) ul_bcos )
829 let ce_all_additions = zip nms hvals
830 ce_top_additions = filter (isExternalName.fst) ce_all_additions
831 ce_additions = if toplevs_only then ce_top_additions
832 else ce_all_additions
833 ce_out = -- make sure we're not inserting duplicate names into the
834 -- closure environment, which leads to trouble.
835 ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
836 extendClosureEnv ce_in ce_additions
837 return (ce_out, hvals)
842 %************************************************************************
844 Unload some object modules
846 %************************************************************************
849 -- ---------------------------------------------------------------------------
850 -- Unloading old objects ready for a new compilation sweep.
852 -- The compilation manager provides us with a list of linkables that it
853 -- considers "stable", i.e. won't be recompiled this time around. For
854 -- each of the modules current linked in memory,
856 -- * if the linkable is stable (and it's the same one - the
857 -- user may have recompiled the module on the side), we keep it,
859 -- * otherwise, we unload it.
861 -- * we also implicitly unload all temporary bindings at this point.
863 unload :: DynFlags -> [Linkable] -> IO ()
864 -- The 'linkables' are the ones to *keep*
866 unload dflags linkables
867 = block $ do -- block, so we're safe from Ctrl-C in here
869 -- Initialise the linker (if it's not been done already)
872 pls <- readIORef v_PersistentLinkerState
873 new_pls <- unload_wkr dflags linkables pls
874 writeIORef v_PersistentLinkerState new_pls
876 debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
877 debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
880 unload_wkr :: DynFlags
881 -> [Linkable] -- stable linkables
882 -> PersistentLinkerState
883 -> IO PersistentLinkerState
884 -- Does the core unload business
885 -- (the wrapper blocks exceptions and deals with the PLS get and put)
887 unload_wkr dflags linkables pls
888 = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
890 objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
891 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
893 let bcos_retained = map linkableModule bcos_loaded'
894 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
895 closure_env' = filterNameMap bcos_retained (closure_env pls)
896 new_pls = pls { itbl_env = itbl_env',
897 closure_env = closure_env',
898 bcos_loaded = bcos_loaded',
899 objs_loaded = objs_loaded' }
903 maybeUnload :: [Linkable] -> Linkable -> IO Bool
904 maybeUnload keep_linkables lnk
905 | linkableInSet lnk linkables = return True
907 = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
908 -- The components of a BCO linkable may contain
909 -- dot-o files. Which is very confusing.
911 -- But the BCO parts can be unlinked just by
912 -- letting go of them (plus of course depopulating
913 -- the symbol table which is done in the main body)
918 %************************************************************************
922 %************************************************************************
927 = Object FilePath -- Full path name of a .o file, including trailing .o
928 -- For dynamic objects only, try to find the object
929 -- file in all the directories specified in
930 -- v_Library_paths before giving up.
932 | DLL String -- "Unadorned" name of a .DLL/.so
933 -- e.g. On unix "qt" denotes "libqt.so"
934 -- On WinDoze "burble" denotes "burble.DLL"
935 -- loadDLL is platform-specific and adds the lib/.so/.DLL
936 -- suffixes platform-dependently
938 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
939 -- (ends with .dll or .so).
941 | Framework String -- Only used for darwin, but does no harm
943 -- If this package is already part of the GHCi binary, we'll already
944 -- have the right DLLs for this package loaded, so don't try to
947 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
948 -- as far as the loader is concerned, but it does initialise the list
949 -- of DLL handles that rts/Linker.c maintains, and that in turn is
950 -- used by lookupSymbol. So we must call addDLL for each library
951 -- just to get the DLL handle into the list.
953 # if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS)
956 = [ "base", "haskell98", "template-haskell", "editline" ]
959 showLS (Object nm) = "(static) " ++ nm
960 showLS (DLL nm) = "(dynamic) " ++ nm
961 showLS (DLLPath nm) = "(dynamic) " ++ nm
962 showLS (Framework nm) = "(framework) " ++ nm
964 linkPackages :: DynFlags -> [PackageId] -> IO ()
965 -- Link exactly the specified packages, and their dependents
966 -- (unless of course they are already linked)
967 -- The dependents are linked automatically, and it doesn't matter
968 -- what order you specify the input packages.
970 -- NOTE: in fact, since each module tracks all the packages it depends on,
971 -- we don't really need to use the package-config dependencies.
972 -- However we do need the package-config stuff (to find aux libs etc),
973 -- and following them lets us load libraries in the right order, which
974 -- perhaps makes the error message a bit more localised if we get a link
975 -- failure. So the dependency walking code is still here.
977 linkPackages dflags new_pkgs
978 = do { pls <- readIORef v_PersistentLinkerState
979 ; let pkg_map = pkgIdMap (pkgState dflags)
981 ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
983 ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
986 link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
987 link pkg_map pkgs new_pkgs
988 = foldM (link_one pkg_map) pkgs new_pkgs
990 link_one pkg_map pkgs new_pkg
991 | new_pkg `elem` pkgs -- Already linked
994 | Just pkg_cfg <- lookupPackage pkg_map new_pkg
995 = do { -- Link dependents first
996 pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
997 -- Now link the package itself
998 ; linkPackage dflags pkg_cfg
999 ; return (new_pkg : pkgs') }
1002 = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
1005 linkPackage :: DynFlags -> PackageConfig -> IO ()
1006 linkPackage dflags pkg
1008 let dirs = Packages.libraryDirs pkg
1010 let libs = Packages.hsLibraries pkg
1011 -- Because of slight differences between the GHC dynamic linker and
1012 -- the native system linker some packages have to link with a
1013 -- different list of libraries when using GHCi. Examples include: libs
1014 -- that are actually gnu ld scripts, and the possability that the .a
1015 -- libs do not exactly match the .so/.dll equivalents. So if the
1016 -- package file provides an "extra-ghci-libraries" field then we use
1017 -- that instead of the "extra-libraries" field.
1018 ++ (if null (Packages.extraGHCiLibraries pkg)
1019 then Packages.extraLibraries pkg
1020 else Packages.extraGHCiLibraries pkg)
1021 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
1022 classifieds <- mapM (locateOneObj dirs) libs
1024 -- Complication: all the .so's must be loaded before any of the .o's.
1025 let dlls = [ dll | DLL dll <- classifieds ]
1026 objs = [ obj | Object obj <- classifieds ]
1028 maybePutStr dflags ("Loading package " ++ display (package pkg) ++ " ... ")
1030 -- See comments with partOfGHCi
1031 when (pkgName (package pkg) `notElem` partOfGHCi) $ do
1033 -- When a library A needs symbols from a library B, the order in
1034 -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
1035 -- way ld expects it for static linking. Dynamic linking is a
1036 -- different story: When A has no dependency information for B,
1037 -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
1038 -- when B has not been loaded before. In a nutshell: Reverse the
1039 -- order of DLLs for dynamic linking.
1040 -- This fixes a problem with the HOpenGL package (see "Compiling
1041 -- HOpenGL under recent versions of GHC" on the HOpenGL list).
1042 mapM_ (load_dyn dirs) (reverse dlls)
1044 -- After loading all the DLLs, we can load the static objects.
1045 -- Ordering isn't important here, because we do one final link
1046 -- step to resolve everything.
1049 maybePutStr dflags "linking ... "
1051 if succeeded ok then maybePutStrLn dflags "done."
1052 else throwDyn (InstallationError ("unable to load package `" ++ display (package pkg) ++ "'"))
1054 load_dyn dirs dll = do r <- loadDynamic dirs dll
1056 Nothing -> return ()
1057 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1058 ++ dll ++ " (" ++ err ++ ")" ))
1059 #ifndef darwin_TARGET_OS
1060 loadFrameworks pkg = return ()
1062 loadFrameworks pkg = mapM_ load frameworks
1064 fw_dirs = Packages.frameworkDirs pkg
1065 frameworks = Packages.frameworks pkg
1067 load fw = do r <- loadFramework fw_dirs fw
1069 Nothing -> return ()
1070 Just err -> throwDyn (CmdLineError ("can't load framework: "
1071 ++ fw ++ " (" ++ err ++ ")" ))
1074 -- Try to find an object file for a given library in the given paths.
1075 -- If it isn't present, we assume it's a dynamic library.
1077 -- When the GHC package was not compiled as dynamic library (=__PIC__ not set),
1078 -- we search for .o libraries first.
1079 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1080 locateOneObj dirs lib
1081 = do { mb_obj_path <- findFile mk_obj_path dirs
1082 ; case mb_obj_path of
1083 Just obj_path -> return (Object obj_path)
1085 do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1086 ; case mb_lib_path of
1087 Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
1088 Nothing -> return (DLL lib) }} -- We assume
1090 mk_obj_path dir = dir </> lib <.> "o"
1091 mk_dyn_lib_path dir = dir </> mkSOName (lib ++ "-ghc" ++ cProjectVersion)
1093 -- When the GHC package was compiled as dynamic library (=__PIC__ set),
1094 -- we search for .so libraries first.
1095 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1096 locateOneObj dirs lib
1097 = do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1098 ; case mb_lib_path of
1099 Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
1101 do { mb_obj_path <- findFile mk_obj_path dirs
1102 ; case mb_obj_path of
1103 Just obj_path -> return (Object obj_path)
1104 Nothing -> return (DLL lib) }} -- We assume
1106 mk_obj_path dir = dir </> (lib <.> "o")
1107 mk_dyn_lib_path dir = dir </> mkSOName (lib ++ "-ghc" ++ cProjectVersion)
1110 -- ----------------------------------------------------------------------------
1111 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1113 -- return Nothing == success, else Just error message from dlopen
1114 loadDynamic paths rootname
1115 = do { mb_dll <- findFile mk_dll_path paths
1117 Just dll -> loadDLL dll
1118 Nothing -> loadDLL (mkSOName rootname) }
1119 -- Tried all our known library paths, so let
1120 -- dlopen() search its own builtin paths now.
1122 mk_dll_path dir = dir </> mkSOName rootname
1124 #if defined(darwin_TARGET_OS)
1125 mkSOName root = ("lib" ++ root) <.> "dylib"
1126 #elif defined(mingw32_TARGET_OS)
1127 -- Win32 DLLs have no .dll extension here, because addDLL tries
1128 -- both foo.dll and foo.drv
1129 mkSOName root = root
1131 mkSOName root = ("lib" ++ root) <.> "so"
1134 -- Darwin / MacOS X only: load a framework
1135 -- a framework is a dynamic library packaged inside a directory of the same
1136 -- name. They are searched for in different paths than normal libraries.
1137 #ifdef darwin_TARGET_OS
1138 loadFramework extraPaths rootname
1139 = do { either_dir <- Control.Exception.try getHomeDirectory
1140 ; let homeFrameworkPath = case either_dir of
1142 Right dir -> [dir ++ "/Library/Frameworks"]
1143 ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
1144 ; mb_fwk <- findFile mk_fwk ps
1146 Just fwk_path -> loadDLL fwk_path
1147 Nothing -> return (Just "not found") }
1148 -- Tried all our known library paths, but dlopen()
1149 -- has no built-in paths for frameworks: give up
1151 mk_fwk dir = dir </> (rootname ++ ".framework/" ++ rootname)
1152 -- sorry for the hardcoded paths, I hope they won't change anytime soon:
1153 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1157 %************************************************************************
1161 %************************************************************************
1164 findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
1165 -> [FilePath] -- Directories to look in
1166 -> IO (Maybe FilePath) -- The first file path to match
1167 findFile mk_file_path []
1169 findFile mk_file_path (dir:dirs)
1170 = do { let file_path = mk_file_path dir
1171 ; b <- doesFileExist file_path
1173 return (Just file_path)
1175 findFile mk_file_path dirs }
1179 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1180 | otherwise = return ()
1182 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1183 | otherwise = return ()