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
74 %************************************************************************
78 %************************************************************************
80 The persistent linker state *must* match the actual state of the
81 C dynamic linker at all times, so we keep it in a private global variable.
84 The PersistentLinkerState maps Names to actual closures (for
85 interpreted code only), for use during linking.
88 GLOBAL_VAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState)
89 GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
91 data PersistentLinkerState
92 = PersistentLinkerState {
94 -- Current global mapping from Names to their true values
95 closure_env :: ClosureEnv,
97 -- The current global mapping from RdrNames of DataCons to
98 -- info table addresses.
99 -- When a new Unlinked is linked into the running image, or an existing
100 -- module in the image is replaced, the itbl_env must be updated
104 -- The currently loaded interpreted modules (home package)
105 bcos_loaded :: [Linkable],
107 -- And the currently-loaded compiled modules (home package)
108 objs_loaded :: [Linkable],
110 -- The currently-loaded packages; always object code
111 -- Held, as usual, in dependency order; though I am not sure if
112 -- that is really important
113 pkgs_loaded :: [PackageId]
116 emptyPLS :: DynFlags -> PersistentLinkerState
117 emptyPLS dflags = PersistentLinkerState {
118 closure_env = emptyNameEnv,
119 itbl_env = emptyNameEnv,
120 pkgs_loaded = init_pkgs,
124 -- Packages that don't need loading, because the compiler
125 -- shares them with the interpreted program.
127 -- The linker's symbol table is populated with RTS symbols using an
128 -- explicit list. See rts/Linker.c for details.
129 where init_pkgs = [rtsPackageId]
133 extendLoadedPkgs :: [PackageId] -> IO ()
134 extendLoadedPkgs pkgs
135 = modifyIORef v_PersistentLinkerState (\s -> s{pkgs_loaded = pkgs ++ pkgs_loaded s})
137 extendLinkEnv :: [(Name,HValue)] -> IO ()
138 -- Automatically discards shadowed bindings
139 extendLinkEnv new_bindings
140 = do pls <- readIORef v_PersistentLinkerState
141 let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
142 new_pls = pls { closure_env = new_closure_env }
143 writeIORef v_PersistentLinkerState new_pls
145 -- | Given a data constructor, find its internal name.
146 -- The info tables for data constructors have a field which records the source name
147 -- of the constructor as a CString. The format is:
149 -- Package:Module.Name
151 -- We use this string to lookup the interpreter's internal representation of the name
152 -- using the lookupOrig.
154 recoverDataCon :: a -> TcM Name
155 recoverDataCon x = do
156 theString <- ioToTcRn $ do
157 let ptr = getInfoTablePtr x
158 conDescAddress <- getConDescAddress ptr
159 peekCString conDescAddress
160 let (pkg, mod, occ) = parse theString
161 occName = mkOccName OccName.dataName occ
162 modName = mkModule (stringToPackageId pkg) (mkModuleName mod)
163 lookupOrig modName occName
167 {- To find the string in the constructor's info table we need to consider
168 the layout of info tables relative to the entry code for a closure.
170 An info table can be next to the entry code for the closure, or it can
171 be separate. The former (faster) is used in registerised versions of ghc,
172 and the latter (portable) is for non-registerised versions.
174 The diagrams below show where the string is to be found relative to
175 the normal info table of the closure.
177 1) Code next to table:
180 | | <- pointer to the start of the string
182 | | <- the (start of the) info table structure
189 In this case the pointer to the start of the string can be found in
190 the memory location _one word before_ the first entry in the normal info
193 2) Code NOT next to table:
196 info table structure -> | *------------------> --------------
200 ptr to start of str -> | |
203 In this case the pointer to the start of the string can be found
204 in the memory location: info_table_ptr + info_table_size
207 getConDescAddress :: Ptr StgInfoTable -> IO (Ptr CChar)
208 getConDescAddress ptr = do
209 #ifdef GHCI_TABLES_NEXT_TO_CODE
210 offsetToString <- peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset
211 return $ ptr `plusPtr` offsetToString
213 -- subtract a word number of bytes
214 offset = negate (fromIntegral SIZEOF_VOID_P)
216 #ifndef GHCI_TABLES_NEXT_TO_CODE
217 peek $ intPtrToPtr $ (ptrToIntPtr ptr) + offset
219 -- add the standard info table size in bytes
220 infoTableSizeBytes = sTD_ITBL_SIZE * wORD_SIZE
221 offset = infoTableSizeBytes
224 -- parsing names is a little bit fiddly because we have a string in the form:
225 -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
226 -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
227 -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
228 -- this is not the conventional way of writing Haskell names. We stick with
229 -- convention, even though it makes the parsing code more troublesome.
230 -- Warning: this code assumes that the string is well formed.
231 parse :: String -> (String, String, String)
233 = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
235 (pkg, rest1) = break (==':') input
237 = (concat $ intersperse "." $ reverse modWords, occWord)
239 (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
240 parseModOcc :: [String] -> String -> ([String], String)
242 = case break (== '.') str of
243 (top, []) -> (acc, top)
244 (top, '.':bot) -> parseModOcc (top : acc) bot
247 getHValue :: Name -> IO (Maybe HValue)
249 pls <- readIORef v_PersistentLinkerState
250 case lookupNameEnv (closure_env pls) name of
251 Just (_,x) -> return$ Just x
254 withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
255 withExtendedLinkEnv new_env action
256 = bracket set_new_env
259 where set_new_env = do pls <- readIORef v_PersistentLinkerState
260 let new_closure_env = extendClosureEnv (closure_env pls) new_env
261 new_pls = pls { closure_env = new_closure_env }
262 writeIORef v_PersistentLinkerState new_pls
263 return (closure_env pls)
264 reset_old_env env = modifyIORef v_PersistentLinkerState (\pls -> pls{ closure_env = env })
266 -- filterNameMap removes from the environment all entries except
267 -- those for a given set of modules;
268 -- Note that this removes all *local* (i.e. non-isExternal) names too
269 -- (these are the temporary bindings from the command line).
270 -- Used to filter both the ClosureEnv and ItblEnv
272 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
273 filterNameMap mods env
274 = filterNameEnv keep_elt env
276 keep_elt (n,_) = isExternalName n
277 && (nameModule n `elem` mods)
282 showLinkerState :: IO ()
283 -- Display the persistent linker state
285 = do pls <- readIORef v_PersistentLinkerState
286 printDump (vcat [text "----- Linker state -----",
287 text "Pkgs:" <+> ppr (pkgs_loaded pls),
288 text "Objs:" <+> ppr (objs_loaded pls),
289 text "BCOs:" <+> ppr (bcos_loaded pls)])
295 %************************************************************************
297 \subsection{Initialisation}
299 %************************************************************************
301 We initialise the dynamic linker by
303 a) calling the C initialisation procedure
305 b) Loading any packages specified on the command line,
307 c) Loading any packages specified on the command line,
308 now held in the -l options in v_Opt_l
310 d) Loading any .o/.dll files specified on the command line,
311 now held in v_Ld_inputs
313 e) Loading any MacOS frameworks
316 initDynLinker :: DynFlags -> IO ()
317 -- This function is idempotent; if called more than once, it does nothing
318 -- This is useful in Template Haskell, where we call it before trying to link
320 = do { done <- readIORef v_InitLinkerDone
321 ; if done then return ()
322 else do { writeIORef v_InitLinkerDone True
323 ; reallyInitDynLinker dflags }
326 reallyInitDynLinker dflags
327 = do { -- Initialise the linker state
328 ; writeIORef v_PersistentLinkerState (emptyPLS dflags)
330 -- (a) initialise the C dynamic linker
333 -- (b) Load packages from the command-line
334 ; linkPackages dflags (preloadPackages (pkgState dflags))
336 -- (c) Link libraries from the command-line
337 ; let optl = getOpts dflags opt_l
338 ; let minus_ls = [ lib | '-':'l':lib <- optl ]
340 -- (d) Link .o files from the command-line
341 ; let lib_paths = libraryPaths dflags
342 ; cmdline_ld_inputs <- readIORef v_Ld_inputs
344 ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
346 -- (e) Link any MacOS frameworks
347 #ifdef darwin_TARGET_OS
348 ; let framework_paths = frameworkPaths dflags
349 ; let frameworks = cmdlineFrameworks dflags
351 ; let frameworks = []
352 ; let framework_paths = []
354 -- Finally do (c),(d),(e)
355 ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
357 ++ map Framework frameworks
358 ; if null cmdline_lib_specs then return ()
361 { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
362 ; maybePutStr dflags "final link ... "
365 ; if succeeded ok then maybePutStrLn dflags "done"
366 else throwDyn (InstallationError "linking extra libraries/objects failed")
369 classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
371 | isObjectFilename f = return (Just (Object f))
372 | isDynLibFilename f = return (Just (DLLPath f))
374 hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
377 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
378 preloadLib dflags lib_paths framework_paths lib_spec
379 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
382 -> do b <- preload_static lib_paths static_ish
383 maybePutStrLn dflags (if b then "done"
387 -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
389 Nothing -> maybePutStrLn dflags "done"
390 Just mm -> preloadFailed mm lib_paths lib_spec
393 -> do maybe_errstr <- loadDLL dll_path
395 Nothing -> maybePutStrLn dflags "done"
396 Just mm -> preloadFailed mm lib_paths lib_spec
398 #ifdef darwin_TARGET_OS
400 -> do maybe_errstr <- loadFramework framework_paths framework
402 Nothing -> maybePutStrLn dflags "done"
403 Just mm -> preloadFailed mm framework_paths lib_spec
406 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
407 preloadFailed sys_errmsg paths spec
408 = do maybePutStr dflags
409 ("failed.\nDynamic linker error message was:\n "
410 ++ sys_errmsg ++ "\nWhilst trying to load: "
411 ++ showLS spec ++ "\nDirectories to search are:\n"
412 ++ unlines (map (" "++) paths) )
415 -- Not interested in the paths in the static case.
416 preload_static paths name
417 = do b <- doesFileExist name
418 if not b then return False
419 else loadObj name >> return True
422 CmdLineError "user specified .o/.so/.DLL could not be loaded."
426 %************************************************************************
428 Link a byte-code expression
430 %************************************************************************
433 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
435 -- Link a single expression, *including* first linking packages and
436 -- modules that this expression depends on.
438 -- Raises an IO exception if it can't find a compiled version of the
439 -- dependents to link.
441 -- Note: This function side-effects the linker state (Pepe)
443 linkExpr hsc_env span root_ul_bco
445 -- Initialise the linker (if it's not been done already)
446 let dflags = hsc_dflags hsc_env
447 ; initDynLinker dflags
449 -- The interpreter and dynamic linker can only handle object code built
450 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
451 -- So here we check the build tag: if we're building a non-standard way
452 -- then we need to find & link object files built the "normal" way.
453 ; maybe_normal_osuf <- checkNonStdWay dflags span
455 -- Find what packages and linkables are required
456 ; eps <- readIORef (hsc_EPS hsc_env)
457 ; (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
458 maybe_normal_osuf span needed_mods
460 -- Link the packages and modules required
461 ; linkPackages dflags pkgs
462 ; ok <- linkModules dflags lnks
464 throwDyn (ProgramError "")
467 -- Link the expression itself
468 pls <- readIORef v_PersistentLinkerState
469 ; let ie = itbl_env pls
472 -- Link the necessary packages and linkables
473 ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
477 hpt = hsc_HPT hsc_env
478 free_names = nameSetToList (bcoFreeNames root_ul_bco)
480 needed_mods :: [Module]
481 needed_mods = [ nameModule n | n <- free_names,
482 isExternalName n, -- Names from other modules
483 not (isWiredInName n) -- Exclude wired-in names
484 ] -- (see note below)
485 -- Exclude wired-in names because we may not have read
486 -- their interface files, so getLinkDeps will fail
487 -- All wired-in names are in the base package, which we link
488 -- by default, so we can safely ignore them here.
490 dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg)))
493 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
494 checkNonStdWay dflags srcspan = do
495 tag <- readIORef v_Build_tag
496 if null tag then return Nothing else do
497 let default_osuf = phaseInputExt StopLn
498 if objectSuf dflags == default_osuf
499 then failNonStd srcspan
500 else return (Just default_osuf)
502 failNonStd srcspan = dieWith srcspan $
503 ptext SLIT("Dynamic linking required, but this is a non-standard build (eg. prof).") $$
504 ptext SLIT("You need to build the program twice: once the normal way, and then") $$
505 ptext SLIT("in the desired way using -osuf to set the object file suffix.")
508 getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable
509 -> Maybe String -- the "normal" object suffix
510 -> SrcSpan -- for error messages
511 -> [Module] -- If you need these
512 -> IO ([Linkable], [PackageId]) -- ... then link these first
513 -- Fails with an IO exception if it can't find enough files
515 getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
516 -- Find all the packages and linkables that a set of modules depends on
517 = do { pls <- readIORef v_PersistentLinkerState ;
519 -- 1. Find the dependent home-pkg-modules/packages from each iface
520 (mods_s, pkgs_s) = follow_deps mods emptyUniqSet emptyUniqSet;
522 -- 2. Exclude ones already linked
523 -- Main reason: avoid findModule calls in get_linkable
524 mods_needed = mods_s `minusList` linked_mods ;
525 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
527 linked_mods = map (moduleName.linkableModule)
528 (objs_loaded pls ++ bcos_loaded pls)
531 -- putStrLn (showSDoc (ppr mods_s)) ;
532 -- 3. For each dependent module, find its linkable
533 -- This will either be in the HPT or (in the case of one-shot
534 -- compilation) we may need to use maybe_getFileLinkable
535 lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
537 return (lnks_needed, pkgs_needed) }
539 dflags = hsc_dflags hsc_env
540 this_pkg = thisPackage dflags
542 -- The ModIface contains the transitive closure of the module dependencies
543 -- within the current package, *except* for boot modules: if we encounter
544 -- a boot module, we have to find its real interface and discover the
545 -- dependencies of that. Hence we need to traverse the dependency
546 -- tree recursively. See bug #936, testcase ghci/prog007.
547 follow_deps :: [Module] -- modules to follow
548 -> UniqSet ModuleName -- accum. module dependencies
549 -> UniqSet PackageId -- accum. package dependencies
550 -> ([ModuleName], [PackageId]) -- result
551 follow_deps [] acc_mods acc_pkgs
552 = (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
553 follow_deps (mod:mods) acc_mods acc_pkgs
555 = follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
557 = link_boot_mod_error mod
559 = follow_deps (map (mkModule this_pkg) boot_deps ++ mods) acc_mods' acc_pkgs'
561 pkg = modulePackageId mod
562 iface = get_iface mod
565 pkg_deps = dep_pkgs deps
566 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
567 where is_boot (m,True) = Left m
568 is_boot (m,False) = Right m
570 boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
571 acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
572 acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
575 link_boot_mod_error mod =
576 throwDyn (ProgramError (showSDoc (
577 text "module" <+> ppr mod <+>
578 text "cannot be linked; it is only available as a boot module")))
580 get_iface mod = case lookupIfaceByModule dflags hpt pit mod of
582 Nothing -> pprPanic "getLinkDeps" (no_iface mod)
583 no_iface mod = ptext SLIT("No iface for") <+> ppr mod
584 -- This one is a GHC bug
586 no_obj mod = dieWith span $
587 ptext SLIT("cannot find object file for module ") <>
591 while_linking_expr = ptext SLIT("while linking an interpreted expression")
593 -- This one is a build-system bug
595 get_linkable maybe_normal_osuf mod_name -- A home-package module
596 | Just mod_info <- lookupUFM hpt mod_name
597 = ASSERT(isJust (hm_linkable mod_info))
598 adjust_linkable (fromJust (hm_linkable mod_info))
600 = do -- It's not in the HPT because we are in one shot mode,
601 -- so use the Finder to get a ModLocation...
602 mb_stuff <- findHomeModule hsc_env mod_name
604 Found loc mod -> found loc mod
608 -- ...and then find the linkable for it
609 mb_lnk <- findObjectLinkableMaybe mod loc ;
611 Nothing -> no_obj mod ;
612 Just lnk -> adjust_linkable lnk
616 | Just osuf <- maybe_normal_osuf = do
617 new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
618 return lnk{ linkableUnlinked=new_uls }
622 adjust_ul osuf (DotO file) = do
623 let new_file = replaceFilenameSuffix file osuf
624 ok <- doesFileExist new_file
627 ptext SLIT("cannot find normal object file ")
628 <> quotes (text new_file) $$ while_linking_expr
629 else return (DotO new_file)
633 %************************************************************************
636 The linkables may consist of a mixture of
637 byte-code modules and object modules
639 %************************************************************************
642 linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
643 linkModules dflags linkables
644 = block $ do -- don't want to be interrupted by ^C in here
646 let (objs, bcos) = partition isObjectLinkable
647 (concatMap partitionLinkable linkables)
649 -- Load objects first; they can't depend on BCOs
650 ok_flag <- dynLinkObjs dflags objs
652 if failed ok_flag then
659 -- HACK to support f-x-dynamic in the interpreter; no other purpose
660 partitionLinkable :: Linkable -> [Linkable]
662 = let li_uls = linkableUnlinked li
663 li_uls_obj = filter isObject li_uls
664 li_uls_bco = filter isInterpretable li_uls
666 case (li_uls_obj, li_uls_bco) of
667 (objs@(_:_), bcos@(_:_))
668 -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
672 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
673 findModuleLinkable_maybe lis mod
674 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
677 many -> pprPanic "findModuleLinkable" (ppr mod)
679 linkableInSet :: Linkable -> [Linkable] -> Bool
680 linkableInSet l objs_loaded =
681 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
683 Just m -> linkableTime l == linkableTime m
687 %************************************************************************
689 \subsection{The object-code linker}
691 %************************************************************************
694 dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
695 -- Side-effects the PersistentLinkerState
697 dynLinkObjs dflags objs
698 = do pls <- readIORef v_PersistentLinkerState
700 -- Load the object files and link them
701 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
702 pls1 = pls { objs_loaded = objs_loaded' }
703 unlinkeds = concatMap linkableUnlinked new_objs
705 mapM loadObj (map nameOfObject unlinkeds)
707 -- Link the all together
710 -- If resolving failed, unload all our
711 -- object modules and carry on
712 if succeeded ok then do
713 writeIORef v_PersistentLinkerState pls1
716 pls2 <- unload_wkr dflags [] pls1
717 writeIORef v_PersistentLinkerState pls2
721 rmDupLinkables :: [Linkable] -- Already loaded
722 -> [Linkable] -- New linkables
723 -> ([Linkable], -- New loaded set (including new ones)
724 [Linkable]) -- New linkables (excluding dups)
725 rmDupLinkables already ls
728 go already extras [] = (already, extras)
729 go already extras (l:ls)
730 | linkableInSet l already = go already extras ls
731 | otherwise = go (l:already) (l:extras) ls
734 %************************************************************************
736 \subsection{The byte-code linker}
738 %************************************************************************
741 dynLinkBCOs :: [Linkable] -> IO ()
742 -- Side-effects the persistent linker state
744 = do pls <- readIORef v_PersistentLinkerState
746 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
747 pls1 = pls { bcos_loaded = bcos_loaded' }
748 unlinkeds :: [Unlinked]
749 unlinkeds = concatMap linkableUnlinked new_bcos
751 cbcs :: [CompiledByteCode]
752 cbcs = map byteCodeOfObject unlinkeds
755 ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
756 ies = [ie | ByteCode _ ie <- cbcs]
757 gce = closure_env pls
758 final_ie = foldr plusNameEnv (itbl_env pls) ies
760 (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
761 -- What happens to these linked_bcos?
763 let pls2 = pls1 { closure_env = final_gce,
764 itbl_env = final_ie }
766 writeIORef v_PersistentLinkerState pls2
769 -- Link a bunch of BCOs and return them + updated closure env.
770 linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
771 -- True <=> add only toplevel BCOs to closure env
775 -> IO (ClosureEnv, [HValue])
776 -- The returned HValues are associated 1-1 with
777 -- the incoming unlinked BCOs. Each gives the
778 -- value of the corresponding unlinked BCO
780 linkSomeBCOs toplevs_only ie ce_in ul_bcos
781 = do let nms = map unlinkedBCOName ul_bcos
783 ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
784 in mapM (linkBCO ie ce_out) ul_bcos )
785 let ce_all_additions = zip nms hvals
786 ce_top_additions = filter (isExternalName.fst) ce_all_additions
787 ce_additions = if toplevs_only then ce_top_additions
788 else ce_all_additions
789 ce_out = -- make sure we're not inserting duplicate names into the
790 -- closure environment, which leads to trouble.
791 ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
792 extendClosureEnv ce_in ce_additions
793 return (ce_out, hvals)
798 %************************************************************************
800 Unload some object modules
802 %************************************************************************
805 -- ---------------------------------------------------------------------------
806 -- Unloading old objects ready for a new compilation sweep.
808 -- The compilation manager provides us with a list of linkables that it
809 -- considers "stable", i.e. won't be recompiled this time around. For
810 -- each of the modules current linked in memory,
812 -- * if the linkable is stable (and it's the same one - the
813 -- user may have recompiled the module on the side), we keep it,
815 -- * otherwise, we unload it.
817 -- * we also implicitly unload all temporary bindings at this point.
819 unload :: DynFlags -> [Linkable] -> IO ()
820 -- The 'linkables' are the ones to *keep*
822 unload dflags linkables
823 = block $ do -- block, so we're safe from Ctrl-C in here
825 -- Initialise the linker (if it's not been done already)
828 pls <- readIORef v_PersistentLinkerState
829 new_pls <- unload_wkr dflags linkables pls
830 writeIORef v_PersistentLinkerState new_pls
832 debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
833 debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
836 unload_wkr :: DynFlags
837 -> [Linkable] -- stable linkables
838 -> PersistentLinkerState
839 -> IO PersistentLinkerState
840 -- Does the core unload business
841 -- (the wrapper blocks exceptions and deals with the PLS get and put)
843 unload_wkr dflags linkables pls
844 = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
846 objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
847 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
849 let bcos_retained = map linkableModule bcos_loaded'
850 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
851 closure_env' = filterNameMap bcos_retained (closure_env pls)
852 new_pls = pls { itbl_env = itbl_env',
853 closure_env = closure_env',
854 bcos_loaded = bcos_loaded',
855 objs_loaded = objs_loaded' }
859 maybeUnload :: [Linkable] -> Linkable -> IO Bool
860 maybeUnload keep_linkables lnk
861 | linkableInSet lnk linkables = return True
863 = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
864 -- The components of a BCO linkable may contain
865 -- dot-o files. Which is very confusing.
867 -- But the BCO parts can be unlinked just by
868 -- letting go of them (plus of course depopulating
869 -- the symbol table which is done in the main body)
874 %************************************************************************
878 %************************************************************************
883 = Object FilePath -- Full path name of a .o file, including trailing .o
884 -- For dynamic objects only, try to find the object
885 -- file in all the directories specified in
886 -- v_Library_paths before giving up.
888 | DLL String -- "Unadorned" name of a .DLL/.so
889 -- e.g. On unix "qt" denotes "libqt.so"
890 -- On WinDoze "burble" denotes "burble.DLL"
891 -- loadDLL is platform-specific and adds the lib/.so/.DLL
892 -- suffixes platform-dependently
894 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
895 -- (ends with .dll or .so).
897 | Framework String -- Only used for darwin, but does no harm
899 -- If this package is already part of the GHCi binary, we'll already
900 -- have the right DLLs for this package loaded, so don't try to
903 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
904 -- as far as the loader is concerned, but it does initialise the list
905 -- of DLL handles that rts/Linker.c maintains, and that in turn is
906 -- used by lookupSymbol. So we must call addDLL for each library
907 -- just to get the DLL handle into the list.
909 # if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS)
912 = [ "base", "haskell98", "template-haskell", "readline" ]
915 showLS (Object nm) = "(static) " ++ nm
916 showLS (DLL nm) = "(dynamic) " ++ nm
917 showLS (DLLPath nm) = "(dynamic) " ++ nm
918 showLS (Framework nm) = "(framework) " ++ nm
920 linkPackages :: DynFlags -> [PackageId] -> IO ()
921 -- Link exactly the specified packages, and their dependents
922 -- (unless of course they are already linked)
923 -- The dependents are linked automatically, and it doesn't matter
924 -- what order you specify the input packages.
926 -- NOTE: in fact, since each module tracks all the packages it depends on,
927 -- we don't really need to use the package-config dependencies.
928 -- However we do need the package-config stuff (to find aux libs etc),
929 -- and following them lets us load libraries in the right order, which
930 -- perhaps makes the error message a bit more localised if we get a link
931 -- failure. So the dependency walking code is still here.
933 linkPackages dflags new_pkgs
934 = do { pls <- readIORef v_PersistentLinkerState
935 ; let pkg_map = pkgIdMap (pkgState dflags)
937 ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
939 ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
942 link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
943 link pkg_map pkgs new_pkgs
944 = foldM (link_one pkg_map) pkgs new_pkgs
946 link_one pkg_map pkgs new_pkg
947 | new_pkg `elem` pkgs -- Already linked
950 | Just pkg_cfg <- lookupPackage pkg_map new_pkg
951 = do { -- Link dependents first
952 pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
953 -- Now link the package itself
954 ; linkPackage dflags pkg_cfg
955 ; return (new_pkg : pkgs') }
958 = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
961 linkPackage :: DynFlags -> PackageConfig -> IO ()
962 linkPackage dflags pkg
964 let dirs = Packages.libraryDirs pkg
966 let libs = Packages.hsLibraries pkg
967 -- Because of slight differences between the GHC dynamic linker and
968 -- the native system linker some packages have to link with a
969 -- different list of libraries when using GHCi. Examples include: libs
970 -- that are actually gnu ld scripts, and the possability that the .a
971 -- libs do not exactly match the .so/.dll equivalents. So if the
972 -- package file provides an "extra-ghci-libraries" field then we use
973 -- that instead of the "extra-libraries" field.
974 ++ (if null (Packages.extraGHCiLibraries pkg)
975 then Packages.extraLibraries pkg
976 else Packages.extraGHCiLibraries pkg)
977 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
978 classifieds <- mapM (locateOneObj dirs) libs
980 -- Complication: all the .so's must be loaded before any of the .o's.
981 let dlls = [ dll | DLL dll <- classifieds ]
982 objs = [ obj | Object obj <- classifieds ]
984 maybePutStr dflags ("Loading package " ++ showPackageId (package pkg) ++ " ... ")
986 -- See comments with partOfGHCi
987 when (pkgName (package pkg) `notElem` partOfGHCi) $ do
989 -- When a library A needs symbols from a library B, the order in
990 -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
991 -- way ld expects it for static linking. Dynamic linking is a
992 -- different story: When A has no dependency information for B,
993 -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
994 -- when B has not been loaded before. In a nutshell: Reverse the
995 -- order of DLLs for dynamic linking.
996 -- This fixes a problem with the HOpenGL package (see "Compiling
997 -- HOpenGL under recent versions of GHC" on the HOpenGL list).
998 mapM_ (load_dyn dirs) (reverse dlls)
1000 -- After loading all the DLLs, we can load the static objects.
1001 -- Ordering isn't important here, because we do one final link
1002 -- step to resolve everything.
1005 maybePutStr dflags "linking ... "
1007 if succeeded ok then maybePutStrLn dflags "done."
1008 else throwDyn (InstallationError ("unable to load package `" ++ showPackageId (package pkg) ++ "'"))
1010 load_dyn dirs dll = do r <- loadDynamic dirs dll
1012 Nothing -> return ()
1013 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1014 ++ dll ++ " (" ++ err ++ ")" ))
1015 #ifndef darwin_TARGET_OS
1016 loadFrameworks pkg = return ()
1018 loadFrameworks pkg = mapM_ load frameworks
1020 fw_dirs = Packages.frameworkDirs pkg
1021 frameworks = Packages.frameworks pkg
1023 load fw = do r <- loadFramework fw_dirs fw
1025 Nothing -> return ()
1026 Just err -> throwDyn (CmdLineError ("can't load framework: "
1027 ++ fw ++ " (" ++ err ++ ")" ))
1030 -- Try to find an object file for a given library in the given paths.
1031 -- If it isn't present, we assume it's a dynamic library.
1032 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1033 locateOneObj dirs lib
1034 = do { mb_obj_path <- findFile mk_obj_path dirs
1035 ; case mb_obj_path of
1036 Just obj_path -> return (Object obj_path)
1038 do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1039 ; case mb_lib_path of
1040 Just lib_path -> return (DLL (lib ++ "_dyn"))
1041 Nothing -> return (DLL lib) }} -- We assume
1043 mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o")
1044 mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "_dyn")
1047 -- ----------------------------------------------------------------------------
1048 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1050 -- return Nothing == success, else Just error message from dlopen
1051 loadDynamic paths rootname
1052 = do { mb_dll <- findFile mk_dll_path paths
1054 Just dll -> loadDLL dll
1055 Nothing -> loadDLL (mkSOName rootname) }
1056 -- Tried all our known library paths, so let
1057 -- dlopen() search its own builtin paths now.
1059 mk_dll_path dir = dir `joinFileName` mkSOName rootname
1061 #if defined(darwin_TARGET_OS)
1062 mkSOName root = ("lib" ++ root) `joinFileExt` "dylib"
1063 #elif defined(mingw32_TARGET_OS)
1064 -- Win32 DLLs have no .dll extension here, because addDLL tries
1065 -- both foo.dll and foo.drv
1066 mkSOName root = root
1068 mkSOName root = ("lib" ++ root) `joinFileExt` "so"
1071 -- Darwin / MacOS X only: load a framework
1072 -- a framework is a dynamic library packaged inside a directory of the same
1073 -- name. They are searched for in different paths than normal libraries.
1074 #ifdef darwin_TARGET_OS
1075 loadFramework extraPaths rootname
1076 = do { mb_fwk <- findFile mk_fwk (extraPaths ++ defaultFrameworkPaths)
1078 Just fwk_path -> loadDLL fwk_path
1079 Nothing -> return (Just "not found") }
1080 -- Tried all our known library paths, but dlopen()
1081 -- has no built-in paths for frameworks: give up
1083 mk_fwk dir = dir `joinFileName` (rootname ++ ".framework/" ++ rootname)
1084 -- sorry for the hardcoded paths, I hope they won't change anytime soon:
1085 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1089 %************************************************************************
1093 %************************************************************************
1096 findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
1097 -> [FilePath] -- Directories to look in
1098 -> IO (Maybe FilePath) -- The first file path to match
1099 findFile mk_file_path []
1101 findFile mk_file_path (dir:dirs)
1102 = do { let file_path = mk_file_path dir
1103 ; b <- doesFileExist file_path
1105 return (Just file_path)
1107 findFile mk_file_path dirs }
1111 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1112 | otherwise = return ()
1114 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1115 | otherwise = return ()