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" #-}
18 -- The above warning supression flag is a temporary kludge.
19 -- While working on this module you are encouraged to remove it and fix
20 -- any warnings in the module. See
21 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
24 module Linker ( HValue, getHValue, showLinkerState,
25 linkExpr, unload, withExtendedLinkEnv,
26 extendLinkEnv, deleteFromLinkEnv,
28 linkPackages,initDynLinker,
32 #include "HsVersions.h"
49 import qualified OccName
66 import Config ( cProjectVersion )
76 import System.FilePath
78 import System.Directory
80 import Control.Exception
85 %************************************************************************
89 %************************************************************************
91 The persistent linker state *must* match the actual state of the
92 C dynamic linker at all times, so we keep it in a private global variable.
95 The PersistentLinkerState maps Names to actual closures (for
96 interpreted code only), for use during linking.
99 GLOBAL_VAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState)
100 GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
102 data PersistentLinkerState
103 = PersistentLinkerState {
105 -- Current global mapping from Names to their true values
106 closure_env :: ClosureEnv,
108 -- The current global mapping from RdrNames of DataCons to
109 -- info table addresses.
110 -- When a new Unlinked is linked into the running image, or an existing
111 -- module in the image is replaced, the itbl_env must be updated
115 -- The currently loaded interpreted modules (home package)
116 bcos_loaded :: [Linkable],
118 -- And the currently-loaded compiled modules (home package)
119 objs_loaded :: [Linkable],
121 -- The currently-loaded packages; always object code
122 -- Held, as usual, in dependency order; though I am not sure if
123 -- that is really important
124 pkgs_loaded :: [PackageId]
127 emptyPLS :: DynFlags -> PersistentLinkerState
128 emptyPLS dflags = PersistentLinkerState {
129 closure_env = emptyNameEnv,
130 itbl_env = emptyNameEnv,
131 pkgs_loaded = init_pkgs,
135 -- Packages that don't need loading, because the compiler
136 -- shares them with the interpreted program.
138 -- The linker's symbol table is populated with RTS symbols using an
139 -- explicit list. See rts/Linker.c for details.
140 where init_pkgs = [rtsPackageId]
144 extendLoadedPkgs :: [PackageId] -> IO ()
145 extendLoadedPkgs pkgs
146 = modifyIORef v_PersistentLinkerState (\s -> s{pkgs_loaded = pkgs ++ pkgs_loaded s})
148 extendLinkEnv :: [(Name,HValue)] -> IO ()
149 -- Automatically discards shadowed bindings
150 extendLinkEnv new_bindings
151 = do pls <- readIORef v_PersistentLinkerState
152 let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
153 new_pls = pls { closure_env = new_closure_env }
154 writeIORef v_PersistentLinkerState new_pls
156 deleteFromLinkEnv :: [Name] -> IO ()
157 deleteFromLinkEnv to_remove
158 = do pls <- readIORef v_PersistentLinkerState
159 let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
160 new_pls = pls { closure_env = new_closure_env }
161 writeIORef v_PersistentLinkerState new_pls
163 -- | Given a data constructor in the heap, find its Name.
164 -- The info tables for data constructors have a field which records
165 -- the source name of the constructor as a Ptr Word8 (UTF-8 encoded
166 -- string). The format is:
168 -- Package:Module.Name
170 -- We use this string to lookup the interpreter's internal representation of the name
171 -- using the lookupOrig.
173 dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
174 dataConInfoPtrToName x = do
175 theString <- ioToTcRn $ do
176 let ptr = castPtr x :: Ptr StgInfoTable
177 conDescAddress <- getConDescAddress ptr
178 peekArray0 0 conDescAddress
179 let (pkg, mod, occ) = parse theString
180 pkgFS = mkFastStringByteList pkg
181 modFS = mkFastStringByteList mod
182 occFS = mkFastStringByteList occ
183 occName = mkOccNameFS OccName.dataName occFS
184 modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS)
185 return (Left$ showSDoc$ ppr modName <> dot <> ppr occName )
186 `recoverM` (Right `fmap` lookupOrig modName occName)
190 {- To find the string in the constructor's info table we need to consider
191 the layout of info tables relative to the entry code for a closure.
193 An info table can be next to the entry code for the closure, or it can
194 be separate. The former (faster) is used in registerised versions of ghc,
195 and the latter (portable) is for non-registerised versions.
197 The diagrams below show where the string is to be found relative to
198 the normal info table of the closure.
200 1) Code next to table:
203 | | <- pointer to the start of the string
205 | | <- the (start of the) info table structure
212 In this case the pointer to the start of the string can be found in
213 the memory location _one word before_ the first entry in the normal info
216 2) Code NOT next to table:
219 info table structure -> | *------------------> --------------
223 ptr to start of str -> | |
226 In this case the pointer to the start of the string can be found
227 in the memory location: info_table_ptr + info_table_size
230 getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
231 getConDescAddress ptr = do
232 #ifdef GHCI_TABLES_NEXT_TO_CODE
233 offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
234 return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
236 peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
239 -- parsing names is a little bit fiddly because we have a string in the form:
240 -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
241 -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
242 -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
243 -- this is not the conventional way of writing Haskell names. We stick with
244 -- convention, even though it makes the parsing code more troublesome.
245 -- Warning: this code assumes that the string is well formed.
246 parse :: [Word8] -> ([Word8], [Word8], [Word8])
248 = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
250 dot = fromIntegral (ord '.')
251 (pkg, rest1) = break (== fromIntegral (ord ':')) input
253 = (concat $ intersperse [dot] $ reverse modWords, occWord)
255 (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
256 parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
258 = case break (== dot) str of
259 (top, []) -> (acc, top)
260 (top, _:bot) -> parseModOcc (top : acc) bot
263 getHValue :: HscEnv -> Name -> IO HValue
264 getHValue hsc_env name = do
265 when (isExternalName name) $ do
266 ok <- linkDependencies hsc_env noSrcSpan [nameModule name]
267 when (failed ok) $ throwDyn (ProgramError "")
268 pls <- readIORef v_PersistentLinkerState
269 lookupName (closure_env pls) name
271 linkDependencies :: HscEnv -> SrcSpan -> [Module] -> IO SuccessFlag
272 linkDependencies hsc_env span needed_mods = do
273 let hpt = hsc_HPT hsc_env
274 dflags = hsc_dflags hsc_env
275 -- The interpreter and dynamic linker can only handle object code built
276 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
277 -- So here we check the build tag: if we're building a non-standard way
278 -- then we need to find & link object files built the "normal" way.
279 maybe_normal_osuf <- checkNonStdWay dflags span
281 -- Find what packages and linkables are required
282 eps <- readIORef (hsc_EPS hsc_env)
283 (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
284 maybe_normal_osuf span needed_mods
286 -- Link the packages and modules required
287 linkPackages dflags pkgs
288 linkModules dflags lnks
291 -- | Temporarily extend the linker state.
293 withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
294 withExtendedLinkEnv new_env action
295 = bracket set_new_env
298 where set_new_env = do
299 pls <- readIORef v_PersistentLinkerState
300 let new_closure_env = extendClosureEnv (closure_env pls) new_env
301 new_pls = pls { closure_env = new_closure_env }
302 writeIORef v_PersistentLinkerState new_pls
303 return (closure_env pls)
305 -- Remember that the linker state might be side-effected
306 -- during the execution of the IO action, and we don't want to
307 -- lose those changes (we might have linked a new module or
308 -- package), so the reset action only removes the names we
310 reset_old_env env = do
311 modifyIORef v_PersistentLinkerState $ \pls ->
312 let cur = closure_env pls
313 new = delListFromNameEnv cur (map fst new_env)
315 pls{ closure_env = new }
317 -- filterNameMap removes from the environment all entries except
318 -- those for a given set of modules;
319 -- Note that this removes all *local* (i.e. non-isExternal) names too
320 -- (these are the temporary bindings from the command line).
321 -- Used to filter both the ClosureEnv and ItblEnv
323 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
324 filterNameMap mods env
325 = filterNameEnv keep_elt env
327 keep_elt (n,_) = isExternalName n
328 && (nameModule n `elem` mods)
333 showLinkerState :: IO ()
334 -- Display the persistent linker state
336 = do pls <- readIORef v_PersistentLinkerState
337 printDump (vcat [text "----- Linker state -----",
338 text "Pkgs:" <+> ppr (pkgs_loaded pls),
339 text "Objs:" <+> ppr (objs_loaded pls),
340 text "BCOs:" <+> ppr (bcos_loaded pls)])
346 %************************************************************************
348 \subsection{Initialisation}
350 %************************************************************************
352 We initialise the dynamic linker by
354 a) calling the C initialisation procedure
356 b) Loading any packages specified on the command line,
358 c) Loading any packages specified on the command line,
359 now held in the -l options in v_Opt_l
361 d) Loading any .o/.dll files specified on the command line,
362 now held in v_Ld_inputs
364 e) Loading any MacOS frameworks
367 initDynLinker :: DynFlags -> IO ()
368 -- This function is idempotent; if called more than once, it does nothing
369 -- This is useful in Template Haskell, where we call it before trying to link
371 = do { done <- readIORef v_InitLinkerDone
372 ; if done then return ()
373 else do { writeIORef v_InitLinkerDone True
374 ; reallyInitDynLinker dflags }
377 reallyInitDynLinker dflags
378 = do { -- Initialise the linker state
379 ; writeIORef v_PersistentLinkerState (emptyPLS dflags)
381 -- (a) initialise the C dynamic linker
384 -- (b) Load packages from the command-line
385 ; linkPackages dflags (preloadPackages (pkgState dflags))
387 -- (c) Link libraries from the command-line
388 ; let optl = getOpts dflags opt_l
389 ; let minus_ls = [ lib | '-':'l':lib <- optl ]
391 -- (d) Link .o files from the command-line
392 ; let lib_paths = libraryPaths dflags
393 ; cmdline_ld_inputs <- readIORef v_Ld_inputs
395 ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
397 -- (e) Link any MacOS frameworks
398 #ifdef darwin_TARGET_OS
399 ; let framework_paths = frameworkPaths dflags
400 ; let frameworks = cmdlineFrameworks dflags
402 ; let frameworks = []
403 ; let framework_paths = []
405 -- Finally do (c),(d),(e)
406 ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
408 ++ map Framework frameworks
409 ; if null cmdline_lib_specs then return ()
412 { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
413 ; maybePutStr dflags "final link ... "
416 ; if succeeded ok then maybePutStrLn dflags "done"
417 else throwDyn (InstallationError "linking extra libraries/objects failed")
420 classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
422 | isObjectFilename f = return (Just (Object f))
423 | isDynLibFilename f = return (Just (DLLPath f))
425 hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
428 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
429 preloadLib dflags lib_paths framework_paths lib_spec
430 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
433 -> do b <- preload_static lib_paths static_ish
434 maybePutStrLn dflags (if b then "done"
438 -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
440 Nothing -> maybePutStrLn dflags "done"
441 Just mm -> preloadFailed mm lib_paths lib_spec
444 -> do maybe_errstr <- loadDLL dll_path
446 Nothing -> maybePutStrLn dflags "done"
447 Just mm -> preloadFailed mm lib_paths lib_spec
449 #ifdef darwin_TARGET_OS
451 -> do maybe_errstr <- loadFramework framework_paths framework
453 Nothing -> maybePutStrLn dflags "done"
454 Just mm -> preloadFailed mm framework_paths lib_spec
457 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
458 preloadFailed sys_errmsg paths spec
459 = do maybePutStr dflags
460 ("failed.\nDynamic linker error message was:\n "
461 ++ sys_errmsg ++ "\nWhilst trying to load: "
462 ++ showLS spec ++ "\nDirectories to search are:\n"
463 ++ unlines (map (" "++) paths) )
466 -- Not interested in the paths in the static case.
467 preload_static paths name
468 = do b <- doesFileExist name
469 if not b then return False
470 else loadObj name >> return True
473 CmdLineError "user specified .o/.so/.DLL could not be loaded."
477 %************************************************************************
479 Link a byte-code expression
481 %************************************************************************
484 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
486 -- Link a single expression, *including* first linking packages and
487 -- modules that this expression depends on.
489 -- Raises an IO exception if it can't find a compiled version of the
490 -- dependents to link.
492 -- Note: This function side-effects the linker state (Pepe)
494 linkExpr hsc_env span root_ul_bco
496 -- Initialise the linker (if it's not been done already)
497 let dflags = hsc_dflags hsc_env
498 ; initDynLinker dflags
500 -- Link the packages and modules required
501 ; ok <- linkDependencies hsc_env span needed_mods
503 throwDyn (ProgramError "")
506 -- Link the expression itself
507 pls <- readIORef v_PersistentLinkerState
508 ; let ie = itbl_env pls
511 -- Link the necessary packages and linkables
512 ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
516 free_names = nameSetToList (bcoFreeNames root_ul_bco)
518 needed_mods :: [Module]
519 needed_mods = [ nameModule n | n <- free_names,
520 isExternalName n, -- Names from other modules
521 not (isWiredInName n) -- Exclude wired-in names
522 ] -- (see note below)
523 -- Exclude wired-in names because we may not have read
524 -- their interface files, so getLinkDeps will fail
525 -- All wired-in names are in the base package, which we link
526 -- by default, so we can safely ignore them here.
528 dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg)))
531 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
532 checkNonStdWay dflags srcspan = do
533 tag <- readIORef v_Build_tag
534 if null tag then return Nothing else do
535 let default_osuf = phaseInputExt StopLn
536 if objectSuf dflags == default_osuf
537 then failNonStd srcspan
538 else return (Just default_osuf)
540 failNonStd srcspan = dieWith srcspan $
541 ptext SLIT("Dynamic linking required, but this is a non-standard build (eg. prof).") $$
542 ptext SLIT("You need to build the program twice: once the normal way, and then") $$
543 ptext SLIT("in the desired way using -osuf to set the object file suffix.")
546 getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable
547 -> Maybe String -- the "normal" object suffix
548 -> SrcSpan -- for error messages
549 -> [Module] -- If you need these
550 -> IO ([Linkable], [PackageId]) -- ... then link these first
551 -- Fails with an IO exception if it can't find enough files
553 getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
554 -- Find all the packages and linkables that a set of modules depends on
555 = do { pls <- readIORef v_PersistentLinkerState ;
557 -- 1. Find the dependent home-pkg-modules/packages from each iface
558 (mods_s, pkgs_s) = follow_deps mods emptyUniqSet emptyUniqSet;
560 -- 2. Exclude ones already linked
561 -- Main reason: avoid findModule calls in get_linkable
562 mods_needed = mods_s `minusList` linked_mods ;
563 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
565 linked_mods = map (moduleName.linkableModule)
566 (objs_loaded pls ++ bcos_loaded pls)
569 -- putStrLn (showSDoc (ppr mods_s)) ;
570 -- 3. For each dependent module, find its linkable
571 -- This will either be in the HPT or (in the case of one-shot
572 -- compilation) we may need to use maybe_getFileLinkable
573 lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
575 return (lnks_needed, pkgs_needed) }
577 dflags = hsc_dflags hsc_env
578 this_pkg = thisPackage dflags
580 -- The ModIface contains the transitive closure of the module dependencies
581 -- within the current package, *except* for boot modules: if we encounter
582 -- a boot module, we have to find its real interface and discover the
583 -- dependencies of that. Hence we need to traverse the dependency
584 -- tree recursively. See bug #936, testcase ghci/prog007.
585 follow_deps :: [Module] -- modules to follow
586 -> UniqSet ModuleName -- accum. module dependencies
587 -> UniqSet PackageId -- accum. package dependencies
588 -> ([ModuleName], [PackageId]) -- result
589 follow_deps [] acc_mods acc_pkgs
590 = (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
591 follow_deps (mod:mods) acc_mods acc_pkgs
593 = follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
595 = link_boot_mod_error mod
597 = follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) acc_mods' acc_pkgs'
599 pkg = modulePackageId mod
600 iface = get_iface mod
603 pkg_deps = dep_pkgs deps
604 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
605 where is_boot (m,True) = Left m
606 is_boot (m,False) = Right m
608 boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
609 acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
610 acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
613 link_boot_mod_error mod =
614 throwDyn (ProgramError (showSDoc (
615 text "module" <+> ppr mod <+>
616 text "cannot be linked; it is only available as a boot module")))
618 get_iface mod = case lookupIfaceByModule dflags hpt pit mod of
620 Nothing -> pprPanic "getLinkDeps" (no_iface mod)
621 no_iface mod = ptext SLIT("No iface for") <+> ppr mod
622 -- This one is a GHC bug
624 no_obj mod = dieWith span $
625 ptext SLIT("cannot find object file for module ") <>
629 while_linking_expr = ptext SLIT("while linking an interpreted expression")
631 -- This one is a build-system bug
633 get_linkable maybe_normal_osuf mod_name -- A home-package module
634 | Just mod_info <- lookupUFM hpt mod_name
635 = ASSERT(isJust (hm_linkable mod_info))
636 adjust_linkable (fromJust (hm_linkable mod_info))
638 = do -- It's not in the HPT because we are in one shot mode,
639 -- so use the Finder to get a ModLocation...
640 mb_stuff <- findHomeModule hsc_env mod_name
642 Found loc mod -> found loc mod
646 -- ...and then find the linkable for it
647 mb_lnk <- findObjectLinkableMaybe mod loc ;
649 Nothing -> no_obj mod ;
650 Just lnk -> adjust_linkable lnk
654 | Just osuf <- maybe_normal_osuf = do
655 new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
656 return lnk{ linkableUnlinked=new_uls }
660 adjust_ul osuf (DotO file) = do
661 let new_file = replaceExtension file osuf
662 ok <- doesFileExist new_file
665 ptext SLIT("cannot find normal object file ")
666 <> quotes (text new_file) $$ while_linking_expr
667 else return (DotO new_file)
671 %************************************************************************
674 The linkables may consist of a mixture of
675 byte-code modules and object modules
677 %************************************************************************
680 linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
681 linkModules dflags linkables
682 = block $ do -- don't want to be interrupted by ^C in here
684 let (objs, bcos) = partition isObjectLinkable
685 (concatMap partitionLinkable linkables)
687 -- Load objects first; they can't depend on BCOs
688 ok_flag <- dynLinkObjs dflags objs
690 if failed ok_flag then
697 -- HACK to support f-x-dynamic in the interpreter; no other purpose
698 partitionLinkable :: Linkable -> [Linkable]
700 = let li_uls = linkableUnlinked li
701 li_uls_obj = filter isObject li_uls
702 li_uls_bco = filter isInterpretable li_uls
704 case (li_uls_obj, li_uls_bco) of
705 (objs@(_:_), bcos@(_:_))
706 -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
710 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
711 findModuleLinkable_maybe lis mod
712 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
715 many -> pprPanic "findModuleLinkable" (ppr mod)
717 linkableInSet :: Linkable -> [Linkable] -> Bool
718 linkableInSet l objs_loaded =
719 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
721 Just m -> linkableTime l == linkableTime m
725 %************************************************************************
727 \subsection{The object-code linker}
729 %************************************************************************
732 dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
733 -- Side-effects the PersistentLinkerState
735 dynLinkObjs dflags objs
736 = do pls <- readIORef v_PersistentLinkerState
738 -- Load the object files and link them
739 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
740 pls1 = pls { objs_loaded = objs_loaded' }
741 unlinkeds = concatMap linkableUnlinked new_objs
743 mapM loadObj (map nameOfObject unlinkeds)
745 -- Link the all together
748 -- If resolving failed, unload all our
749 -- object modules and carry on
750 if succeeded ok then do
751 writeIORef v_PersistentLinkerState pls1
754 pls2 <- unload_wkr dflags [] pls1
755 writeIORef v_PersistentLinkerState pls2
759 rmDupLinkables :: [Linkable] -- Already loaded
760 -> [Linkable] -- New linkables
761 -> ([Linkable], -- New loaded set (including new ones)
762 [Linkable]) -- New linkables (excluding dups)
763 rmDupLinkables already ls
766 go already extras [] = (already, extras)
767 go already extras (l:ls)
768 | linkableInSet l already = go already extras ls
769 | otherwise = go (l:already) (l:extras) ls
772 %************************************************************************
774 \subsection{The byte-code linker}
776 %************************************************************************
779 dynLinkBCOs :: [Linkable] -> IO ()
780 -- Side-effects the persistent linker state
782 = do pls <- readIORef v_PersistentLinkerState
784 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
785 pls1 = pls { bcos_loaded = bcos_loaded' }
786 unlinkeds :: [Unlinked]
787 unlinkeds = concatMap linkableUnlinked new_bcos
789 cbcs :: [CompiledByteCode]
790 cbcs = map byteCodeOfObject unlinkeds
793 ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
794 ies = [ie | ByteCode _ ie <- cbcs]
795 gce = closure_env pls
796 final_ie = foldr plusNameEnv (itbl_env pls) ies
798 (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
799 -- What happens to these linked_bcos?
801 let pls2 = pls1 { closure_env = final_gce,
802 itbl_env = final_ie }
804 writeIORef v_PersistentLinkerState pls2
807 -- Link a bunch of BCOs and return them + updated closure env.
808 linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
809 -- True <=> add only toplevel BCOs to closure env
813 -> IO (ClosureEnv, [HValue])
814 -- The returned HValues are associated 1-1 with
815 -- the incoming unlinked BCOs. Each gives the
816 -- value of the corresponding unlinked BCO
818 linkSomeBCOs toplevs_only ie ce_in ul_bcos
819 = do let nms = map unlinkedBCOName ul_bcos
821 ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
822 in mapM (linkBCO ie ce_out) ul_bcos )
823 let ce_all_additions = zip nms hvals
824 ce_top_additions = filter (isExternalName.fst) ce_all_additions
825 ce_additions = if toplevs_only then ce_top_additions
826 else ce_all_additions
827 ce_out = -- make sure we're not inserting duplicate names into the
828 -- closure environment, which leads to trouble.
829 ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
830 extendClosureEnv ce_in ce_additions
831 return (ce_out, hvals)
836 %************************************************************************
838 Unload some object modules
840 %************************************************************************
843 -- ---------------------------------------------------------------------------
844 -- Unloading old objects ready for a new compilation sweep.
846 -- The compilation manager provides us with a list of linkables that it
847 -- considers "stable", i.e. won't be recompiled this time around. For
848 -- each of the modules current linked in memory,
850 -- * if the linkable is stable (and it's the same one - the
851 -- user may have recompiled the module on the side), we keep it,
853 -- * otherwise, we unload it.
855 -- * we also implicitly unload all temporary bindings at this point.
857 unload :: DynFlags -> [Linkable] -> IO ()
858 -- The 'linkables' are the ones to *keep*
860 unload dflags linkables
861 = block $ do -- block, so we're safe from Ctrl-C in here
863 -- Initialise the linker (if it's not been done already)
866 pls <- readIORef v_PersistentLinkerState
867 new_pls <- unload_wkr dflags linkables pls
868 writeIORef v_PersistentLinkerState new_pls
870 debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
871 debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
874 unload_wkr :: DynFlags
875 -> [Linkable] -- stable linkables
876 -> PersistentLinkerState
877 -> IO PersistentLinkerState
878 -- Does the core unload business
879 -- (the wrapper blocks exceptions and deals with the PLS get and put)
881 unload_wkr dflags linkables pls
882 = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
884 objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
885 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
887 let bcos_retained = map linkableModule bcos_loaded'
888 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
889 closure_env' = filterNameMap bcos_retained (closure_env pls)
890 new_pls = pls { itbl_env = itbl_env',
891 closure_env = closure_env',
892 bcos_loaded = bcos_loaded',
893 objs_loaded = objs_loaded' }
897 maybeUnload :: [Linkable] -> Linkable -> IO Bool
898 maybeUnload keep_linkables lnk
899 | linkableInSet lnk linkables = return True
901 = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
902 -- The components of a BCO linkable may contain
903 -- dot-o files. Which is very confusing.
905 -- But the BCO parts can be unlinked just by
906 -- letting go of them (plus of course depopulating
907 -- the symbol table which is done in the main body)
912 %************************************************************************
916 %************************************************************************
921 = Object FilePath -- Full path name of a .o file, including trailing .o
922 -- For dynamic objects only, try to find the object
923 -- file in all the directories specified in
924 -- v_Library_paths before giving up.
926 | DLL String -- "Unadorned" name of a .DLL/.so
927 -- e.g. On unix "qt" denotes "libqt.so"
928 -- On WinDoze "burble" denotes "burble.DLL"
929 -- loadDLL is platform-specific and adds the lib/.so/.DLL
930 -- suffixes platform-dependently
932 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
933 -- (ends with .dll or .so).
935 | Framework String -- Only used for darwin, but does no harm
937 -- If this package is already part of the GHCi binary, we'll already
938 -- have the right DLLs for this package loaded, so don't try to
941 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
942 -- as far as the loader is concerned, but it does initialise the list
943 -- of DLL handles that rts/Linker.c maintains, and that in turn is
944 -- used by lookupSymbol. So we must call addDLL for each library
945 -- just to get the DLL handle into the list.
947 # if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS)
950 = [ "base", "haskell98", "template-haskell", "readline" ]
953 showLS (Object nm) = "(static) " ++ nm
954 showLS (DLL nm) = "(dynamic) " ++ nm
955 showLS (DLLPath nm) = "(dynamic) " ++ nm
956 showLS (Framework nm) = "(framework) " ++ nm
958 linkPackages :: DynFlags -> [PackageId] -> IO ()
959 -- Link exactly the specified packages, and their dependents
960 -- (unless of course they are already linked)
961 -- The dependents are linked automatically, and it doesn't matter
962 -- what order you specify the input packages.
964 -- NOTE: in fact, since each module tracks all the packages it depends on,
965 -- we don't really need to use the package-config dependencies.
966 -- However we do need the package-config stuff (to find aux libs etc),
967 -- and following them lets us load libraries in the right order, which
968 -- perhaps makes the error message a bit more localised if we get a link
969 -- failure. So the dependency walking code is still here.
971 linkPackages dflags new_pkgs
972 = do { pls <- readIORef v_PersistentLinkerState
973 ; let pkg_map = pkgIdMap (pkgState dflags)
975 ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
977 ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
980 link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
981 link pkg_map pkgs new_pkgs
982 = foldM (link_one pkg_map) pkgs new_pkgs
984 link_one pkg_map pkgs new_pkg
985 | new_pkg `elem` pkgs -- Already linked
988 | Just pkg_cfg <- lookupPackage pkg_map new_pkg
989 = do { -- Link dependents first
990 pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
991 -- Now link the package itself
992 ; linkPackage dflags pkg_cfg
993 ; return (new_pkg : pkgs') }
996 = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
999 linkPackage :: DynFlags -> PackageConfig -> IO ()
1000 linkPackage dflags pkg
1002 let dirs = Packages.libraryDirs pkg
1004 let libs = Packages.hsLibraries pkg
1005 -- Because of slight differences between the GHC dynamic linker and
1006 -- the native system linker some packages have to link with a
1007 -- different list of libraries when using GHCi. Examples include: libs
1008 -- that are actually gnu ld scripts, and the possability that the .a
1009 -- libs do not exactly match the .so/.dll equivalents. So if the
1010 -- package file provides an "extra-ghci-libraries" field then we use
1011 -- that instead of the "extra-libraries" field.
1012 ++ (if null (Packages.extraGHCiLibraries pkg)
1013 then Packages.extraLibraries pkg
1014 else Packages.extraGHCiLibraries pkg)
1015 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
1016 classifieds <- mapM (locateOneObj dirs) libs
1018 -- Complication: all the .so's must be loaded before any of the .o's.
1019 let dlls = [ dll | DLL dll <- classifieds ]
1020 objs = [ obj | Object obj <- classifieds ]
1022 maybePutStr dflags ("Loading package " ++ showPackageId (package pkg) ++ " ... ")
1024 -- See comments with partOfGHCi
1025 when (pkgName (package pkg) `notElem` partOfGHCi) $ do
1027 -- When a library A needs symbols from a library B, the order in
1028 -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
1029 -- way ld expects it for static linking. Dynamic linking is a
1030 -- different story: When A has no dependency information for B,
1031 -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
1032 -- when B has not been loaded before. In a nutshell: Reverse the
1033 -- order of DLLs for dynamic linking.
1034 -- This fixes a problem with the HOpenGL package (see "Compiling
1035 -- HOpenGL under recent versions of GHC" on the HOpenGL list).
1036 mapM_ (load_dyn dirs) (reverse dlls)
1038 -- After loading all the DLLs, we can load the static objects.
1039 -- Ordering isn't important here, because we do one final link
1040 -- step to resolve everything.
1043 maybePutStr dflags "linking ... "
1045 if succeeded ok then maybePutStrLn dflags "done."
1046 else throwDyn (InstallationError ("unable to load package `" ++ showPackageId (package pkg) ++ "'"))
1048 load_dyn dirs dll = do r <- loadDynamic dirs dll
1050 Nothing -> return ()
1051 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1052 ++ dll ++ " (" ++ err ++ ")" ))
1053 #ifndef darwin_TARGET_OS
1054 loadFrameworks pkg = return ()
1056 loadFrameworks pkg = mapM_ load frameworks
1058 fw_dirs = Packages.frameworkDirs pkg
1059 frameworks = Packages.frameworks pkg
1061 load fw = do r <- loadFramework fw_dirs fw
1063 Nothing -> return ()
1064 Just err -> throwDyn (CmdLineError ("can't load framework: "
1065 ++ fw ++ " (" ++ err ++ ")" ))
1068 -- Try to find an object file for a given library in the given paths.
1069 -- If it isn't present, we assume it's a dynamic library.
1071 -- When the GHC package was not compiled as dynamic library (=__PIC__ not set),
1072 -- we search for .o libraries first.
1073 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1074 locateOneObj dirs lib
1075 = do { mb_obj_path <- findFile mk_obj_path dirs
1076 ; case mb_obj_path of
1077 Just obj_path -> return (Object obj_path)
1079 do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1080 ; case mb_lib_path of
1081 Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
1082 Nothing -> return (DLL lib) }} -- We assume
1084 mk_obj_path dir = dir </> lib <.> "o"
1085 mk_dyn_lib_path dir = dir </> mkSOName (lib ++ "-ghc" ++ cProjectVersion)
1087 -- When the GHC package was compiled as dynamic library (=__PIC__ set),
1088 -- we search for .so libraries first.
1089 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1090 locateOneObj dirs lib
1091 = do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1092 ; case mb_lib_path of
1093 Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
1095 do { mb_obj_path <- findFile mk_obj_path dirs
1096 ; case mb_obj_path of
1097 Just obj_path -> return (Object obj_path)
1098 Nothing -> return (DLL lib) }} -- We assume
1100 mk_obj_path dir = dir </> (lib <.> "o")
1101 mk_dyn_lib_path dir = dir </> mkSOName (lib ++ "-ghc" ++ cProjectVersion)
1104 -- ----------------------------------------------------------------------------
1105 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1107 -- return Nothing == success, else Just error message from dlopen
1108 loadDynamic paths rootname
1109 = do { mb_dll <- findFile mk_dll_path paths
1111 Just dll -> loadDLL dll
1112 Nothing -> loadDLL (mkSOName rootname) }
1113 -- Tried all our known library paths, so let
1114 -- dlopen() search its own builtin paths now.
1116 mk_dll_path dir = dir </> mkSOName rootname
1118 #if defined(darwin_TARGET_OS)
1119 mkSOName root = ("lib" ++ root) <.> "dylib"
1120 #elif defined(mingw32_TARGET_OS)
1121 -- Win32 DLLs have no .dll extension here, because addDLL tries
1122 -- both foo.dll and foo.drv
1123 mkSOName root = root
1125 mkSOName root = ("lib" ++ root) <.> "so"
1128 -- Darwin / MacOS X only: load a framework
1129 -- a framework is a dynamic library packaged inside a directory of the same
1130 -- name. They are searched for in different paths than normal libraries.
1131 #ifdef darwin_TARGET_OS
1132 loadFramework extraPaths rootname
1133 = do { either_dir <- Control.Exception.try getHomeDirectory
1134 ; let homeFrameworkPath = case either_dir of
1136 Right dir -> [dir ++ "/Library/Frameworks"]
1137 ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
1138 ; mb_fwk <- findFile mk_fwk ps
1140 Just fwk_path -> loadDLL fwk_path
1141 Nothing -> return (Just "not found") }
1142 -- Tried all our known library paths, but dlopen()
1143 -- has no built-in paths for frameworks: give up
1145 mk_fwk dir = dir </> (rootname ++ ".framework/" ++ rootname)
1146 -- sorry for the hardcoded paths, I hope they won't change anytime soon:
1147 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1151 %************************************************************************
1155 %************************************************************************
1158 findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
1159 -> [FilePath] -- Directories to look in
1160 -> IO (Maybe FilePath) -- The first file path to match
1161 findFile mk_file_path []
1163 findFile mk_file_path (dir:dirs)
1164 = do { let file_path = mk_file_path dir
1165 ; b <- doesFileExist file_path
1167 return (Just file_path)
1169 findFile mk_file_path dirs }
1173 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1174 | otherwise = return ()
1176 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1177 | otherwise = return ()