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, extendLinkEnv, withExtendedLinkEnv,
20 linkPackages,initDynLinker,
24 #include "HsVersions.h"
30 import RtClosureInspect
62 import Foreign.C.Types
63 import Foreign.C.String
64 import Foreign.Storable
67 import System.Directory
69 import Control.Exception
72 #if __GLASGOW_HASKELL__ >= 503
73 import GHC.IOBase ( IO(..) )
75 import PrelIOBase ( IO(..) )
81 %************************************************************************
85 %************************************************************************
87 The persistent linker state *must* match the actual state of the
88 C dynamic linker at all times, so we keep it in a private global variable.
91 The PersistentLinkerState maps Names to actual closures (for
92 interpreted code only), for use during linking.
95 GLOBAL_VAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState)
96 GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
98 data PersistentLinkerState
99 = PersistentLinkerState {
101 -- Current global mapping from Names to their true values
102 closure_env :: ClosureEnv,
104 -- The current global mapping from RdrNames of DataCons to
105 -- info table addresses.
106 -- When a new Unlinked is linked into the running image, or an existing
107 -- module in the image is replaced, the itbl_env must be updated
111 -- The currently loaded interpreted modules (home package)
112 bcos_loaded :: [Linkable],
114 -- And the currently-loaded compiled modules (home package)
115 objs_loaded :: [Linkable],
117 -- The currently-loaded packages; always object code
118 -- Held, as usual, in dependency order; though I am not sure if
119 -- that is really important
120 pkgs_loaded :: [PackageId]
123 emptyPLS :: DynFlags -> PersistentLinkerState
124 emptyPLS dflags = PersistentLinkerState {
125 closure_env = emptyNameEnv,
126 itbl_env = emptyNameEnv,
127 pkgs_loaded = init_pkgs,
131 -- Packages that don't need loading, because the compiler
132 -- shares them with the interpreted program.
134 -- The linker's symbol table is populated with RTS symbols using an
135 -- explicit list. See rts/Linker.c for details.
136 where init_pkgs = [rtsPackageId]
140 extendLoadedPkgs :: [PackageId] -> IO ()
141 extendLoadedPkgs pkgs
142 = modifyIORef v_PersistentLinkerState (\s -> s{pkgs_loaded = pkgs ++ pkgs_loaded s})
144 extendLinkEnv :: [(Name,HValue)] -> IO ()
145 -- Automatically discards shadowed bindings
146 extendLinkEnv new_bindings
147 = do pls <- readIORef v_PersistentLinkerState
148 let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
149 new_pls = pls { closure_env = new_closure_env }
150 writeIORef v_PersistentLinkerState new_pls
152 -- | Given a data constructor, find its internal name.
153 -- The info tables for data constructors have a field which records the source name
154 -- of the constructor as a CString. The format is:
156 -- Package:Module.Name
158 -- We use this string to lookup the interpreter's internal representation of the name
159 -- using the lookupOrig.
161 recoverDataCon :: a -> TcM Name
162 recoverDataCon x = do
163 theString <- ioToTcRn $ do
164 let ptr = getInfoTablePtr x
165 conDescAddress <- getConDescAddress ptr
166 peekCString conDescAddress
167 let (pkg, mod, occ) = parse theString
168 occName = mkOccName OccName.dataName occ
169 modName = mkModule (stringToPackageId pkg) (mkModuleName mod)
170 lookupOrig modName occName
174 {- To find the string in the constructor's info table we need to consider
175 the layout of info tables relative to the entry code for a closure.
177 An info table can be next to the entry code for the closure, or it can
178 be separate. The former (faster) is used in registerised versions of ghc,
179 and the latter (portable) is for non-registerised versions.
181 The diagrams below show where the string is to be found relative to
182 the normal info table of the closure.
184 1) Code next to table:
187 | | <- pointer to the start of the string
189 | | <- the (start of the) info table structure
196 In this case the pointer to the start of the string can be found in
197 the memory location _one word before_ the first entry in the normal info
200 2) Code NOT next to table:
203 info table structure -> | *------------------> --------------
207 ptr to start of str -> | |
210 In this case the pointer to the start of the string can be found
211 in the memory location: info_table_ptr + info_table_size
214 getConDescAddress :: Ptr StgInfoTable -> IO (Ptr CChar)
215 getConDescAddress ptr = do
216 peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset
217 #ifdef GHCI_TABLES_NEXT_TO_CODE
219 -- subtract a word number of bytes
220 offset = negate (fromIntegral SIZEOF_VOID_P)
222 #ifndef GHCI_TABLES_NEXT_TO_CODE
224 -- add the standard info table size in bytes
225 infoTableSizeBytes = sTD_ITBL_SIZE * wORD_SIZE
226 offset = infoTableSizeBytes
229 -- parsing names is a little bit fiddly because we have a string in the form:
230 -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
231 -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
232 -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
233 -- this is not the conventional way of writing Haskell names. We stick with
234 -- convention, even though it makes the parsing code more troublesome.
235 -- Warning: this code assumes that the string is well formed.
236 parse :: String -> (String, String, String)
238 = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
240 (pkg, rest1) = break (==':') input
242 = (concat $ intersperse "." $ reverse modWords, occWord)
244 (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
245 parseModOcc :: [String] -> String -> ([String], String)
247 = case break (== '.') str of
248 (top, []) -> (acc, top)
249 (top, '.':bot) -> parseModOcc (top : acc) bot
252 getHValue :: Name -> IO (Maybe HValue)
254 pls <- readIORef v_PersistentLinkerState
255 case lookupNameEnv (closure_env pls) name of
256 Just (_,x) -> return$ Just x
259 withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
260 withExtendedLinkEnv new_env action
261 = bracket set_new_env
264 where set_new_env = do pls <- readIORef v_PersistentLinkerState
265 let new_closure_env = extendClosureEnv (closure_env pls) new_env
266 new_pls = pls { closure_env = new_closure_env }
267 writeIORef v_PersistentLinkerState new_pls
268 return (closure_env pls)
269 reset_old_env env = modifyIORef v_PersistentLinkerState (\pls -> pls{ closure_env = env })
271 -- filterNameMap removes from the environment all entries except
272 -- those for a given set of modules;
273 -- Note that this removes all *local* (i.e. non-isExternal) names too
274 -- (these are the temporary bindings from the command line).
275 -- Used to filter both the ClosureEnv and ItblEnv
277 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
278 filterNameMap mods env
279 = filterNameEnv keep_elt env
281 keep_elt (n,_) = isExternalName n
282 && (nameModule n `elem` mods)
287 showLinkerState :: IO ()
288 -- Display the persistent linker state
290 = do pls <- readIORef v_PersistentLinkerState
291 printDump (vcat [text "----- Linker state -----",
292 text "Pkgs:" <+> ppr (pkgs_loaded pls),
293 text "Objs:" <+> ppr (objs_loaded pls),
294 text "BCOs:" <+> ppr (bcos_loaded pls)])
300 %************************************************************************
302 \subsection{Initialisation}
304 %************************************************************************
306 We initialise the dynamic linker by
308 a) calling the C initialisation procedure
310 b) Loading any packages specified on the command line,
312 c) Loading any packages specified on the command line,
313 now held in the -l options in v_Opt_l
315 d) Loading any .o/.dll files specified on the command line,
316 now held in v_Ld_inputs
318 e) Loading any MacOS frameworks
321 initDynLinker :: DynFlags -> IO ()
322 -- This function is idempotent; if called more than once, it does nothing
323 -- This is useful in Template Haskell, where we call it before trying to link
325 = do { done <- readIORef v_InitLinkerDone
326 ; if done then return ()
327 else do { writeIORef v_InitLinkerDone True
328 ; reallyInitDynLinker dflags }
331 reallyInitDynLinker dflags
332 = do { -- Initialise the linker state
333 ; writeIORef v_PersistentLinkerState (emptyPLS dflags)
335 -- (a) initialise the C dynamic linker
338 -- (b) Load packages from the command-line
339 ; linkPackages dflags (preloadPackages (pkgState dflags))
341 -- (c) Link libraries from the command-line
342 ; let optl = getOpts dflags opt_l
343 ; let minus_ls = [ lib | '-':'l':lib <- optl ]
345 -- (d) Link .o files from the command-line
346 ; let lib_paths = libraryPaths dflags
347 ; cmdline_ld_inputs <- readIORef v_Ld_inputs
349 ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
351 -- (e) Link any MacOS frameworks
352 #ifdef darwin_TARGET_OS
353 ; let framework_paths = frameworkPaths dflags
354 ; let frameworks = cmdlineFrameworks dflags
356 ; let frameworks = []
357 ; let framework_paths = []
359 -- Finally do (c),(d),(e)
360 ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
362 ++ map Framework frameworks
363 ; if null cmdline_lib_specs then return ()
366 { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
367 ; maybePutStr dflags "final link ... "
370 ; if succeeded ok then maybePutStrLn dflags "done"
371 else throwDyn (InstallationError "linking extra libraries/objects failed")
374 classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
376 | isObjectFilename f = return (Just (Object f))
377 | isDynLibFilename f = return (Just (DLLPath f))
379 hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
382 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
383 preloadLib dflags lib_paths framework_paths lib_spec
384 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
387 -> do b <- preload_static lib_paths static_ish
388 maybePutStrLn dflags (if b then "done"
392 -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
394 Nothing -> maybePutStrLn dflags "done"
395 Just mm -> preloadFailed mm lib_paths lib_spec
398 -> do maybe_errstr <- loadDLL dll_path
400 Nothing -> maybePutStrLn dflags "done"
401 Just mm -> preloadFailed mm lib_paths lib_spec
403 #ifdef darwin_TARGET_OS
405 -> do maybe_errstr <- loadFramework framework_paths framework
407 Nothing -> maybePutStrLn dflags "done"
408 Just mm -> preloadFailed mm framework_paths lib_spec
411 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
412 preloadFailed sys_errmsg paths spec
413 = do maybePutStr dflags
414 ("failed.\nDynamic linker error message was:\n "
415 ++ sys_errmsg ++ "\nWhilst trying to load: "
416 ++ showLS spec ++ "\nDirectories to search are:\n"
417 ++ unlines (map (" "++) paths) )
420 -- Not interested in the paths in the static case.
421 preload_static paths name
422 = do b <- doesFileExist name
423 if not b then return False
424 else loadObj name >> return True
427 CmdLineError "user specified .o/.so/.DLL could not be loaded."
431 %************************************************************************
433 Link a byte-code expression
435 %************************************************************************
438 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
440 -- Link a single expression, *including* first linking packages and
441 -- modules that this expression depends on.
443 -- Raises an IO exception if it can't find a compiled version of the
444 -- dependents to link.
446 -- Note: This function side-effects the linker state (Pepe)
448 linkExpr hsc_env span root_ul_bco
450 -- Initialise the linker (if it's not been done already)
451 let dflags = hsc_dflags hsc_env
452 ; initDynLinker dflags
454 -- The interpreter and dynamic linker can only handle object code built
455 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
456 -- So here we check the build tag: if we're building a non-standard way
457 -- then we need to find & link object files built the "normal" way.
458 ; maybe_normal_osuf <- checkNonStdWay dflags span
460 -- Find what packages and linkables are required
461 ; eps <- readIORef (hsc_EPS hsc_env)
462 ; (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
463 maybe_normal_osuf span needed_mods
465 -- Link the packages and modules required
466 ; linkPackages dflags pkgs
467 ; ok <- linkModules dflags lnks
469 throwDyn (ProgramError "")
472 -- Link the expression itself
473 pls <- readIORef v_PersistentLinkerState
474 ; let ie = itbl_env pls
477 -- Link the necessary packages and linkables
478 ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
482 hpt = hsc_HPT hsc_env
483 free_names = nameSetToList (bcoFreeNames root_ul_bco)
485 needed_mods :: [Module]
486 needed_mods = [ nameModule n | n <- free_names,
487 isExternalName n, -- Names from other modules
488 not (isWiredInName n) -- Exclude wired-in names
489 ] -- (see note below)
490 -- Exclude wired-in names because we may not have read
491 -- their interface files, so getLinkDeps will fail
492 -- All wired-in names are in the base package, which we link
493 -- by default, so we can safely ignore them here.
495 dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg)))
498 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
499 checkNonStdWay dflags srcspan = do
500 tag <- readIORef v_Build_tag
501 if null tag then return Nothing else do
502 let default_osuf = phaseInputExt StopLn
503 if objectSuf dflags == default_osuf
504 then failNonStd srcspan
505 else return (Just default_osuf)
507 failNonStd srcspan = dieWith srcspan $
508 ptext SLIT("Dynamic linking required, but this is a non-standard build (eg. prof).") $$
509 ptext SLIT("You need to build the program twice: once the normal way, and then") $$
510 ptext SLIT("in the desired way using -osuf to set the object file suffix.")
513 getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable
514 -> Maybe String -- the "normal" object suffix
515 -> SrcSpan -- for error messages
516 -> [Module] -- If you need these
517 -> IO ([Linkable], [PackageId]) -- ... then link these first
518 -- Fails with an IO exception if it can't find enough files
520 getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
521 -- Find all the packages and linkables that a set of modules depends on
522 = do { pls <- readIORef v_PersistentLinkerState ;
524 -- 1. Find the dependent home-pkg-modules/packages from each iface
525 (mods_s, pkgs_s) = follow_deps mods emptyUniqSet emptyUniqSet;
527 -- 2. Exclude ones already linked
528 -- Main reason: avoid findModule calls in get_linkable
529 mods_needed = mods_s `minusList` linked_mods ;
530 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
532 linked_mods = map (moduleName.linkableModule)
533 (objs_loaded pls ++ bcos_loaded pls)
536 -- putStrLn (showSDoc (ppr mods_s)) ;
537 -- 3. For each dependent module, find its linkable
538 -- This will either be in the HPT or (in the case of one-shot
539 -- compilation) we may need to use maybe_getFileLinkable
540 lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
542 return (lnks_needed, pkgs_needed) }
544 dflags = hsc_dflags hsc_env
545 this_pkg = thisPackage dflags
547 -- The ModIface contains the transitive closure of the module dependencies
548 -- within the current package, *except* for boot modules: if we encounter
549 -- a boot module, we have to find its real interface and discover the
550 -- dependencies of that. Hence we need to traverse the dependency
551 -- tree recursively. See bug #936, testcase ghci/prog007.
552 follow_deps :: [Module] -- modules to follow
553 -> UniqSet ModuleName -- accum. module dependencies
554 -> UniqSet PackageId -- accum. package dependencies
555 -> ([ModuleName], [PackageId]) -- result
556 follow_deps [] acc_mods acc_pkgs
557 = (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
558 follow_deps (mod:mods) acc_mods acc_pkgs
560 = follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
562 = link_boot_mod_error mod
564 = follow_deps (map (mkModule this_pkg) boot_deps ++ mods) acc_mods' acc_pkgs'
566 pkg = modulePackageId mod
567 iface = get_iface mod
570 pkg_deps = dep_pkgs deps
571 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
572 where is_boot (m,True) = Left m
573 is_boot (m,False) = Right m
575 boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
576 acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
577 acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
580 link_boot_mod_error mod =
581 throwDyn (ProgramError (showSDoc (
582 text "module" <+> ppr mod <+>
583 text "cannot be linked; it is only available as a boot module")))
585 get_iface mod = case lookupIfaceByModule dflags hpt pit mod of
587 Nothing -> pprPanic "getLinkDeps" (no_iface mod)
588 no_iface mod = ptext SLIT("No iface for") <+> ppr mod
589 -- This one is a GHC bug
591 no_obj mod = dieWith span $
592 ptext SLIT("cannot find object file for module ") <>
596 while_linking_expr = ptext SLIT("while linking an interpreted expression")
598 -- This one is a build-system bug
600 get_linkable maybe_normal_osuf mod_name -- A home-package module
601 | Just mod_info <- lookupUFM hpt mod_name
602 = ASSERT(isJust (hm_linkable mod_info))
603 adjust_linkable (fromJust (hm_linkable mod_info))
605 = do -- It's not in the HPT because we are in one shot mode,
606 -- so use the Finder to get a ModLocation...
607 mb_stuff <- findHomeModule hsc_env mod_name
609 Found loc mod -> found loc mod
613 -- ...and then find the linkable for it
614 mb_lnk <- findObjectLinkableMaybe mod loc ;
616 Nothing -> no_obj mod ;
617 Just lnk -> adjust_linkable lnk
621 | Just osuf <- maybe_normal_osuf = do
622 new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
623 return lnk{ linkableUnlinked=new_uls }
627 adjust_ul osuf (DotO file) = do
628 let new_file = replaceFilenameSuffix file osuf
629 ok <- doesFileExist new_file
632 ptext SLIT("cannot find normal object file ")
633 <> quotes (text new_file) $$ while_linking_expr
634 else return (DotO new_file)
638 %************************************************************************
641 The linkables may consist of a mixture of
642 byte-code modules and object modules
644 %************************************************************************
647 linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
648 linkModules dflags linkables
649 = block $ do -- don't want to be interrupted by ^C in here
651 let (objs, bcos) = partition isObjectLinkable
652 (concatMap partitionLinkable linkables)
654 -- Load objects first; they can't depend on BCOs
655 ok_flag <- dynLinkObjs dflags objs
657 if failed ok_flag then
664 -- HACK to support f-x-dynamic in the interpreter; no other purpose
665 partitionLinkable :: Linkable -> [Linkable]
667 = let li_uls = linkableUnlinked li
668 li_uls_obj = filter isObject li_uls
669 li_uls_bco = filter isInterpretable li_uls
671 case (li_uls_obj, li_uls_bco) of
672 (objs@(_:_), bcos@(_:_))
673 -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
677 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
678 findModuleLinkable_maybe lis mod
679 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
682 many -> pprPanic "findModuleLinkable" (ppr mod)
684 linkableInSet :: Linkable -> [Linkable] -> Bool
685 linkableInSet l objs_loaded =
686 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
688 Just m -> linkableTime l == linkableTime m
692 %************************************************************************
694 \subsection{The object-code linker}
696 %************************************************************************
699 dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
700 -- Side-effects the PersistentLinkerState
702 dynLinkObjs dflags objs
703 = do pls <- readIORef v_PersistentLinkerState
705 -- Load the object files and link them
706 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
707 pls1 = pls { objs_loaded = objs_loaded' }
708 unlinkeds = concatMap linkableUnlinked new_objs
710 mapM loadObj (map nameOfObject unlinkeds)
712 -- Link the all together
715 -- If resolving failed, unload all our
716 -- object modules and carry on
717 if succeeded ok then do
718 writeIORef v_PersistentLinkerState pls1
721 pls2 <- unload_wkr dflags [] pls1
722 writeIORef v_PersistentLinkerState pls2
726 rmDupLinkables :: [Linkable] -- Already loaded
727 -> [Linkable] -- New linkables
728 -> ([Linkable], -- New loaded set (including new ones)
729 [Linkable]) -- New linkables (excluding dups)
730 rmDupLinkables already ls
733 go already extras [] = (already, extras)
734 go already extras (l:ls)
735 | linkableInSet l already = go already extras ls
736 | otherwise = go (l:already) (l:extras) ls
739 %************************************************************************
741 \subsection{The byte-code linker}
743 %************************************************************************
746 dynLinkBCOs :: [Linkable] -> IO ()
747 -- Side-effects the persistent linker state
749 = do pls <- readIORef v_PersistentLinkerState
751 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
752 pls1 = pls { bcos_loaded = bcos_loaded' }
753 unlinkeds :: [Unlinked]
754 unlinkeds = concatMap linkableUnlinked new_bcos
756 cbcs :: [CompiledByteCode]
757 cbcs = map byteCodeOfObject unlinkeds
760 ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
761 ies = [ie | ByteCode _ ie <- cbcs]
762 gce = closure_env pls
763 final_ie = foldr plusNameEnv (itbl_env pls) ies
765 (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
766 -- What happens to these linked_bcos?
768 let pls2 = pls1 { closure_env = final_gce,
769 itbl_env = final_ie }
771 writeIORef v_PersistentLinkerState pls2
774 -- Link a bunch of BCOs and return them + updated closure env.
775 linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
776 -- True <=> add only toplevel BCOs to closure env
780 -> IO (ClosureEnv, [HValue])
781 -- The returned HValues are associated 1-1 with
782 -- the incoming unlinked BCOs. Each gives the
783 -- value of the corresponding unlinked BCO
785 linkSomeBCOs toplevs_only ie ce_in ul_bcos
786 = do let nms = map unlinkedBCOName ul_bcos
788 ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
789 in mapM (linkBCO ie ce_out) ul_bcos )
790 let ce_all_additions = zip nms hvals
791 ce_top_additions = filter (isExternalName.fst) ce_all_additions
792 ce_additions = if toplevs_only then ce_top_additions
793 else ce_all_additions
794 ce_out = -- make sure we're not inserting duplicate names into the
795 -- closure environment, which leads to trouble.
796 ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
797 extendClosureEnv ce_in ce_additions
798 return (ce_out, hvals)
803 %************************************************************************
805 Unload some object modules
807 %************************************************************************
810 -- ---------------------------------------------------------------------------
811 -- Unloading old objects ready for a new compilation sweep.
813 -- The compilation manager provides us with a list of linkables that it
814 -- considers "stable", i.e. won't be recompiled this time around. For
815 -- each of the modules current linked in memory,
817 -- * if the linkable is stable (and it's the same one - the
818 -- user may have recompiled the module on the side), we keep it,
820 -- * otherwise, we unload it.
822 -- * we also implicitly unload all temporary bindings at this point.
824 unload :: DynFlags -> [Linkable] -> IO ()
825 -- The 'linkables' are the ones to *keep*
827 unload dflags linkables
828 = block $ do -- block, so we're safe from Ctrl-C in here
830 -- Initialise the linker (if it's not been done already)
833 pls <- readIORef v_PersistentLinkerState
834 new_pls <- unload_wkr dflags linkables pls
835 writeIORef v_PersistentLinkerState new_pls
837 debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
838 debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
841 unload_wkr :: DynFlags
842 -> [Linkable] -- stable linkables
843 -> PersistentLinkerState
844 -> IO PersistentLinkerState
845 -- Does the core unload business
846 -- (the wrapper blocks exceptions and deals with the PLS get and put)
848 unload_wkr dflags linkables pls
849 = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
851 objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
852 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
854 let bcos_retained = map linkableModule bcos_loaded'
855 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
856 closure_env' = filterNameMap bcos_retained (closure_env pls)
857 new_pls = pls { itbl_env = itbl_env',
858 closure_env = closure_env',
859 bcos_loaded = bcos_loaded',
860 objs_loaded = objs_loaded' }
864 maybeUnload :: [Linkable] -> Linkable -> IO Bool
865 maybeUnload keep_linkables lnk
866 | linkableInSet lnk linkables = return True
868 = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
869 -- The components of a BCO linkable may contain
870 -- dot-o files. Which is very confusing.
872 -- But the BCO parts can be unlinked just by
873 -- letting go of them (plus of course depopulating
874 -- the symbol table which is done in the main body)
879 %************************************************************************
883 %************************************************************************
888 = Object FilePath -- Full path name of a .o file, including trailing .o
889 -- For dynamic objects only, try to find the object
890 -- file in all the directories specified in
891 -- v_Library_paths before giving up.
893 | DLL String -- "Unadorned" name of a .DLL/.so
894 -- e.g. On unix "qt" denotes "libqt.so"
895 -- On WinDoze "burble" denotes "burble.DLL"
896 -- loadDLL is platform-specific and adds the lib/.so/.DLL
897 -- suffixes platform-dependently
899 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
900 -- (ends with .dll or .so).
902 | Framework String -- Only used for darwin, but does no harm
904 -- If this package is already part of the GHCi binary, we'll already
905 -- have the right DLLs for this package loaded, so don't try to
908 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
909 -- as far as the loader is concerned, but it does initialise the list
910 -- of DLL handles that rts/Linker.c maintains, and that in turn is
911 -- used by lookupSymbol. So we must call addDLL for each library
912 -- just to get the DLL handle into the list.
914 # if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS)
917 = [ "base", "haskell98", "template-haskell", "readline" ]
920 showLS (Object nm) = "(static) " ++ nm
921 showLS (DLL nm) = "(dynamic) " ++ nm
922 showLS (DLLPath nm) = "(dynamic) " ++ nm
923 showLS (Framework nm) = "(framework) " ++ nm
925 linkPackages :: DynFlags -> [PackageId] -> IO ()
926 -- Link exactly the specified packages, and their dependents
927 -- (unless of course they are already linked)
928 -- The dependents are linked automatically, and it doesn't matter
929 -- what order you specify the input packages.
931 -- NOTE: in fact, since each module tracks all the packages it depends on,
932 -- we don't really need to use the package-config dependencies.
933 -- However we do need the package-config stuff (to find aux libs etc),
934 -- and following them lets us load libraries in the right order, which
935 -- perhaps makes the error message a bit more localised if we get a link
936 -- failure. So the dependency walking code is still here.
938 linkPackages dflags new_pkgs
939 = do { pls <- readIORef v_PersistentLinkerState
940 ; let pkg_map = pkgIdMap (pkgState dflags)
942 ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
944 ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
947 link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
948 link pkg_map pkgs new_pkgs
949 = foldM (link_one pkg_map) pkgs new_pkgs
951 link_one pkg_map pkgs new_pkg
952 | new_pkg `elem` pkgs -- Already linked
955 | Just pkg_cfg <- lookupPackage pkg_map new_pkg
956 = do { -- Link dependents first
957 pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
958 -- Now link the package itself
959 ; linkPackage dflags pkg_cfg
960 ; return (new_pkg : pkgs') }
963 = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
966 linkPackage :: DynFlags -> PackageConfig -> IO ()
967 linkPackage dflags pkg
969 let dirs = Packages.libraryDirs pkg
971 let libs = Packages.hsLibraries pkg
972 -- Because of slight differences between the GHC dynamic linker and
973 -- the native system linker some packages have to link with a
974 -- different list of libraries when using GHCi. Examples include: libs
975 -- that are actually gnu ld scripts, and the possability that the .a
976 -- libs do not exactly match the .so/.dll equivalents. So if the
977 -- package file provides an "extra-ghci-libraries" field then we use
978 -- that instead of the "extra-libraries" field.
979 ++ (if null (Packages.extraGHCiLibraries pkg)
980 then Packages.extraLibraries pkg
981 else Packages.extraGHCiLibraries pkg)
982 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
983 classifieds <- mapM (locateOneObj dirs) libs
985 -- Complication: all the .so's must be loaded before any of the .o's.
986 let dlls = [ dll | DLL dll <- classifieds ]
987 objs = [ obj | Object obj <- classifieds ]
989 maybePutStr dflags ("Loading package " ++ showPackageId (package pkg) ++ " ... ")
991 -- See comments with partOfGHCi
992 when (pkgName (package pkg) `notElem` partOfGHCi) $ do
994 -- When a library A needs symbols from a library B, the order in
995 -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
996 -- way ld expects it for static linking. Dynamic linking is a
997 -- different story: When A has no dependency information for B,
998 -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
999 -- when B has not been loaded before. In a nutshell: Reverse the
1000 -- order of DLLs for dynamic linking.
1001 -- This fixes a problem with the HOpenGL package (see "Compiling
1002 -- HOpenGL under recent versions of GHC" on the HOpenGL list).
1003 mapM_ (load_dyn dirs) (reverse dlls)
1005 -- After loading all the DLLs, we can load the static objects.
1006 -- Ordering isn't important here, because we do one final link
1007 -- step to resolve everything.
1010 maybePutStr dflags "linking ... "
1012 if succeeded ok then maybePutStrLn dflags "done."
1013 else throwDyn (InstallationError ("unable to load package `" ++ showPackageId (package pkg) ++ "'"))
1015 load_dyn dirs dll = do r <- loadDynamic dirs dll
1017 Nothing -> return ()
1018 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1019 ++ dll ++ " (" ++ err ++ ")" ))
1020 #ifndef darwin_TARGET_OS
1021 loadFrameworks pkg = return ()
1023 loadFrameworks pkg = mapM_ load frameworks
1025 fw_dirs = Packages.frameworkDirs pkg
1026 frameworks = Packages.frameworks pkg
1028 load fw = do r <- loadFramework fw_dirs fw
1030 Nothing -> return ()
1031 Just err -> throwDyn (CmdLineError ("can't load framework: "
1032 ++ fw ++ " (" ++ err ++ ")" ))
1035 -- Try to find an object file for a given library in the given paths.
1036 -- If it isn't present, we assume it's a dynamic library.
1037 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1038 locateOneObj dirs lib
1039 = do { mb_obj_path <- findFile mk_obj_path dirs
1040 ; case mb_obj_path of
1041 Just obj_path -> return (Object obj_path)
1043 do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1044 ; case mb_lib_path of
1045 Just lib_path -> return (DLL (lib ++ "_dyn"))
1046 Nothing -> return (DLL lib) }} -- We assume
1048 mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o")
1049 mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "_dyn")
1052 -- ----------------------------------------------------------------------------
1053 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1055 -- return Nothing == success, else Just error message from dlopen
1056 loadDynamic paths rootname
1057 = do { mb_dll <- findFile mk_dll_path paths
1059 Just dll -> loadDLL dll
1060 Nothing -> loadDLL (mkSOName rootname) }
1061 -- Tried all our known library paths, so let
1062 -- dlopen() search its own builtin paths now.
1064 mk_dll_path dir = dir `joinFileName` mkSOName rootname
1066 #if defined(darwin_TARGET_OS)
1067 mkSOName root = ("lib" ++ root) `joinFileExt` "dylib"
1068 #elif defined(mingw32_TARGET_OS)
1069 -- Win32 DLLs have no .dll extension here, because addDLL tries
1070 -- both foo.dll and foo.drv
1071 mkSOName root = root
1073 mkSOName root = ("lib" ++ root) `joinFileExt` "so"
1076 -- Darwin / MacOS X only: load a framework
1077 -- a framework is a dynamic library packaged inside a directory of the same
1078 -- name. They are searched for in different paths than normal libraries.
1079 #ifdef darwin_TARGET_OS
1080 loadFramework extraPaths rootname
1081 = do { mb_fwk <- findFile mk_fwk (extraPaths ++ defaultFrameworkPaths)
1083 Just fwk_path -> loadDLL fwk_path
1084 Nothing -> return (Just "not found") }
1085 -- Tried all our known library paths, but dlopen()
1086 -- has no built-in paths for frameworks: give up
1088 mk_fwk dir = dir `joinFileName` (rootname ++ ".framework/" ++ rootname)
1089 -- sorry for the hardcoded paths, I hope they won't change anytime soon:
1090 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1094 %************************************************************************
1098 %************************************************************************
1101 findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
1102 -> [FilePath] -- Directories to look in
1103 -> IO (Maybe FilePath) -- The first file path to match
1104 findFile mk_file_path []
1106 findFile mk_file_path (dir:dirs)
1107 = do { let file_path = mk_file_path dir
1108 ; b <- doesFileExist file_path
1110 return (Just file_path)
1112 findFile mk_file_path dirs }
1116 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1117 | otherwise = return ()
1119 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1120 | otherwise = return ()