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 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 lookupOrig modName occName
180 {- To find the string in the constructor's info table we need to consider
181 the layout of info tables relative to the entry code for a closure.
183 An info table can be next to the entry code for the closure, or it can
184 be separate. The former (faster) is used in registerised versions of ghc,
185 and the latter (portable) is for non-registerised versions.
187 The diagrams below show where the string is to be found relative to
188 the normal info table of the closure.
190 1) Code next to table:
193 | | <- pointer to the start of the string
195 | | <- the (start of the) info table structure
202 In this case the pointer to the start of the string can be found in
203 the memory location _one word before_ the first entry in the normal info
206 2) Code NOT next to table:
209 info table structure -> | *------------------> --------------
213 ptr to start of str -> | |
216 In this case the pointer to the start of the string can be found
217 in the memory location: info_table_ptr + info_table_size
220 getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
221 getConDescAddress ptr = do
222 #ifdef GHCI_TABLES_NEXT_TO_CODE
223 offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
224 return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
226 peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
229 -- parsing names is a little bit fiddly because we have a string in the form:
230 -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
231 -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
232 -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
233 -- this is not the conventional way of writing Haskell names. We stick with
234 -- convention, even though it makes the parsing code more troublesome.
235 -- Warning: this code assumes that the string is well formed.
236 parse :: [Word8] -> ([Word8], [Word8], [Word8])
238 = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
240 dot = fromIntegral (ord '.')
241 (pkg, rest1) = break (== fromIntegral (ord ':')) input
243 = (concat $ intersperse [dot] $ reverse modWords, occWord)
245 (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
246 parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
248 = case break (== dot) str of
249 (top, []) -> (acc, top)
250 (top, _:bot) -> parseModOcc (top : acc) bot
253 getHValue :: HscEnv -> Name -> IO HValue
254 getHValue hsc_env name = do
255 when (isExternalName name) $ do
256 ok <- linkDependencies hsc_env noSrcSpan [nameModule name]
257 when (failed ok) $ throwDyn (ProgramError "")
258 pls <- readIORef v_PersistentLinkerState
259 lookupName (closure_env pls) name
261 linkDependencies :: HscEnv -> SrcSpan -> [Module] -> IO SuccessFlag
262 linkDependencies hsc_env span needed_mods = do
263 let hpt = hsc_HPT hsc_env
264 dflags = hsc_dflags hsc_env
265 -- The interpreter and dynamic linker can only handle object code built
266 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
267 -- So here we check the build tag: if we're building a non-standard way
268 -- then we need to find & link object files built the "normal" way.
269 maybe_normal_osuf <- checkNonStdWay dflags span
271 -- Find what packages and linkables are required
272 eps <- readIORef (hsc_EPS hsc_env)
273 (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
274 maybe_normal_osuf span needed_mods
276 -- Link the packages and modules required
277 linkPackages dflags pkgs
278 linkModules dflags lnks
281 -- | Temporarily extend the linker state.
283 withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
284 withExtendedLinkEnv new_env action
285 = bracket set_new_env
288 where set_new_env = do
289 pls <- readIORef v_PersistentLinkerState
290 let new_closure_env = extendClosureEnv (closure_env pls) new_env
291 new_pls = pls { closure_env = new_closure_env }
292 writeIORef v_PersistentLinkerState new_pls
293 return (closure_env pls)
295 -- Remember that the linker state might be side-effected
296 -- during the execution of the IO action, and we don't want to
297 -- lose those changes (we might have linked a new module or
298 -- package), so the reset action only removes the names we
300 reset_old_env env = do
301 modifyIORef v_PersistentLinkerState $ \pls ->
302 let cur = closure_env pls
303 new = delListFromNameEnv cur (map fst new_env)
305 pls{ closure_env = new }
307 -- filterNameMap removes from the environment all entries except
308 -- those for a given set of modules;
309 -- Note that this removes all *local* (i.e. non-isExternal) names too
310 -- (these are the temporary bindings from the command line).
311 -- Used to filter both the ClosureEnv and ItblEnv
313 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
314 filterNameMap mods env
315 = filterNameEnv keep_elt env
317 keep_elt (n,_) = isExternalName n
318 && (nameModule n `elem` mods)
323 showLinkerState :: IO ()
324 -- Display the persistent linker state
326 = do pls <- readIORef v_PersistentLinkerState
327 printDump (vcat [text "----- Linker state -----",
328 text "Pkgs:" <+> ppr (pkgs_loaded pls),
329 text "Objs:" <+> ppr (objs_loaded pls),
330 text "BCOs:" <+> ppr (bcos_loaded pls)])
336 %************************************************************************
338 \subsection{Initialisation}
340 %************************************************************************
342 We initialise the dynamic linker by
344 a) calling the C initialisation procedure
346 b) Loading any packages specified on the command line,
348 c) Loading any packages specified on the command line,
349 now held in the -l options in v_Opt_l
351 d) Loading any .o/.dll files specified on the command line,
352 now held in v_Ld_inputs
354 e) Loading any MacOS frameworks
357 initDynLinker :: DynFlags -> IO ()
358 -- This function is idempotent; if called more than once, it does nothing
359 -- This is useful in Template Haskell, where we call it before trying to link
361 = do { done <- readIORef v_InitLinkerDone
362 ; if done then return ()
363 else do { writeIORef v_InitLinkerDone True
364 ; reallyInitDynLinker dflags }
367 reallyInitDynLinker dflags
368 = do { -- Initialise the linker state
369 ; writeIORef v_PersistentLinkerState (emptyPLS dflags)
371 -- (a) initialise the C dynamic linker
374 -- (b) Load packages from the command-line
375 ; linkPackages dflags (preloadPackages (pkgState dflags))
377 -- (c) Link libraries from the command-line
378 ; let optl = getOpts dflags opt_l
379 ; let minus_ls = [ lib | '-':'l':lib <- optl ]
381 -- (d) Link .o files from the command-line
382 ; let lib_paths = libraryPaths dflags
383 ; cmdline_ld_inputs <- readIORef v_Ld_inputs
385 ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
387 -- (e) Link any MacOS frameworks
388 #ifdef darwin_TARGET_OS
389 ; let framework_paths = frameworkPaths dflags
390 ; let frameworks = cmdlineFrameworks dflags
392 ; let frameworks = []
393 ; let framework_paths = []
395 -- Finally do (c),(d),(e)
396 ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
398 ++ map Framework frameworks
399 ; if null cmdline_lib_specs then return ()
402 { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
403 ; maybePutStr dflags "final link ... "
406 ; if succeeded ok then maybePutStrLn dflags "done"
407 else throwDyn (InstallationError "linking extra libraries/objects failed")
410 classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
412 | isObjectFilename f = return (Just (Object f))
413 | isDynLibFilename f = return (Just (DLLPath f))
415 hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
418 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
419 preloadLib dflags lib_paths framework_paths lib_spec
420 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
423 -> do b <- preload_static lib_paths static_ish
424 maybePutStrLn dflags (if b then "done"
428 -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
430 Nothing -> maybePutStrLn dflags "done"
431 Just mm -> preloadFailed mm lib_paths lib_spec
434 -> do maybe_errstr <- loadDLL dll_path
436 Nothing -> maybePutStrLn dflags "done"
437 Just mm -> preloadFailed mm lib_paths lib_spec
439 #ifdef darwin_TARGET_OS
441 -> do maybe_errstr <- loadFramework framework_paths framework
443 Nothing -> maybePutStrLn dflags "done"
444 Just mm -> preloadFailed mm framework_paths lib_spec
447 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
448 preloadFailed sys_errmsg paths spec
449 = do maybePutStr dflags
450 ("failed.\nDynamic linker error message was:\n "
451 ++ sys_errmsg ++ "\nWhilst trying to load: "
452 ++ showLS spec ++ "\nDirectories to search are:\n"
453 ++ unlines (map (" "++) paths) )
456 -- Not interested in the paths in the static case.
457 preload_static paths name
458 = do b <- doesFileExist name
459 if not b then return False
460 else loadObj name >> return True
463 CmdLineError "user specified .o/.so/.DLL could not be loaded."
467 %************************************************************************
469 Link a byte-code expression
471 %************************************************************************
474 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
476 -- Link a single expression, *including* first linking packages and
477 -- modules that this expression depends on.
479 -- Raises an IO exception if it can't find a compiled version of the
480 -- dependents to link.
482 -- Note: This function side-effects the linker state (Pepe)
484 linkExpr hsc_env span root_ul_bco
486 -- Initialise the linker (if it's not been done already)
487 let dflags = hsc_dflags hsc_env
488 ; initDynLinker dflags
490 -- Link the packages and modules required
491 ; ok <- linkDependencies hsc_env span needed_mods
493 throwDyn (ProgramError "")
496 -- Link the expression itself
497 pls <- readIORef v_PersistentLinkerState
498 ; let ie = itbl_env pls
501 -- Link the necessary packages and linkables
502 ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
506 free_names = nameSetToList (bcoFreeNames root_ul_bco)
508 needed_mods :: [Module]
509 needed_mods = [ nameModule n | n <- free_names,
510 isExternalName n, -- Names from other modules
511 not (isWiredInName n) -- Exclude wired-in names
512 ] -- (see note below)
513 -- Exclude wired-in names because we may not have read
514 -- their interface files, so getLinkDeps will fail
515 -- All wired-in names are in the base package, which we link
516 -- by default, so we can safely ignore them here.
518 dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg)))
521 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
522 checkNonStdWay dflags srcspan = do
523 tag <- readIORef v_Build_tag
524 if null tag then return Nothing else do
525 let default_osuf = phaseInputExt StopLn
526 if objectSuf dflags == default_osuf
527 then failNonStd srcspan
528 else return (Just default_osuf)
530 failNonStd srcspan = dieWith srcspan $
531 ptext SLIT("Dynamic linking required, but this is a non-standard build (eg. prof).") $$
532 ptext SLIT("You need to build the program twice: once the normal way, and then") $$
533 ptext SLIT("in the desired way using -osuf to set the object file suffix.")
536 getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable
537 -> Maybe String -- the "normal" object suffix
538 -> SrcSpan -- for error messages
539 -> [Module] -- If you need these
540 -> IO ([Linkable], [PackageId]) -- ... then link these first
541 -- Fails with an IO exception if it can't find enough files
543 getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
544 -- Find all the packages and linkables that a set of modules depends on
545 = do { pls <- readIORef v_PersistentLinkerState ;
547 -- 1. Find the dependent home-pkg-modules/packages from each iface
548 (mods_s, pkgs_s) = follow_deps mods emptyUniqSet emptyUniqSet;
550 -- 2. Exclude ones already linked
551 -- Main reason: avoid findModule calls in get_linkable
552 mods_needed = mods_s `minusList` linked_mods ;
553 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
555 linked_mods = map (moduleName.linkableModule)
556 (objs_loaded pls ++ bcos_loaded pls)
559 -- putStrLn (showSDoc (ppr mods_s)) ;
560 -- 3. For each dependent module, find its linkable
561 -- This will either be in the HPT or (in the case of one-shot
562 -- compilation) we may need to use maybe_getFileLinkable
563 lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
565 return (lnks_needed, pkgs_needed) }
567 dflags = hsc_dflags hsc_env
568 this_pkg = thisPackage dflags
570 -- The ModIface contains the transitive closure of the module dependencies
571 -- within the current package, *except* for boot modules: if we encounter
572 -- a boot module, we have to find its real interface and discover the
573 -- dependencies of that. Hence we need to traverse the dependency
574 -- tree recursively. See bug #936, testcase ghci/prog007.
575 follow_deps :: [Module] -- modules to follow
576 -> UniqSet ModuleName -- accum. module dependencies
577 -> UniqSet PackageId -- accum. package dependencies
578 -> ([ModuleName], [PackageId]) -- result
579 follow_deps [] acc_mods acc_pkgs
580 = (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
581 follow_deps (mod:mods) acc_mods acc_pkgs
583 = follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
585 = link_boot_mod_error mod
587 = follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) acc_mods' acc_pkgs'
589 pkg = modulePackageId mod
590 iface = get_iface mod
593 pkg_deps = dep_pkgs deps
594 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
595 where is_boot (m,True) = Left m
596 is_boot (m,False) = Right m
598 boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
599 acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
600 acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
603 link_boot_mod_error mod =
604 throwDyn (ProgramError (showSDoc (
605 text "module" <+> ppr mod <+>
606 text "cannot be linked; it is only available as a boot module")))
608 get_iface mod = case lookupIfaceByModule dflags hpt pit mod of
610 Nothing -> pprPanic "getLinkDeps" (no_iface mod)
611 no_iface mod = ptext SLIT("No iface for") <+> ppr mod
612 -- This one is a GHC bug
614 no_obj mod = dieWith span $
615 ptext SLIT("cannot find object file for module ") <>
619 while_linking_expr = ptext SLIT("while linking an interpreted expression")
621 -- This one is a build-system bug
623 get_linkable maybe_normal_osuf mod_name -- A home-package module
624 | Just mod_info <- lookupUFM hpt mod_name
625 = ASSERT(isJust (hm_linkable mod_info))
626 adjust_linkable (fromJust (hm_linkable mod_info))
628 = do -- It's not in the HPT because we are in one shot mode,
629 -- so use the Finder to get a ModLocation...
630 mb_stuff <- findHomeModule hsc_env mod_name
632 Found loc mod -> found loc mod
636 -- ...and then find the linkable for it
637 mb_lnk <- findObjectLinkableMaybe mod loc ;
639 Nothing -> no_obj mod ;
640 Just lnk -> adjust_linkable lnk
644 | Just osuf <- maybe_normal_osuf = do
645 new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
646 return lnk{ linkableUnlinked=new_uls }
650 adjust_ul osuf (DotO file) = do
651 let new_file = replaceFilenameSuffix file osuf
652 ok <- doesFileExist new_file
655 ptext SLIT("cannot find normal object file ")
656 <> quotes (text new_file) $$ while_linking_expr
657 else return (DotO new_file)
661 %************************************************************************
664 The linkables may consist of a mixture of
665 byte-code modules and object modules
667 %************************************************************************
670 linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
671 linkModules dflags linkables
672 = block $ do -- don't want to be interrupted by ^C in here
674 let (objs, bcos) = partition isObjectLinkable
675 (concatMap partitionLinkable linkables)
677 -- Load objects first; they can't depend on BCOs
678 ok_flag <- dynLinkObjs dflags objs
680 if failed ok_flag then
687 -- HACK to support f-x-dynamic in the interpreter; no other purpose
688 partitionLinkable :: Linkable -> [Linkable]
690 = let li_uls = linkableUnlinked li
691 li_uls_obj = filter isObject li_uls
692 li_uls_bco = filter isInterpretable li_uls
694 case (li_uls_obj, li_uls_bco) of
695 (objs@(_:_), bcos@(_:_))
696 -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
700 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
701 findModuleLinkable_maybe lis mod
702 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
705 many -> pprPanic "findModuleLinkable" (ppr mod)
707 linkableInSet :: Linkable -> [Linkable] -> Bool
708 linkableInSet l objs_loaded =
709 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
711 Just m -> linkableTime l == linkableTime m
715 %************************************************************************
717 \subsection{The object-code linker}
719 %************************************************************************
722 dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
723 -- Side-effects the PersistentLinkerState
725 dynLinkObjs dflags objs
726 = do pls <- readIORef v_PersistentLinkerState
728 -- Load the object files and link them
729 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
730 pls1 = pls { objs_loaded = objs_loaded' }
731 unlinkeds = concatMap linkableUnlinked new_objs
733 mapM loadObj (map nameOfObject unlinkeds)
735 -- Link the all together
738 -- If resolving failed, unload all our
739 -- object modules and carry on
740 if succeeded ok then do
741 writeIORef v_PersistentLinkerState pls1
744 pls2 <- unload_wkr dflags [] pls1
745 writeIORef v_PersistentLinkerState pls2
749 rmDupLinkables :: [Linkable] -- Already loaded
750 -> [Linkable] -- New linkables
751 -> ([Linkable], -- New loaded set (including new ones)
752 [Linkable]) -- New linkables (excluding dups)
753 rmDupLinkables already ls
756 go already extras [] = (already, extras)
757 go already extras (l:ls)
758 | linkableInSet l already = go already extras ls
759 | otherwise = go (l:already) (l:extras) ls
762 %************************************************************************
764 \subsection{The byte-code linker}
766 %************************************************************************
769 dynLinkBCOs :: [Linkable] -> IO ()
770 -- Side-effects the persistent linker state
772 = do pls <- readIORef v_PersistentLinkerState
774 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
775 pls1 = pls { bcos_loaded = bcos_loaded' }
776 unlinkeds :: [Unlinked]
777 unlinkeds = concatMap linkableUnlinked new_bcos
779 cbcs :: [CompiledByteCode]
780 cbcs = map byteCodeOfObject unlinkeds
783 ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
784 ies = [ie | ByteCode _ ie <- cbcs]
785 gce = closure_env pls
786 final_ie = foldr plusNameEnv (itbl_env pls) ies
788 (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
789 -- What happens to these linked_bcos?
791 let pls2 = pls1 { closure_env = final_gce,
792 itbl_env = final_ie }
794 writeIORef v_PersistentLinkerState pls2
797 -- Link a bunch of BCOs and return them + updated closure env.
798 linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
799 -- True <=> add only toplevel BCOs to closure env
803 -> IO (ClosureEnv, [HValue])
804 -- The returned HValues are associated 1-1 with
805 -- the incoming unlinked BCOs. Each gives the
806 -- value of the corresponding unlinked BCO
808 linkSomeBCOs toplevs_only ie ce_in ul_bcos
809 = do let nms = map unlinkedBCOName ul_bcos
811 ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
812 in mapM (linkBCO ie ce_out) ul_bcos )
813 let ce_all_additions = zip nms hvals
814 ce_top_additions = filter (isExternalName.fst) ce_all_additions
815 ce_additions = if toplevs_only then ce_top_additions
816 else ce_all_additions
817 ce_out = -- make sure we're not inserting duplicate names into the
818 -- closure environment, which leads to trouble.
819 ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
820 extendClosureEnv ce_in ce_additions
821 return (ce_out, hvals)
826 %************************************************************************
828 Unload some object modules
830 %************************************************************************
833 -- ---------------------------------------------------------------------------
834 -- Unloading old objects ready for a new compilation sweep.
836 -- The compilation manager provides us with a list of linkables that it
837 -- considers "stable", i.e. won't be recompiled this time around. For
838 -- each of the modules current linked in memory,
840 -- * if the linkable is stable (and it's the same one - the
841 -- user may have recompiled the module on the side), we keep it,
843 -- * otherwise, we unload it.
845 -- * we also implicitly unload all temporary bindings at this point.
847 unload :: DynFlags -> [Linkable] -> IO ()
848 -- The 'linkables' are the ones to *keep*
850 unload dflags linkables
851 = block $ do -- block, so we're safe from Ctrl-C in here
853 -- Initialise the linker (if it's not been done already)
856 pls <- readIORef v_PersistentLinkerState
857 new_pls <- unload_wkr dflags linkables pls
858 writeIORef v_PersistentLinkerState new_pls
860 debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
861 debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
864 unload_wkr :: DynFlags
865 -> [Linkable] -- stable linkables
866 -> PersistentLinkerState
867 -> IO PersistentLinkerState
868 -- Does the core unload business
869 -- (the wrapper blocks exceptions and deals with the PLS get and put)
871 unload_wkr dflags linkables pls
872 = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
874 objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
875 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
877 let bcos_retained = map linkableModule bcos_loaded'
878 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
879 closure_env' = filterNameMap bcos_retained (closure_env pls)
880 new_pls = pls { itbl_env = itbl_env',
881 closure_env = closure_env',
882 bcos_loaded = bcos_loaded',
883 objs_loaded = objs_loaded' }
887 maybeUnload :: [Linkable] -> Linkable -> IO Bool
888 maybeUnload keep_linkables lnk
889 | linkableInSet lnk linkables = return True
891 = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
892 -- The components of a BCO linkable may contain
893 -- dot-o files. Which is very confusing.
895 -- But the BCO parts can be unlinked just by
896 -- letting go of them (plus of course depopulating
897 -- the symbol table which is done in the main body)
902 %************************************************************************
906 %************************************************************************
911 = Object FilePath -- Full path name of a .o file, including trailing .o
912 -- For dynamic objects only, try to find the object
913 -- file in all the directories specified in
914 -- v_Library_paths before giving up.
916 | DLL String -- "Unadorned" name of a .DLL/.so
917 -- e.g. On unix "qt" denotes "libqt.so"
918 -- On WinDoze "burble" denotes "burble.DLL"
919 -- loadDLL is platform-specific and adds the lib/.so/.DLL
920 -- suffixes platform-dependently
922 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
923 -- (ends with .dll or .so).
925 | Framework String -- Only used for darwin, but does no harm
927 -- If this package is already part of the GHCi binary, we'll already
928 -- have the right DLLs for this package loaded, so don't try to
931 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
932 -- as far as the loader is concerned, but it does initialise the list
933 -- of DLL handles that rts/Linker.c maintains, and that in turn is
934 -- used by lookupSymbol. So we must call addDLL for each library
935 -- just to get the DLL handle into the list.
937 # if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS)
940 = [ "base", "haskell98", "template-haskell", "readline" ]
943 showLS (Object nm) = "(static) " ++ nm
944 showLS (DLL nm) = "(dynamic) " ++ nm
945 showLS (DLLPath nm) = "(dynamic) " ++ nm
946 showLS (Framework nm) = "(framework) " ++ nm
948 linkPackages :: DynFlags -> [PackageId] -> IO ()
949 -- Link exactly the specified packages, and their dependents
950 -- (unless of course they are already linked)
951 -- The dependents are linked automatically, and it doesn't matter
952 -- what order you specify the input packages.
954 -- NOTE: in fact, since each module tracks all the packages it depends on,
955 -- we don't really need to use the package-config dependencies.
956 -- However we do need the package-config stuff (to find aux libs etc),
957 -- and following them lets us load libraries in the right order, which
958 -- perhaps makes the error message a bit more localised if we get a link
959 -- failure. So the dependency walking code is still here.
961 linkPackages dflags new_pkgs
962 = do { pls <- readIORef v_PersistentLinkerState
963 ; let pkg_map = pkgIdMap (pkgState dflags)
965 ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
967 ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
970 link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
971 link pkg_map pkgs new_pkgs
972 = foldM (link_one pkg_map) pkgs new_pkgs
974 link_one pkg_map pkgs new_pkg
975 | new_pkg `elem` pkgs -- Already linked
978 | Just pkg_cfg <- lookupPackage pkg_map new_pkg
979 = do { -- Link dependents first
980 pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
981 -- Now link the package itself
982 ; linkPackage dflags pkg_cfg
983 ; return (new_pkg : pkgs') }
986 = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
989 linkPackage :: DynFlags -> PackageConfig -> IO ()
990 linkPackage dflags pkg
992 let dirs = Packages.libraryDirs pkg
994 let libs = Packages.hsLibraries pkg
995 -- Because of slight differences between the GHC dynamic linker and
996 -- the native system linker some packages have to link with a
997 -- different list of libraries when using GHCi. Examples include: libs
998 -- that are actually gnu ld scripts, and the possability that the .a
999 -- libs do not exactly match the .so/.dll equivalents. So if the
1000 -- package file provides an "extra-ghci-libraries" field then we use
1001 -- that instead of the "extra-libraries" field.
1002 ++ (if null (Packages.extraGHCiLibraries pkg)
1003 then Packages.extraLibraries pkg
1004 else Packages.extraGHCiLibraries pkg)
1005 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
1006 classifieds <- mapM (locateOneObj dirs) libs
1008 -- Complication: all the .so's must be loaded before any of the .o's.
1009 let dlls = [ dll | DLL dll <- classifieds ]
1010 objs = [ obj | Object obj <- classifieds ]
1012 maybePutStr dflags ("Loading package " ++ showPackageId (package pkg) ++ " ... ")
1014 -- See comments with partOfGHCi
1015 when (pkgName (package pkg) `notElem` partOfGHCi) $ do
1017 -- When a library A needs symbols from a library B, the order in
1018 -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
1019 -- way ld expects it for static linking. Dynamic linking is a
1020 -- different story: When A has no dependency information for B,
1021 -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
1022 -- when B has not been loaded before. In a nutshell: Reverse the
1023 -- order of DLLs for dynamic linking.
1024 -- This fixes a problem with the HOpenGL package (see "Compiling
1025 -- HOpenGL under recent versions of GHC" on the HOpenGL list).
1026 mapM_ (load_dyn dirs) (reverse dlls)
1028 -- After loading all the DLLs, we can load the static objects.
1029 -- Ordering isn't important here, because we do one final link
1030 -- step to resolve everything.
1033 maybePutStr dflags "linking ... "
1035 if succeeded ok then maybePutStrLn dflags "done."
1036 else throwDyn (InstallationError ("unable to load package `" ++ showPackageId (package pkg) ++ "'"))
1038 load_dyn dirs dll = do r <- loadDynamic dirs dll
1040 Nothing -> return ()
1041 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1042 ++ dll ++ " (" ++ err ++ ")" ))
1043 #ifndef darwin_TARGET_OS
1044 loadFrameworks pkg = return ()
1046 loadFrameworks pkg = mapM_ load frameworks
1048 fw_dirs = Packages.frameworkDirs pkg
1049 frameworks = Packages.frameworks pkg
1051 load fw = do r <- loadFramework fw_dirs fw
1053 Nothing -> return ()
1054 Just err -> throwDyn (CmdLineError ("can't load framework: "
1055 ++ fw ++ " (" ++ err ++ ")" ))
1058 -- Try to find an object file for a given library in the given paths.
1059 -- If it isn't present, we assume it's a dynamic library.
1060 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1061 locateOneObj dirs lib
1062 = do { mb_obj_path <- findFile mk_obj_path dirs
1063 ; case mb_obj_path of
1064 Just obj_path -> return (Object obj_path)
1066 do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1067 ; case mb_lib_path of
1068 Just lib_path -> return (DLL (lib ++ "_dyn"))
1069 Nothing -> return (DLL lib) }} -- We assume
1071 mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o")
1072 mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "_dyn")
1075 -- ----------------------------------------------------------------------------
1076 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1078 -- return Nothing == success, else Just error message from dlopen
1079 loadDynamic paths rootname
1080 = do { mb_dll <- findFile mk_dll_path paths
1082 Just dll -> loadDLL dll
1083 Nothing -> loadDLL (mkSOName rootname) }
1084 -- Tried all our known library paths, so let
1085 -- dlopen() search its own builtin paths now.
1087 mk_dll_path dir = dir `joinFileName` mkSOName rootname
1089 #if defined(darwin_TARGET_OS)
1090 mkSOName root = ("lib" ++ root) `joinFileExt` "dylib"
1091 #elif defined(mingw32_TARGET_OS)
1092 -- Win32 DLLs have no .dll extension here, because addDLL tries
1093 -- both foo.dll and foo.drv
1094 mkSOName root = root
1096 mkSOName root = ("lib" ++ root) `joinFileExt` "so"
1099 -- Darwin / MacOS X only: load a framework
1100 -- a framework is a dynamic library packaged inside a directory of the same
1101 -- name. They are searched for in different paths than normal libraries.
1102 #ifdef darwin_TARGET_OS
1103 loadFramework extraPaths rootname
1104 = do { mb_fwk <- findFile mk_fwk (extraPaths ++ defaultFrameworkPaths)
1106 Just fwk_path -> loadDLL fwk_path
1107 Nothing -> return (Just "not found") }
1108 -- Tried all our known library paths, but dlopen()
1109 -- has no built-in paths for frameworks: give up
1111 mk_fwk dir = dir `joinFileName` (rootname ++ ".framework/" ++ rootname)
1112 -- sorry for the hardcoded paths, I hope they won't change anytime soon:
1113 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1117 %************************************************************************
1121 %************************************************************************
1124 findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
1125 -> [FilePath] -- Directories to look in
1126 -> IO (Maybe FilePath) -- The first file path to match
1127 findFile mk_file_path []
1129 findFile mk_file_path (dir:dirs)
1130 = do { let file_path = mk_file_path dir
1131 ; b <- doesFileExist file_path
1133 return (Just file_path)
1135 findFile mk_file_path dirs }
1139 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1140 | otherwise = return ()
1142 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1143 | otherwise = return ()