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 {-# OPTIONS -fno-cse #-}
18 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
20 module Linker ( HValue, getHValue, showLinkerState,
21 linkExpr, unload, withExtendedLinkEnv,
22 extendLinkEnv, deleteFromLinkEnv,
24 linkPackages,initDynLinker,
28 #include "HsVersions.h"
46 import qualified OccName
60 import qualified Maybes
64 import Config ( cProjectVersion )
74 import System.FilePath
76 import System.Directory
78 import Distribution.Package hiding (depends, PackageId)
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 _ = 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 <- liftIO $ 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
232 | ghciTablesNextToCode = do
233 offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
234 return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
236 peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
238 -- parsing names is a little bit fiddly because we have a string in the form:
239 -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
240 -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
241 -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
242 -- this is not the conventional way of writing Haskell names. We stick with
243 -- convention, even though it makes the parsing code more troublesome.
244 -- Warning: this code assumes that the string is well formed.
245 parse :: [Word8] -> ([Word8], [Word8], [Word8])
247 = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
249 dot = fromIntegral (ord '.')
250 (pkg, rest1) = break (== fromIntegral (ord ':')) input
252 = (concat $ intersperse [dot] $ reverse modWords, occWord)
254 (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
255 parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
257 = case break (== dot) str of
258 (top, []) -> (acc, top)
259 (top, _:bot) -> parseModOcc (top : acc) bot
262 getHValue :: HscEnv -> Name -> IO HValue
263 getHValue hsc_env name = do
264 when (isExternalName name) $ do
265 ok <- linkDependencies hsc_env noSrcSpan [nameModule name]
266 when (failed ok) $ ghcError (ProgramError "")
267 pls <- readIORef v_PersistentLinkerState
268 lookupName (closure_env pls) name
270 linkDependencies :: HscEnv -> SrcSpan -> [Module] -> IO SuccessFlag
271 linkDependencies hsc_env span needed_mods = do
272 let hpt = hsc_HPT hsc_env
273 dflags = hsc_dflags hsc_env
274 -- The interpreter and dynamic linker can only handle object code built
275 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
276 -- So here we check the build tag: if we're building a non-standard way
277 -- then we need to find & link object files built the "normal" way.
278 maybe_normal_osuf <- checkNonStdWay dflags span
280 -- Find what packages and linkables are required
281 eps <- readIORef (hsc_EPS hsc_env)
282 (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
283 maybe_normal_osuf span needed_mods
285 -- Link the packages and modules required
286 linkPackages dflags pkgs
287 linkModules dflags lnks
290 -- | Temporarily extend the linker state.
292 withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
293 withExtendedLinkEnv new_env action
294 = bracket_ set_new_env
297 where set_new_env = do
298 pls <- readIORef v_PersistentLinkerState
299 let new_closure_env = extendClosureEnv (closure_env pls) new_env
300 new_pls = pls { closure_env = new_closure_env }
301 writeIORef v_PersistentLinkerState new_pls
304 -- Remember that the linker state might be side-effected
305 -- during the execution of the IO action, and we don't want to
306 -- lose those changes (we might have linked a new module or
307 -- package), so the reset action only removes the names we
310 modifyIORef v_PersistentLinkerState $ \pls ->
311 let cur = closure_env pls
312 new = delListFromNameEnv cur (map fst new_env)
314 pls{ closure_env = new }
316 -- filterNameMap removes from the environment all entries except
317 -- those for a given set of modules;
318 -- Note that this removes all *local* (i.e. non-isExternal) names too
319 -- (these are the temporary bindings from the command line).
320 -- Used to filter both the ClosureEnv and ItblEnv
322 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
323 filterNameMap mods env
324 = filterNameEnv keep_elt env
326 keep_elt (n,_) = isExternalName n
327 && (nameModule n `elem` mods)
332 showLinkerState :: IO ()
333 -- Display the persistent linker state
335 = do pls <- readIORef v_PersistentLinkerState
336 printDump (vcat [text "----- Linker state -----",
337 text "Pkgs:" <+> ppr (pkgs_loaded pls),
338 text "Objs:" <+> ppr (objs_loaded pls),
339 text "BCOs:" <+> ppr (bcos_loaded pls)])
345 %************************************************************************
347 \subsection{Initialisation}
349 %************************************************************************
351 We initialise the dynamic linker by
353 a) calling the C initialisation procedure
355 b) Loading any packages specified on the command line,
357 c) Loading any packages specified on the command line,
358 now held in the -l options in v_Opt_l
360 d) Loading any .o/.dll files specified on the command line,
361 now held in v_Ld_inputs
363 e) Loading any MacOS frameworks
366 initDynLinker :: DynFlags -> IO ()
367 -- This function is idempotent; if called more than once, it does nothing
368 -- This is useful in Template Haskell, where we call it before trying to link
370 = do { done <- readIORef v_InitLinkerDone
371 ; if done then return ()
372 else do { writeIORef v_InitLinkerDone True
373 ; reallyInitDynLinker dflags }
376 reallyInitDynLinker :: DynFlags -> IO ()
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 ; let framework_paths
399 | isDarwinTarget = frameworkPaths dflags
402 | isDarwinTarget = cmdlineFrameworks dflags
404 -- Finally do (c),(d),(e)
405 ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
407 ++ map Framework frameworks
408 ; if null cmdline_lib_specs then return ()
411 { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
412 ; maybePutStr dflags "final link ... "
415 ; if succeeded ok then maybePutStrLn dflags "done"
416 else ghcError (InstallationError "linking extra libraries/objects failed")
419 classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
421 | isObjectFilename f = return (Just (Object f))
422 | isDynLibFilename f = return (Just (DLLPath f))
424 hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
427 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
428 preloadLib dflags lib_paths framework_paths lib_spec
429 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
432 -> do b <- preload_static lib_paths static_ish
433 maybePutStrLn dflags (if b then "done"
437 -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
439 Nothing -> maybePutStrLn dflags "done"
440 Just mm -> preloadFailed mm lib_paths lib_spec
443 -> do maybe_errstr <- loadDLL dll_path
445 Nothing -> maybePutStrLn dflags "done"
446 Just mm -> preloadFailed mm lib_paths lib_spec
450 -> do maybe_errstr <- loadFramework framework_paths framework
452 Nothing -> maybePutStrLn dflags "done"
453 Just mm -> preloadFailed mm framework_paths lib_spec
454 | otherwise -> panic "preloadLib Framework"
457 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
458 preloadFailed sys_errmsg paths spec
459 = do maybePutStr dflags "failed.\n"
462 "user specified .o/.so/.DLL could not be loaded ("
463 ++ sys_errmsg ++ ")\nWhilst trying to load: "
464 ++ showLS spec ++ "\nAdditional directories searched:"
465 ++ (if null paths then " (none)" else
466 (concat (intersperse "\n" (map (" "++) paths)))))
468 -- Not interested in the paths in the static case.
469 preload_static _paths name
470 = do b <- doesFileExist name
471 if not b then return False
472 else loadObj name >> return True
476 %************************************************************************
478 Link a byte-code expression
480 %************************************************************************
483 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
485 -- Link a single expression, *including* first linking packages and
486 -- modules that this expression depends on.
488 -- Raises an IO exception if it can't find a compiled version of the
489 -- dependents to link.
491 -- Note: This function side-effects the linker state (Pepe)
493 linkExpr hsc_env span root_ul_bco
495 -- Initialise the linker (if it's not been done already)
496 let dflags = hsc_dflags hsc_env
497 ; initDynLinker dflags
499 -- Link the packages and modules required
500 ; ok <- linkDependencies hsc_env span needed_mods
502 ghcError (ProgramError "")
505 -- Link the expression itself
506 pls <- readIORef v_PersistentLinkerState
507 ; let ie = itbl_env pls
510 -- Link the necessary packages and linkables
511 ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
515 free_names = nameSetToList (bcoFreeNames root_ul_bco)
517 needed_mods :: [Module]
518 needed_mods = [ nameModule n | n <- free_names,
519 isExternalName n, -- Names from other modules
520 not (isWiredInName n) -- Exclude wired-in names
521 ] -- (see note below)
522 -- Exclude wired-in names because we may not have read
523 -- their interface files, so getLinkDeps will fail
524 -- All wired-in names are in the base package, which we link
525 -- by default, so we can safely ignore them here.
527 dieWith :: SrcSpan -> Message -> IO a
528 dieWith span msg = ghcError (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 -> IO (Maybe String)
541 failNonStd srcspan = dieWith srcspan $
542 ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$
543 ptext (sLit "You need to build the program twice: once the normal way, and then") $$
544 ptext (sLit "in the desired way using -osuf to set the object file suffix.")
547 getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable
548 -> Maybe String -- the "normal" object suffix
549 -> SrcSpan -- for error messages
550 -> [Module] -- If you need these
551 -> IO ([Linkable], [PackageId]) -- ... then link these first
552 -- Fails with an IO exception if it can't find enough files
554 getLinkDeps hsc_env hpt _ maybe_normal_osuf span mods
555 -- Find all the packages and linkables that a set of modules depends on
556 = 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;
561 -- 2. Exclude ones already linked
562 -- Main reason: avoid findModule calls in get_linkable
563 mods_needed = mods_s `minusList` linked_mods ;
564 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
566 linked_mods = map (moduleName.linkableModule)
567 (objs_loaded pls ++ bcos_loaded pls)
570 -- putStrLn (showSDoc (ppr mods_s)) ;
571 -- 3. For each dependent module, find its linkable
572 -- This will either be in the HPT or (in the case of one-shot
573 -- compilation) we may need to use maybe_getFileLinkable
574 lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
576 return (lnks_needed, pkgs_needed) }
578 dflags = hsc_dflags hsc_env
579 this_pkg = thisPackage dflags
581 -- The ModIface contains the transitive closure of the module dependencies
582 -- within the current package, *except* for boot modules: if we encounter
583 -- a boot module, we have to find its real interface and discover the
584 -- dependencies of that. Hence we need to traverse the dependency
585 -- tree recursively. See bug #936, testcase ghci/prog007.
586 follow_deps :: [Module] -- modules to follow
587 -> UniqSet ModuleName -- accum. module dependencies
588 -> UniqSet PackageId -- accum. package dependencies
589 -> IO ([ModuleName], [PackageId]) -- result
590 follow_deps [] acc_mods acc_pkgs
591 = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
592 follow_deps (mod:mods) acc_mods acc_pkgs
594 mb_iface <- initIfaceCheck hsc_env $
595 loadInterface msg mod (ImportByUser False)
596 iface <- case mb_iface of
597 Maybes.Failed err -> ghcError (ProgramError (showSDoc err))
598 Maybes.Succeeded iface -> return iface
600 when (mi_boot iface) $ link_boot_mod_error mod
603 pkg = modulePackageId mod
606 pkg_deps = dep_pkgs deps
607 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
608 where is_boot (m,True) = Left m
609 is_boot (m,False) = Right m
611 boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
612 acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
613 acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
616 then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
617 else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)
620 msg = text "need to link module" <+> ppr mod <+>
621 text "due to use of Template Haskell"
624 link_boot_mod_error mod =
625 ghcError (ProgramError (showSDoc (
626 text "module" <+> ppr mod <+>
627 text "cannot be linked; it is only available as a boot module")))
629 no_obj mod = dieWith span $
630 ptext (sLit "cannot find object file for module ") <>
634 while_linking_expr = ptext (sLit "while linking an interpreted expression")
636 -- This one is a build-system bug
638 get_linkable maybe_normal_osuf mod_name -- A home-package module
639 | Just mod_info <- lookupUFM hpt mod_name
640 = ASSERT(isJust (hm_linkable mod_info))
641 adjust_linkable (fromJust (hm_linkable mod_info))
643 = do -- It's not in the HPT because we are in one shot mode,
644 -- so use the Finder to get a ModLocation...
645 mb_stuff <- findHomeModule hsc_env mod_name
647 Found loc mod -> found loc mod
651 -- ...and then find the linkable for it
652 mb_lnk <- findObjectLinkableMaybe mod loc ;
654 Nothing -> no_obj mod ;
655 Just lnk -> adjust_linkable lnk
659 | Just osuf <- maybe_normal_osuf = do
660 new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
661 return lnk{ linkableUnlinked=new_uls }
665 adjust_ul osuf (DotO file) = do
666 let new_file = replaceExtension file osuf
667 ok <- doesFileExist new_file
670 ptext (sLit "cannot find normal object file ")
671 <> quotes (text new_file) $$ while_linking_expr
672 else return (DotO new_file)
673 adjust_ul _ _ = panic "adjust_ul"
677 %************************************************************************
680 The linkables may consist of a mixture of
681 byte-code modules and object modules
683 %************************************************************************
686 linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
687 linkModules dflags linkables
688 = block $ do -- don't want to be interrupted by ^C in here
690 let (objs, bcos) = partition isObjectLinkable
691 (concatMap partitionLinkable linkables)
693 -- Load objects first; they can't depend on BCOs
694 ok_flag <- dynLinkObjs dflags objs
696 if failed ok_flag then
703 -- HACK to support f-x-dynamic in the interpreter; no other purpose
704 partitionLinkable :: Linkable -> [Linkable]
706 = let li_uls = linkableUnlinked li
707 li_uls_obj = filter isObject li_uls
708 li_uls_bco = filter isInterpretable li_uls
710 case (li_uls_obj, li_uls_bco) of
711 (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
712 li {linkableUnlinked=li_uls_bco}]
715 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
716 findModuleLinkable_maybe lis mod
717 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
720 _ -> pprPanic "findModuleLinkable" (ppr mod)
722 linkableInSet :: Linkable -> [Linkable] -> Bool
723 linkableInSet l objs_loaded =
724 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
726 Just m -> linkableTime l == linkableTime m
730 %************************************************************************
732 \subsection{The object-code linker}
734 %************************************************************************
737 dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
738 -- Side-effects the PersistentLinkerState
740 dynLinkObjs dflags objs
741 = do pls <- readIORef v_PersistentLinkerState
743 -- Load the object files and link them
744 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
745 pls1 = pls { objs_loaded = objs_loaded' }
746 unlinkeds = concatMap linkableUnlinked new_objs
748 mapM loadObj (map nameOfObject unlinkeds)
750 -- Link the all together
753 -- If resolving failed, unload all our
754 -- object modules and carry on
755 if succeeded ok then do
756 writeIORef v_PersistentLinkerState pls1
759 pls2 <- unload_wkr dflags [] pls1
760 writeIORef v_PersistentLinkerState pls2
764 rmDupLinkables :: [Linkable] -- Already loaded
765 -> [Linkable] -- New linkables
766 -> ([Linkable], -- New loaded set (including new ones)
767 [Linkable]) -- New linkables (excluding dups)
768 rmDupLinkables already ls
771 go already extras [] = (already, extras)
772 go already extras (l:ls)
773 | linkableInSet l already = go already extras ls
774 | otherwise = go (l:already) (l:extras) ls
777 %************************************************************************
779 \subsection{The byte-code linker}
781 %************************************************************************
784 dynLinkBCOs :: [Linkable] -> IO ()
785 -- Side-effects the persistent linker state
787 = do pls <- readIORef v_PersistentLinkerState
789 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
790 pls1 = pls { bcos_loaded = bcos_loaded' }
791 unlinkeds :: [Unlinked]
792 unlinkeds = concatMap linkableUnlinked new_bcos
794 cbcs :: [CompiledByteCode]
795 cbcs = map byteCodeOfObject unlinkeds
798 ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
799 ies = [ie | ByteCode _ ie <- cbcs]
800 gce = closure_env pls
801 final_ie = foldr plusNameEnv (itbl_env pls) ies
803 (final_gce, _linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
804 -- XXX What happens to these linked_bcos?
806 let pls2 = pls1 { closure_env = final_gce,
807 itbl_env = final_ie }
809 writeIORef v_PersistentLinkerState pls2
812 -- Link a bunch of BCOs and return them + updated closure env.
813 linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
814 -- True <=> add only toplevel BCOs to closure env
818 -> IO (ClosureEnv, [HValue])
819 -- The returned HValues are associated 1-1 with
820 -- the incoming unlinked BCOs. Each gives the
821 -- value of the corresponding unlinked BCO
823 linkSomeBCOs toplevs_only ie ce_in ul_bcos
824 = do let nms = map unlinkedBCOName ul_bcos
826 ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
827 in mapM (linkBCO ie ce_out) ul_bcos )
828 let ce_all_additions = zip nms hvals
829 ce_top_additions = filter (isExternalName.fst) ce_all_additions
830 ce_additions = if toplevs_only then ce_top_additions
831 else ce_all_additions
832 ce_out = -- make sure we're not inserting duplicate names into the
833 -- closure environment, which leads to trouble.
834 ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
835 extendClosureEnv ce_in ce_additions
836 return (ce_out, hvals)
841 %************************************************************************
843 Unload some object modules
845 %************************************************************************
848 -- ---------------------------------------------------------------------------
849 -- Unloading old objects ready for a new compilation sweep.
851 -- The compilation manager provides us with a list of linkables that it
852 -- considers "stable", i.e. won't be recompiled this time around. For
853 -- each of the modules current linked in memory,
855 -- * if the linkable is stable (and it's the same one - the
856 -- user may have recompiled the module on the side), we keep it,
858 -- * otherwise, we unload it.
860 -- * we also implicitly unload all temporary bindings at this point.
862 unload :: DynFlags -> [Linkable] -> IO ()
863 -- The 'linkables' are the ones to *keep*
865 unload dflags linkables
866 = block $ do -- block, so we're safe from Ctrl-C in here
868 -- Initialise the linker (if it's not been done already)
871 pls <- readIORef v_PersistentLinkerState
872 new_pls <- unload_wkr dflags linkables pls
873 writeIORef v_PersistentLinkerState new_pls
875 debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
876 debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
879 unload_wkr :: DynFlags
880 -> [Linkable] -- stable linkables
881 -> PersistentLinkerState
882 -> IO PersistentLinkerState
883 -- Does the core unload business
884 -- (the wrapper blocks exceptions and deals with the PLS get and put)
886 unload_wkr _ linkables pls
887 = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
889 objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
890 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
892 let bcos_retained = map linkableModule bcos_loaded'
893 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
894 closure_env' = filterNameMap bcos_retained (closure_env pls)
895 new_pls = pls { itbl_env = itbl_env',
896 closure_env = closure_env',
897 bcos_loaded = bcos_loaded',
898 objs_loaded = objs_loaded' }
902 maybeUnload :: [Linkable] -> Linkable -> IO Bool
903 maybeUnload keep_linkables lnk
904 | linkableInSet lnk keep_linkables = return True
906 = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
907 -- The components of a BCO linkable may contain
908 -- dot-o files. Which is very confusing.
910 -- But the BCO parts can be unlinked just by
911 -- letting go of them (plus of course depopulating
912 -- the symbol table which is done in the main body)
917 %************************************************************************
921 %************************************************************************
926 = Object FilePath -- Full path name of a .o file, including trailing .o
927 -- For dynamic objects only, try to find the object
928 -- file in all the directories specified in
929 -- v_Library_paths before giving up.
931 | DLL String -- "Unadorned" name of a .DLL/.so
932 -- e.g. On unix "qt" denotes "libqt.so"
933 -- On WinDoze "burble" denotes "burble.DLL"
934 -- loadDLL is platform-specific and adds the lib/.so/.DLL
935 -- suffixes platform-dependently
937 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
938 -- (ends with .dll or .so).
940 | Framework String -- Only used for darwin, but does no harm
942 -- If this package is already part of the GHCi binary, we'll already
943 -- have the right DLLs for this package loaded, so don't try to
946 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
947 -- as far as the loader is concerned, but it does initialise the list
948 -- of DLL handles that rts/Linker.c maintains, and that in turn is
949 -- used by lookupSymbol. So we must call addDLL for each library
950 -- just to get the DLL handle into the list.
951 partOfGHCi :: [PackageName]
953 | isWindowsTarget || isDarwinTarget = []
954 | otherwise = map PackageName
955 ["base", "haskell98", "template-haskell", "editline"]
957 showLS :: LibrarySpec -> String
958 showLS (Object nm) = "(static) " ++ nm
959 showLS (DLL nm) = "(dynamic) " ++ nm
960 showLS (DLLPath nm) = "(dynamic) " ++ nm
961 showLS (Framework nm) = "(framework) " ++ nm
963 linkPackages :: DynFlags -> [PackageId] -> IO ()
964 -- Link exactly the specified packages, and their dependents
965 -- (unless of course they are already linked)
966 -- The dependents are linked automatically, and it doesn't matter
967 -- what order you specify the input packages.
969 -- NOTE: in fact, since each module tracks all the packages it depends on,
970 -- we don't really need to use the package-config dependencies.
971 -- However we do need the package-config stuff (to find aux libs etc),
972 -- and following them lets us load libraries in the right order, which
973 -- perhaps makes the error message a bit more localised if we get a link
974 -- failure. So the dependency walking code is still here.
976 linkPackages dflags new_pkgs
977 = do { pls <- readIORef v_PersistentLinkerState
978 ; let pkg_map = pkgIdMap (pkgState dflags)
980 ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
982 ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
985 link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
986 link pkg_map pkgs new_pkgs
987 = foldM (link_one pkg_map) pkgs new_pkgs
989 link_one pkg_map pkgs new_pkg
990 | new_pkg `elem` pkgs -- Already linked
993 | Just pkg_cfg <- lookupPackage pkg_map new_pkg
994 = do { -- Link dependents first
995 pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
996 -- Now link the package itself
997 ; linkPackage dflags pkg_cfg
998 ; return (new_pkg : pkgs') }
1001 = ghcError (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
1004 linkPackage :: DynFlags -> PackageConfig -> IO ()
1005 linkPackage dflags pkg
1007 let dirs = Packages.libraryDirs pkg
1009 let libs = Packages.hsLibraries pkg
1010 -- Because of slight differences between the GHC dynamic linker and
1011 -- the native system linker some packages have to link with a
1012 -- different list of libraries when using GHCi. Examples include: libs
1013 -- that are actually gnu ld scripts, and the possability that the .a
1014 -- libs do not exactly match the .so/.dll equivalents. So if the
1015 -- package file provides an "extra-ghci-libraries" field then we use
1016 -- that instead of the "extra-libraries" field.
1017 ++ (if null (Packages.extraGHCiLibraries pkg)
1018 then Packages.extraLibraries pkg
1019 else Packages.extraGHCiLibraries pkg)
1020 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
1021 classifieds <- mapM (locateOneObj dirs) libs
1023 -- Complication: all the .so's must be loaded before any of the .o's.
1024 let dlls = [ dll | DLL dll <- classifieds ]
1025 objs = [ obj | Object obj <- classifieds ]
1027 maybePutStr dflags ("Loading package " ++ display (package pkg) ++ " ... ")
1029 -- See comments with partOfGHCi
1030 when (packageName pkg `notElem` partOfGHCi) $ do
1032 -- When a library A needs symbols from a library B, the order in
1033 -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
1034 -- way ld expects it for static linking. Dynamic linking is a
1035 -- different story: When A has no dependency information for B,
1036 -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
1037 -- when B has not been loaded before. In a nutshell: Reverse the
1038 -- order of DLLs for dynamic linking.
1039 -- This fixes a problem with the HOpenGL package (see "Compiling
1040 -- HOpenGL under recent versions of GHC" on the HOpenGL list).
1041 mapM_ (load_dyn dirs) (reverse dlls)
1043 -- After loading all the DLLs, we can load the static objects.
1044 -- Ordering isn't important here, because we do one final link
1045 -- step to resolve everything.
1048 maybePutStr dflags "linking ... "
1050 if succeeded ok then maybePutStrLn dflags "done."
1051 else ghcError (InstallationError ("unable to load package `" ++ display (package pkg) ++ "'"))
1053 load_dyn :: [FilePath] -> FilePath -> IO ()
1054 load_dyn dirs dll = do r <- loadDynamic dirs dll
1056 Nothing -> return ()
1057 Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: "
1058 ++ dll ++ " (" ++ err ++ ")" ))
1060 loadFrameworks :: InstalledPackageInfo_ ModuleName -> IO ()
1062 | isDarwinTarget = mapM_ load frameworks
1063 | otherwise = return ()
1065 fw_dirs = Packages.frameworkDirs pkg
1066 frameworks = Packages.frameworks pkg
1068 load fw = do r <- loadFramework fw_dirs fw
1070 Nothing -> return ()
1071 Just err -> ghcError (CmdLineError ("can't load framework: "
1072 ++ fw ++ " (" ++ err ++ ")" ))
1074 -- Try to find an object file for a given library in the given paths.
1075 -- If it isn't present, we assume it's a dynamic library.
1076 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1077 locateOneObj dirs lib
1079 -- When the GHC package was not compiled as dynamic library
1080 -- (=__PIC__ not set), we search for .o libraries first.
1081 = do { mb_obj_path <- findFile mk_obj_path dirs
1082 ; case mb_obj_path of
1083 Just obj_path -> return (Object obj_path)
1085 do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1086 ; case mb_lib_path of
1087 Just _ -> return (DLL dyn_lib_name)
1088 Nothing -> return (DLL lib) }} -- We assume
1090 -- When the GHC package was compiled as dynamic library (=__PIC__ set),
1091 -- we search for .so libraries first.
1092 = do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1093 ; case mb_lib_path of
1094 Just _ -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
1096 do { mb_obj_path <- findFile mk_obj_path dirs
1097 ; case mb_obj_path of
1098 Just obj_path -> return (Object obj_path)
1099 Nothing -> return (DLL lib) }} -- We assume
1101 mk_obj_path dir = dir </> (lib <.> "o")
1102 dyn_lib_name = lib ++ "-ghc" ++ cProjectVersion
1103 mk_dyn_lib_path dir = dir </> mkSOName dyn_lib_name
1105 -- ----------------------------------------------------------------------------
1106 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1108 -- return Nothing == success, else Just error message from dlopen
1109 loadDynamic :: [FilePath] -> FilePath -> IO (Maybe String)
1110 loadDynamic paths rootname
1111 = do { mb_dll <- findFile mk_dll_path paths
1113 Just dll -> loadDLL dll
1114 Nothing -> loadDLL (mkSOName rootname) }
1115 -- Tried all our known library paths, so let
1116 -- dlopen() search its own builtin paths now.
1118 mk_dll_path dir = dir </> mkSOName rootname
1120 mkSOName :: FilePath -> FilePath
1122 | isDarwinTarget = ("lib" ++ root) <.> "dylib"
1123 | isWindowsTarget = -- Win32 DLLs have no .dll extension here, because
1124 -- addDLL tries both foo.dll and foo.drv
1126 | otherwise = ("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 loadFramework :: [FilePath] -> FilePath -> IO (Maybe String)
1132 loadFramework extraPaths rootname
1133 = do { either_dir <- tryIO 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"]
1150 %************************************************************************
1154 %************************************************************************
1157 findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
1158 -> [FilePath] -- Directories to look in
1159 -> IO (Maybe FilePath) -- The first file path to match
1162 findFile mk_file_path (dir:dirs)
1163 = do { let file_path = mk_file_path dir
1164 ; b <- doesFileExist file_path
1166 return (Just file_path)
1168 findFile mk_file_path dirs }
1172 maybePutStr :: DynFlags -> String -> IO ()
1173 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1174 | otherwise = return ()
1176 maybePutStrLn :: DynFlags -> String -> IO ()
1177 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1178 | otherwise = return ()