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" #-}
17 module Linker ( HValue, getHValue, showLinkerState,
18 linkExpr, unload, withExtendedLinkEnv,
19 extendLinkEnv, deleteFromLinkEnv,
21 linkPackages,initDynLinker,
25 #include "HsVersions.h"
42 import qualified OccName
59 import Config ( cProjectVersion )
70 import System.Directory
72 import Control.Exception
77 %************************************************************************
81 %************************************************************************
83 The persistent linker state *must* match the actual state of the
84 C dynamic linker at all times, so we keep it in a private global variable.
87 The PersistentLinkerState maps Names to actual closures (for
88 interpreted code only), for use during linking.
91 GLOBAL_VAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState)
92 GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
94 data PersistentLinkerState
95 = PersistentLinkerState {
97 -- Current global mapping from Names to their true values
98 closure_env :: ClosureEnv,
100 -- The current global mapping from RdrNames of DataCons to
101 -- info table addresses.
102 -- When a new Unlinked is linked into the running image, or an existing
103 -- module in the image is replaced, the itbl_env must be updated
107 -- The currently loaded interpreted modules (home package)
108 bcos_loaded :: [Linkable],
110 -- And the currently-loaded compiled modules (home package)
111 objs_loaded :: [Linkable],
113 -- The currently-loaded packages; always object code
114 -- Held, as usual, in dependency order; though I am not sure if
115 -- that is really important
116 pkgs_loaded :: [PackageId]
119 emptyPLS :: DynFlags -> PersistentLinkerState
120 emptyPLS dflags = PersistentLinkerState {
121 closure_env = emptyNameEnv,
122 itbl_env = emptyNameEnv,
123 pkgs_loaded = init_pkgs,
127 -- Packages that don't need loading, because the compiler
128 -- shares them with the interpreted program.
130 -- The linker's symbol table is populated with RTS symbols using an
131 -- explicit list. See rts/Linker.c for details.
132 where init_pkgs = [rtsPackageId]
136 extendLoadedPkgs :: [PackageId] -> IO ()
137 extendLoadedPkgs pkgs
138 = modifyIORef v_PersistentLinkerState (\s -> s{pkgs_loaded = pkgs ++ pkgs_loaded s})
140 extendLinkEnv :: [(Name,HValue)] -> IO ()
141 -- Automatically discards shadowed bindings
142 extendLinkEnv new_bindings
143 = do pls <- readIORef v_PersistentLinkerState
144 let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
145 new_pls = pls { closure_env = new_closure_env }
146 writeIORef v_PersistentLinkerState new_pls
148 deleteFromLinkEnv :: [Name] -> IO ()
149 deleteFromLinkEnv to_remove
150 = do pls <- readIORef v_PersistentLinkerState
151 let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
152 new_pls = pls { closure_env = new_closure_env }
153 writeIORef v_PersistentLinkerState new_pls
155 -- | Given a data constructor in the heap, find its Name.
156 -- The info tables for data constructors have a field which records
157 -- the source name of the constructor as a Ptr Word8 (UTF-8 encoded
158 -- string). The format is:
160 -- Package:Module.Name
162 -- We use this string to lookup the interpreter's internal representation of the name
163 -- using the lookupOrig.
165 dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
166 dataConInfoPtrToName x = do
167 theString <- ioToTcRn $ do
168 let ptr = castPtr x :: Ptr StgInfoTable
169 conDescAddress <- getConDescAddress ptr
170 peekArray0 0 conDescAddress
171 let (pkg, mod, occ) = parse theString
172 pkgFS = mkFastStringByteList pkg
173 modFS = mkFastStringByteList mod
174 occFS = mkFastStringByteList occ
175 occName = mkOccNameFS OccName.dataName occFS
176 modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS)
177 return (Left$ showSDoc$ ppr modName <> dot <> ppr occName )
178 `recoverM` (Right `fmap` lookupOrig modName occName)
182 {- To find the string in the constructor's info table we need to consider
183 the layout of info tables relative to the entry code for a closure.
185 An info table can be next to the entry code for the closure, or it can
186 be separate. The former (faster) is used in registerised versions of ghc,
187 and the latter (portable) is for non-registerised versions.
189 The diagrams below show where the string is to be found relative to
190 the normal info table of the closure.
192 1) Code next to table:
195 | | <- pointer to the start of the string
197 | | <- the (start of the) info table structure
204 In this case the pointer to the start of the string can be found in
205 the memory location _one word before_ the first entry in the normal info
208 2) Code NOT next to table:
211 info table structure -> | *------------------> --------------
215 ptr to start of str -> | |
218 In this case the pointer to the start of the string can be found
219 in the memory location: info_table_ptr + info_table_size
222 getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
223 getConDescAddress ptr = do
224 #ifdef GHCI_TABLES_NEXT_TO_CODE
225 offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
226 return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
228 peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
231 -- parsing names is a little bit fiddly because we have a string in the form:
232 -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
233 -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
234 -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
235 -- this is not the conventional way of writing Haskell names. We stick with
236 -- convention, even though it makes the parsing code more troublesome.
237 -- Warning: this code assumes that the string is well formed.
238 parse :: [Word8] -> ([Word8], [Word8], [Word8])
240 = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
242 dot = fromIntegral (ord '.')
243 (pkg, rest1) = break (== fromIntegral (ord ':')) input
245 = (concat $ intersperse [dot] $ reverse modWords, occWord)
247 (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
248 parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
250 = case break (== dot) str of
251 (top, []) -> (acc, top)
252 (top, _:bot) -> parseModOcc (top : acc) bot
255 getHValue :: HscEnv -> Name -> IO HValue
256 getHValue hsc_env name = do
257 when (isExternalName name) $ do
258 ok <- linkDependencies hsc_env noSrcSpan [nameModule name]
259 when (failed ok) $ throwDyn (ProgramError "")
260 pls <- readIORef v_PersistentLinkerState
261 lookupName (closure_env pls) name
263 linkDependencies :: HscEnv -> SrcSpan -> [Module] -> IO SuccessFlag
264 linkDependencies hsc_env span needed_mods = do
265 let hpt = hsc_HPT hsc_env
266 dflags = hsc_dflags hsc_env
267 -- The interpreter and dynamic linker can only handle object code built
268 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
269 -- So here we check the build tag: if we're building a non-standard way
270 -- then we need to find & link object files built the "normal" way.
271 maybe_normal_osuf <- checkNonStdWay dflags span
273 -- Find what packages and linkables are required
274 eps <- readIORef (hsc_EPS hsc_env)
275 (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
276 maybe_normal_osuf span needed_mods
278 -- Link the packages and modules required
279 linkPackages dflags pkgs
280 linkModules dflags lnks
283 -- | Temporarily extend the linker state.
285 withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
286 withExtendedLinkEnv new_env action
287 = bracket set_new_env
290 where set_new_env = do
291 pls <- readIORef v_PersistentLinkerState
292 let new_closure_env = extendClosureEnv (closure_env pls) new_env
293 new_pls = pls { closure_env = new_closure_env }
294 writeIORef v_PersistentLinkerState new_pls
295 return (closure_env pls)
297 -- Remember that the linker state might be side-effected
298 -- during the execution of the IO action, and we don't want to
299 -- lose those changes (we might have linked a new module or
300 -- package), so the reset action only removes the names we
302 reset_old_env env = do
303 modifyIORef v_PersistentLinkerState $ \pls ->
304 let cur = closure_env pls
305 new = delListFromNameEnv cur (map fst new_env)
307 pls{ closure_env = new }
309 -- filterNameMap removes from the environment all entries except
310 -- those for a given set of modules;
311 -- Note that this removes all *local* (i.e. non-isExternal) names too
312 -- (these are the temporary bindings from the command line).
313 -- Used to filter both the ClosureEnv and ItblEnv
315 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
316 filterNameMap mods env
317 = filterNameEnv keep_elt env
319 keep_elt (n,_) = isExternalName n
320 && (nameModule n `elem` mods)
325 showLinkerState :: IO ()
326 -- Display the persistent linker state
328 = do pls <- readIORef v_PersistentLinkerState
329 printDump (vcat [text "----- Linker state -----",
330 text "Pkgs:" <+> ppr (pkgs_loaded pls),
331 text "Objs:" <+> ppr (objs_loaded pls),
332 text "BCOs:" <+> ppr (bcos_loaded pls)])
338 %************************************************************************
340 \subsection{Initialisation}
342 %************************************************************************
344 We initialise the dynamic linker by
346 a) calling the C initialisation procedure
348 b) Loading any packages specified on the command line,
350 c) Loading any packages specified on the command line,
351 now held in the -l options in v_Opt_l
353 d) Loading any .o/.dll files specified on the command line,
354 now held in v_Ld_inputs
356 e) Loading any MacOS frameworks
359 initDynLinker :: DynFlags -> IO ()
360 -- This function is idempotent; if called more than once, it does nothing
361 -- This is useful in Template Haskell, where we call it before trying to link
363 = do { done <- readIORef v_InitLinkerDone
364 ; if done then return ()
365 else do { writeIORef v_InitLinkerDone True
366 ; reallyInitDynLinker dflags }
369 reallyInitDynLinker dflags
370 = do { -- Initialise the linker state
371 ; writeIORef v_PersistentLinkerState (emptyPLS dflags)
373 -- (a) initialise the C dynamic linker
376 -- (b) Load packages from the command-line
377 ; linkPackages dflags (preloadPackages (pkgState dflags))
379 -- (c) Link libraries from the command-line
380 ; let optl = getOpts dflags opt_l
381 ; let minus_ls = [ lib | '-':'l':lib <- optl ]
383 -- (d) Link .o files from the command-line
384 ; let lib_paths = libraryPaths dflags
385 ; cmdline_ld_inputs <- readIORef v_Ld_inputs
387 ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
389 -- (e) Link any MacOS frameworks
390 #ifdef darwin_TARGET_OS
391 ; let framework_paths = frameworkPaths dflags
392 ; let frameworks = cmdlineFrameworks dflags
394 ; let frameworks = []
395 ; let framework_paths = []
397 -- Finally do (c),(d),(e)
398 ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
400 ++ map Framework frameworks
401 ; if null cmdline_lib_specs then return ()
404 { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
405 ; maybePutStr dflags "final link ... "
408 ; if succeeded ok then maybePutStrLn dflags "done"
409 else throwDyn (InstallationError "linking extra libraries/objects failed")
412 classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
414 | isObjectFilename f = return (Just (Object f))
415 | isDynLibFilename f = return (Just (DLLPath f))
417 hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
420 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
421 preloadLib dflags lib_paths framework_paths lib_spec
422 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
425 -> do b <- preload_static lib_paths static_ish
426 maybePutStrLn dflags (if b then "done"
430 -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
432 Nothing -> maybePutStrLn dflags "done"
433 Just mm -> preloadFailed mm lib_paths lib_spec
436 -> do maybe_errstr <- loadDLL dll_path
438 Nothing -> maybePutStrLn dflags "done"
439 Just mm -> preloadFailed mm lib_paths lib_spec
441 #ifdef darwin_TARGET_OS
443 -> do maybe_errstr <- loadFramework framework_paths framework
445 Nothing -> maybePutStrLn dflags "done"
446 Just mm -> preloadFailed mm framework_paths lib_spec
449 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
450 preloadFailed sys_errmsg paths spec
451 = do maybePutStr dflags
452 ("failed.\nDynamic linker error message was:\n "
453 ++ sys_errmsg ++ "\nWhilst trying to load: "
454 ++ showLS spec ++ "\nDirectories to search are:\n"
455 ++ unlines (map (" "++) paths) )
458 -- Not interested in the paths in the static case.
459 preload_static paths name
460 = do b <- doesFileExist name
461 if not b then return False
462 else loadObj name >> return True
465 CmdLineError "user specified .o/.so/.DLL could not be loaded."
469 %************************************************************************
471 Link a byte-code expression
473 %************************************************************************
476 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
478 -- Link a single expression, *including* first linking packages and
479 -- modules that this expression depends on.
481 -- Raises an IO exception if it can't find a compiled version of the
482 -- dependents to link.
484 -- Note: This function side-effects the linker state (Pepe)
486 linkExpr hsc_env span root_ul_bco
488 -- Initialise the linker (if it's not been done already)
489 let dflags = hsc_dflags hsc_env
490 ; initDynLinker dflags
492 -- Link the packages and modules required
493 ; ok <- linkDependencies hsc_env span needed_mods
495 throwDyn (ProgramError "")
498 -- Link the expression itself
499 pls <- readIORef v_PersistentLinkerState
500 ; let ie = itbl_env pls
503 -- Link the necessary packages and linkables
504 ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
508 free_names = nameSetToList (bcoFreeNames root_ul_bco)
510 needed_mods :: [Module]
511 needed_mods = [ nameModule n | n <- free_names,
512 isExternalName n, -- Names from other modules
513 not (isWiredInName n) -- Exclude wired-in names
514 ] -- (see note below)
515 -- Exclude wired-in names because we may not have read
516 -- their interface files, so getLinkDeps will fail
517 -- All wired-in names are in the base package, which we link
518 -- by default, so we can safely ignore them here.
520 dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg)))
523 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
524 checkNonStdWay dflags srcspan = do
525 tag <- readIORef v_Build_tag
526 if null tag then return Nothing else do
527 let default_osuf = phaseInputExt StopLn
528 if objectSuf dflags == default_osuf
529 then failNonStd srcspan
530 else return (Just default_osuf)
532 failNonStd srcspan = dieWith srcspan $
533 ptext SLIT("Dynamic linking required, but this is a non-standard build (eg. prof).") $$
534 ptext SLIT("You need to build the program twice: once the normal way, and then") $$
535 ptext SLIT("in the desired way using -osuf to set the object file suffix.")
538 getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable
539 -> Maybe String -- the "normal" object suffix
540 -> SrcSpan -- for error messages
541 -> [Module] -- If you need these
542 -> IO ([Linkable], [PackageId]) -- ... then link these first
543 -- Fails with an IO exception if it can't find enough files
545 getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
546 -- Find all the packages and linkables that a set of modules depends on
547 = do { pls <- readIORef v_PersistentLinkerState ;
549 -- 1. Find the dependent home-pkg-modules/packages from each iface
550 (mods_s, pkgs_s) = follow_deps mods emptyUniqSet emptyUniqSet;
552 -- 2. Exclude ones already linked
553 -- Main reason: avoid findModule calls in get_linkable
554 mods_needed = mods_s `minusList` linked_mods ;
555 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
557 linked_mods = map (moduleName.linkableModule)
558 (objs_loaded pls ++ bcos_loaded pls)
561 -- putStrLn (showSDoc (ppr mods_s)) ;
562 -- 3. For each dependent module, find its linkable
563 -- This will either be in the HPT or (in the case of one-shot
564 -- compilation) we may need to use maybe_getFileLinkable
565 lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
567 return (lnks_needed, pkgs_needed) }
569 dflags = hsc_dflags hsc_env
570 this_pkg = thisPackage dflags
572 -- The ModIface contains the transitive closure of the module dependencies
573 -- within the current package, *except* for boot modules: if we encounter
574 -- a boot module, we have to find its real interface and discover the
575 -- dependencies of that. Hence we need to traverse the dependency
576 -- tree recursively. See bug #936, testcase ghci/prog007.
577 follow_deps :: [Module] -- modules to follow
578 -> UniqSet ModuleName -- accum. module dependencies
579 -> UniqSet PackageId -- accum. package dependencies
580 -> ([ModuleName], [PackageId]) -- result
581 follow_deps [] acc_mods acc_pkgs
582 = (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
583 follow_deps (mod:mods) acc_mods acc_pkgs
585 = follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
587 = link_boot_mod_error mod
589 = follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) acc_mods' acc_pkgs'
591 pkg = modulePackageId mod
592 iface = get_iface mod
595 pkg_deps = dep_pkgs deps
596 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
597 where is_boot (m,True) = Left m
598 is_boot (m,False) = Right m
600 boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
601 acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
602 acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
605 link_boot_mod_error mod =
606 throwDyn (ProgramError (showSDoc (
607 text "module" <+> ppr mod <+>
608 text "cannot be linked; it is only available as a boot module")))
610 get_iface mod = case lookupIfaceByModule dflags hpt pit mod of
612 Nothing -> pprPanic "getLinkDeps" (no_iface mod)
613 no_iface mod = ptext SLIT("No iface for") <+> ppr mod
614 -- This one is a GHC bug
616 no_obj mod = dieWith span $
617 ptext SLIT("cannot find object file for module ") <>
621 while_linking_expr = ptext SLIT("while linking an interpreted expression")
623 -- This one is a build-system bug
625 get_linkable maybe_normal_osuf mod_name -- A home-package module
626 | Just mod_info <- lookupUFM hpt mod_name
627 = ASSERT(isJust (hm_linkable mod_info))
628 adjust_linkable (fromJust (hm_linkable mod_info))
630 = do -- It's not in the HPT because we are in one shot mode,
631 -- so use the Finder to get a ModLocation...
632 mb_stuff <- findHomeModule hsc_env mod_name
634 Found loc mod -> found loc mod
638 -- ...and then find the linkable for it
639 mb_lnk <- findObjectLinkableMaybe mod loc ;
641 Nothing -> no_obj mod ;
642 Just lnk -> adjust_linkable lnk
646 | Just osuf <- maybe_normal_osuf = do
647 new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
648 return lnk{ linkableUnlinked=new_uls }
652 adjust_ul osuf (DotO file) = do
653 let new_file = replaceFilenameSuffix file osuf
654 ok <- doesFileExist new_file
657 ptext SLIT("cannot find normal object file ")
658 <> quotes (text new_file) $$ while_linking_expr
659 else return (DotO new_file)
663 %************************************************************************
666 The linkables may consist of a mixture of
667 byte-code modules and object modules
669 %************************************************************************
672 linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
673 linkModules dflags linkables
674 = block $ do -- don't want to be interrupted by ^C in here
676 let (objs, bcos) = partition isObjectLinkable
677 (concatMap partitionLinkable linkables)
679 -- Load objects first; they can't depend on BCOs
680 ok_flag <- dynLinkObjs dflags objs
682 if failed ok_flag then
689 -- HACK to support f-x-dynamic in the interpreter; no other purpose
690 partitionLinkable :: Linkable -> [Linkable]
692 = let li_uls = linkableUnlinked li
693 li_uls_obj = filter isObject li_uls
694 li_uls_bco = filter isInterpretable li_uls
696 case (li_uls_obj, li_uls_bco) of
697 (objs@(_:_), bcos@(_:_))
698 -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
702 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
703 findModuleLinkable_maybe lis mod
704 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
707 many -> pprPanic "findModuleLinkable" (ppr mod)
709 linkableInSet :: Linkable -> [Linkable] -> Bool
710 linkableInSet l objs_loaded =
711 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
713 Just m -> linkableTime l == linkableTime m
717 %************************************************************************
719 \subsection{The object-code linker}
721 %************************************************************************
724 dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
725 -- Side-effects the PersistentLinkerState
727 dynLinkObjs dflags objs
728 = do pls <- readIORef v_PersistentLinkerState
730 -- Load the object files and link them
731 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
732 pls1 = pls { objs_loaded = objs_loaded' }
733 unlinkeds = concatMap linkableUnlinked new_objs
735 mapM loadObj (map nameOfObject unlinkeds)
737 -- Link the all together
740 -- If resolving failed, unload all our
741 -- object modules and carry on
742 if succeeded ok then do
743 writeIORef v_PersistentLinkerState pls1
746 pls2 <- unload_wkr dflags [] pls1
747 writeIORef v_PersistentLinkerState pls2
751 rmDupLinkables :: [Linkable] -- Already loaded
752 -> [Linkable] -- New linkables
753 -> ([Linkable], -- New loaded set (including new ones)
754 [Linkable]) -- New linkables (excluding dups)
755 rmDupLinkables already ls
758 go already extras [] = (already, extras)
759 go already extras (l:ls)
760 | linkableInSet l already = go already extras ls
761 | otherwise = go (l:already) (l:extras) ls
764 %************************************************************************
766 \subsection{The byte-code linker}
768 %************************************************************************
771 dynLinkBCOs :: [Linkable] -> IO ()
772 -- Side-effects the persistent linker state
774 = do pls <- readIORef v_PersistentLinkerState
776 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
777 pls1 = pls { bcos_loaded = bcos_loaded' }
778 unlinkeds :: [Unlinked]
779 unlinkeds = concatMap linkableUnlinked new_bcos
781 cbcs :: [CompiledByteCode]
782 cbcs = map byteCodeOfObject unlinkeds
785 ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
786 ies = [ie | ByteCode _ ie <- cbcs]
787 gce = closure_env pls
788 final_ie = foldr plusNameEnv (itbl_env pls) ies
790 (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
791 -- What happens to these linked_bcos?
793 let pls2 = pls1 { closure_env = final_gce,
794 itbl_env = final_ie }
796 writeIORef v_PersistentLinkerState pls2
799 -- Link a bunch of BCOs and return them + updated closure env.
800 linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
801 -- True <=> add only toplevel BCOs to closure env
805 -> IO (ClosureEnv, [HValue])
806 -- The returned HValues are associated 1-1 with
807 -- the incoming unlinked BCOs. Each gives the
808 -- value of the corresponding unlinked BCO
810 linkSomeBCOs toplevs_only ie ce_in ul_bcos
811 = do let nms = map unlinkedBCOName ul_bcos
813 ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
814 in mapM (linkBCO ie ce_out) ul_bcos )
815 let ce_all_additions = zip nms hvals
816 ce_top_additions = filter (isExternalName.fst) ce_all_additions
817 ce_additions = if toplevs_only then ce_top_additions
818 else ce_all_additions
819 ce_out = -- make sure we're not inserting duplicate names into the
820 -- closure environment, which leads to trouble.
821 ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
822 extendClosureEnv ce_in ce_additions
823 return (ce_out, hvals)
828 %************************************************************************
830 Unload some object modules
832 %************************************************************************
835 -- ---------------------------------------------------------------------------
836 -- Unloading old objects ready for a new compilation sweep.
838 -- The compilation manager provides us with a list of linkables that it
839 -- considers "stable", i.e. won't be recompiled this time around. For
840 -- each of the modules current linked in memory,
842 -- * if the linkable is stable (and it's the same one - the
843 -- user may have recompiled the module on the side), we keep it,
845 -- * otherwise, we unload it.
847 -- * we also implicitly unload all temporary bindings at this point.
849 unload :: DynFlags -> [Linkable] -> IO ()
850 -- The 'linkables' are the ones to *keep*
852 unload dflags linkables
853 = block $ do -- block, so we're safe from Ctrl-C in here
855 -- Initialise the linker (if it's not been done already)
858 pls <- readIORef v_PersistentLinkerState
859 new_pls <- unload_wkr dflags linkables pls
860 writeIORef v_PersistentLinkerState new_pls
862 debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
863 debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
866 unload_wkr :: DynFlags
867 -> [Linkable] -- stable linkables
868 -> PersistentLinkerState
869 -> IO PersistentLinkerState
870 -- Does the core unload business
871 -- (the wrapper blocks exceptions and deals with the PLS get and put)
873 unload_wkr dflags linkables pls
874 = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
876 objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
877 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
879 let bcos_retained = map linkableModule bcos_loaded'
880 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
881 closure_env' = filterNameMap bcos_retained (closure_env pls)
882 new_pls = pls { itbl_env = itbl_env',
883 closure_env = closure_env',
884 bcos_loaded = bcos_loaded',
885 objs_loaded = objs_loaded' }
889 maybeUnload :: [Linkable] -> Linkable -> IO Bool
890 maybeUnload keep_linkables lnk
891 | linkableInSet lnk linkables = return True
893 = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
894 -- The components of a BCO linkable may contain
895 -- dot-o files. Which is very confusing.
897 -- But the BCO parts can be unlinked just by
898 -- letting go of them (plus of course depopulating
899 -- the symbol table which is done in the main body)
904 %************************************************************************
908 %************************************************************************
913 = Object FilePath -- Full path name of a .o file, including trailing .o
914 -- For dynamic objects only, try to find the object
915 -- file in all the directories specified in
916 -- v_Library_paths before giving up.
918 | DLL String -- "Unadorned" name of a .DLL/.so
919 -- e.g. On unix "qt" denotes "libqt.so"
920 -- On WinDoze "burble" denotes "burble.DLL"
921 -- loadDLL is platform-specific and adds the lib/.so/.DLL
922 -- suffixes platform-dependently
924 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
925 -- (ends with .dll or .so).
927 | Framework String -- Only used for darwin, but does no harm
929 -- If this package is already part of the GHCi binary, we'll already
930 -- have the right DLLs for this package loaded, so don't try to
933 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
934 -- as far as the loader is concerned, but it does initialise the list
935 -- of DLL handles that rts/Linker.c maintains, and that in turn is
936 -- used by lookupSymbol. So we must call addDLL for each library
937 -- just to get the DLL handle into the list.
939 # if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS)
942 = [ "base", "haskell98", "template-haskell", "readline" ]
945 showLS (Object nm) = "(static) " ++ nm
946 showLS (DLL nm) = "(dynamic) " ++ nm
947 showLS (DLLPath nm) = "(dynamic) " ++ nm
948 showLS (Framework nm) = "(framework) " ++ nm
950 linkPackages :: DynFlags -> [PackageId] -> IO ()
951 -- Link exactly the specified packages, and their dependents
952 -- (unless of course they are already linked)
953 -- The dependents are linked automatically, and it doesn't matter
954 -- what order you specify the input packages.
956 -- NOTE: in fact, since each module tracks all the packages it depends on,
957 -- we don't really need to use the package-config dependencies.
958 -- However we do need the package-config stuff (to find aux libs etc),
959 -- and following them lets us load libraries in the right order, which
960 -- perhaps makes the error message a bit more localised if we get a link
961 -- failure. So the dependency walking code is still here.
963 linkPackages dflags new_pkgs
964 = do { pls <- readIORef v_PersistentLinkerState
965 ; let pkg_map = pkgIdMap (pkgState dflags)
967 ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
969 ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
972 link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
973 link pkg_map pkgs new_pkgs
974 = foldM (link_one pkg_map) pkgs new_pkgs
976 link_one pkg_map pkgs new_pkg
977 | new_pkg `elem` pkgs -- Already linked
980 | Just pkg_cfg <- lookupPackage pkg_map new_pkg
981 = do { -- Link dependents first
982 pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
983 -- Now link the package itself
984 ; linkPackage dflags pkg_cfg
985 ; return (new_pkg : pkgs') }
988 = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
991 linkPackage :: DynFlags -> PackageConfig -> IO ()
992 linkPackage dflags pkg
994 let dirs = Packages.libraryDirs pkg
996 let libs = Packages.hsLibraries pkg
997 -- Because of slight differences between the GHC dynamic linker and
998 -- the native system linker some packages have to link with a
999 -- different list of libraries when using GHCi. Examples include: libs
1000 -- that are actually gnu ld scripts, and the possability that the .a
1001 -- libs do not exactly match the .so/.dll equivalents. So if the
1002 -- package file provides an "extra-ghci-libraries" field then we use
1003 -- that instead of the "extra-libraries" field.
1004 ++ (if null (Packages.extraGHCiLibraries pkg)
1005 then Packages.extraLibraries pkg
1006 else Packages.extraGHCiLibraries pkg)
1007 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
1008 classifieds <- mapM (locateOneObj dirs) libs
1010 -- Complication: all the .so's must be loaded before any of the .o's.
1011 let dlls = [ dll | DLL dll <- classifieds ]
1012 objs = [ obj | Object obj <- classifieds ]
1014 maybePutStr dflags ("Loading package " ++ showPackageId (package pkg) ++ " ... ")
1016 -- See comments with partOfGHCi
1017 when (pkgName (package pkg) `notElem` partOfGHCi) $ do
1019 -- When a library A needs symbols from a library B, the order in
1020 -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
1021 -- way ld expects it for static linking. Dynamic linking is a
1022 -- different story: When A has no dependency information for B,
1023 -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
1024 -- when B has not been loaded before. In a nutshell: Reverse the
1025 -- order of DLLs for dynamic linking.
1026 -- This fixes a problem with the HOpenGL package (see "Compiling
1027 -- HOpenGL under recent versions of GHC" on the HOpenGL list).
1028 mapM_ (load_dyn dirs) (reverse dlls)
1030 -- After loading all the DLLs, we can load the static objects.
1031 -- Ordering isn't important here, because we do one final link
1032 -- step to resolve everything.
1035 maybePutStr dflags "linking ... "
1037 if succeeded ok then maybePutStrLn dflags "done."
1038 else throwDyn (InstallationError ("unable to load package `" ++ showPackageId (package pkg) ++ "'"))
1040 load_dyn dirs dll = do r <- loadDynamic dirs dll
1042 Nothing -> return ()
1043 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1044 ++ dll ++ " (" ++ err ++ ")" ))
1045 #ifndef darwin_TARGET_OS
1046 loadFrameworks pkg = return ()
1048 loadFrameworks pkg = mapM_ load frameworks
1050 fw_dirs = Packages.frameworkDirs pkg
1051 frameworks = Packages.frameworks pkg
1053 load fw = do r <- loadFramework fw_dirs fw
1055 Nothing -> return ()
1056 Just err -> throwDyn (CmdLineError ("can't load framework: "
1057 ++ fw ++ " (" ++ err ++ ")" ))
1060 -- Try to find an object file for a given library in the given paths.
1061 -- If it isn't present, we assume it's a dynamic library.
1063 -- When the GHC package was not compiled as dynamic library (=__PIC__ not set),
1064 -- we search for .o libraries first.
1065 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1066 locateOneObj dirs lib
1067 = do { mb_obj_path <- findFile mk_obj_path dirs
1068 ; case mb_obj_path of
1069 Just obj_path -> return (Object obj_path)
1071 do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1072 ; case mb_lib_path of
1073 Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
1074 Nothing -> return (DLL lib) }} -- We assume
1076 mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o")
1077 mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "-ghc" ++ cProjectVersion)
1079 -- When the GHC package was compiled as dynamic library (=__PIC__ set),
1080 -- we search for .so libraries first.
1081 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1082 locateOneObj dirs lib
1083 = do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1084 ; case mb_lib_path of
1085 Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
1087 do { mb_obj_path <- findFile mk_obj_path dirs
1088 ; case mb_obj_path of
1089 Just obj_path -> return (Object obj_path)
1090 Nothing -> return (DLL lib) }} -- We assume
1092 mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o")
1093 mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "-ghc" ++ cProjectVersion)
1096 -- ----------------------------------------------------------------------------
1097 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1099 -- return Nothing == success, else Just error message from dlopen
1100 loadDynamic paths rootname
1101 = do { mb_dll <- findFile mk_dll_path paths
1103 Just dll -> loadDLL dll
1104 Nothing -> loadDLL (mkSOName rootname) }
1105 -- Tried all our known library paths, so let
1106 -- dlopen() search its own builtin paths now.
1108 mk_dll_path dir = dir `joinFileName` mkSOName rootname
1110 #if defined(darwin_TARGET_OS)
1111 mkSOName root = ("lib" ++ root) `joinFileExt` "dylib"
1112 #elif defined(mingw32_TARGET_OS)
1113 -- Win32 DLLs have no .dll extension here, because addDLL tries
1114 -- both foo.dll and foo.drv
1115 mkSOName root = root
1117 mkSOName root = ("lib" ++ root) `joinFileExt` "so"
1120 -- Darwin / MacOS X only: load a framework
1121 -- a framework is a dynamic library packaged inside a directory of the same
1122 -- name. They are searched for in different paths than normal libraries.
1123 #ifdef darwin_TARGET_OS
1124 loadFramework extraPaths rootname
1125 = do { mb_fwk <- findFile mk_fwk (extraPaths ++ defaultFrameworkPaths)
1127 Just fwk_path -> loadDLL fwk_path
1128 Nothing -> return (Just "not found") }
1129 -- Tried all our known library paths, but dlopen()
1130 -- has no built-in paths for frameworks: give up
1132 mk_fwk dir = dir `joinFileName` (rootname ++ ".framework/" ++ rootname)
1133 -- sorry for the hardcoded paths, I hope they won't change anytime soon:
1134 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1138 %************************************************************************
1142 %************************************************************************
1145 findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
1146 -> [FilePath] -- Directories to look in
1147 -> IO (Maybe FilePath) -- The first file path to match
1148 findFile mk_file_path []
1150 findFile mk_file_path (dir:dirs)
1151 = do { let file_path = mk_file_path dir
1152 ; b <- doesFileExist file_path
1154 return (Just file_path)
1156 findFile mk_file_path dirs }
1160 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1161 | otherwise = return ()
1163 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1164 | otherwise = return ()