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"
43 import qualified OccName
57 import qualified Maybes
61 import Config ( cProjectVersion )
71 import System.FilePath
73 import System.Directory
75 import Distribution.Package hiding (depends)
77 import Control.Exception
82 %************************************************************************
86 %************************************************************************
88 The persistent linker state *must* match the actual state of the
89 C dynamic linker at all times, so we keep it in a private global variable.
92 The PersistentLinkerState maps Names to actual closures (for
93 interpreted code only), for use during linking.
96 GLOBAL_VAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState)
97 GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
99 data PersistentLinkerState
100 = PersistentLinkerState {
102 -- Current global mapping from Names to their true values
103 closure_env :: ClosureEnv,
105 -- The current global mapping from RdrNames of DataCons to
106 -- info table addresses.
107 -- When a new Unlinked is linked into the running image, or an existing
108 -- module in the image is replaced, the itbl_env must be updated
112 -- The currently loaded interpreted modules (home package)
113 bcos_loaded :: [Linkable],
115 -- And the currently-loaded compiled modules (home package)
116 objs_loaded :: [Linkable],
118 -- The currently-loaded packages; always object code
119 -- Held, as usual, in dependency order; though I am not sure if
120 -- that is really important
121 pkgs_loaded :: [PackageId]
124 emptyPLS :: DynFlags -> PersistentLinkerState
125 emptyPLS _ = PersistentLinkerState {
126 closure_env = emptyNameEnv,
127 itbl_env = emptyNameEnv,
128 pkgs_loaded = init_pkgs,
132 -- Packages that don't need loading, because the compiler
133 -- shares them with the interpreted program.
135 -- The linker's symbol table is populated with RTS symbols using an
136 -- explicit list. See rts/Linker.c for details.
137 where init_pkgs = [rtsPackageId]
141 extendLoadedPkgs :: [PackageId] -> IO ()
142 extendLoadedPkgs pkgs
143 = modifyIORef v_PersistentLinkerState (\s -> s{pkgs_loaded = pkgs ++ pkgs_loaded s})
145 extendLinkEnv :: [(Name,HValue)] -> IO ()
146 -- Automatically discards shadowed bindings
147 extendLinkEnv new_bindings
148 = do pls <- readIORef v_PersistentLinkerState
149 let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
150 new_pls = pls { closure_env = new_closure_env }
151 writeIORef v_PersistentLinkerState new_pls
153 deleteFromLinkEnv :: [Name] -> IO ()
154 deleteFromLinkEnv to_remove
155 = do pls <- readIORef v_PersistentLinkerState
156 let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
157 new_pls = pls { closure_env = new_closure_env }
158 writeIORef v_PersistentLinkerState new_pls
160 -- | Given a data constructor in the heap, find its Name.
161 -- The info tables for data constructors have a field which records
162 -- the source name of the constructor as a Ptr Word8 (UTF-8 encoded
163 -- string). The format is:
165 -- Package:Module.Name
167 -- We use this string to lookup the interpreter's internal representation of the name
168 -- using the lookupOrig.
170 dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
171 dataConInfoPtrToName x = do
172 theString <- liftIO $ do
173 let ptr = castPtr x :: Ptr StgInfoTable
174 conDescAddress <- getConDescAddress ptr
175 peekArray0 0 conDescAddress
176 let (pkg, mod, occ) = parse theString
177 pkgFS = mkFastStringByteList pkg
178 modFS = mkFastStringByteList mod
179 occFS = mkFastStringByteList occ
180 occName = mkOccNameFS OccName.dataName occFS
181 modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS)
182 return (Left$ showSDoc$ ppr modName <> dot <> ppr occName )
183 `recoverM` (Right `fmap` lookupOrig modName occName)
187 {- To find the string in the constructor's info table we need to consider
188 the layout of info tables relative to the entry code for a closure.
190 An info table can be next to the entry code for the closure, or it can
191 be separate. The former (faster) is used in registerised versions of ghc,
192 and the latter (portable) is for non-registerised versions.
194 The diagrams below show where the string is to be found relative to
195 the normal info table of the closure.
197 1) Code next to table:
200 | | <- pointer to the start of the string
202 | | <- the (start of the) info table structure
209 In this case the pointer to the start of the string can be found in
210 the memory location _one word before_ the first entry in the normal info
213 2) Code NOT next to table:
216 info table structure -> | *------------------> --------------
220 ptr to start of str -> | |
223 In this case the pointer to the start of the string can be found
224 in the memory location: info_table_ptr + info_table_size
227 getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
228 getConDescAddress ptr
229 | ghciTablesNextToCode = do
230 offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
231 return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
233 peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
235 -- parsing names is a little bit fiddly because we have a string in the form:
236 -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
237 -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
238 -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
239 -- this is not the conventional way of writing Haskell names. We stick with
240 -- convention, even though it makes the parsing code more troublesome.
241 -- Warning: this code assumes that the string is well formed.
242 parse :: [Word8] -> ([Word8], [Word8], [Word8])
244 = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
246 dot = fromIntegral (ord '.')
247 (pkg, rest1) = break (== fromIntegral (ord ':')) input
249 = (concat $ intersperse [dot] $ reverse modWords, occWord)
251 (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
252 parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
254 = case break (== dot) str of
255 (top, []) -> (acc, top)
256 (top, _:bot) -> parseModOcc (top : acc) bot
259 getHValue :: HscEnv -> Name -> IO HValue
260 getHValue hsc_env name = do
261 when (isExternalName name) $ do
262 ok <- linkDependencies hsc_env noSrcSpan [nameModule name]
263 when (failed ok) $ throwDyn (ProgramError "")
264 pls <- readIORef v_PersistentLinkerState
265 lookupName (closure_env pls) name
267 linkDependencies :: HscEnv -> SrcSpan -> [Module] -> IO SuccessFlag
268 linkDependencies hsc_env span needed_mods = do
269 let hpt = hsc_HPT hsc_env
270 dflags = hsc_dflags hsc_env
271 -- The interpreter and dynamic linker can only handle object code built
272 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
273 -- So here we check the build tag: if we're building a non-standard way
274 -- then we need to find & link object files built the "normal" way.
275 maybe_normal_osuf <- checkNonStdWay dflags span
277 -- Find what packages and linkables are required
278 eps <- readIORef (hsc_EPS hsc_env)
279 (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
280 maybe_normal_osuf span needed_mods
282 -- Link the packages and modules required
283 linkPackages dflags pkgs
284 linkModules dflags lnks
287 -- | Temporarily extend the linker state.
289 withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
290 withExtendedLinkEnv new_env action
291 = bracket_ set_new_env
294 where set_new_env = do
295 pls <- readIORef v_PersistentLinkerState
296 let new_closure_env = extendClosureEnv (closure_env pls) new_env
297 new_pls = pls { closure_env = new_closure_env }
298 writeIORef v_PersistentLinkerState new_pls
301 -- Remember that the linker state might be side-effected
302 -- during the execution of the IO action, and we don't want to
303 -- lose those changes (we might have linked a new module or
304 -- package), so the reset action only removes the names we
307 modifyIORef v_PersistentLinkerState $ \pls ->
308 let cur = closure_env pls
309 new = delListFromNameEnv cur (map fst new_env)
311 pls{ closure_env = new }
313 -- filterNameMap removes from the environment all entries except
314 -- those for a given set of modules;
315 -- Note that this removes all *local* (i.e. non-isExternal) names too
316 -- (these are the temporary bindings from the command line).
317 -- Used to filter both the ClosureEnv and ItblEnv
319 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
320 filterNameMap mods env
321 = filterNameEnv keep_elt env
323 keep_elt (n,_) = isExternalName n
324 && (nameModule n `elem` mods)
329 showLinkerState :: IO ()
330 -- Display the persistent linker state
332 = do pls <- readIORef v_PersistentLinkerState
333 printDump (vcat [text "----- Linker state -----",
334 text "Pkgs:" <+> ppr (pkgs_loaded pls),
335 text "Objs:" <+> ppr (objs_loaded pls),
336 text "BCOs:" <+> ppr (bcos_loaded pls)])
342 %************************************************************************
344 \subsection{Initialisation}
346 %************************************************************************
348 We initialise the dynamic linker by
350 a) calling the C initialisation procedure
352 b) Loading any packages specified on the command line,
354 c) Loading any packages specified on the command line,
355 now held in the -l options in v_Opt_l
357 d) Loading any .o/.dll files specified on the command line,
358 now held in v_Ld_inputs
360 e) Loading any MacOS frameworks
363 initDynLinker :: DynFlags -> IO ()
364 -- This function is idempotent; if called more than once, it does nothing
365 -- This is useful in Template Haskell, where we call it before trying to link
367 = do { done <- readIORef v_InitLinkerDone
368 ; if done then return ()
369 else do { writeIORef v_InitLinkerDone True
370 ; reallyInitDynLinker dflags }
373 reallyInitDynLinker :: DynFlags -> IO ()
374 reallyInitDynLinker dflags
375 = do { -- Initialise the linker state
376 ; writeIORef v_PersistentLinkerState (emptyPLS dflags)
378 -- (a) initialise the C dynamic linker
381 -- (b) Load packages from the command-line
382 ; linkPackages dflags (preloadPackages (pkgState dflags))
384 -- (c) Link libraries from the command-line
385 ; let optl = getOpts dflags opt_l
386 ; let minus_ls = [ lib | '-':'l':lib <- optl ]
388 -- (d) Link .o files from the command-line
389 ; let lib_paths = libraryPaths dflags
390 ; cmdline_ld_inputs <- readIORef v_Ld_inputs
392 ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
394 -- (e) Link any MacOS frameworks
395 ; let framework_paths
396 | isDarwinTarget = frameworkPaths dflags
399 | isDarwinTarget = cmdlineFrameworks dflags
401 -- Finally do (c),(d),(e)
402 ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
404 ++ map Framework frameworks
405 ; if null cmdline_lib_specs then return ()
408 { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
409 ; maybePutStr dflags "final link ... "
412 ; if succeeded ok then maybePutStrLn dflags "done"
413 else throwDyn (InstallationError "linking extra libraries/objects failed")
416 classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
418 | isObjectFilename f = return (Just (Object f))
419 | isDynLibFilename f = return (Just (DLLPath f))
421 hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
424 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
425 preloadLib dflags lib_paths framework_paths lib_spec
426 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
429 -> do b <- preload_static lib_paths static_ish
430 maybePutStrLn dflags (if b then "done"
434 -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
436 Nothing -> maybePutStrLn dflags "done"
437 Just mm -> preloadFailed mm lib_paths lib_spec
440 -> do maybe_errstr <- loadDLL dll_path
442 Nothing -> maybePutStrLn dflags "done"
443 Just mm -> preloadFailed mm lib_paths lib_spec
447 -> do maybe_errstr <- loadFramework framework_paths framework
449 Nothing -> maybePutStrLn dflags "done"
450 Just mm -> preloadFailed mm framework_paths lib_spec
451 | otherwise -> panic "preloadLib Framework"
454 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
455 preloadFailed sys_errmsg paths spec
456 = do maybePutStr dflags
457 ("failed.\nDynamic linker error message was:\n "
458 ++ sys_errmsg ++ "\nWhilst trying to load: "
459 ++ showLS spec ++ "\nDirectories to search are:\n"
460 ++ unlines (map (" "++) paths) )
463 -- Not interested in the paths in the static case.
464 preload_static _paths name
465 = do b <- doesFileExist name
466 if not b then return False
467 else loadObj name >> return True
470 CmdLineError "user specified .o/.so/.DLL could not be loaded."
474 %************************************************************************
476 Link a byte-code expression
478 %************************************************************************
481 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
483 -- Link a single expression, *including* first linking packages and
484 -- modules that this expression depends on.
486 -- Raises an IO exception if it can't find a compiled version of the
487 -- dependents to link.
489 -- Note: This function side-effects the linker state (Pepe)
491 linkExpr hsc_env span root_ul_bco
493 -- Initialise the linker (if it's not been done already)
494 let dflags = hsc_dflags hsc_env
495 ; initDynLinker dflags
497 -- Link the packages and modules required
498 ; ok <- linkDependencies hsc_env span needed_mods
500 throwDyn (ProgramError "")
503 -- Link the expression itself
504 pls <- readIORef v_PersistentLinkerState
505 ; let ie = itbl_env pls
508 -- Link the necessary packages and linkables
509 ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
513 free_names = nameSetToList (bcoFreeNames root_ul_bco)
515 needed_mods :: [Module]
516 needed_mods = [ nameModule n | n <- free_names,
517 isExternalName n, -- Names from other modules
518 not (isWiredInName n) -- Exclude wired-in names
519 ] -- (see note below)
520 -- Exclude wired-in names because we may not have read
521 -- their interface files, so getLinkDeps will fail
522 -- All wired-in names are in the base package, which we link
523 -- by default, so we can safely ignore them here.
525 dieWith :: SrcSpan -> Message -> IO a
526 dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg)))
529 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
530 checkNonStdWay dflags srcspan = do
531 tag <- readIORef v_Build_tag
532 if null tag then return Nothing else do
533 let default_osuf = phaseInputExt StopLn
534 if objectSuf dflags == default_osuf
535 then failNonStd srcspan
536 else return (Just default_osuf)
538 failNonStd :: SrcSpan -> IO (Maybe String)
539 failNonStd srcspan = dieWith srcspan $
540 ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$
541 ptext (sLit "You need to build the program twice: once the normal way, and then") $$
542 ptext (sLit "in the desired way using -osuf to set the object file suffix.")
545 getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable
546 -> Maybe String -- the "normal" object suffix
547 -> SrcSpan -- for error messages
548 -> [Module] -- If you need these
549 -> IO ([Linkable], [PackageId]) -- ... then link these first
550 -- Fails with an IO exception if it can't find enough files
552 getLinkDeps hsc_env hpt _ maybe_normal_osuf span mods
553 -- Find all the packages and linkables that a set of modules depends on
554 = do { pls <- readIORef v_PersistentLinkerState ;
555 -- 1. Find the dependent home-pkg-modules/packages from each iface
556 (mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet;
559 -- 2. Exclude ones already linked
560 -- Main reason: avoid findModule calls in get_linkable
561 mods_needed = mods_s `minusList` linked_mods ;
562 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
564 linked_mods = map (moduleName.linkableModule)
565 (objs_loaded pls ++ bcos_loaded pls)
568 -- putStrLn (showSDoc (ppr mods_s)) ;
569 -- 3. For each dependent module, find its linkable
570 -- This will either be in the HPT or (in the case of one-shot
571 -- compilation) we may need to use maybe_getFileLinkable
572 lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
574 return (lnks_needed, pkgs_needed) }
576 dflags = hsc_dflags hsc_env
577 this_pkg = thisPackage dflags
579 -- The ModIface contains the transitive closure of the module dependencies
580 -- within the current package, *except* for boot modules: if we encounter
581 -- a boot module, we have to find its real interface and discover the
582 -- dependencies of that. Hence we need to traverse the dependency
583 -- tree recursively. See bug #936, testcase ghci/prog007.
584 follow_deps :: [Module] -- modules to follow
585 -> UniqSet ModuleName -- accum. module dependencies
586 -> UniqSet PackageId -- accum. package dependencies
587 -> IO ([ModuleName], [PackageId]) -- result
588 follow_deps [] acc_mods acc_pkgs
589 = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
590 follow_deps (mod:mods) acc_mods acc_pkgs
592 mb_iface <- initIfaceCheck hsc_env $
593 loadInterface msg mod (ImportByUser False)
594 iface <- case mb_iface of
595 Maybes.Failed err -> ghcError (ProgramError (showSDoc err))
596 Maybes.Succeeded iface -> return iface
598 when (mi_boot iface) $ link_boot_mod_error mod
601 pkg = modulePackageId mod
604 pkg_deps = dep_pkgs deps
605 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
606 where is_boot (m,True) = Left m
607 is_boot (m,False) = Right m
609 boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
610 acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
611 acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
614 then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
615 else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)
618 msg = text "need to link module" <+> ppr mod <+>
619 text "due to use of Template Haskell"
622 link_boot_mod_error mod =
623 throwDyn (ProgramError (showSDoc (
624 text "module" <+> ppr mod <+>
625 text "cannot be linked; it is only available as a boot module")))
627 no_obj mod = dieWith span $
628 ptext (sLit "cannot find object file for module ") <>
632 while_linking_expr = ptext (sLit "while linking an interpreted expression")
634 -- This one is a build-system bug
636 get_linkable maybe_normal_osuf mod_name -- A home-package module
637 | Just mod_info <- lookupUFM hpt mod_name
638 = ASSERT(isJust (hm_linkable mod_info))
639 adjust_linkable (fromJust (hm_linkable mod_info))
641 = do -- It's not in the HPT because we are in one shot mode,
642 -- so use the Finder to get a ModLocation...
643 mb_stuff <- findHomeModule hsc_env mod_name
645 Found loc mod -> found loc mod
649 -- ...and then find the linkable for it
650 mb_lnk <- findObjectLinkableMaybe mod loc ;
652 Nothing -> no_obj mod ;
653 Just lnk -> adjust_linkable lnk
657 | Just osuf <- maybe_normal_osuf = do
658 new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
659 return lnk{ linkableUnlinked=new_uls }
663 adjust_ul osuf (DotO file) = do
664 let new_file = replaceExtension file osuf
665 ok <- doesFileExist new_file
668 ptext (sLit "cannot find normal object file ")
669 <> quotes (text new_file) $$ while_linking_expr
670 else return (DotO new_file)
671 adjust_ul _ _ = panic "adjust_ul"
675 %************************************************************************
678 The linkables may consist of a mixture of
679 byte-code modules and object modules
681 %************************************************************************
684 linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
685 linkModules dflags linkables
686 = block $ do -- don't want to be interrupted by ^C in here
688 let (objs, bcos) = partition isObjectLinkable
689 (concatMap partitionLinkable linkables)
691 -- Load objects first; they can't depend on BCOs
692 ok_flag <- dynLinkObjs dflags objs
694 if failed ok_flag then
701 -- HACK to support f-x-dynamic in the interpreter; no other purpose
702 partitionLinkable :: Linkable -> [Linkable]
704 = let li_uls = linkableUnlinked li
705 li_uls_obj = filter isObject li_uls
706 li_uls_bco = filter isInterpretable li_uls
708 case (li_uls_obj, li_uls_bco) of
709 (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
710 li {linkableUnlinked=li_uls_bco}]
713 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
714 findModuleLinkable_maybe lis mod
715 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
718 _ -> pprPanic "findModuleLinkable" (ppr mod)
720 linkableInSet :: Linkable -> [Linkable] -> Bool
721 linkableInSet l objs_loaded =
722 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
724 Just m -> linkableTime l == linkableTime m
728 %************************************************************************
730 \subsection{The object-code linker}
732 %************************************************************************
735 dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
736 -- Side-effects the PersistentLinkerState
738 dynLinkObjs dflags objs
739 = do pls <- readIORef v_PersistentLinkerState
741 -- Load the object files and link them
742 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
743 pls1 = pls { objs_loaded = objs_loaded' }
744 unlinkeds = concatMap linkableUnlinked new_objs
746 mapM loadObj (map nameOfObject unlinkeds)
748 -- Link the all together
751 -- If resolving failed, unload all our
752 -- object modules and carry on
753 if succeeded ok then do
754 writeIORef v_PersistentLinkerState pls1
757 pls2 <- unload_wkr dflags [] pls1
758 writeIORef v_PersistentLinkerState pls2
762 rmDupLinkables :: [Linkable] -- Already loaded
763 -> [Linkable] -- New linkables
764 -> ([Linkable], -- New loaded set (including new ones)
765 [Linkable]) -- New linkables (excluding dups)
766 rmDupLinkables already ls
769 go already extras [] = (already, extras)
770 go already extras (l:ls)
771 | linkableInSet l already = go already extras ls
772 | otherwise = go (l:already) (l:extras) ls
775 %************************************************************************
777 \subsection{The byte-code linker}
779 %************************************************************************
782 dynLinkBCOs :: [Linkable] -> IO ()
783 -- Side-effects the persistent linker state
785 = do pls <- readIORef v_PersistentLinkerState
787 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
788 pls1 = pls { bcos_loaded = bcos_loaded' }
789 unlinkeds :: [Unlinked]
790 unlinkeds = concatMap linkableUnlinked new_bcos
792 cbcs :: [CompiledByteCode]
793 cbcs = map byteCodeOfObject unlinkeds
796 ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
797 ies = [ie | ByteCode _ ie <- cbcs]
798 gce = closure_env pls
799 final_ie = foldr plusNameEnv (itbl_env pls) ies
801 (final_gce, _linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
802 -- XXX What happens to these linked_bcos?
804 let pls2 = pls1 { closure_env = final_gce,
805 itbl_env = final_ie }
807 writeIORef v_PersistentLinkerState pls2
810 -- Link a bunch of BCOs and return them + updated closure env.
811 linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
812 -- True <=> add only toplevel BCOs to closure env
816 -> IO (ClosureEnv, [HValue])
817 -- The returned HValues are associated 1-1 with
818 -- the incoming unlinked BCOs. Each gives the
819 -- value of the corresponding unlinked BCO
821 linkSomeBCOs toplevs_only ie ce_in ul_bcos
822 = do let nms = map unlinkedBCOName ul_bcos
824 ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
825 in mapM (linkBCO ie ce_out) ul_bcos )
826 let ce_all_additions = zip nms hvals
827 ce_top_additions = filter (isExternalName.fst) ce_all_additions
828 ce_additions = if toplevs_only then ce_top_additions
829 else ce_all_additions
830 ce_out = -- make sure we're not inserting duplicate names into the
831 -- closure environment, which leads to trouble.
832 ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
833 extendClosureEnv ce_in ce_additions
834 return (ce_out, hvals)
839 %************************************************************************
841 Unload some object modules
843 %************************************************************************
846 -- ---------------------------------------------------------------------------
847 -- Unloading old objects ready for a new compilation sweep.
849 -- The compilation manager provides us with a list of linkables that it
850 -- considers "stable", i.e. won't be recompiled this time around. For
851 -- each of the modules current linked in memory,
853 -- * if the linkable is stable (and it's the same one - the
854 -- user may have recompiled the module on the side), we keep it,
856 -- * otherwise, we unload it.
858 -- * we also implicitly unload all temporary bindings at this point.
860 unload :: DynFlags -> [Linkable] -> IO ()
861 -- The 'linkables' are the ones to *keep*
863 unload dflags linkables
864 = block $ do -- block, so we're safe from Ctrl-C in here
866 -- Initialise the linker (if it's not been done already)
869 pls <- readIORef v_PersistentLinkerState
870 new_pls <- unload_wkr dflags linkables pls
871 writeIORef v_PersistentLinkerState new_pls
873 debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
874 debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
877 unload_wkr :: DynFlags
878 -> [Linkable] -- stable linkables
879 -> PersistentLinkerState
880 -> IO PersistentLinkerState
881 -- Does the core unload business
882 -- (the wrapper blocks exceptions and deals with the PLS get and put)
884 unload_wkr _ linkables pls
885 = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
887 objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
888 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
890 let bcos_retained = map linkableModule bcos_loaded'
891 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
892 closure_env' = filterNameMap bcos_retained (closure_env pls)
893 new_pls = pls { itbl_env = itbl_env',
894 closure_env = closure_env',
895 bcos_loaded = bcos_loaded',
896 objs_loaded = objs_loaded' }
900 maybeUnload :: [Linkable] -> Linkable -> IO Bool
901 maybeUnload keep_linkables lnk
902 | linkableInSet lnk keep_linkables = return True
904 = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
905 -- The components of a BCO linkable may contain
906 -- dot-o files. Which is very confusing.
908 -- But the BCO parts can be unlinked just by
909 -- letting go of them (plus of course depopulating
910 -- the symbol table which is done in the main body)
915 %************************************************************************
919 %************************************************************************
924 = Object FilePath -- Full path name of a .o file, including trailing .o
925 -- For dynamic objects only, try to find the object
926 -- file in all the directories specified in
927 -- v_Library_paths before giving up.
929 | DLL String -- "Unadorned" name of a .DLL/.so
930 -- e.g. On unix "qt" denotes "libqt.so"
931 -- On WinDoze "burble" denotes "burble.DLL"
932 -- loadDLL is platform-specific and adds the lib/.so/.DLL
933 -- suffixes platform-dependently
935 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
936 -- (ends with .dll or .so).
938 | Framework String -- Only used for darwin, but does no harm
940 -- If this package is already part of the GHCi binary, we'll already
941 -- have the right DLLs for this package loaded, so don't try to
944 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
945 -- as far as the loader is concerned, but it does initialise the list
946 -- of DLL handles that rts/Linker.c maintains, and that in turn is
947 -- used by lookupSymbol. So we must call addDLL for each library
948 -- just to get the DLL handle into the list.
949 partOfGHCi :: [PackageName]
951 | isWindowsTarget || isDarwinTarget = []
952 | otherwise = map PackageName
953 ["base", "haskell98", "template-haskell", "editline"]
955 showLS :: LibrarySpec -> String
956 showLS (Object nm) = "(static) " ++ nm
957 showLS (DLL nm) = "(dynamic) " ++ nm
958 showLS (DLLPath nm) = "(dynamic) " ++ nm
959 showLS (Framework nm) = "(framework) " ++ nm
961 linkPackages :: DynFlags -> [PackageId] -> IO ()
962 -- Link exactly the specified packages, and their dependents
963 -- (unless of course they are already linked)
964 -- The dependents are linked automatically, and it doesn't matter
965 -- what order you specify the input packages.
967 -- NOTE: in fact, since each module tracks all the packages it depends on,
968 -- we don't really need to use the package-config dependencies.
969 -- However we do need the package-config stuff (to find aux libs etc),
970 -- and following them lets us load libraries in the right order, which
971 -- perhaps makes the error message a bit more localised if we get a link
972 -- failure. So the dependency walking code is still here.
974 linkPackages dflags new_pkgs
975 = do { pls <- readIORef v_PersistentLinkerState
976 ; let pkg_map = pkgIdMap (pkgState dflags)
978 ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
980 ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
983 link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
984 link pkg_map pkgs new_pkgs
985 = foldM (link_one pkg_map) pkgs new_pkgs
987 link_one pkg_map pkgs new_pkg
988 | new_pkg `elem` pkgs -- Already linked
991 | Just pkg_cfg <- lookupPackage pkg_map new_pkg
992 = do { -- Link dependents first
993 pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
994 -- Now link the package itself
995 ; linkPackage dflags pkg_cfg
996 ; return (new_pkg : pkgs') }
999 = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
1002 linkPackage :: DynFlags -> PackageConfig -> IO ()
1003 linkPackage dflags pkg
1005 let dirs = Packages.libraryDirs pkg
1007 let libs = Packages.hsLibraries pkg
1008 -- Because of slight differences between the GHC dynamic linker and
1009 -- the native system linker some packages have to link with a
1010 -- different list of libraries when using GHCi. Examples include: libs
1011 -- that are actually gnu ld scripts, and the possability that the .a
1012 -- libs do not exactly match the .so/.dll equivalents. So if the
1013 -- package file provides an "extra-ghci-libraries" field then we use
1014 -- that instead of the "extra-libraries" field.
1015 ++ (if null (Packages.extraGHCiLibraries pkg)
1016 then Packages.extraLibraries pkg
1017 else Packages.extraGHCiLibraries pkg)
1018 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
1019 classifieds <- mapM (locateOneObj dirs) libs
1021 -- Complication: all the .so's must be loaded before any of the .o's.
1022 let dlls = [ dll | DLL dll <- classifieds ]
1023 objs = [ obj | Object obj <- classifieds ]
1025 maybePutStr dflags ("Loading package " ++ display (package pkg) ++ " ... ")
1027 -- See comments with partOfGHCi
1028 when (packageName pkg `notElem` partOfGHCi) $ do
1030 -- When a library A needs symbols from a library B, the order in
1031 -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
1032 -- way ld expects it for static linking. Dynamic linking is a
1033 -- different story: When A has no dependency information for B,
1034 -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
1035 -- when B has not been loaded before. In a nutshell: Reverse the
1036 -- order of DLLs for dynamic linking.
1037 -- This fixes a problem with the HOpenGL package (see "Compiling
1038 -- HOpenGL under recent versions of GHC" on the HOpenGL list).
1039 mapM_ (load_dyn dirs) (reverse dlls)
1041 -- After loading all the DLLs, we can load the static objects.
1042 -- Ordering isn't important here, because we do one final link
1043 -- step to resolve everything.
1046 maybePutStr dflags "linking ... "
1048 if succeeded ok then maybePutStrLn dflags "done."
1049 else throwDyn (InstallationError ("unable to load package `" ++ display (package pkg) ++ "'"))
1051 load_dyn :: [FilePath] -> FilePath -> IO ()
1052 load_dyn dirs dll = do r <- loadDynamic dirs dll
1054 Nothing -> return ()
1055 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1056 ++ dll ++ " (" ++ err ++ ")" ))
1058 loadFrameworks :: InstalledPackageInfo_ ModuleName -> IO ()
1060 | isDarwinTarget = mapM_ load frameworks
1061 | otherwise = return ()
1063 fw_dirs = Packages.frameworkDirs pkg
1064 frameworks = Packages.frameworks pkg
1066 load fw = do r <- loadFramework fw_dirs fw
1068 Nothing -> return ()
1069 Just err -> throwDyn (CmdLineError ("can't load framework: "
1070 ++ fw ++ " (" ++ err ++ ")" ))
1072 -- Try to find an object file for a given library in the given paths.
1073 -- If it isn't present, we assume it's a dynamic library.
1074 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1075 locateOneObj dirs lib
1077 -- When the GHC package was not compiled as dynamic library
1078 -- (=__PIC__ not set), we search for .o libraries first.
1079 = do { mb_obj_path <- findFile mk_obj_path dirs
1080 ; case mb_obj_path of
1081 Just obj_path -> return (Object obj_path)
1083 do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1084 ; case mb_lib_path of
1085 Just _ -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
1086 Nothing -> return (DLL lib) }} -- We assume
1088 -- When the GHC package was compiled as dynamic library (=__PIC__ set),
1089 -- we search for .so libraries first.
1090 = do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1091 ; case mb_lib_path of
1092 Just _ -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
1094 do { mb_obj_path <- findFile mk_obj_path dirs
1095 ; case mb_obj_path of
1096 Just obj_path -> return (Object obj_path)
1097 Nothing -> return (DLL lib) }} -- We assume
1099 mk_obj_path dir = dir </> (lib <.> "o")
1100 mk_dyn_lib_path dir = dir </> mkSOName (lib ++ "-ghc" ++ cProjectVersion)
1102 -- ----------------------------------------------------------------------------
1103 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1105 -- return Nothing == success, else Just error message from dlopen
1106 loadDynamic :: [FilePath] -> FilePath -> IO (Maybe String)
1107 loadDynamic paths rootname
1108 = do { mb_dll <- findFile mk_dll_path paths
1110 Just dll -> loadDLL dll
1111 Nothing -> loadDLL (mkSOName rootname) }
1112 -- Tried all our known library paths, so let
1113 -- dlopen() search its own builtin paths now.
1115 mk_dll_path dir = dir </> mkSOName rootname
1117 mkSOName :: FilePath -> FilePath
1119 | isDarwinTarget = ("lib" ++ root) <.> "dylib"
1120 | isWindowsTarget = -- Win32 DLLs have no .dll extension here, because
1121 -- addDLL tries both foo.dll and foo.drv
1123 | otherwise = ("lib" ++ root) <.> "so"
1125 -- Darwin / MacOS X only: load a framework
1126 -- a framework is a dynamic library packaged inside a directory of the same
1127 -- name. They are searched for in different paths than normal libraries.
1128 loadFramework :: [FilePath] -> FilePath -> IO (Maybe String)
1129 loadFramework extraPaths rootname
1130 = do { either_dir <- Control.Exception.try getHomeDirectory
1131 ; let homeFrameworkPath = case either_dir of
1133 Right dir -> [dir ++ "/Library/Frameworks"]
1134 ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
1135 ; mb_fwk <- findFile mk_fwk ps
1137 Just fwk_path -> loadDLL fwk_path
1138 Nothing -> return (Just "not found") }
1139 -- Tried all our known library paths, but dlopen()
1140 -- has no built-in paths for frameworks: give up
1142 mk_fwk dir = dir </> (rootname ++ ".framework/" ++ rootname)
1143 -- sorry for the hardcoded paths, I hope they won't change anytime soon:
1144 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1147 %************************************************************************
1151 %************************************************************************
1154 findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
1155 -> [FilePath] -- Directories to look in
1156 -> IO (Maybe FilePath) -- The first file path to match
1159 findFile mk_file_path (dir:dirs)
1160 = do { let file_path = mk_file_path dir
1161 ; b <- doesFileExist file_path
1163 return (Just file_path)
1165 findFile mk_file_path dirs }
1169 maybePutStr :: DynFlags -> String -> IO ()
1170 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1171 | otherwise = return ()
1173 maybePutStrLn :: DynFlags -> String -> IO ()
1174 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1175 | otherwise = return ()