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
65 import Foreign.C.Types
66 import Foreign.C.String
67 import Foreign.Storable
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, find its internal name.
156 -- The info tables for data constructors have a field which records the source name
157 -- of the constructor as a CString. The format is:
159 -- Package:Module.Name
161 -- We use this string to lookup the interpreter's internal representation of the name
162 -- using the lookupOrig.
164 dataConInfoPtrToName :: Ptr () -> TcM Name
165 dataConInfoPtrToName x = do
166 theString <- ioToTcRn $ do
167 let ptr = castPtr x :: Ptr StgInfoTable
168 conDescAddress <- getConDescAddress ptr
169 str <- peekCString conDescAddress
171 let (pkg, mod, occ) = parse theString
172 occName = mkOccName OccName.dataName occ
173 modName = mkModule (stringToPackageId pkg) (mkModuleName mod)
174 lookupOrig modName occName
178 {- To find the string in the constructor's info table we need to consider
179 the layout of info tables relative to the entry code for a closure.
181 An info table can be next to the entry code for the closure, or it can
182 be separate. The former (faster) is used in registerised versions of ghc,
183 and the latter (portable) is for non-registerised versions.
185 The diagrams below show where the string is to be found relative to
186 the normal info table of the closure.
188 1) Code next to table:
191 | | <- pointer to the start of the string
193 | | <- the (start of the) info table structure
200 In this case the pointer to the start of the string can be found in
201 the memory location _one word before_ the first entry in the normal info
204 2) Code NOT next to table:
207 info table structure -> | *------------------> --------------
211 ptr to start of str -> | |
214 In this case the pointer to the start of the string can be found
215 in the memory location: info_table_ptr + info_table_size
218 getConDescAddress :: Ptr StgInfoTable -> IO (Ptr CChar)
219 getConDescAddress ptr = do
220 #ifdef GHCI_TABLES_NEXT_TO_CODE
221 offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
222 return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
224 peek $ intPtrToPtr $ (ptrToIntPtr ptr) + stdInfoTableSizeB
227 -- parsing names is a little bit fiddly because we have a string in the form:
228 -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
229 -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
230 -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
231 -- this is not the conventional way of writing Haskell names. We stick with
232 -- convention, even though it makes the parsing code more troublesome.
233 -- Warning: this code assumes that the string is well formed.
234 parse :: String -> (String, String, String)
236 = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
238 (pkg, rest1) = break (==':') input
240 = (concat $ intersperse "." $ reverse modWords, occWord)
242 (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
243 parseModOcc :: [String] -> String -> ([String], String)
245 = case break (== '.') str of
246 (top, []) -> (acc, top)
247 (top, '.':bot) -> parseModOcc (top : acc) bot
250 getHValue :: Name -> IO (Maybe HValue)
252 pls <- readIORef v_PersistentLinkerState
253 case lookupNameEnv (closure_env pls) name of
254 Just (_,x) -> return$ Just x
257 withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
258 withExtendedLinkEnv new_env action
259 = bracket set_new_env
262 where set_new_env = do pls <- readIORef v_PersistentLinkerState
263 let new_closure_env = extendClosureEnv (closure_env pls) new_env
264 new_pls = pls { closure_env = new_closure_env }
265 writeIORef v_PersistentLinkerState new_pls
266 return (closure_env pls)
267 reset_old_env env = modifyIORef v_PersistentLinkerState (\pls -> pls{ closure_env = env })
269 -- filterNameMap removes from the environment all entries except
270 -- those for a given set of modules;
271 -- Note that this removes all *local* (i.e. non-isExternal) names too
272 -- (these are the temporary bindings from the command line).
273 -- Used to filter both the ClosureEnv and ItblEnv
275 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
276 filterNameMap mods env
277 = filterNameEnv keep_elt env
279 keep_elt (n,_) = isExternalName n
280 && (nameModule n `elem` mods)
285 showLinkerState :: IO ()
286 -- Display the persistent linker state
288 = do pls <- readIORef v_PersistentLinkerState
289 printDump (vcat [text "----- Linker state -----",
290 text "Pkgs:" <+> ppr (pkgs_loaded pls),
291 text "Objs:" <+> ppr (objs_loaded pls),
292 text "BCOs:" <+> ppr (bcos_loaded pls)])
298 %************************************************************************
300 \subsection{Initialisation}
302 %************************************************************************
304 We initialise the dynamic linker by
306 a) calling the C initialisation procedure
308 b) Loading any packages specified on the command line,
310 c) Loading any packages specified on the command line,
311 now held in the -l options in v_Opt_l
313 d) Loading any .o/.dll files specified on the command line,
314 now held in v_Ld_inputs
316 e) Loading any MacOS frameworks
319 initDynLinker :: DynFlags -> IO ()
320 -- This function is idempotent; if called more than once, it does nothing
321 -- This is useful in Template Haskell, where we call it before trying to link
323 = do { done <- readIORef v_InitLinkerDone
324 ; if done then return ()
325 else do { writeIORef v_InitLinkerDone True
326 ; reallyInitDynLinker dflags }
329 reallyInitDynLinker dflags
330 = do { -- Initialise the linker state
331 ; writeIORef v_PersistentLinkerState (emptyPLS dflags)
333 -- (a) initialise the C dynamic linker
336 -- (b) Load packages from the command-line
337 ; linkPackages dflags (preloadPackages (pkgState dflags))
339 -- (c) Link libraries from the command-line
340 ; let optl = getOpts dflags opt_l
341 ; let minus_ls = [ lib | '-':'l':lib <- optl ]
343 -- (d) Link .o files from the command-line
344 ; let lib_paths = libraryPaths dflags
345 ; cmdline_ld_inputs <- readIORef v_Ld_inputs
347 ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
349 -- (e) Link any MacOS frameworks
350 #ifdef darwin_TARGET_OS
351 ; let framework_paths = frameworkPaths dflags
352 ; let frameworks = cmdlineFrameworks dflags
354 ; let frameworks = []
355 ; let framework_paths = []
357 -- Finally do (c),(d),(e)
358 ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
360 ++ map Framework frameworks
361 ; if null cmdline_lib_specs then return ()
364 { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
365 ; maybePutStr dflags "final link ... "
368 ; if succeeded ok then maybePutStrLn dflags "done"
369 else throwDyn (InstallationError "linking extra libraries/objects failed")
372 classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
374 | isObjectFilename f = return (Just (Object f))
375 | isDynLibFilename f = return (Just (DLLPath f))
377 hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
380 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
381 preloadLib dflags lib_paths framework_paths lib_spec
382 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
385 -> do b <- preload_static lib_paths static_ish
386 maybePutStrLn dflags (if b then "done"
390 -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
392 Nothing -> maybePutStrLn dflags "done"
393 Just mm -> preloadFailed mm lib_paths lib_spec
396 -> do maybe_errstr <- loadDLL dll_path
398 Nothing -> maybePutStrLn dflags "done"
399 Just mm -> preloadFailed mm lib_paths lib_spec
401 #ifdef darwin_TARGET_OS
403 -> do maybe_errstr <- loadFramework framework_paths framework
405 Nothing -> maybePutStrLn dflags "done"
406 Just mm -> preloadFailed mm framework_paths lib_spec
409 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
410 preloadFailed sys_errmsg paths spec
411 = do maybePutStr dflags
412 ("failed.\nDynamic linker error message was:\n "
413 ++ sys_errmsg ++ "\nWhilst trying to load: "
414 ++ showLS spec ++ "\nDirectories to search are:\n"
415 ++ unlines (map (" "++) paths) )
418 -- Not interested in the paths in the static case.
419 preload_static paths name
420 = do b <- doesFileExist name
421 if not b then return False
422 else loadObj name >> return True
425 CmdLineError "user specified .o/.so/.DLL could not be loaded."
429 %************************************************************************
431 Link a byte-code expression
433 %************************************************************************
436 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
438 -- Link a single expression, *including* first linking packages and
439 -- modules that this expression depends on.
441 -- Raises an IO exception if it can't find a compiled version of the
442 -- dependents to link.
444 -- Note: This function side-effects the linker state (Pepe)
446 linkExpr hsc_env span root_ul_bco
448 -- Initialise the linker (if it's not been done already)
449 let dflags = hsc_dflags hsc_env
450 ; initDynLinker dflags
452 -- The interpreter and dynamic linker can only handle object code built
453 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
454 -- So here we check the build tag: if we're building a non-standard way
455 -- then we need to find & link object files built the "normal" way.
456 ; maybe_normal_osuf <- checkNonStdWay dflags span
458 -- Find what packages and linkables are required
459 ; eps <- readIORef (hsc_EPS hsc_env)
460 ; (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
461 maybe_normal_osuf span needed_mods
463 -- Link the packages and modules required
464 ; linkPackages dflags pkgs
465 ; ok <- linkModules dflags lnks
467 throwDyn (ProgramError "")
470 -- Link the expression itself
471 pls <- readIORef v_PersistentLinkerState
472 ; let ie = itbl_env pls
475 -- Link the necessary packages and linkables
476 ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
480 hpt = hsc_HPT hsc_env
481 free_names = nameSetToList (bcoFreeNames root_ul_bco)
483 needed_mods :: [Module]
484 needed_mods = [ nameModule n | n <- free_names,
485 isExternalName n, -- Names from other modules
486 not (isWiredInName n) -- Exclude wired-in names
487 ] -- (see note below)
488 -- Exclude wired-in names because we may not have read
489 -- their interface files, so getLinkDeps will fail
490 -- All wired-in names are in the base package, which we link
491 -- by default, so we can safely ignore them here.
493 dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg)))
496 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
497 checkNonStdWay dflags srcspan = do
498 tag <- readIORef v_Build_tag
499 if null tag then return Nothing else do
500 let default_osuf = phaseInputExt StopLn
501 if objectSuf dflags == default_osuf
502 then failNonStd srcspan
503 else return (Just default_osuf)
505 failNonStd srcspan = dieWith srcspan $
506 ptext SLIT("Dynamic linking required, but this is a non-standard build (eg. prof).") $$
507 ptext SLIT("You need to build the program twice: once the normal way, and then") $$
508 ptext SLIT("in the desired way using -osuf to set the object file suffix.")
511 getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable
512 -> Maybe String -- the "normal" object suffix
513 -> SrcSpan -- for error messages
514 -> [Module] -- If you need these
515 -> IO ([Linkable], [PackageId]) -- ... then link these first
516 -- Fails with an IO exception if it can't find enough files
518 getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
519 -- Find all the packages and linkables that a set of modules depends on
520 = do { pls <- readIORef v_PersistentLinkerState ;
522 -- 1. Find the dependent home-pkg-modules/packages from each iface
523 (mods_s, pkgs_s) = follow_deps mods emptyUniqSet emptyUniqSet;
525 -- 2. Exclude ones already linked
526 -- Main reason: avoid findModule calls in get_linkable
527 mods_needed = mods_s `minusList` linked_mods ;
528 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
530 linked_mods = map (moduleName.linkableModule)
531 (objs_loaded pls ++ bcos_loaded pls)
534 -- putStrLn (showSDoc (ppr mods_s)) ;
535 -- 3. For each dependent module, find its linkable
536 -- This will either be in the HPT or (in the case of one-shot
537 -- compilation) we may need to use maybe_getFileLinkable
538 lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
540 return (lnks_needed, pkgs_needed) }
542 dflags = hsc_dflags hsc_env
543 this_pkg = thisPackage dflags
545 -- The ModIface contains the transitive closure of the module dependencies
546 -- within the current package, *except* for boot modules: if we encounter
547 -- a boot module, we have to find its real interface and discover the
548 -- dependencies of that. Hence we need to traverse the dependency
549 -- tree recursively. See bug #936, testcase ghci/prog007.
550 follow_deps :: [Module] -- modules to follow
551 -> UniqSet ModuleName -- accum. module dependencies
552 -> UniqSet PackageId -- accum. package dependencies
553 -> ([ModuleName], [PackageId]) -- result
554 follow_deps [] acc_mods acc_pkgs
555 = (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
556 follow_deps (mod:mods) acc_mods acc_pkgs
558 = follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
560 = link_boot_mod_error mod
562 = follow_deps (map (mkModule this_pkg) boot_deps ++ mods) acc_mods' acc_pkgs'
564 pkg = modulePackageId mod
565 iface = get_iface mod
568 pkg_deps = dep_pkgs deps
569 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
570 where is_boot (m,True) = Left m
571 is_boot (m,False) = Right m
573 boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
574 acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
575 acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
578 link_boot_mod_error mod =
579 throwDyn (ProgramError (showSDoc (
580 text "module" <+> ppr mod <+>
581 text "cannot be linked; it is only available as a boot module")))
583 get_iface mod = case lookupIfaceByModule dflags hpt pit mod of
585 Nothing -> pprPanic "getLinkDeps" (no_iface mod)
586 no_iface mod = ptext SLIT("No iface for") <+> ppr mod
587 -- This one is a GHC bug
589 no_obj mod = dieWith span $
590 ptext SLIT("cannot find object file for module ") <>
594 while_linking_expr = ptext SLIT("while linking an interpreted expression")
596 -- This one is a build-system bug
598 get_linkable maybe_normal_osuf mod_name -- A home-package module
599 | Just mod_info <- lookupUFM hpt mod_name
600 = ASSERT(isJust (hm_linkable mod_info))
601 adjust_linkable (fromJust (hm_linkable mod_info))
603 = do -- It's not in the HPT because we are in one shot mode,
604 -- so use the Finder to get a ModLocation...
605 mb_stuff <- findHomeModule hsc_env mod_name
607 Found loc mod -> found loc mod
611 -- ...and then find the linkable for it
612 mb_lnk <- findObjectLinkableMaybe mod loc ;
614 Nothing -> no_obj mod ;
615 Just lnk -> adjust_linkable lnk
619 | Just osuf <- maybe_normal_osuf = do
620 new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
621 return lnk{ linkableUnlinked=new_uls }
625 adjust_ul osuf (DotO file) = do
626 let new_file = replaceFilenameSuffix file osuf
627 ok <- doesFileExist new_file
630 ptext SLIT("cannot find normal object file ")
631 <> quotes (text new_file) $$ while_linking_expr
632 else return (DotO new_file)
636 %************************************************************************
639 The linkables may consist of a mixture of
640 byte-code modules and object modules
642 %************************************************************************
645 linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
646 linkModules dflags linkables
647 = block $ do -- don't want to be interrupted by ^C in here
649 let (objs, bcos) = partition isObjectLinkable
650 (concatMap partitionLinkable linkables)
652 -- Load objects first; they can't depend on BCOs
653 ok_flag <- dynLinkObjs dflags objs
655 if failed ok_flag then
662 -- HACK to support f-x-dynamic in the interpreter; no other purpose
663 partitionLinkable :: Linkable -> [Linkable]
665 = let li_uls = linkableUnlinked li
666 li_uls_obj = filter isObject li_uls
667 li_uls_bco = filter isInterpretable li_uls
669 case (li_uls_obj, li_uls_bco) of
670 (objs@(_:_), bcos@(_:_))
671 -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
675 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
676 findModuleLinkable_maybe lis mod
677 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
680 many -> pprPanic "findModuleLinkable" (ppr mod)
682 linkableInSet :: Linkable -> [Linkable] -> Bool
683 linkableInSet l objs_loaded =
684 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
686 Just m -> linkableTime l == linkableTime m
690 %************************************************************************
692 \subsection{The object-code linker}
694 %************************************************************************
697 dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
698 -- Side-effects the PersistentLinkerState
700 dynLinkObjs dflags objs
701 = do pls <- readIORef v_PersistentLinkerState
703 -- Load the object files and link them
704 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
705 pls1 = pls { objs_loaded = objs_loaded' }
706 unlinkeds = concatMap linkableUnlinked new_objs
708 mapM loadObj (map nameOfObject unlinkeds)
710 -- Link the all together
713 -- If resolving failed, unload all our
714 -- object modules and carry on
715 if succeeded ok then do
716 writeIORef v_PersistentLinkerState pls1
719 pls2 <- unload_wkr dflags [] pls1
720 writeIORef v_PersistentLinkerState pls2
724 rmDupLinkables :: [Linkable] -- Already loaded
725 -> [Linkable] -- New linkables
726 -> ([Linkable], -- New loaded set (including new ones)
727 [Linkable]) -- New linkables (excluding dups)
728 rmDupLinkables already ls
731 go already extras [] = (already, extras)
732 go already extras (l:ls)
733 | linkableInSet l already = go already extras ls
734 | otherwise = go (l:already) (l:extras) ls
737 %************************************************************************
739 \subsection{The byte-code linker}
741 %************************************************************************
744 dynLinkBCOs :: [Linkable] -> IO ()
745 -- Side-effects the persistent linker state
747 = do pls <- readIORef v_PersistentLinkerState
749 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
750 pls1 = pls { bcos_loaded = bcos_loaded' }
751 unlinkeds :: [Unlinked]
752 unlinkeds = concatMap linkableUnlinked new_bcos
754 cbcs :: [CompiledByteCode]
755 cbcs = map byteCodeOfObject unlinkeds
758 ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
759 ies = [ie | ByteCode _ ie <- cbcs]
760 gce = closure_env pls
761 final_ie = foldr plusNameEnv (itbl_env pls) ies
763 (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
764 -- What happens to these linked_bcos?
766 let pls2 = pls1 { closure_env = final_gce,
767 itbl_env = final_ie }
769 writeIORef v_PersistentLinkerState pls2
772 -- Link a bunch of BCOs and return them + updated closure env.
773 linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
774 -- True <=> add only toplevel BCOs to closure env
778 -> IO (ClosureEnv, [HValue])
779 -- The returned HValues are associated 1-1 with
780 -- the incoming unlinked BCOs. Each gives the
781 -- value of the corresponding unlinked BCO
783 linkSomeBCOs toplevs_only ie ce_in ul_bcos
784 = do let nms = map unlinkedBCOName ul_bcos
786 ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
787 in mapM (linkBCO ie ce_out) ul_bcos )
788 let ce_all_additions = zip nms hvals
789 ce_top_additions = filter (isExternalName.fst) ce_all_additions
790 ce_additions = if toplevs_only then ce_top_additions
791 else ce_all_additions
792 ce_out = -- make sure we're not inserting duplicate names into the
793 -- closure environment, which leads to trouble.
794 ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
795 extendClosureEnv ce_in ce_additions
796 return (ce_out, hvals)
801 %************************************************************************
803 Unload some object modules
805 %************************************************************************
808 -- ---------------------------------------------------------------------------
809 -- Unloading old objects ready for a new compilation sweep.
811 -- The compilation manager provides us with a list of linkables that it
812 -- considers "stable", i.e. won't be recompiled this time around. For
813 -- each of the modules current linked in memory,
815 -- * if the linkable is stable (and it's the same one - the
816 -- user may have recompiled the module on the side), we keep it,
818 -- * otherwise, we unload it.
820 -- * we also implicitly unload all temporary bindings at this point.
822 unload :: DynFlags -> [Linkable] -> IO ()
823 -- The 'linkables' are the ones to *keep*
825 unload dflags linkables
826 = block $ do -- block, so we're safe from Ctrl-C in here
828 -- Initialise the linker (if it's not been done already)
831 pls <- readIORef v_PersistentLinkerState
832 new_pls <- unload_wkr dflags linkables pls
833 writeIORef v_PersistentLinkerState new_pls
835 debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
836 debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
839 unload_wkr :: DynFlags
840 -> [Linkable] -- stable linkables
841 -> PersistentLinkerState
842 -> IO PersistentLinkerState
843 -- Does the core unload business
844 -- (the wrapper blocks exceptions and deals with the PLS get and put)
846 unload_wkr dflags linkables pls
847 = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
849 objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
850 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
852 let bcos_retained = map linkableModule bcos_loaded'
853 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
854 closure_env' = filterNameMap bcos_retained (closure_env pls)
855 new_pls = pls { itbl_env = itbl_env',
856 closure_env = closure_env',
857 bcos_loaded = bcos_loaded',
858 objs_loaded = objs_loaded' }
862 maybeUnload :: [Linkable] -> Linkable -> IO Bool
863 maybeUnload keep_linkables lnk
864 | linkableInSet lnk linkables = return True
866 = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
867 -- The components of a BCO linkable may contain
868 -- dot-o files. Which is very confusing.
870 -- But the BCO parts can be unlinked just by
871 -- letting go of them (plus of course depopulating
872 -- the symbol table which is done in the main body)
877 %************************************************************************
881 %************************************************************************
886 = Object FilePath -- Full path name of a .o file, including trailing .o
887 -- For dynamic objects only, try to find the object
888 -- file in all the directories specified in
889 -- v_Library_paths before giving up.
891 | DLL String -- "Unadorned" name of a .DLL/.so
892 -- e.g. On unix "qt" denotes "libqt.so"
893 -- On WinDoze "burble" denotes "burble.DLL"
894 -- loadDLL is platform-specific and adds the lib/.so/.DLL
895 -- suffixes platform-dependently
897 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
898 -- (ends with .dll or .so).
900 | Framework String -- Only used for darwin, but does no harm
902 -- If this package is already part of the GHCi binary, we'll already
903 -- have the right DLLs for this package loaded, so don't try to
906 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
907 -- as far as the loader is concerned, but it does initialise the list
908 -- of DLL handles that rts/Linker.c maintains, and that in turn is
909 -- used by lookupSymbol. So we must call addDLL for each library
910 -- just to get the DLL handle into the list.
912 # if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS)
915 = [ "base", "haskell98", "template-haskell", "readline" ]
918 showLS (Object nm) = "(static) " ++ nm
919 showLS (DLL nm) = "(dynamic) " ++ nm
920 showLS (DLLPath nm) = "(dynamic) " ++ nm
921 showLS (Framework nm) = "(framework) " ++ nm
923 linkPackages :: DynFlags -> [PackageId] -> IO ()
924 -- Link exactly the specified packages, and their dependents
925 -- (unless of course they are already linked)
926 -- The dependents are linked automatically, and it doesn't matter
927 -- what order you specify the input packages.
929 -- NOTE: in fact, since each module tracks all the packages it depends on,
930 -- we don't really need to use the package-config dependencies.
931 -- However we do need the package-config stuff (to find aux libs etc),
932 -- and following them lets us load libraries in the right order, which
933 -- perhaps makes the error message a bit more localised if we get a link
934 -- failure. So the dependency walking code is still here.
936 linkPackages dflags new_pkgs
937 = do { pls <- readIORef v_PersistentLinkerState
938 ; let pkg_map = pkgIdMap (pkgState dflags)
940 ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
942 ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
945 link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
946 link pkg_map pkgs new_pkgs
947 = foldM (link_one pkg_map) pkgs new_pkgs
949 link_one pkg_map pkgs new_pkg
950 | new_pkg `elem` pkgs -- Already linked
953 | Just pkg_cfg <- lookupPackage pkg_map new_pkg
954 = do { -- Link dependents first
955 pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
956 -- Now link the package itself
957 ; linkPackage dflags pkg_cfg
958 ; return (new_pkg : pkgs') }
961 = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
964 linkPackage :: DynFlags -> PackageConfig -> IO ()
965 linkPackage dflags pkg
967 let dirs = Packages.libraryDirs pkg
969 let libs = Packages.hsLibraries pkg
970 -- Because of slight differences between the GHC dynamic linker and
971 -- the native system linker some packages have to link with a
972 -- different list of libraries when using GHCi. Examples include: libs
973 -- that are actually gnu ld scripts, and the possability that the .a
974 -- libs do not exactly match the .so/.dll equivalents. So if the
975 -- package file provides an "extra-ghci-libraries" field then we use
976 -- that instead of the "extra-libraries" field.
977 ++ (if null (Packages.extraGHCiLibraries pkg)
978 then Packages.extraLibraries pkg
979 else Packages.extraGHCiLibraries pkg)
980 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
981 classifieds <- mapM (locateOneObj dirs) libs
983 -- Complication: all the .so's must be loaded before any of the .o's.
984 let dlls = [ dll | DLL dll <- classifieds ]
985 objs = [ obj | Object obj <- classifieds ]
987 maybePutStr dflags ("Loading package " ++ showPackageId (package pkg) ++ " ... ")
989 -- See comments with partOfGHCi
990 when (pkgName (package pkg) `notElem` partOfGHCi) $ do
992 -- When a library A needs symbols from a library B, the order in
993 -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
994 -- way ld expects it for static linking. Dynamic linking is a
995 -- different story: When A has no dependency information for B,
996 -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
997 -- when B has not been loaded before. In a nutshell: Reverse the
998 -- order of DLLs for dynamic linking.
999 -- This fixes a problem with the HOpenGL package (see "Compiling
1000 -- HOpenGL under recent versions of GHC" on the HOpenGL list).
1001 mapM_ (load_dyn dirs) (reverse dlls)
1003 -- After loading all the DLLs, we can load the static objects.
1004 -- Ordering isn't important here, because we do one final link
1005 -- step to resolve everything.
1008 maybePutStr dflags "linking ... "
1010 if succeeded ok then maybePutStrLn dflags "done."
1011 else throwDyn (InstallationError ("unable to load package `" ++ showPackageId (package pkg) ++ "'"))
1013 load_dyn dirs dll = do r <- loadDynamic dirs dll
1015 Nothing -> return ()
1016 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1017 ++ dll ++ " (" ++ err ++ ")" ))
1018 #ifndef darwin_TARGET_OS
1019 loadFrameworks pkg = return ()
1021 loadFrameworks pkg = mapM_ load frameworks
1023 fw_dirs = Packages.frameworkDirs pkg
1024 frameworks = Packages.frameworks pkg
1026 load fw = do r <- loadFramework fw_dirs fw
1028 Nothing -> return ()
1029 Just err -> throwDyn (CmdLineError ("can't load framework: "
1030 ++ fw ++ " (" ++ err ++ ")" ))
1033 -- Try to find an object file for a given library in the given paths.
1034 -- If it isn't present, we assume it's a dynamic library.
1035 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1036 locateOneObj dirs lib
1037 = do { mb_obj_path <- findFile mk_obj_path dirs
1038 ; case mb_obj_path of
1039 Just obj_path -> return (Object obj_path)
1041 do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1042 ; case mb_lib_path of
1043 Just lib_path -> return (DLL (lib ++ "_dyn"))
1044 Nothing -> return (DLL lib) }} -- We assume
1046 mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o")
1047 mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "_dyn")
1050 -- ----------------------------------------------------------------------------
1051 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1053 -- return Nothing == success, else Just error message from dlopen
1054 loadDynamic paths rootname
1055 = do { mb_dll <- findFile mk_dll_path paths
1057 Just dll -> loadDLL dll
1058 Nothing -> loadDLL (mkSOName rootname) }
1059 -- Tried all our known library paths, so let
1060 -- dlopen() search its own builtin paths now.
1062 mk_dll_path dir = dir `joinFileName` mkSOName rootname
1064 #if defined(darwin_TARGET_OS)
1065 mkSOName root = ("lib" ++ root) `joinFileExt` "dylib"
1066 #elif defined(mingw32_TARGET_OS)
1067 -- Win32 DLLs have no .dll extension here, because addDLL tries
1068 -- both foo.dll and foo.drv
1069 mkSOName root = root
1071 mkSOName root = ("lib" ++ root) `joinFileExt` "so"
1074 -- Darwin / MacOS X only: load a framework
1075 -- a framework is a dynamic library packaged inside a directory of the same
1076 -- name. They are searched for in different paths than normal libraries.
1077 #ifdef darwin_TARGET_OS
1078 loadFramework extraPaths rootname
1079 = do { mb_fwk <- findFile mk_fwk (extraPaths ++ defaultFrameworkPaths)
1081 Just fwk_path -> loadDLL fwk_path
1082 Nothing -> return (Just "not found") }
1083 -- Tried all our known library paths, but dlopen()
1084 -- has no built-in paths for frameworks: give up
1086 mk_fwk dir = dir `joinFileName` (rootname ++ ".framework/" ++ rootname)
1087 -- sorry for the hardcoded paths, I hope they won't change anytime soon:
1088 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1092 %************************************************************************
1096 %************************************************************************
1099 findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
1100 -> [FilePath] -- Directories to look in
1101 -> IO (Maybe FilePath) -- The first file path to match
1102 findFile mk_file_path []
1104 findFile mk_file_path (dir:dirs)
1105 = do { let file_path = mk_file_path dir
1106 ; b <- doesFileExist file_path
1108 return (Just file_path)
1110 findFile mk_file_path dirs }
1114 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1115 | otherwise = return ()
1117 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1118 | otherwise = return ()