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
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 -- | Given a data constructor, find its internal name.
149 -- The info tables for data constructors have a field which records the source name
150 -- of the constructor as a CString. The format is:
152 -- Package:Module.Name
154 -- We use this string to lookup the interpreter's internal representation of the name
155 -- using the lookupOrig.
157 dataConInfoPtrToName :: Ptr () -> TcM Name
158 dataConInfoPtrToName x = do
159 theString <- ioToTcRn $ do
160 let ptr = castPtr x :: Ptr StgInfoTable
161 conDescAddress <- getConDescAddress ptr
162 str <- peekCString conDescAddress
164 let (pkg, mod, occ) = parse theString
165 occName = mkOccName OccName.dataName occ
166 modName = mkModule (stringToPackageId pkg) (mkModuleName mod)
167 lookupOrig modName occName
171 {- To find the string in the constructor's info table we need to consider
172 the layout of info tables relative to the entry code for a closure.
174 An info table can be next to the entry code for the closure, or it can
175 be separate. The former (faster) is used in registerised versions of ghc,
176 and the latter (portable) is for non-registerised versions.
178 The diagrams below show where the string is to be found relative to
179 the normal info table of the closure.
181 1) Code next to table:
184 | | <- pointer to the start of the string
186 | | <- the (start of the) info table structure
193 In this case the pointer to the start of the string can be found in
194 the memory location _one word before_ the first entry in the normal info
197 2) Code NOT next to table:
200 info table structure -> | *------------------> --------------
204 ptr to start of str -> | |
207 In this case the pointer to the start of the string can be found
208 in the memory location: info_table_ptr + info_table_size
211 getConDescAddress :: Ptr StgInfoTable -> IO (Ptr CChar)
212 getConDescAddress ptr = do
213 #ifdef GHCI_TABLES_NEXT_TO_CODE
214 offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
215 return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
217 peek $ intPtrToPtr $ (ptrToIntPtr ptr) + stdInfoTableSizeB
220 -- parsing names is a little bit fiddly because we have a string in the form:
221 -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
222 -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
223 -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
224 -- this is not the conventional way of writing Haskell names. We stick with
225 -- convention, even though it makes the parsing code more troublesome.
226 -- Warning: this code assumes that the string is well formed.
227 parse :: String -> (String, String, String)
229 = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
231 (pkg, rest1) = break (==':') input
233 = (concat $ intersperse "." $ reverse modWords, occWord)
235 (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
236 parseModOcc :: [String] -> String -> ([String], String)
238 = case break (== '.') str of
239 (top, []) -> (acc, top)
240 (top, '.':bot) -> parseModOcc (top : acc) bot
243 getHValue :: Name -> IO (Maybe HValue)
245 pls <- readIORef v_PersistentLinkerState
246 case lookupNameEnv (closure_env pls) name of
247 Just (_,x) -> return$ Just x
250 withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
251 withExtendedLinkEnv new_env action
252 = bracket set_new_env
255 where set_new_env = do pls <- readIORef v_PersistentLinkerState
256 let new_closure_env = extendClosureEnv (closure_env pls) new_env
257 new_pls = pls { closure_env = new_closure_env }
258 writeIORef v_PersistentLinkerState new_pls
259 return (closure_env pls)
260 reset_old_env env = modifyIORef v_PersistentLinkerState (\pls -> pls{ closure_env = env })
262 -- filterNameMap removes from the environment all entries except
263 -- those for a given set of modules;
264 -- Note that this removes all *local* (i.e. non-isExternal) names too
265 -- (these are the temporary bindings from the command line).
266 -- Used to filter both the ClosureEnv and ItblEnv
268 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
269 filterNameMap mods env
270 = filterNameEnv keep_elt env
272 keep_elt (n,_) = isExternalName n
273 && (nameModule n `elem` mods)
278 showLinkerState :: IO ()
279 -- Display the persistent linker state
281 = do pls <- readIORef v_PersistentLinkerState
282 printDump (vcat [text "----- Linker state -----",
283 text "Pkgs:" <+> ppr (pkgs_loaded pls),
284 text "Objs:" <+> ppr (objs_loaded pls),
285 text "BCOs:" <+> ppr (bcos_loaded pls)])
291 %************************************************************************
293 \subsection{Initialisation}
295 %************************************************************************
297 We initialise the dynamic linker by
299 a) calling the C initialisation procedure
301 b) Loading any packages specified on the command line,
303 c) Loading any packages specified on the command line,
304 now held in the -l options in v_Opt_l
306 d) Loading any .o/.dll files specified on the command line,
307 now held in v_Ld_inputs
309 e) Loading any MacOS frameworks
312 initDynLinker :: DynFlags -> IO ()
313 -- This function is idempotent; if called more than once, it does nothing
314 -- This is useful in Template Haskell, where we call it before trying to link
316 = do { done <- readIORef v_InitLinkerDone
317 ; if done then return ()
318 else do { writeIORef v_InitLinkerDone True
319 ; reallyInitDynLinker dflags }
322 reallyInitDynLinker dflags
323 = do { -- Initialise the linker state
324 ; writeIORef v_PersistentLinkerState (emptyPLS dflags)
326 -- (a) initialise the C dynamic linker
329 -- (b) Load packages from the command-line
330 ; linkPackages dflags (preloadPackages (pkgState dflags))
332 -- (c) Link libraries from the command-line
333 ; let optl = getOpts dflags opt_l
334 ; let minus_ls = [ lib | '-':'l':lib <- optl ]
336 -- (d) Link .o files from the command-line
337 ; let lib_paths = libraryPaths dflags
338 ; cmdline_ld_inputs <- readIORef v_Ld_inputs
340 ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
342 -- (e) Link any MacOS frameworks
343 #ifdef darwin_TARGET_OS
344 ; let framework_paths = frameworkPaths dflags
345 ; let frameworks = cmdlineFrameworks dflags
347 ; let frameworks = []
348 ; let framework_paths = []
350 -- Finally do (c),(d),(e)
351 ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
353 ++ map Framework frameworks
354 ; if null cmdline_lib_specs then return ()
357 { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
358 ; maybePutStr dflags "final link ... "
361 ; if succeeded ok then maybePutStrLn dflags "done"
362 else throwDyn (InstallationError "linking extra libraries/objects failed")
365 classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
367 | isObjectFilename f = return (Just (Object f))
368 | isDynLibFilename f = return (Just (DLLPath f))
370 hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
373 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
374 preloadLib dflags lib_paths framework_paths lib_spec
375 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
378 -> do b <- preload_static lib_paths static_ish
379 maybePutStrLn dflags (if b then "done"
383 -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
385 Nothing -> maybePutStrLn dflags "done"
386 Just mm -> preloadFailed mm lib_paths lib_spec
389 -> do maybe_errstr <- loadDLL dll_path
391 Nothing -> maybePutStrLn dflags "done"
392 Just mm -> preloadFailed mm lib_paths lib_spec
394 #ifdef darwin_TARGET_OS
396 -> do maybe_errstr <- loadFramework framework_paths framework
398 Nothing -> maybePutStrLn dflags "done"
399 Just mm -> preloadFailed mm framework_paths lib_spec
402 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
403 preloadFailed sys_errmsg paths spec
404 = do maybePutStr dflags
405 ("failed.\nDynamic linker error message was:\n "
406 ++ sys_errmsg ++ "\nWhilst trying to load: "
407 ++ showLS spec ++ "\nDirectories to search are:\n"
408 ++ unlines (map (" "++) paths) )
411 -- Not interested in the paths in the static case.
412 preload_static paths name
413 = do b <- doesFileExist name
414 if not b then return False
415 else loadObj name >> return True
418 CmdLineError "user specified .o/.so/.DLL could not be loaded."
422 %************************************************************************
424 Link a byte-code expression
426 %************************************************************************
429 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
431 -- Link a single expression, *including* first linking packages and
432 -- modules that this expression depends on.
434 -- Raises an IO exception if it can't find a compiled version of the
435 -- dependents to link.
437 -- Note: This function side-effects the linker state (Pepe)
439 linkExpr hsc_env span root_ul_bco
441 -- Initialise the linker (if it's not been done already)
442 let dflags = hsc_dflags hsc_env
443 ; initDynLinker dflags
445 -- The interpreter and dynamic linker can only handle object code built
446 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
447 -- So here we check the build tag: if we're building a non-standard way
448 -- then we need to find & link object files built the "normal" way.
449 ; maybe_normal_osuf <- checkNonStdWay dflags span
451 -- Find what packages and linkables are required
452 ; eps <- readIORef (hsc_EPS hsc_env)
453 ; (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
454 maybe_normal_osuf span needed_mods
456 -- Link the packages and modules required
457 ; linkPackages dflags pkgs
458 ; ok <- linkModules dflags lnks
460 throwDyn (ProgramError "")
463 -- Link the expression itself
464 pls <- readIORef v_PersistentLinkerState
465 ; let ie = itbl_env pls
468 -- Link the necessary packages and linkables
469 ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
473 hpt = hsc_HPT hsc_env
474 free_names = nameSetToList (bcoFreeNames root_ul_bco)
476 needed_mods :: [Module]
477 needed_mods = [ nameModule n | n <- free_names,
478 isExternalName n, -- Names from other modules
479 not (isWiredInName n) -- Exclude wired-in names
480 ] -- (see note below)
481 -- Exclude wired-in names because we may not have read
482 -- their interface files, so getLinkDeps will fail
483 -- All wired-in names are in the base package, which we link
484 -- by default, so we can safely ignore them here.
486 dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg)))
489 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
490 checkNonStdWay dflags srcspan = do
491 tag <- readIORef v_Build_tag
492 if null tag then return Nothing else do
493 let default_osuf = phaseInputExt StopLn
494 if objectSuf dflags == default_osuf
495 then failNonStd srcspan
496 else return (Just default_osuf)
498 failNonStd srcspan = dieWith srcspan $
499 ptext SLIT("Dynamic linking required, but this is a non-standard build (eg. prof).") $$
500 ptext SLIT("You need to build the program twice: once the normal way, and then") $$
501 ptext SLIT("in the desired way using -osuf to set the object file suffix.")
504 getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable
505 -> Maybe String -- the "normal" object suffix
506 -> SrcSpan -- for error messages
507 -> [Module] -- If you need these
508 -> IO ([Linkable], [PackageId]) -- ... then link these first
509 -- Fails with an IO exception if it can't find enough files
511 getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
512 -- Find all the packages and linkables that a set of modules depends on
513 = do { pls <- readIORef v_PersistentLinkerState ;
515 -- 1. Find the dependent home-pkg-modules/packages from each iface
516 (mods_s, pkgs_s) = follow_deps mods emptyUniqSet emptyUniqSet;
518 -- 2. Exclude ones already linked
519 -- Main reason: avoid findModule calls in get_linkable
520 mods_needed = mods_s `minusList` linked_mods ;
521 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
523 linked_mods = map (moduleName.linkableModule)
524 (objs_loaded pls ++ bcos_loaded pls)
527 -- putStrLn (showSDoc (ppr mods_s)) ;
528 -- 3. For each dependent module, find its linkable
529 -- This will either be in the HPT or (in the case of one-shot
530 -- compilation) we may need to use maybe_getFileLinkable
531 lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
533 return (lnks_needed, pkgs_needed) }
535 dflags = hsc_dflags hsc_env
536 this_pkg = thisPackage dflags
538 -- The ModIface contains the transitive closure of the module dependencies
539 -- within the current package, *except* for boot modules: if we encounter
540 -- a boot module, we have to find its real interface and discover the
541 -- dependencies of that. Hence we need to traverse the dependency
542 -- tree recursively. See bug #936, testcase ghci/prog007.
543 follow_deps :: [Module] -- modules to follow
544 -> UniqSet ModuleName -- accum. module dependencies
545 -> UniqSet PackageId -- accum. package dependencies
546 -> ([ModuleName], [PackageId]) -- result
547 follow_deps [] acc_mods acc_pkgs
548 = (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
549 follow_deps (mod:mods) acc_mods acc_pkgs
551 = follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
553 = link_boot_mod_error mod
555 = follow_deps (map (mkModule this_pkg) boot_deps ++ mods) acc_mods' acc_pkgs'
557 pkg = modulePackageId mod
558 iface = get_iface mod
561 pkg_deps = dep_pkgs deps
562 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
563 where is_boot (m,True) = Left m
564 is_boot (m,False) = Right m
566 boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
567 acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
568 acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
571 link_boot_mod_error mod =
572 throwDyn (ProgramError (showSDoc (
573 text "module" <+> ppr mod <+>
574 text "cannot be linked; it is only available as a boot module")))
576 get_iface mod = case lookupIfaceByModule dflags hpt pit mod of
578 Nothing -> pprPanic "getLinkDeps" (no_iface mod)
579 no_iface mod = ptext SLIT("No iface for") <+> ppr mod
580 -- This one is a GHC bug
582 no_obj mod = dieWith span $
583 ptext SLIT("cannot find object file for module ") <>
587 while_linking_expr = ptext SLIT("while linking an interpreted expression")
589 -- This one is a build-system bug
591 get_linkable maybe_normal_osuf mod_name -- A home-package module
592 | Just mod_info <- lookupUFM hpt mod_name
593 = ASSERT(isJust (hm_linkable mod_info))
594 adjust_linkable (fromJust (hm_linkable mod_info))
596 = do -- It's not in the HPT because we are in one shot mode,
597 -- so use the Finder to get a ModLocation...
598 mb_stuff <- findHomeModule hsc_env mod_name
600 Found loc mod -> found loc mod
604 -- ...and then find the linkable for it
605 mb_lnk <- findObjectLinkableMaybe mod loc ;
607 Nothing -> no_obj mod ;
608 Just lnk -> adjust_linkable lnk
612 | Just osuf <- maybe_normal_osuf = do
613 new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
614 return lnk{ linkableUnlinked=new_uls }
618 adjust_ul osuf (DotO file) = do
619 let new_file = replaceFilenameSuffix file osuf
620 ok <- doesFileExist new_file
623 ptext SLIT("cannot find normal object file ")
624 <> quotes (text new_file) $$ while_linking_expr
625 else return (DotO new_file)
629 %************************************************************************
632 The linkables may consist of a mixture of
633 byte-code modules and object modules
635 %************************************************************************
638 linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
639 linkModules dflags linkables
640 = block $ do -- don't want to be interrupted by ^C in here
642 let (objs, bcos) = partition isObjectLinkable
643 (concatMap partitionLinkable linkables)
645 -- Load objects first; they can't depend on BCOs
646 ok_flag <- dynLinkObjs dflags objs
648 if failed ok_flag then
655 -- HACK to support f-x-dynamic in the interpreter; no other purpose
656 partitionLinkable :: Linkable -> [Linkable]
658 = let li_uls = linkableUnlinked li
659 li_uls_obj = filter isObject li_uls
660 li_uls_bco = filter isInterpretable li_uls
662 case (li_uls_obj, li_uls_bco) of
663 (objs@(_:_), bcos@(_:_))
664 -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
668 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
669 findModuleLinkable_maybe lis mod
670 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
673 many -> pprPanic "findModuleLinkable" (ppr mod)
675 linkableInSet :: Linkable -> [Linkable] -> Bool
676 linkableInSet l objs_loaded =
677 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
679 Just m -> linkableTime l == linkableTime m
683 %************************************************************************
685 \subsection{The object-code linker}
687 %************************************************************************
690 dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
691 -- Side-effects the PersistentLinkerState
693 dynLinkObjs dflags objs
694 = do pls <- readIORef v_PersistentLinkerState
696 -- Load the object files and link them
697 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
698 pls1 = pls { objs_loaded = objs_loaded' }
699 unlinkeds = concatMap linkableUnlinked new_objs
701 mapM loadObj (map nameOfObject unlinkeds)
703 -- Link the all together
706 -- If resolving failed, unload all our
707 -- object modules and carry on
708 if succeeded ok then do
709 writeIORef v_PersistentLinkerState pls1
712 pls2 <- unload_wkr dflags [] pls1
713 writeIORef v_PersistentLinkerState pls2
717 rmDupLinkables :: [Linkable] -- Already loaded
718 -> [Linkable] -- New linkables
719 -> ([Linkable], -- New loaded set (including new ones)
720 [Linkable]) -- New linkables (excluding dups)
721 rmDupLinkables already ls
724 go already extras [] = (already, extras)
725 go already extras (l:ls)
726 | linkableInSet l already = go already extras ls
727 | otherwise = go (l:already) (l:extras) ls
730 %************************************************************************
732 \subsection{The byte-code linker}
734 %************************************************************************
737 dynLinkBCOs :: [Linkable] -> IO ()
738 -- Side-effects the persistent linker state
740 = do pls <- readIORef v_PersistentLinkerState
742 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
743 pls1 = pls { bcos_loaded = bcos_loaded' }
744 unlinkeds :: [Unlinked]
745 unlinkeds = concatMap linkableUnlinked new_bcos
747 cbcs :: [CompiledByteCode]
748 cbcs = map byteCodeOfObject unlinkeds
751 ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
752 ies = [ie | ByteCode _ ie <- cbcs]
753 gce = closure_env pls
754 final_ie = foldr plusNameEnv (itbl_env pls) ies
756 (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
757 -- What happens to these linked_bcos?
759 let pls2 = pls1 { closure_env = final_gce,
760 itbl_env = final_ie }
762 writeIORef v_PersistentLinkerState pls2
765 -- Link a bunch of BCOs and return them + updated closure env.
766 linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
767 -- True <=> add only toplevel BCOs to closure env
771 -> IO (ClosureEnv, [HValue])
772 -- The returned HValues are associated 1-1 with
773 -- the incoming unlinked BCOs. Each gives the
774 -- value of the corresponding unlinked BCO
776 linkSomeBCOs toplevs_only ie ce_in ul_bcos
777 = do let nms = map unlinkedBCOName ul_bcos
779 ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
780 in mapM (linkBCO ie ce_out) ul_bcos )
781 let ce_all_additions = zip nms hvals
782 ce_top_additions = filter (isExternalName.fst) ce_all_additions
783 ce_additions = if toplevs_only then ce_top_additions
784 else ce_all_additions
785 ce_out = -- make sure we're not inserting duplicate names into the
786 -- closure environment, which leads to trouble.
787 ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
788 extendClosureEnv ce_in ce_additions
789 return (ce_out, hvals)
794 %************************************************************************
796 Unload some object modules
798 %************************************************************************
801 -- ---------------------------------------------------------------------------
802 -- Unloading old objects ready for a new compilation sweep.
804 -- The compilation manager provides us with a list of linkables that it
805 -- considers "stable", i.e. won't be recompiled this time around. For
806 -- each of the modules current linked in memory,
808 -- * if the linkable is stable (and it's the same one - the
809 -- user may have recompiled the module on the side), we keep it,
811 -- * otherwise, we unload it.
813 -- * we also implicitly unload all temporary bindings at this point.
815 unload :: DynFlags -> [Linkable] -> IO ()
816 -- The 'linkables' are the ones to *keep*
818 unload dflags linkables
819 = block $ do -- block, so we're safe from Ctrl-C in here
821 -- Initialise the linker (if it's not been done already)
824 pls <- readIORef v_PersistentLinkerState
825 new_pls <- unload_wkr dflags linkables pls
826 writeIORef v_PersistentLinkerState new_pls
828 debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
829 debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
832 unload_wkr :: DynFlags
833 -> [Linkable] -- stable linkables
834 -> PersistentLinkerState
835 -> IO PersistentLinkerState
836 -- Does the core unload business
837 -- (the wrapper blocks exceptions and deals with the PLS get and put)
839 unload_wkr dflags linkables pls
840 = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
842 objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
843 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
845 let bcos_retained = map linkableModule bcos_loaded'
846 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
847 closure_env' = filterNameMap bcos_retained (closure_env pls)
848 new_pls = pls { itbl_env = itbl_env',
849 closure_env = closure_env',
850 bcos_loaded = bcos_loaded',
851 objs_loaded = objs_loaded' }
855 maybeUnload :: [Linkable] -> Linkable -> IO Bool
856 maybeUnload keep_linkables lnk
857 | linkableInSet lnk linkables = return True
859 = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
860 -- The components of a BCO linkable may contain
861 -- dot-o files. Which is very confusing.
863 -- But the BCO parts can be unlinked just by
864 -- letting go of them (plus of course depopulating
865 -- the symbol table which is done in the main body)
870 %************************************************************************
874 %************************************************************************
879 = Object FilePath -- Full path name of a .o file, including trailing .o
880 -- For dynamic objects only, try to find the object
881 -- file in all the directories specified in
882 -- v_Library_paths before giving up.
884 | DLL String -- "Unadorned" name of a .DLL/.so
885 -- e.g. On unix "qt" denotes "libqt.so"
886 -- On WinDoze "burble" denotes "burble.DLL"
887 -- loadDLL is platform-specific and adds the lib/.so/.DLL
888 -- suffixes platform-dependently
890 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
891 -- (ends with .dll or .so).
893 | Framework String -- Only used for darwin, but does no harm
895 -- If this package is already part of the GHCi binary, we'll already
896 -- have the right DLLs for this package loaded, so don't try to
899 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
900 -- as far as the loader is concerned, but it does initialise the list
901 -- of DLL handles that rts/Linker.c maintains, and that in turn is
902 -- used by lookupSymbol. So we must call addDLL for each library
903 -- just to get the DLL handle into the list.
905 # if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS)
908 = [ "base", "haskell98", "template-haskell", "readline" ]
911 showLS (Object nm) = "(static) " ++ nm
912 showLS (DLL nm) = "(dynamic) " ++ nm
913 showLS (DLLPath nm) = "(dynamic) " ++ nm
914 showLS (Framework nm) = "(framework) " ++ nm
916 linkPackages :: DynFlags -> [PackageId] -> IO ()
917 -- Link exactly the specified packages, and their dependents
918 -- (unless of course they are already linked)
919 -- The dependents are linked automatically, and it doesn't matter
920 -- what order you specify the input packages.
922 -- NOTE: in fact, since each module tracks all the packages it depends on,
923 -- we don't really need to use the package-config dependencies.
924 -- However we do need the package-config stuff (to find aux libs etc),
925 -- and following them lets us load libraries in the right order, which
926 -- perhaps makes the error message a bit more localised if we get a link
927 -- failure. So the dependency walking code is still here.
929 linkPackages dflags new_pkgs
930 = do { pls <- readIORef v_PersistentLinkerState
931 ; let pkg_map = pkgIdMap (pkgState dflags)
933 ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
935 ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
938 link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
939 link pkg_map pkgs new_pkgs
940 = foldM (link_one pkg_map) pkgs new_pkgs
942 link_one pkg_map pkgs new_pkg
943 | new_pkg `elem` pkgs -- Already linked
946 | Just pkg_cfg <- lookupPackage pkg_map new_pkg
947 = do { -- Link dependents first
948 pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
949 -- Now link the package itself
950 ; linkPackage dflags pkg_cfg
951 ; return (new_pkg : pkgs') }
954 = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
957 linkPackage :: DynFlags -> PackageConfig -> IO ()
958 linkPackage dflags pkg
960 let dirs = Packages.libraryDirs pkg
962 let libs = Packages.hsLibraries pkg
963 -- Because of slight differences between the GHC dynamic linker and
964 -- the native system linker some packages have to link with a
965 -- different list of libraries when using GHCi. Examples include: libs
966 -- that are actually gnu ld scripts, and the possability that the .a
967 -- libs do not exactly match the .so/.dll equivalents. So if the
968 -- package file provides an "extra-ghci-libraries" field then we use
969 -- that instead of the "extra-libraries" field.
970 ++ (if null (Packages.extraGHCiLibraries pkg)
971 then Packages.extraLibraries pkg
972 else Packages.extraGHCiLibraries pkg)
973 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
974 classifieds <- mapM (locateOneObj dirs) libs
976 -- Complication: all the .so's must be loaded before any of the .o's.
977 let dlls = [ dll | DLL dll <- classifieds ]
978 objs = [ obj | Object obj <- classifieds ]
980 maybePutStr dflags ("Loading package " ++ showPackageId (package pkg) ++ " ... ")
982 -- See comments with partOfGHCi
983 when (pkgName (package pkg) `notElem` partOfGHCi) $ do
985 -- When a library A needs symbols from a library B, the order in
986 -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
987 -- way ld expects it for static linking. Dynamic linking is a
988 -- different story: When A has no dependency information for B,
989 -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
990 -- when B has not been loaded before. In a nutshell: Reverse the
991 -- order of DLLs for dynamic linking.
992 -- This fixes a problem with the HOpenGL package (see "Compiling
993 -- HOpenGL under recent versions of GHC" on the HOpenGL list).
994 mapM_ (load_dyn dirs) (reverse dlls)
996 -- After loading all the DLLs, we can load the static objects.
997 -- Ordering isn't important here, because we do one final link
998 -- step to resolve everything.
1001 maybePutStr dflags "linking ... "
1003 if succeeded ok then maybePutStrLn dflags "done."
1004 else throwDyn (InstallationError ("unable to load package `" ++ showPackageId (package pkg) ++ "'"))
1006 load_dyn dirs dll = do r <- loadDynamic dirs dll
1008 Nothing -> return ()
1009 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1010 ++ dll ++ " (" ++ err ++ ")" ))
1011 #ifndef darwin_TARGET_OS
1012 loadFrameworks pkg = return ()
1014 loadFrameworks pkg = mapM_ load frameworks
1016 fw_dirs = Packages.frameworkDirs pkg
1017 frameworks = Packages.frameworks pkg
1019 load fw = do r <- loadFramework fw_dirs fw
1021 Nothing -> return ()
1022 Just err -> throwDyn (CmdLineError ("can't load framework: "
1023 ++ fw ++ " (" ++ err ++ ")" ))
1026 -- Try to find an object file for a given library in the given paths.
1027 -- If it isn't present, we assume it's a dynamic library.
1028 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1029 locateOneObj dirs lib
1030 = do { mb_obj_path <- findFile mk_obj_path dirs
1031 ; case mb_obj_path of
1032 Just obj_path -> return (Object obj_path)
1034 do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1035 ; case mb_lib_path of
1036 Just lib_path -> return (DLL (lib ++ "_dyn"))
1037 Nothing -> return (DLL lib) }} -- We assume
1039 mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o")
1040 mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "_dyn")
1043 -- ----------------------------------------------------------------------------
1044 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1046 -- return Nothing == success, else Just error message from dlopen
1047 loadDynamic paths rootname
1048 = do { mb_dll <- findFile mk_dll_path paths
1050 Just dll -> loadDLL dll
1051 Nothing -> loadDLL (mkSOName rootname) }
1052 -- Tried all our known library paths, so let
1053 -- dlopen() search its own builtin paths now.
1055 mk_dll_path dir = dir `joinFileName` mkSOName rootname
1057 #if defined(darwin_TARGET_OS)
1058 mkSOName root = ("lib" ++ root) `joinFileExt` "dylib"
1059 #elif defined(mingw32_TARGET_OS)
1060 -- Win32 DLLs have no .dll extension here, because addDLL tries
1061 -- both foo.dll and foo.drv
1062 mkSOName root = root
1064 mkSOName root = ("lib" ++ root) `joinFileExt` "so"
1067 -- Darwin / MacOS X only: load a framework
1068 -- a framework is a dynamic library packaged inside a directory of the same
1069 -- name. They are searched for in different paths than normal libraries.
1070 #ifdef darwin_TARGET_OS
1071 loadFramework extraPaths rootname
1072 = do { mb_fwk <- findFile mk_fwk (extraPaths ++ defaultFrameworkPaths)
1074 Just fwk_path -> loadDLL fwk_path
1075 Nothing -> return (Just "not found") }
1076 -- Tried all our known library paths, but dlopen()
1077 -- has no built-in paths for frameworks: give up
1079 mk_fwk dir = dir `joinFileName` (rootname ++ ".framework/" ++ rootname)
1080 -- sorry for the hardcoded paths, I hope they won't change anytime soon:
1081 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1085 %************************************************************************
1089 %************************************************************************
1092 findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
1093 -> [FilePath] -- Directories to look in
1094 -> IO (Maybe FilePath) -- The first file path to match
1095 findFile mk_file_path []
1097 findFile mk_file_path (dir:dirs)
1098 = do { let file_path = mk_file_path dir
1099 ; b <- doesFileExist file_path
1101 return (Just file_path)
1103 findFile mk_file_path dirs }
1107 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1108 | otherwise = return ()
1110 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1111 | otherwise = return ()