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 #ifdef GHCI_TABLES_NEXT_TO_CODE
217 offsetToString <- peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset
218 return $ ptr `plusPtr` offsetToString
220 -- subtract a word number of bytes
221 offset = negate (fromIntegral SIZEOF_VOID_P)
223 #ifndef GHCI_TABLES_NEXT_TO_CODE
224 peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset
226 -- add the standard info table size in bytes
227 infoTableSizeBytes = sTD_ITBL_SIZE * wORD_SIZE
228 offset = infoTableSizeBytes
231 -- parsing names is a little bit fiddly because we have a string in the form:
232 -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
233 -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
234 -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
235 -- this is not the conventional way of writing Haskell names. We stick with
236 -- convention, even though it makes the parsing code more troublesome.
237 -- Warning: this code assumes that the string is well formed.
238 parse :: String -> (String, String, String)
240 = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
242 (pkg, rest1) = break (==':') input
244 = (concat $ intersperse "." $ reverse modWords, occWord)
246 (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
247 parseModOcc :: [String] -> String -> ([String], String)
249 = case break (== '.') str of
250 (top, []) -> (acc, top)
251 (top, '.':bot) -> parseModOcc (top : acc) bot
254 getHValue :: Name -> IO (Maybe HValue)
256 pls <- readIORef v_PersistentLinkerState
257 case lookupNameEnv (closure_env pls) name of
258 Just (_,x) -> return$ Just x
261 withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
262 withExtendedLinkEnv new_env action
263 = bracket set_new_env
266 where set_new_env = do pls <- readIORef v_PersistentLinkerState
267 let new_closure_env = extendClosureEnv (closure_env pls) new_env
268 new_pls = pls { closure_env = new_closure_env }
269 writeIORef v_PersistentLinkerState new_pls
270 return (closure_env pls)
271 reset_old_env env = modifyIORef v_PersistentLinkerState (\pls -> pls{ closure_env = env })
273 -- filterNameMap removes from the environment all entries except
274 -- those for a given set of modules;
275 -- Note that this removes all *local* (i.e. non-isExternal) names too
276 -- (these are the temporary bindings from the command line).
277 -- Used to filter both the ClosureEnv and ItblEnv
279 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
280 filterNameMap mods env
281 = filterNameEnv keep_elt env
283 keep_elt (n,_) = isExternalName n
284 && (nameModule n `elem` mods)
289 showLinkerState :: IO ()
290 -- Display the persistent linker state
292 = do pls <- readIORef v_PersistentLinkerState
293 printDump (vcat [text "----- Linker state -----",
294 text "Pkgs:" <+> ppr (pkgs_loaded pls),
295 text "Objs:" <+> ppr (objs_loaded pls),
296 text "BCOs:" <+> ppr (bcos_loaded pls)])
302 %************************************************************************
304 \subsection{Initialisation}
306 %************************************************************************
308 We initialise the dynamic linker by
310 a) calling the C initialisation procedure
312 b) Loading any packages specified on the command line,
314 c) Loading any packages specified on the command line,
315 now held in the -l options in v_Opt_l
317 d) Loading any .o/.dll files specified on the command line,
318 now held in v_Ld_inputs
320 e) Loading any MacOS frameworks
323 initDynLinker :: DynFlags -> IO ()
324 -- This function is idempotent; if called more than once, it does nothing
325 -- This is useful in Template Haskell, where we call it before trying to link
327 = do { done <- readIORef v_InitLinkerDone
328 ; if done then return ()
329 else do { writeIORef v_InitLinkerDone True
330 ; reallyInitDynLinker dflags }
333 reallyInitDynLinker dflags
334 = do { -- Initialise the linker state
335 ; writeIORef v_PersistentLinkerState (emptyPLS dflags)
337 -- (a) initialise the C dynamic linker
340 -- (b) Load packages from the command-line
341 ; linkPackages dflags (preloadPackages (pkgState dflags))
343 -- (c) Link libraries from the command-line
344 ; let optl = getOpts dflags opt_l
345 ; let minus_ls = [ lib | '-':'l':lib <- optl ]
347 -- (d) Link .o files from the command-line
348 ; let lib_paths = libraryPaths dflags
349 ; cmdline_ld_inputs <- readIORef v_Ld_inputs
351 ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
353 -- (e) Link any MacOS frameworks
354 #ifdef darwin_TARGET_OS
355 ; let framework_paths = frameworkPaths dflags
356 ; let frameworks = cmdlineFrameworks dflags
358 ; let frameworks = []
359 ; let framework_paths = []
361 -- Finally do (c),(d),(e)
362 ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
364 ++ map Framework frameworks
365 ; if null cmdline_lib_specs then return ()
368 { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
369 ; maybePutStr dflags "final link ... "
372 ; if succeeded ok then maybePutStrLn dflags "done"
373 else throwDyn (InstallationError "linking extra libraries/objects failed")
376 classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
378 | isObjectFilename f = return (Just (Object f))
379 | isDynLibFilename f = return (Just (DLLPath f))
381 hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
384 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
385 preloadLib dflags lib_paths framework_paths lib_spec
386 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
389 -> do b <- preload_static lib_paths static_ish
390 maybePutStrLn dflags (if b then "done"
394 -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
396 Nothing -> maybePutStrLn dflags "done"
397 Just mm -> preloadFailed mm lib_paths lib_spec
400 -> do maybe_errstr <- loadDLL dll_path
402 Nothing -> maybePutStrLn dflags "done"
403 Just mm -> preloadFailed mm lib_paths lib_spec
405 #ifdef darwin_TARGET_OS
407 -> do maybe_errstr <- loadFramework framework_paths framework
409 Nothing -> maybePutStrLn dflags "done"
410 Just mm -> preloadFailed mm framework_paths lib_spec
413 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
414 preloadFailed sys_errmsg paths spec
415 = do maybePutStr dflags
416 ("failed.\nDynamic linker error message was:\n "
417 ++ sys_errmsg ++ "\nWhilst trying to load: "
418 ++ showLS spec ++ "\nDirectories to search are:\n"
419 ++ unlines (map (" "++) paths) )
422 -- Not interested in the paths in the static case.
423 preload_static paths name
424 = do b <- doesFileExist name
425 if not b then return False
426 else loadObj name >> return True
429 CmdLineError "user specified .o/.so/.DLL could not be loaded."
433 %************************************************************************
435 Link a byte-code expression
437 %************************************************************************
440 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
442 -- Link a single expression, *including* first linking packages and
443 -- modules that this expression depends on.
445 -- Raises an IO exception if it can't find a compiled version of the
446 -- dependents to link.
448 -- Note: This function side-effects the linker state (Pepe)
450 linkExpr hsc_env span root_ul_bco
452 -- Initialise the linker (if it's not been done already)
453 let dflags = hsc_dflags hsc_env
454 ; initDynLinker dflags
456 -- The interpreter and dynamic linker can only handle object code built
457 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
458 -- So here we check the build tag: if we're building a non-standard way
459 -- then we need to find & link object files built the "normal" way.
460 ; maybe_normal_osuf <- checkNonStdWay dflags span
462 -- Find what packages and linkables are required
463 ; eps <- readIORef (hsc_EPS hsc_env)
464 ; (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
465 maybe_normal_osuf span needed_mods
467 -- Link the packages and modules required
468 ; linkPackages dflags pkgs
469 ; ok <- linkModules dflags lnks
471 throwDyn (ProgramError "")
474 -- Link the expression itself
475 pls <- readIORef v_PersistentLinkerState
476 ; let ie = itbl_env pls
479 -- Link the necessary packages and linkables
480 ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
484 hpt = hsc_HPT hsc_env
485 free_names = nameSetToList (bcoFreeNames root_ul_bco)
487 needed_mods :: [Module]
488 needed_mods = [ nameModule n | n <- free_names,
489 isExternalName n, -- Names from other modules
490 not (isWiredInName n) -- Exclude wired-in names
491 ] -- (see note below)
492 -- Exclude wired-in names because we may not have read
493 -- their interface files, so getLinkDeps will fail
494 -- All wired-in names are in the base package, which we link
495 -- by default, so we can safely ignore them here.
497 dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg)))
500 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
501 checkNonStdWay dflags srcspan = do
502 tag <- readIORef v_Build_tag
503 if null tag then return Nothing else do
504 let default_osuf = phaseInputExt StopLn
505 if objectSuf dflags == default_osuf
506 then failNonStd srcspan
507 else return (Just default_osuf)
509 failNonStd srcspan = dieWith srcspan $
510 ptext SLIT("Dynamic linking required, but this is a non-standard build (eg. prof).") $$
511 ptext SLIT("You need to build the program twice: once the normal way, and then") $$
512 ptext SLIT("in the desired way using -osuf to set the object file suffix.")
515 getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable
516 -> Maybe String -- the "normal" object suffix
517 -> SrcSpan -- for error messages
518 -> [Module] -- If you need these
519 -> IO ([Linkable], [PackageId]) -- ... then link these first
520 -- Fails with an IO exception if it can't find enough files
522 getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
523 -- Find all the packages and linkables that a set of modules depends on
524 = do { pls <- readIORef v_PersistentLinkerState ;
526 -- 1. Find the dependent home-pkg-modules/packages from each iface
527 (mods_s, pkgs_s) = follow_deps mods emptyUniqSet emptyUniqSet;
529 -- 2. Exclude ones already linked
530 -- Main reason: avoid findModule calls in get_linkable
531 mods_needed = mods_s `minusList` linked_mods ;
532 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
534 linked_mods = map (moduleName.linkableModule)
535 (objs_loaded pls ++ bcos_loaded pls)
538 -- putStrLn (showSDoc (ppr mods_s)) ;
539 -- 3. For each dependent module, find its linkable
540 -- This will either be in the HPT or (in the case of one-shot
541 -- compilation) we may need to use maybe_getFileLinkable
542 lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
544 return (lnks_needed, pkgs_needed) }
546 dflags = hsc_dflags hsc_env
547 this_pkg = thisPackage dflags
549 -- The ModIface contains the transitive closure of the module dependencies
550 -- within the current package, *except* for boot modules: if we encounter
551 -- a boot module, we have to find its real interface and discover the
552 -- dependencies of that. Hence we need to traverse the dependency
553 -- tree recursively. See bug #936, testcase ghci/prog007.
554 follow_deps :: [Module] -- modules to follow
555 -> UniqSet ModuleName -- accum. module dependencies
556 -> UniqSet PackageId -- accum. package dependencies
557 -> ([ModuleName], [PackageId]) -- result
558 follow_deps [] acc_mods acc_pkgs
559 = (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
560 follow_deps (mod:mods) acc_mods acc_pkgs
562 = follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
564 = link_boot_mod_error mod
566 = follow_deps (map (mkModule this_pkg) boot_deps ++ mods) acc_mods' acc_pkgs'
568 pkg = modulePackageId mod
569 iface = get_iface mod
572 pkg_deps = dep_pkgs deps
573 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
574 where is_boot (m,True) = Left m
575 is_boot (m,False) = Right m
577 boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
578 acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
579 acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
582 link_boot_mod_error mod =
583 throwDyn (ProgramError (showSDoc (
584 text "module" <+> ppr mod <+>
585 text "cannot be linked; it is only available as a boot module")))
587 get_iface mod = case lookupIfaceByModule dflags hpt pit mod of
589 Nothing -> pprPanic "getLinkDeps" (no_iface mod)
590 no_iface mod = ptext SLIT("No iface for") <+> ppr mod
591 -- This one is a GHC bug
593 no_obj mod = dieWith span $
594 ptext SLIT("cannot find object file for module ") <>
598 while_linking_expr = ptext SLIT("while linking an interpreted expression")
600 -- This one is a build-system bug
602 get_linkable maybe_normal_osuf mod_name -- A home-package module
603 | Just mod_info <- lookupUFM hpt mod_name
604 = ASSERT(isJust (hm_linkable mod_info))
605 adjust_linkable (fromJust (hm_linkable mod_info))
607 = do -- It's not in the HPT because we are in one shot mode,
608 -- so use the Finder to get a ModLocation...
609 mb_stuff <- findHomeModule hsc_env mod_name
611 Found loc mod -> found loc mod
615 -- ...and then find the linkable for it
616 mb_lnk <- findObjectLinkableMaybe mod loc ;
618 Nothing -> no_obj mod ;
619 Just lnk -> adjust_linkable lnk
623 | Just osuf <- maybe_normal_osuf = do
624 new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
625 return lnk{ linkableUnlinked=new_uls }
629 adjust_ul osuf (DotO file) = do
630 let new_file = replaceFilenameSuffix file osuf
631 ok <- doesFileExist new_file
634 ptext SLIT("cannot find normal object file ")
635 <> quotes (text new_file) $$ while_linking_expr
636 else return (DotO new_file)
640 %************************************************************************
643 The linkables may consist of a mixture of
644 byte-code modules and object modules
646 %************************************************************************
649 linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
650 linkModules dflags linkables
651 = block $ do -- don't want to be interrupted by ^C in here
653 let (objs, bcos) = partition isObjectLinkable
654 (concatMap partitionLinkable linkables)
656 -- Load objects first; they can't depend on BCOs
657 ok_flag <- dynLinkObjs dflags objs
659 if failed ok_flag then
666 -- HACK to support f-x-dynamic in the interpreter; no other purpose
667 partitionLinkable :: Linkable -> [Linkable]
669 = let li_uls = linkableUnlinked li
670 li_uls_obj = filter isObject li_uls
671 li_uls_bco = filter isInterpretable li_uls
673 case (li_uls_obj, li_uls_bco) of
674 (objs@(_:_), bcos@(_:_))
675 -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
679 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
680 findModuleLinkable_maybe lis mod
681 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
684 many -> pprPanic "findModuleLinkable" (ppr mod)
686 linkableInSet :: Linkable -> [Linkable] -> Bool
687 linkableInSet l objs_loaded =
688 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
690 Just m -> linkableTime l == linkableTime m
694 %************************************************************************
696 \subsection{The object-code linker}
698 %************************************************************************
701 dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
702 -- Side-effects the PersistentLinkerState
704 dynLinkObjs dflags objs
705 = do pls <- readIORef v_PersistentLinkerState
707 -- Load the object files and link them
708 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
709 pls1 = pls { objs_loaded = objs_loaded' }
710 unlinkeds = concatMap linkableUnlinked new_objs
712 mapM loadObj (map nameOfObject unlinkeds)
714 -- Link the all together
717 -- If resolving failed, unload all our
718 -- object modules and carry on
719 if succeeded ok then do
720 writeIORef v_PersistentLinkerState pls1
723 pls2 <- unload_wkr dflags [] pls1
724 writeIORef v_PersistentLinkerState pls2
728 rmDupLinkables :: [Linkable] -- Already loaded
729 -> [Linkable] -- New linkables
730 -> ([Linkable], -- New loaded set (including new ones)
731 [Linkable]) -- New linkables (excluding dups)
732 rmDupLinkables already ls
735 go already extras [] = (already, extras)
736 go already extras (l:ls)
737 | linkableInSet l already = go already extras ls
738 | otherwise = go (l:already) (l:extras) ls
741 %************************************************************************
743 \subsection{The byte-code linker}
745 %************************************************************************
748 dynLinkBCOs :: [Linkable] -> IO ()
749 -- Side-effects the persistent linker state
751 = do pls <- readIORef v_PersistentLinkerState
753 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
754 pls1 = pls { bcos_loaded = bcos_loaded' }
755 unlinkeds :: [Unlinked]
756 unlinkeds = concatMap linkableUnlinked new_bcos
758 cbcs :: [CompiledByteCode]
759 cbcs = map byteCodeOfObject unlinkeds
762 ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
763 ies = [ie | ByteCode _ ie <- cbcs]
764 gce = closure_env pls
765 final_ie = foldr plusNameEnv (itbl_env pls) ies
767 (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
768 -- What happens to these linked_bcos?
770 let pls2 = pls1 { closure_env = final_gce,
771 itbl_env = final_ie }
773 writeIORef v_PersistentLinkerState pls2
776 -- Link a bunch of BCOs and return them + updated closure env.
777 linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
778 -- True <=> add only toplevel BCOs to closure env
782 -> IO (ClosureEnv, [HValue])
783 -- The returned HValues are associated 1-1 with
784 -- the incoming unlinked BCOs. Each gives the
785 -- value of the corresponding unlinked BCO
787 linkSomeBCOs toplevs_only ie ce_in ul_bcos
788 = do let nms = map unlinkedBCOName ul_bcos
790 ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
791 in mapM (linkBCO ie ce_out) ul_bcos )
792 let ce_all_additions = zip nms hvals
793 ce_top_additions = filter (isExternalName.fst) ce_all_additions
794 ce_additions = if toplevs_only then ce_top_additions
795 else ce_all_additions
796 ce_out = -- make sure we're not inserting duplicate names into the
797 -- closure environment, which leads to trouble.
798 ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
799 extendClosureEnv ce_in ce_additions
800 return (ce_out, hvals)
805 %************************************************************************
807 Unload some object modules
809 %************************************************************************
812 -- ---------------------------------------------------------------------------
813 -- Unloading old objects ready for a new compilation sweep.
815 -- The compilation manager provides us with a list of linkables that it
816 -- considers "stable", i.e. won't be recompiled this time around. For
817 -- each of the modules current linked in memory,
819 -- * if the linkable is stable (and it's the same one - the
820 -- user may have recompiled the module on the side), we keep it,
822 -- * otherwise, we unload it.
824 -- * we also implicitly unload all temporary bindings at this point.
826 unload :: DynFlags -> [Linkable] -> IO ()
827 -- The 'linkables' are the ones to *keep*
829 unload dflags linkables
830 = block $ do -- block, so we're safe from Ctrl-C in here
832 -- Initialise the linker (if it's not been done already)
835 pls <- readIORef v_PersistentLinkerState
836 new_pls <- unload_wkr dflags linkables pls
837 writeIORef v_PersistentLinkerState new_pls
839 debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
840 debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
843 unload_wkr :: DynFlags
844 -> [Linkable] -- stable linkables
845 -> PersistentLinkerState
846 -> IO PersistentLinkerState
847 -- Does the core unload business
848 -- (the wrapper blocks exceptions and deals with the PLS get and put)
850 unload_wkr dflags linkables pls
851 = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
853 objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
854 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
856 let bcos_retained = map linkableModule bcos_loaded'
857 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
858 closure_env' = filterNameMap bcos_retained (closure_env pls)
859 new_pls = pls { itbl_env = itbl_env',
860 closure_env = closure_env',
861 bcos_loaded = bcos_loaded',
862 objs_loaded = objs_loaded' }
866 maybeUnload :: [Linkable] -> Linkable -> IO Bool
867 maybeUnload keep_linkables lnk
868 | linkableInSet lnk linkables = return True
870 = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
871 -- The components of a BCO linkable may contain
872 -- dot-o files. Which is very confusing.
874 -- But the BCO parts can be unlinked just by
875 -- letting go of them (plus of course depopulating
876 -- the symbol table which is done in the main body)
881 %************************************************************************
885 %************************************************************************
890 = Object FilePath -- Full path name of a .o file, including trailing .o
891 -- For dynamic objects only, try to find the object
892 -- file in all the directories specified in
893 -- v_Library_paths before giving up.
895 | DLL String -- "Unadorned" name of a .DLL/.so
896 -- e.g. On unix "qt" denotes "libqt.so"
897 -- On WinDoze "burble" denotes "burble.DLL"
898 -- loadDLL is platform-specific and adds the lib/.so/.DLL
899 -- suffixes platform-dependently
901 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
902 -- (ends with .dll or .so).
904 | Framework String -- Only used for darwin, but does no harm
906 -- If this package is already part of the GHCi binary, we'll already
907 -- have the right DLLs for this package loaded, so don't try to
910 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
911 -- as far as the loader is concerned, but it does initialise the list
912 -- of DLL handles that rts/Linker.c maintains, and that in turn is
913 -- used by lookupSymbol. So we must call addDLL for each library
914 -- just to get the DLL handle into the list.
916 # if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS)
919 = [ "base", "haskell98", "template-haskell", "readline" ]
922 showLS (Object nm) = "(static) " ++ nm
923 showLS (DLL nm) = "(dynamic) " ++ nm
924 showLS (DLLPath nm) = "(dynamic) " ++ nm
925 showLS (Framework nm) = "(framework) " ++ nm
927 linkPackages :: DynFlags -> [PackageId] -> IO ()
928 -- Link exactly the specified packages, and their dependents
929 -- (unless of course they are already linked)
930 -- The dependents are linked automatically, and it doesn't matter
931 -- what order you specify the input packages.
933 -- NOTE: in fact, since each module tracks all the packages it depends on,
934 -- we don't really need to use the package-config dependencies.
935 -- However we do need the package-config stuff (to find aux libs etc),
936 -- and following them lets us load libraries in the right order, which
937 -- perhaps makes the error message a bit more localised if we get a link
938 -- failure. So the dependency walking code is still here.
940 linkPackages dflags new_pkgs
941 = do { pls <- readIORef v_PersistentLinkerState
942 ; let pkg_map = pkgIdMap (pkgState dflags)
944 ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
946 ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
949 link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
950 link pkg_map pkgs new_pkgs
951 = foldM (link_one pkg_map) pkgs new_pkgs
953 link_one pkg_map pkgs new_pkg
954 | new_pkg `elem` pkgs -- Already linked
957 | Just pkg_cfg <- lookupPackage pkg_map new_pkg
958 = do { -- Link dependents first
959 pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
960 -- Now link the package itself
961 ; linkPackage dflags pkg_cfg
962 ; return (new_pkg : pkgs') }
965 = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
968 linkPackage :: DynFlags -> PackageConfig -> IO ()
969 linkPackage dflags pkg
971 let dirs = Packages.libraryDirs pkg
973 let libs = Packages.hsLibraries pkg
974 -- Because of slight differences between the GHC dynamic linker and
975 -- the native system linker some packages have to link with a
976 -- different list of libraries when using GHCi. Examples include: libs
977 -- that are actually gnu ld scripts, and the possability that the .a
978 -- libs do not exactly match the .so/.dll equivalents. So if the
979 -- package file provides an "extra-ghci-libraries" field then we use
980 -- that instead of the "extra-libraries" field.
981 ++ (if null (Packages.extraGHCiLibraries pkg)
982 then Packages.extraLibraries pkg
983 else Packages.extraGHCiLibraries pkg)
984 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
985 classifieds <- mapM (locateOneObj dirs) libs
987 -- Complication: all the .so's must be loaded before any of the .o's.
988 let dlls = [ dll | DLL dll <- classifieds ]
989 objs = [ obj | Object obj <- classifieds ]
991 maybePutStr dflags ("Loading package " ++ showPackageId (package pkg) ++ " ... ")
993 -- See comments with partOfGHCi
994 when (pkgName (package pkg) `notElem` partOfGHCi) $ do
996 -- When a library A needs symbols from a library B, the order in
997 -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
998 -- way ld expects it for static linking. Dynamic linking is a
999 -- different story: When A has no dependency information for B,
1000 -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
1001 -- when B has not been loaded before. In a nutshell: Reverse the
1002 -- order of DLLs for dynamic linking.
1003 -- This fixes a problem with the HOpenGL package (see "Compiling
1004 -- HOpenGL under recent versions of GHC" on the HOpenGL list).
1005 mapM_ (load_dyn dirs) (reverse dlls)
1007 -- After loading all the DLLs, we can load the static objects.
1008 -- Ordering isn't important here, because we do one final link
1009 -- step to resolve everything.
1012 maybePutStr dflags "linking ... "
1014 if succeeded ok then maybePutStrLn dflags "done."
1015 else throwDyn (InstallationError ("unable to load package `" ++ showPackageId (package pkg) ++ "'"))
1017 load_dyn dirs dll = do r <- loadDynamic dirs dll
1019 Nothing -> return ()
1020 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1021 ++ dll ++ " (" ++ err ++ ")" ))
1022 #ifndef darwin_TARGET_OS
1023 loadFrameworks pkg = return ()
1025 loadFrameworks pkg = mapM_ load frameworks
1027 fw_dirs = Packages.frameworkDirs pkg
1028 frameworks = Packages.frameworks pkg
1030 load fw = do r <- loadFramework fw_dirs fw
1032 Nothing -> return ()
1033 Just err -> throwDyn (CmdLineError ("can't load framework: "
1034 ++ fw ++ " (" ++ err ++ ")" ))
1037 -- Try to find an object file for a given library in the given paths.
1038 -- If it isn't present, we assume it's a dynamic library.
1039 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1040 locateOneObj dirs lib
1041 = do { mb_obj_path <- findFile mk_obj_path dirs
1042 ; case mb_obj_path of
1043 Just obj_path -> return (Object obj_path)
1045 do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1046 ; case mb_lib_path of
1047 Just lib_path -> return (DLL (lib ++ "_dyn"))
1048 Nothing -> return (DLL lib) }} -- We assume
1050 mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o")
1051 mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "_dyn")
1054 -- ----------------------------------------------------------------------------
1055 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1057 -- return Nothing == success, else Just error message from dlopen
1058 loadDynamic paths rootname
1059 = do { mb_dll <- findFile mk_dll_path paths
1061 Just dll -> loadDLL dll
1062 Nothing -> loadDLL (mkSOName rootname) }
1063 -- Tried all our known library paths, so let
1064 -- dlopen() search its own builtin paths now.
1066 mk_dll_path dir = dir `joinFileName` mkSOName rootname
1068 #if defined(darwin_TARGET_OS)
1069 mkSOName root = ("lib" ++ root) `joinFileExt` "dylib"
1070 #elif defined(mingw32_TARGET_OS)
1071 -- Win32 DLLs have no .dll extension here, because addDLL tries
1072 -- both foo.dll and foo.drv
1073 mkSOName root = root
1075 mkSOName root = ("lib" ++ root) `joinFileExt` "so"
1078 -- Darwin / MacOS X only: load a framework
1079 -- a framework is a dynamic library packaged inside a directory of the same
1080 -- name. They are searched for in different paths than normal libraries.
1081 #ifdef darwin_TARGET_OS
1082 loadFramework extraPaths rootname
1083 = do { mb_fwk <- findFile mk_fwk (extraPaths ++ defaultFrameworkPaths)
1085 Just fwk_path -> loadDLL fwk_path
1086 Nothing -> return (Just "not found") }
1087 -- Tried all our known library paths, but dlopen()
1088 -- has no built-in paths for frameworks: give up
1090 mk_fwk dir = dir `joinFileName` (rootname ++ ".framework/" ++ rootname)
1091 -- sorry for the hardcoded paths, I hope they won't change anytime soon:
1092 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1096 %************************************************************************
1100 %************************************************************************
1103 findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
1104 -> [FilePath] -- Directories to look in
1105 -> IO (Maybe FilePath) -- The first file path to match
1106 findFile mk_file_path []
1108 findFile mk_file_path (dir:dirs)
1109 = do { let file_path = mk_file_path dir
1110 ; b <- doesFileExist file_path
1112 return (Just file_path)
1114 findFile mk_file_path dirs }
1118 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1119 | otherwise = return ()
1121 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1122 | otherwise = return ()