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, withExtendedLinkEnv,
19 extendLinkEnv, deleteFromLinkEnv,
21 linkPackages,initDynLinker,
25 #include "HsVersions.h"
42 import qualified OccName
69 import System.Directory
71 import Control.Exception
76 %************************************************************************
80 %************************************************************************
82 The persistent linker state *must* match the actual state of the
83 C dynamic linker at all times, so we keep it in a private global variable.
86 The PersistentLinkerState maps Names to actual closures (for
87 interpreted code only), for use during linking.
90 GLOBAL_VAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState)
91 GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
93 data PersistentLinkerState
94 = PersistentLinkerState {
96 -- Current global mapping from Names to their true values
97 closure_env :: ClosureEnv,
99 -- The current global mapping from RdrNames of DataCons to
100 -- info table addresses.
101 -- When a new Unlinked is linked into the running image, or an existing
102 -- module in the image is replaced, the itbl_env must be updated
106 -- The currently loaded interpreted modules (home package)
107 bcos_loaded :: [Linkable],
109 -- And the currently-loaded compiled modules (home package)
110 objs_loaded :: [Linkable],
112 -- The currently-loaded packages; always object code
113 -- Held, as usual, in dependency order; though I am not sure if
114 -- that is really important
115 pkgs_loaded :: [PackageId]
118 emptyPLS :: DynFlags -> PersistentLinkerState
119 emptyPLS dflags = PersistentLinkerState {
120 closure_env = emptyNameEnv,
121 itbl_env = emptyNameEnv,
122 pkgs_loaded = init_pkgs,
126 -- Packages that don't need loading, because the compiler
127 -- shares them with the interpreted program.
129 -- The linker's symbol table is populated with RTS symbols using an
130 -- explicit list. See rts/Linker.c for details.
131 where init_pkgs = [rtsPackageId]
135 extendLoadedPkgs :: [PackageId] -> IO ()
136 extendLoadedPkgs pkgs
137 = modifyIORef v_PersistentLinkerState (\s -> s{pkgs_loaded = pkgs ++ pkgs_loaded s})
139 extendLinkEnv :: [(Name,HValue)] -> IO ()
140 -- Automatically discards shadowed bindings
141 extendLinkEnv new_bindings
142 = do pls <- readIORef v_PersistentLinkerState
143 let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
144 new_pls = pls { closure_env = new_closure_env }
145 writeIORef v_PersistentLinkerState new_pls
147 deleteFromLinkEnv :: [Name] -> IO ()
148 deleteFromLinkEnv to_remove
149 = do pls <- readIORef v_PersistentLinkerState
150 let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
151 new_pls = pls { closure_env = new_closure_env }
152 writeIORef v_PersistentLinkerState new_pls
154 -- | Given a data constructor in the heap, find its Name.
155 -- The info tables for data constructors have a field which records
156 -- the source name of the constructor as a Ptr Word8 (UTF-8 encoded
157 -- string). The format is:
159 -- Package:Module.Name
161 -- We use this string to lookup the interpreter's internal representation of the name
162 -- using the lookupOrig.
164 dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
165 dataConInfoPtrToName x = do
166 theString <- ioToTcRn $ do
167 let ptr = castPtr x :: Ptr StgInfoTable
168 conDescAddress <- getConDescAddress ptr
169 peekArray0 0 conDescAddress
170 let (pkg, mod, occ) = parse theString
171 pkgFS = mkFastStringByteList pkg
172 modFS = mkFastStringByteList mod
173 occFS = mkFastStringByteList occ
174 occName = mkOccNameFS OccName.dataName occFS
175 modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS)
176 return (Left$ showSDoc$ ppr modName <> dot <> ppr occName )
177 `recoverM` (Right `fmap` lookupOrig modName occName)
181 {- To find the string in the constructor's info table we need to consider
182 the layout of info tables relative to the entry code for a closure.
184 An info table can be next to the entry code for the closure, or it can
185 be separate. The former (faster) is used in registerised versions of ghc,
186 and the latter (portable) is for non-registerised versions.
188 The diagrams below show where the string is to be found relative to
189 the normal info table of the closure.
191 1) Code next to table:
194 | | <- pointer to the start of the string
196 | | <- the (start of the) info table structure
203 In this case the pointer to the start of the string can be found in
204 the memory location _one word before_ the first entry in the normal info
207 2) Code NOT next to table:
210 info table structure -> | *------------------> --------------
214 ptr to start of str -> | |
217 In this case the pointer to the start of the string can be found
218 in the memory location: info_table_ptr + info_table_size
221 getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
222 getConDescAddress ptr = do
223 #ifdef GHCI_TABLES_NEXT_TO_CODE
224 offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
225 return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
227 peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
230 -- parsing names is a little bit fiddly because we have a string in the form:
231 -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
232 -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
233 -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
234 -- this is not the conventional way of writing Haskell names. We stick with
235 -- convention, even though it makes the parsing code more troublesome.
236 -- Warning: this code assumes that the string is well formed.
237 parse :: [Word8] -> ([Word8], [Word8], [Word8])
239 = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
241 dot = fromIntegral (ord '.')
242 (pkg, rest1) = break (== fromIntegral (ord ':')) input
244 = (concat $ intersperse [dot] $ reverse modWords, occWord)
246 (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
247 parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
249 = case break (== dot) str of
250 (top, []) -> (acc, top)
251 (top, _:bot) -> parseModOcc (top : acc) bot
254 getHValue :: HscEnv -> Name -> IO HValue
255 getHValue hsc_env name = do
256 when (isExternalName name) $ do
257 ok <- linkDependencies hsc_env noSrcSpan [nameModule name]
258 when (failed ok) $ throwDyn (ProgramError "")
259 pls <- readIORef v_PersistentLinkerState
260 lookupName (closure_env pls) name
262 linkDependencies :: HscEnv -> SrcSpan -> [Module] -> IO SuccessFlag
263 linkDependencies hsc_env span needed_mods = do
264 let hpt = hsc_HPT hsc_env
265 dflags = hsc_dflags hsc_env
266 -- The interpreter and dynamic linker can only handle object code built
267 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
268 -- So here we check the build tag: if we're building a non-standard way
269 -- then we need to find & link object files built the "normal" way.
270 maybe_normal_osuf <- checkNonStdWay dflags span
272 -- Find what packages and linkables are required
273 eps <- readIORef (hsc_EPS hsc_env)
274 (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
275 maybe_normal_osuf span needed_mods
277 -- Link the packages and modules required
278 linkPackages dflags pkgs
279 linkModules dflags lnks
282 -- | Temporarily extend the linker state.
284 withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
285 withExtendedLinkEnv new_env action
286 = bracket set_new_env
289 where set_new_env = do
290 pls <- readIORef v_PersistentLinkerState
291 let new_closure_env = extendClosureEnv (closure_env pls) new_env
292 new_pls = pls { closure_env = new_closure_env }
293 writeIORef v_PersistentLinkerState new_pls
294 return (closure_env pls)
296 -- Remember that the linker state might be side-effected
297 -- during the execution of the IO action, and we don't want to
298 -- lose those changes (we might have linked a new module or
299 -- package), so the reset action only removes the names we
301 reset_old_env env = do
302 modifyIORef v_PersistentLinkerState $ \pls ->
303 let cur = closure_env pls
304 new = delListFromNameEnv cur (map fst new_env)
306 pls{ closure_env = new }
308 -- filterNameMap removes from the environment all entries except
309 -- those for a given set of modules;
310 -- Note that this removes all *local* (i.e. non-isExternal) names too
311 -- (these are the temporary bindings from the command line).
312 -- Used to filter both the ClosureEnv and ItblEnv
314 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
315 filterNameMap mods env
316 = filterNameEnv keep_elt env
318 keep_elt (n,_) = isExternalName n
319 && (nameModule n `elem` mods)
324 showLinkerState :: IO ()
325 -- Display the persistent linker state
327 = do pls <- readIORef v_PersistentLinkerState
328 printDump (vcat [text "----- Linker state -----",
329 text "Pkgs:" <+> ppr (pkgs_loaded pls),
330 text "Objs:" <+> ppr (objs_loaded pls),
331 text "BCOs:" <+> ppr (bcos_loaded pls)])
337 %************************************************************************
339 \subsection{Initialisation}
341 %************************************************************************
343 We initialise the dynamic linker by
345 a) calling the C initialisation procedure
347 b) Loading any packages specified on the command line,
349 c) Loading any packages specified on the command line,
350 now held in the -l options in v_Opt_l
352 d) Loading any .o/.dll files specified on the command line,
353 now held in v_Ld_inputs
355 e) Loading any MacOS frameworks
358 initDynLinker :: DynFlags -> IO ()
359 -- This function is idempotent; if called more than once, it does nothing
360 -- This is useful in Template Haskell, where we call it before trying to link
362 = do { done <- readIORef v_InitLinkerDone
363 ; if done then return ()
364 else do { writeIORef v_InitLinkerDone True
365 ; reallyInitDynLinker dflags }
368 reallyInitDynLinker dflags
369 = do { -- Initialise the linker state
370 ; writeIORef v_PersistentLinkerState (emptyPLS dflags)
372 -- (a) initialise the C dynamic linker
375 -- (b) Load packages from the command-line
376 ; linkPackages dflags (preloadPackages (pkgState dflags))
378 -- (c) Link libraries from the command-line
379 ; let optl = getOpts dflags opt_l
380 ; let minus_ls = [ lib | '-':'l':lib <- optl ]
382 -- (d) Link .o files from the command-line
383 ; let lib_paths = libraryPaths dflags
384 ; cmdline_ld_inputs <- readIORef v_Ld_inputs
386 ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
388 -- (e) Link any MacOS frameworks
389 #ifdef darwin_TARGET_OS
390 ; let framework_paths = frameworkPaths dflags
391 ; let frameworks = cmdlineFrameworks dflags
393 ; let frameworks = []
394 ; let framework_paths = []
396 -- Finally do (c),(d),(e)
397 ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
399 ++ map Framework frameworks
400 ; if null cmdline_lib_specs then return ()
403 { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
404 ; maybePutStr dflags "final link ... "
407 ; if succeeded ok then maybePutStrLn dflags "done"
408 else throwDyn (InstallationError "linking extra libraries/objects failed")
411 classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
413 | isObjectFilename f = return (Just (Object f))
414 | isDynLibFilename f = return (Just (DLLPath f))
416 hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
419 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
420 preloadLib dflags lib_paths framework_paths lib_spec
421 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
424 -> do b <- preload_static lib_paths static_ish
425 maybePutStrLn dflags (if b then "done"
429 -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
431 Nothing -> maybePutStrLn dflags "done"
432 Just mm -> preloadFailed mm lib_paths lib_spec
435 -> do maybe_errstr <- loadDLL dll_path
437 Nothing -> maybePutStrLn dflags "done"
438 Just mm -> preloadFailed mm lib_paths lib_spec
440 #ifdef darwin_TARGET_OS
442 -> do maybe_errstr <- loadFramework framework_paths framework
444 Nothing -> maybePutStrLn dflags "done"
445 Just mm -> preloadFailed mm framework_paths lib_spec
448 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
449 preloadFailed sys_errmsg paths spec
450 = do maybePutStr dflags
451 ("failed.\nDynamic linker error message was:\n "
452 ++ sys_errmsg ++ "\nWhilst trying to load: "
453 ++ showLS spec ++ "\nDirectories to search are:\n"
454 ++ unlines (map (" "++) paths) )
457 -- Not interested in the paths in the static case.
458 preload_static paths name
459 = do b <- doesFileExist name
460 if not b then return False
461 else loadObj name >> return True
464 CmdLineError "user specified .o/.so/.DLL could not be loaded."
468 %************************************************************************
470 Link a byte-code expression
472 %************************************************************************
475 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
477 -- Link a single expression, *including* first linking packages and
478 -- modules that this expression depends on.
480 -- Raises an IO exception if it can't find a compiled version of the
481 -- dependents to link.
483 -- Note: This function side-effects the linker state (Pepe)
485 linkExpr hsc_env span root_ul_bco
487 -- Initialise the linker (if it's not been done already)
488 let dflags = hsc_dflags hsc_env
489 ; initDynLinker dflags
491 -- Link the packages and modules required
492 ; ok <- linkDependencies hsc_env span needed_mods
494 throwDyn (ProgramError "")
497 -- Link the expression itself
498 pls <- readIORef v_PersistentLinkerState
499 ; let ie = itbl_env pls
502 -- Link the necessary packages and linkables
503 ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
507 free_names = nameSetToList (bcoFreeNames root_ul_bco)
509 needed_mods :: [Module]
510 needed_mods = [ nameModule n | n <- free_names,
511 isExternalName n, -- Names from other modules
512 not (isWiredInName n) -- Exclude wired-in names
513 ] -- (see note below)
514 -- Exclude wired-in names because we may not have read
515 -- their interface files, so getLinkDeps will fail
516 -- All wired-in names are in the base package, which we link
517 -- by default, so we can safely ignore them here.
519 dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg)))
522 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
523 checkNonStdWay dflags srcspan = do
524 tag <- readIORef v_Build_tag
525 if null tag then return Nothing else do
526 let default_osuf = phaseInputExt StopLn
527 if objectSuf dflags == default_osuf
528 then failNonStd srcspan
529 else return (Just default_osuf)
531 failNonStd srcspan = dieWith srcspan $
532 ptext SLIT("Dynamic linking required, but this is a non-standard build (eg. prof).") $$
533 ptext SLIT("You need to build the program twice: once the normal way, and then") $$
534 ptext SLIT("in the desired way using -osuf to set the object file suffix.")
537 getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable
538 -> Maybe String -- the "normal" object suffix
539 -> SrcSpan -- for error messages
540 -> [Module] -- If you need these
541 -> IO ([Linkable], [PackageId]) -- ... then link these first
542 -- Fails with an IO exception if it can't find enough files
544 getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
545 -- Find all the packages and linkables that a set of modules depends on
546 = do { pls <- readIORef v_PersistentLinkerState ;
548 -- 1. Find the dependent home-pkg-modules/packages from each iface
549 (mods_s, pkgs_s) = follow_deps mods emptyUniqSet emptyUniqSet;
551 -- 2. Exclude ones already linked
552 -- Main reason: avoid findModule calls in get_linkable
553 mods_needed = mods_s `minusList` linked_mods ;
554 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
556 linked_mods = map (moduleName.linkableModule)
557 (objs_loaded pls ++ bcos_loaded pls)
560 -- putStrLn (showSDoc (ppr mods_s)) ;
561 -- 3. For each dependent module, find its linkable
562 -- This will either be in the HPT or (in the case of one-shot
563 -- compilation) we may need to use maybe_getFileLinkable
564 lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
566 return (lnks_needed, pkgs_needed) }
568 dflags = hsc_dflags hsc_env
569 this_pkg = thisPackage dflags
571 -- The ModIface contains the transitive closure of the module dependencies
572 -- within the current package, *except* for boot modules: if we encounter
573 -- a boot module, we have to find its real interface and discover the
574 -- dependencies of that. Hence we need to traverse the dependency
575 -- tree recursively. See bug #936, testcase ghci/prog007.
576 follow_deps :: [Module] -- modules to follow
577 -> UniqSet ModuleName -- accum. module dependencies
578 -> UniqSet PackageId -- accum. package dependencies
579 -> ([ModuleName], [PackageId]) -- result
580 follow_deps [] acc_mods acc_pkgs
581 = (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
582 follow_deps (mod:mods) acc_mods acc_pkgs
584 = follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
586 = link_boot_mod_error mod
588 = follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) acc_mods' acc_pkgs'
590 pkg = modulePackageId mod
591 iface = get_iface mod
594 pkg_deps = dep_pkgs deps
595 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
596 where is_boot (m,True) = Left m
597 is_boot (m,False) = Right m
599 boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
600 acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
601 acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
604 link_boot_mod_error mod =
605 throwDyn (ProgramError (showSDoc (
606 text "module" <+> ppr mod <+>
607 text "cannot be linked; it is only available as a boot module")))
609 get_iface mod = case lookupIfaceByModule dflags hpt pit mod of
611 Nothing -> pprPanic "getLinkDeps" (no_iface mod)
612 no_iface mod = ptext SLIT("No iface for") <+> ppr mod
613 -- This one is a GHC bug
615 no_obj mod = dieWith span $
616 ptext SLIT("cannot find object file for module ") <>
620 while_linking_expr = ptext SLIT("while linking an interpreted expression")
622 -- This one is a build-system bug
624 get_linkable maybe_normal_osuf mod_name -- A home-package module
625 | Just mod_info <- lookupUFM hpt mod_name
626 = ASSERT(isJust (hm_linkable mod_info))
627 adjust_linkable (fromJust (hm_linkable mod_info))
629 = do -- It's not in the HPT because we are in one shot mode,
630 -- so use the Finder to get a ModLocation...
631 mb_stuff <- findHomeModule hsc_env mod_name
633 Found loc mod -> found loc mod
637 -- ...and then find the linkable for it
638 mb_lnk <- findObjectLinkableMaybe mod loc ;
640 Nothing -> no_obj mod ;
641 Just lnk -> adjust_linkable lnk
645 | Just osuf <- maybe_normal_osuf = do
646 new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
647 return lnk{ linkableUnlinked=new_uls }
651 adjust_ul osuf (DotO file) = do
652 let new_file = replaceFilenameSuffix file osuf
653 ok <- doesFileExist new_file
656 ptext SLIT("cannot find normal object file ")
657 <> quotes (text new_file) $$ while_linking_expr
658 else return (DotO new_file)
662 %************************************************************************
665 The linkables may consist of a mixture of
666 byte-code modules and object modules
668 %************************************************************************
671 linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
672 linkModules dflags linkables
673 = block $ do -- don't want to be interrupted by ^C in here
675 let (objs, bcos) = partition isObjectLinkable
676 (concatMap partitionLinkable linkables)
678 -- Load objects first; they can't depend on BCOs
679 ok_flag <- dynLinkObjs dflags objs
681 if failed ok_flag then
688 -- HACK to support f-x-dynamic in the interpreter; no other purpose
689 partitionLinkable :: Linkable -> [Linkable]
691 = let li_uls = linkableUnlinked li
692 li_uls_obj = filter isObject li_uls
693 li_uls_bco = filter isInterpretable li_uls
695 case (li_uls_obj, li_uls_bco) of
696 (objs@(_:_), bcos@(_:_))
697 -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
701 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
702 findModuleLinkable_maybe lis mod
703 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
706 many -> pprPanic "findModuleLinkable" (ppr mod)
708 linkableInSet :: Linkable -> [Linkable] -> Bool
709 linkableInSet l objs_loaded =
710 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
712 Just m -> linkableTime l == linkableTime m
716 %************************************************************************
718 \subsection{The object-code linker}
720 %************************************************************************
723 dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
724 -- Side-effects the PersistentLinkerState
726 dynLinkObjs dflags objs
727 = do pls <- readIORef v_PersistentLinkerState
729 -- Load the object files and link them
730 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
731 pls1 = pls { objs_loaded = objs_loaded' }
732 unlinkeds = concatMap linkableUnlinked new_objs
734 mapM loadObj (map nameOfObject unlinkeds)
736 -- Link the all together
739 -- If resolving failed, unload all our
740 -- object modules and carry on
741 if succeeded ok then do
742 writeIORef v_PersistentLinkerState pls1
745 pls2 <- unload_wkr dflags [] pls1
746 writeIORef v_PersistentLinkerState pls2
750 rmDupLinkables :: [Linkable] -- Already loaded
751 -> [Linkable] -- New linkables
752 -> ([Linkable], -- New loaded set (including new ones)
753 [Linkable]) -- New linkables (excluding dups)
754 rmDupLinkables already ls
757 go already extras [] = (already, extras)
758 go already extras (l:ls)
759 | linkableInSet l already = go already extras ls
760 | otherwise = go (l:already) (l:extras) ls
763 %************************************************************************
765 \subsection{The byte-code linker}
767 %************************************************************************
770 dynLinkBCOs :: [Linkable] -> IO ()
771 -- Side-effects the persistent linker state
773 = do pls <- readIORef v_PersistentLinkerState
775 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
776 pls1 = pls { bcos_loaded = bcos_loaded' }
777 unlinkeds :: [Unlinked]
778 unlinkeds = concatMap linkableUnlinked new_bcos
780 cbcs :: [CompiledByteCode]
781 cbcs = map byteCodeOfObject unlinkeds
784 ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
785 ies = [ie | ByteCode _ ie <- cbcs]
786 gce = closure_env pls
787 final_ie = foldr plusNameEnv (itbl_env pls) ies
789 (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
790 -- What happens to these linked_bcos?
792 let pls2 = pls1 { closure_env = final_gce,
793 itbl_env = final_ie }
795 writeIORef v_PersistentLinkerState pls2
798 -- Link a bunch of BCOs and return them + updated closure env.
799 linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
800 -- True <=> add only toplevel BCOs to closure env
804 -> IO (ClosureEnv, [HValue])
805 -- The returned HValues are associated 1-1 with
806 -- the incoming unlinked BCOs. Each gives the
807 -- value of the corresponding unlinked BCO
809 linkSomeBCOs toplevs_only ie ce_in ul_bcos
810 = do let nms = map unlinkedBCOName ul_bcos
812 ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
813 in mapM (linkBCO ie ce_out) ul_bcos )
814 let ce_all_additions = zip nms hvals
815 ce_top_additions = filter (isExternalName.fst) ce_all_additions
816 ce_additions = if toplevs_only then ce_top_additions
817 else ce_all_additions
818 ce_out = -- make sure we're not inserting duplicate names into the
819 -- closure environment, which leads to trouble.
820 ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
821 extendClosureEnv ce_in ce_additions
822 return (ce_out, hvals)
827 %************************************************************************
829 Unload some object modules
831 %************************************************************************
834 -- ---------------------------------------------------------------------------
835 -- Unloading old objects ready for a new compilation sweep.
837 -- The compilation manager provides us with a list of linkables that it
838 -- considers "stable", i.e. won't be recompiled this time around. For
839 -- each of the modules current linked in memory,
841 -- * if the linkable is stable (and it's the same one - the
842 -- user may have recompiled the module on the side), we keep it,
844 -- * otherwise, we unload it.
846 -- * we also implicitly unload all temporary bindings at this point.
848 unload :: DynFlags -> [Linkable] -> IO ()
849 -- The 'linkables' are the ones to *keep*
851 unload dflags linkables
852 = block $ do -- block, so we're safe from Ctrl-C in here
854 -- Initialise the linker (if it's not been done already)
857 pls <- readIORef v_PersistentLinkerState
858 new_pls <- unload_wkr dflags linkables pls
859 writeIORef v_PersistentLinkerState new_pls
861 debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
862 debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
865 unload_wkr :: DynFlags
866 -> [Linkable] -- stable linkables
867 -> PersistentLinkerState
868 -> IO PersistentLinkerState
869 -- Does the core unload business
870 -- (the wrapper blocks exceptions and deals with the PLS get and put)
872 unload_wkr dflags linkables pls
873 = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
875 objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
876 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
878 let bcos_retained = map linkableModule bcos_loaded'
879 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
880 closure_env' = filterNameMap bcos_retained (closure_env pls)
881 new_pls = pls { itbl_env = itbl_env',
882 closure_env = closure_env',
883 bcos_loaded = bcos_loaded',
884 objs_loaded = objs_loaded' }
888 maybeUnload :: [Linkable] -> Linkable -> IO Bool
889 maybeUnload keep_linkables lnk
890 | linkableInSet lnk linkables = return True
892 = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
893 -- The components of a BCO linkable may contain
894 -- dot-o files. Which is very confusing.
896 -- But the BCO parts can be unlinked just by
897 -- letting go of them (plus of course depopulating
898 -- the symbol table which is done in the main body)
903 %************************************************************************
907 %************************************************************************
912 = Object FilePath -- Full path name of a .o file, including trailing .o
913 -- For dynamic objects only, try to find the object
914 -- file in all the directories specified in
915 -- v_Library_paths before giving up.
917 | DLL String -- "Unadorned" name of a .DLL/.so
918 -- e.g. On unix "qt" denotes "libqt.so"
919 -- On WinDoze "burble" denotes "burble.DLL"
920 -- loadDLL is platform-specific and adds the lib/.so/.DLL
921 -- suffixes platform-dependently
923 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
924 -- (ends with .dll or .so).
926 | Framework String -- Only used for darwin, but does no harm
928 -- If this package is already part of the GHCi binary, we'll already
929 -- have the right DLLs for this package loaded, so don't try to
932 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
933 -- as far as the loader is concerned, but it does initialise the list
934 -- of DLL handles that rts/Linker.c maintains, and that in turn is
935 -- used by lookupSymbol. So we must call addDLL for each library
936 -- just to get the DLL handle into the list.
938 # if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS)
941 = [ "base", "haskell98", "template-haskell", "readline" ]
944 showLS (Object nm) = "(static) " ++ nm
945 showLS (DLL nm) = "(dynamic) " ++ nm
946 showLS (DLLPath nm) = "(dynamic) " ++ nm
947 showLS (Framework nm) = "(framework) " ++ nm
949 linkPackages :: DynFlags -> [PackageId] -> IO ()
950 -- Link exactly the specified packages, and their dependents
951 -- (unless of course they are already linked)
952 -- The dependents are linked automatically, and it doesn't matter
953 -- what order you specify the input packages.
955 -- NOTE: in fact, since each module tracks all the packages it depends on,
956 -- we don't really need to use the package-config dependencies.
957 -- However we do need the package-config stuff (to find aux libs etc),
958 -- and following them lets us load libraries in the right order, which
959 -- perhaps makes the error message a bit more localised if we get a link
960 -- failure. So the dependency walking code is still here.
962 linkPackages dflags new_pkgs
963 = do { pls <- readIORef v_PersistentLinkerState
964 ; let pkg_map = pkgIdMap (pkgState dflags)
966 ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
968 ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
971 link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
972 link pkg_map pkgs new_pkgs
973 = foldM (link_one pkg_map) pkgs new_pkgs
975 link_one pkg_map pkgs new_pkg
976 | new_pkg `elem` pkgs -- Already linked
979 | Just pkg_cfg <- lookupPackage pkg_map new_pkg
980 = do { -- Link dependents first
981 pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
982 -- Now link the package itself
983 ; linkPackage dflags pkg_cfg
984 ; return (new_pkg : pkgs') }
987 = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
990 linkPackage :: DynFlags -> PackageConfig -> IO ()
991 linkPackage dflags pkg
993 let dirs = Packages.libraryDirs pkg
995 let libs = Packages.hsLibraries pkg
996 -- Because of slight differences between the GHC dynamic linker and
997 -- the native system linker some packages have to link with a
998 -- different list of libraries when using GHCi. Examples include: libs
999 -- that are actually gnu ld scripts, and the possability that the .a
1000 -- libs do not exactly match the .so/.dll equivalents. So if the
1001 -- package file provides an "extra-ghci-libraries" field then we use
1002 -- that instead of the "extra-libraries" field.
1003 ++ (if null (Packages.extraGHCiLibraries pkg)
1004 then Packages.extraLibraries pkg
1005 else Packages.extraGHCiLibraries pkg)
1006 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
1007 classifieds <- mapM (locateOneObj dirs) libs
1009 -- Complication: all the .so's must be loaded before any of the .o's.
1010 let dlls = [ dll | DLL dll <- classifieds ]
1011 objs = [ obj | Object obj <- classifieds ]
1013 maybePutStr dflags ("Loading package " ++ showPackageId (package pkg) ++ " ... ")
1015 -- See comments with partOfGHCi
1016 when (pkgName (package pkg) `notElem` partOfGHCi) $ do
1018 -- When a library A needs symbols from a library B, the order in
1019 -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
1020 -- way ld expects it for static linking. Dynamic linking is a
1021 -- different story: When A has no dependency information for B,
1022 -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
1023 -- when B has not been loaded before. In a nutshell: Reverse the
1024 -- order of DLLs for dynamic linking.
1025 -- This fixes a problem with the HOpenGL package (see "Compiling
1026 -- HOpenGL under recent versions of GHC" on the HOpenGL list).
1027 mapM_ (load_dyn dirs) (reverse dlls)
1029 -- After loading all the DLLs, we can load the static objects.
1030 -- Ordering isn't important here, because we do one final link
1031 -- step to resolve everything.
1034 maybePutStr dflags "linking ... "
1036 if succeeded ok then maybePutStrLn dflags "done."
1037 else throwDyn (InstallationError ("unable to load package `" ++ showPackageId (package pkg) ++ "'"))
1039 load_dyn dirs dll = do r <- loadDynamic dirs dll
1041 Nothing -> return ()
1042 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1043 ++ dll ++ " (" ++ err ++ ")" ))
1044 #ifndef darwin_TARGET_OS
1045 loadFrameworks pkg = return ()
1047 loadFrameworks pkg = mapM_ load frameworks
1049 fw_dirs = Packages.frameworkDirs pkg
1050 frameworks = Packages.frameworks pkg
1052 load fw = do r <- loadFramework fw_dirs fw
1054 Nothing -> return ()
1055 Just err -> throwDyn (CmdLineError ("can't load framework: "
1056 ++ fw ++ " (" ++ err ++ ")" ))
1059 -- Try to find an object file for a given library in the given paths.
1060 -- If it isn't present, we assume it's a dynamic library.
1061 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1062 locateOneObj dirs lib
1063 = do { mb_obj_path <- findFile mk_obj_path dirs
1064 ; case mb_obj_path of
1065 Just obj_path -> return (Object obj_path)
1067 do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1068 ; case mb_lib_path of
1069 Just lib_path -> return (DLL (lib ++ "_dyn"))
1070 Nothing -> return (DLL lib) }} -- We assume
1072 mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o")
1073 mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "_dyn")
1076 -- ----------------------------------------------------------------------------
1077 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1079 -- return Nothing == success, else Just error message from dlopen
1080 loadDynamic paths rootname
1081 = do { mb_dll <- findFile mk_dll_path paths
1083 Just dll -> loadDLL dll
1084 Nothing -> loadDLL (mkSOName rootname) }
1085 -- Tried all our known library paths, so let
1086 -- dlopen() search its own builtin paths now.
1088 mk_dll_path dir = dir `joinFileName` mkSOName rootname
1090 #if defined(darwin_TARGET_OS)
1091 mkSOName root = ("lib" ++ root) `joinFileExt` "dylib"
1092 #elif defined(mingw32_TARGET_OS)
1093 -- Win32 DLLs have no .dll extension here, because addDLL tries
1094 -- both foo.dll and foo.drv
1095 mkSOName root = root
1097 mkSOName root = ("lib" ++ root) `joinFileExt` "so"
1100 -- Darwin / MacOS X only: load a framework
1101 -- a framework is a dynamic library packaged inside a directory of the same
1102 -- name. They are searched for in different paths than normal libraries.
1103 #ifdef darwin_TARGET_OS
1104 loadFramework extraPaths rootname
1105 = do { mb_fwk <- findFile mk_fwk (extraPaths ++ defaultFrameworkPaths)
1107 Just fwk_path -> loadDLL fwk_path
1108 Nothing -> return (Just "not found") }
1109 -- Tried all our known library paths, but dlopen()
1110 -- has no built-in paths for frameworks: give up
1112 mk_fwk dir = dir `joinFileName` (rootname ++ ".framework/" ++ rootname)
1113 -- sorry for the hardcoded paths, I hope they won't change anytime soon:
1114 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1118 %************************************************************************
1122 %************************************************************************
1125 findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
1126 -> [FilePath] -- Directories to look in
1127 -> IO (Maybe FilePath) -- The first file path to match
1128 findFile mk_file_path []
1130 findFile mk_file_path (dir:dirs)
1131 = do { let file_path = mk_file_path dir
1132 ; b <- doesFileExist file_path
1134 return (Just file_path)
1136 findFile mk_file_path dirs }
1140 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1141 | otherwise = return ()
1143 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1144 | otherwise = return ()