2 % (c) The University of Glasgow 2005-2006
5 -- | The dynamic linker for GHCi.
7 -- This module deals with the top-level issues of dynamic linking,
8 -- calling the object-code linker and the byte-code linker where
11 {-# OPTIONS -fno-cse #-}
12 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
14 module Linker ( HValue, getHValue, showLinkerState,
15 linkExpr, unload, withExtendedLinkEnv,
16 extendLinkEnv, deleteFromLinkEnv,
18 linkPackages,initDynLinker,
22 #include "HsVersions.h"
40 import qualified OccName
52 import qualified Maybes
57 import Config ( cProjectVersion )
66 import Control.Concurrent.MVar
68 import System.FilePath
70 import System.Directory
72 import Distribution.Package hiding (depends, PackageId)
78 %************************************************************************
82 %************************************************************************
84 The persistent linker state *must* match the actual state of the
85 C dynamic linker at all times, so we keep it in a private global variable.
88 The PersistentLinkerState maps Names to actual closures (for
89 interpreted code only), for use during linking.
92 GLOBAL_MVAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState)
93 GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
95 data PersistentLinkerState
96 = PersistentLinkerState {
98 -- Current global mapping from Names to their true values
99 closure_env :: ClosureEnv,
101 -- The current global mapping from RdrNames of DataCons to
102 -- info table addresses.
103 -- When a new Unlinked is linked into the running image, or an existing
104 -- module in the image is replaced, the itbl_env must be updated
106 itbl_env :: !ItblEnv,
108 -- The currently loaded interpreted modules (home package)
109 bcos_loaded :: ![Linkable],
111 -- And the currently-loaded compiled modules (home package)
112 objs_loaded :: ![Linkable],
114 -- The currently-loaded packages; always object code
115 -- Held, as usual, in dependency order; though I am not sure if
116 -- that is really important
117 pkgs_loaded :: ![PackageId]
120 emptyPLS :: DynFlags -> PersistentLinkerState
121 emptyPLS _ = PersistentLinkerState {
122 closure_env = emptyNameEnv,
123 itbl_env = emptyNameEnv,
124 pkgs_loaded = init_pkgs,
128 -- Packages that don't need loading, because the compiler
129 -- shares them with the interpreted program.
131 -- The linker's symbol table is populated with RTS symbols using an
132 -- explicit list. See rts/Linker.c for details.
133 where init_pkgs = [rtsPackageId]
137 extendLoadedPkgs :: [PackageId] -> IO ()
138 extendLoadedPkgs pkgs =
139 modifyMVar_ v_PersistentLinkerState $ \s ->
140 return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
142 extendLinkEnv :: [(Name,HValue)] -> IO ()
143 -- Automatically discards shadowed bindings
144 extendLinkEnv new_bindings =
145 modifyMVar_ v_PersistentLinkerState $ \pls ->
146 let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
147 in return pls{ closure_env = new_closure_env }
149 deleteFromLinkEnv :: [Name] -> IO ()
150 deleteFromLinkEnv to_remove =
151 modifyMVar_ v_PersistentLinkerState $ \pls ->
152 let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
153 in return pls{ closure_env = new_closure_env }
155 -- | Given a data constructor in the heap, find its Name.
156 -- The info tables for data constructors have a field which records
157 -- the source name of the constructor as a Ptr Word8 (UTF-8 encoded
158 -- string). The format is:
160 -- > Package:Module.Name
162 -- We use this string to lookup the interpreter's internal representation of the name
163 -- using the lookupOrig.
165 dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
166 dataConInfoPtrToName x = do
167 theString <- liftIO $ do
168 let ptr = castPtr x :: Ptr StgInfoTable
169 conDescAddress <- getConDescAddress ptr
170 peekArray0 0 conDescAddress
171 let (pkg, mod, occ) = parse theString
172 pkgFS = mkFastStringByteList pkg
173 modFS = mkFastStringByteList mod
174 occFS = mkFastStringByteList occ
175 occName = mkOccNameFS OccName.dataName occFS
176 modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS)
177 return (Left$ showSDoc$ ppr modName <> dot <> ppr occName )
178 `recoverM` (Right `fmap` lookupOrig modName occName)
182 {- To find the string in the constructor's info table we need to consider
183 the layout of info tables relative to the entry code for a closure.
185 An info table can be next to the entry code for the closure, or it can
186 be separate. The former (faster) is used in registerised versions of ghc,
187 and the latter (portable) is for non-registerised versions.
189 The diagrams below show where the string is to be found relative to
190 the normal info table of the closure.
192 1) Code next to table:
195 | | <- pointer to the start of the string
197 | | <- the (start of the) info table structure
204 In this case the pointer to the start of the string can be found in
205 the memory location _one word before_ the first entry in the normal info
208 2) Code NOT next to table:
211 info table structure -> | *------------------> --------------
215 ptr to start of str -> | |
218 In this case the pointer to the start of the string can be found
219 in the memory location: info_table_ptr + info_table_size
222 getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
223 getConDescAddress ptr
224 | ghciTablesNextToCode = do
225 offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
226 return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
228 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
253 -- | Get the 'HValue' associated with the given name.
255 -- May cause loading the module that contains the name.
257 -- Throws a 'ProgramError' if loading fails or the name cannot be found.
258 getHValue :: HscEnv -> Name -> IO HValue
259 getHValue hsc_env name = do
260 pls <- modifyMVar v_PersistentLinkerState $ \pls -> do
261 if (isExternalName name) then do
262 (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name]
263 if (failed ok) then ghcError (ProgramError "")
264 else return (pls', pls')
267 lookupName (closure_env pls) name
269 linkDependencies :: HscEnv -> PersistentLinkerState
270 -> SrcSpan -> [Module]
271 -> IO (PersistentLinkerState, SuccessFlag)
272 linkDependencies hsc_env pls span needed_mods = do
273 let hpt = hsc_HPT hsc_env
274 dflags = hsc_dflags hsc_env
275 -- The interpreter and dynamic linker can only handle object code built
276 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
277 -- So here we check the build tag: if we're building a non-standard way
278 -- then we need to find & link object files built the "normal" way.
279 maybe_normal_osuf <- checkNonStdWay dflags span
281 -- Find what packages and linkables are required
282 (lnks, pkgs) <- getLinkDeps hsc_env hpt pls
283 maybe_normal_osuf span needed_mods
285 -- Link the packages and modules required
286 pls1 <- linkPackages' dflags pkgs pls
287 linkModules dflags pls1 lnks
290 -- | Temporarily extend the linker state.
292 withExtendedLinkEnv :: (MonadIO m, ExceptionMonad m) =>
293 [(Name,HValue)] -> m a -> m a
294 withExtendedLinkEnv new_env action
295 = gbracket (liftIO $ extendLinkEnv new_env)
296 (\_ -> reset_old_env)
299 -- Remember that the linker state might be side-effected
300 -- during the execution of the IO action, and we don't want to
301 -- lose those changes (we might have linked a new module or
302 -- package), so the reset action only removes the names we
304 reset_old_env = liftIO $ do
305 modifyMVar_ v_PersistentLinkerState $ \pls ->
306 let cur = closure_env pls
307 new = delListFromNameEnv cur (map fst new_env)
308 in return pls{ closure_env = new }
310 -- filterNameMap removes from the environment all entries except
311 -- those for a given set of modules;
312 -- Note that this removes all *local* (i.e. non-isExternal) names too
313 -- (these are the temporary bindings from the command line).
314 -- Used to filter both the ClosureEnv and ItblEnv
316 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
317 filterNameMap mods env
318 = filterNameEnv keep_elt env
320 keep_elt (n,_) = isExternalName n
321 && (nameModule n `elem` mods)
326 -- | Display the persistent linker state.
327 showLinkerState :: IO ()
329 = do pls <- readMVar v_PersistentLinkerState
330 printDump (vcat [text "----- Linker state -----",
331 text "Pkgs:" <+> ppr (pkgs_loaded pls),
332 text "Objs:" <+> ppr (objs_loaded pls),
333 text "BCOs:" <+> ppr (bcos_loaded pls)])
339 %************************************************************************
341 \subsection{Initialisation}
343 %************************************************************************
346 -- | Initialise the dynamic linker. This entails
348 -- a) Calling the C initialisation procedure,
350 -- b) Loading any packages specified on the command line,
352 -- c) Loading any packages specified on the command line, now held in the
353 -- @-l@ options in @v_Opt_l@,
355 -- d) Loading any @.o\/.dll@ files specified on the command line, now held
358 -- e) Loading any MacOS frameworks.
360 -- NOTE: This function is idempotent; if called more than once, it does
361 -- nothing. This is useful in Template Haskell, where we call it before
364 initDynLinker :: DynFlags -> IO ()
365 initDynLinker dflags =
366 modifyMVar_ v_PersistentLinkerState $ \pls0 -> do
367 done <- readIORef v_InitLinkerDone
368 if done then return pls0
369 else do writeIORef v_InitLinkerDone True
370 reallyInitDynLinker dflags
372 reallyInitDynLinker :: DynFlags -> IO PersistentLinkerState
373 reallyInitDynLinker dflags =
374 do { -- Initialise the linker state
375 let pls0 = emptyPLS dflags
377 -- (a) initialise the C dynamic linker
380 -- (b) Load packages from the command-line
381 ; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0
383 -- (c) Link libraries from the command-line
384 ; let optl = getOpts dflags opt_l
385 ; let minus_ls = [ lib | '-':'l':lib <- optl ]
387 -- (d) Link .o files from the command-line
388 ; let lib_paths = libraryPaths dflags
389 ; cmdline_ld_inputs <- readIORef v_Ld_inputs
391 ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
393 -- (e) Link any MacOS frameworks
394 ; let framework_paths
395 | isDarwinTarget = frameworkPaths dflags
398 | isDarwinTarget = cmdlineFrameworks dflags
400 -- Finally do (c),(d),(e)
401 ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
403 ++ map Framework frameworks
404 ; if null cmdline_lib_specs then return pls
407 { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
408 ; maybePutStr dflags "final link ... "
411 ; if succeeded ok then maybePutStrLn dflags "done"
412 else ghcError (ProgramError "linking extra libraries/objects failed")
417 classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
419 | isObjectFilename f = return (Just (Object f))
420 | isDynLibFilename f = return (Just (DLLPath f))
422 hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
425 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
426 preloadLib dflags lib_paths framework_paths lib_spec
427 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
430 -> do b <- preload_static lib_paths static_ish
431 maybePutStrLn dflags (if b then "done"
435 -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
437 Nothing -> maybePutStrLn dflags "done"
438 Just mm -> preloadFailed mm lib_paths lib_spec
441 -> do maybe_errstr <- loadDLL dll_path
443 Nothing -> maybePutStrLn dflags "done"
444 Just mm -> preloadFailed mm lib_paths lib_spec
448 -> do maybe_errstr <- loadFramework framework_paths framework
450 Nothing -> maybePutStrLn dflags "done"
451 Just mm -> preloadFailed mm framework_paths lib_spec
452 | otherwise -> panic "preloadLib Framework"
455 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
456 preloadFailed sys_errmsg paths spec
457 = do maybePutStr dflags "failed.\n"
460 "user specified .o/.so/.DLL could not be loaded ("
461 ++ sys_errmsg ++ ")\nWhilst trying to load: "
462 ++ showLS spec ++ "\nAdditional directories searched:"
463 ++ (if null paths then " (none)" else
464 (concat (intersperse "\n" (map (" "++) paths)))))
466 -- Not interested in the paths in the static case.
467 preload_static _paths name
468 = do b <- doesFileExist name
469 if not b then return False
470 else loadObj name >> return True
474 %************************************************************************
476 Link a byte-code expression
478 %************************************************************************
481 -- | Link a single expression, /including/ first linking packages and
482 -- modules that this expression depends on.
484 -- Raises an IO exception ('ProgramError') if it can't find a compiled
485 -- version of the dependents to link.
487 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
488 linkExpr hsc_env span root_ul_bco
490 -- Initialise the linker (if it's not been done already)
491 let dflags = hsc_dflags hsc_env
492 ; initDynLinker dflags
494 -- Take lock for the actual work.
495 ; modifyMVar v_PersistentLinkerState $ \pls0 -> do {
497 -- Link the packages and modules required
498 ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
500 ghcError (ProgramError "")
503 -- Link the expression itself
504 let ie = itbl_env pls
507 -- Link the necessary packages and linkables
508 ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
509 ; return (pls, root_hval)
512 free_names = nameSetToList (bcoFreeNames root_ul_bco)
514 needed_mods :: [Module]
515 needed_mods = [ nameModule n | n <- free_names,
516 isExternalName n, -- Names from other modules
517 not (isWiredInName n) -- Exclude wired-in names
518 ] -- (see note below)
519 -- Exclude wired-in names because we may not have read
520 -- their interface files, so getLinkDeps will fail
521 -- All wired-in names are in the base package, which we link
522 -- by default, so we can safely ignore them here.
524 dieWith :: SrcSpan -> Message -> IO a
525 dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage span msg)))
528 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
529 checkNonStdWay dflags srcspan = do
530 let tag = buildTag dflags
531 if null tag {- || tag == "dyn" -} then return Nothing else do
532 -- see #3604: object files compiled for way "dyn" need to link to the
533 -- dynamic packages, so we can't load them into a statically-linked GHCi.
534 -- we have to treat "dyn" in the same way as "prof".
536 -- In the future when GHCi is dynamically linked we should be able to relax
537 -- this, but they we may have to make it possible to load either ordinary
538 -- .o files or -dynamic .o files into GHCi (currently that's not possible
539 -- because the dynamic objects contain refs to e.g. __stginit_base_Prelude_dyn
540 -- whereas we have __stginit_base_Prelude_.
541 let default_osuf = phaseInputExt StopLn
542 if objectSuf dflags == default_osuf
543 then failNonStd srcspan
544 else return (Just default_osuf)
546 failNonStd :: SrcSpan -> IO (Maybe String)
547 failNonStd srcspan = dieWith srcspan $
548 ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$
549 ptext (sLit "You need to build the program twice: once the normal way, and then") $$
550 ptext (sLit "in the desired way using -osuf to set the object file suffix.")
553 getLinkDeps :: HscEnv -> HomePackageTable
554 -> PersistentLinkerState
555 -> Maybe String -- the "normal" object suffix
556 -> SrcSpan -- for error messages
557 -> [Module] -- If you need these
558 -> IO ([Linkable], [PackageId]) -- ... then link these first
559 -- Fails with an IO exception if it can't find enough files
561 getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
562 -- Find all the packages and linkables that a set of modules depends on
564 -- 1. Find the dependent home-pkg-modules/packages from each iface
565 (mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet;
568 -- 2. Exclude ones already linked
569 -- Main reason: avoid findModule calls in get_linkable
570 mods_needed = mods_s `minusList` linked_mods ;
571 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
573 linked_mods = map (moduleName.linkableModule)
574 (objs_loaded pls ++ bcos_loaded pls)
577 -- putStrLn (showSDoc (ppr mods_s)) ;
578 -- 3. For each dependent module, find its linkable
579 -- This will either be in the HPT or (in the case of one-shot
580 -- compilation) we may need to use maybe_getFileLinkable
581 lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
583 return (lnks_needed, pkgs_needed) }
585 dflags = hsc_dflags hsc_env
586 this_pkg = thisPackage dflags
588 -- The ModIface contains the transitive closure of the module dependencies
589 -- within the current package, *except* for boot modules: if we encounter
590 -- a boot module, we have to find its real interface and discover the
591 -- dependencies of that. Hence we need to traverse the dependency
592 -- tree recursively. See bug #936, testcase ghci/prog007.
593 follow_deps :: [Module] -- modules to follow
594 -> UniqSet ModuleName -- accum. module dependencies
595 -> UniqSet PackageId -- accum. package dependencies
596 -> IO ([ModuleName], [PackageId]) -- result
597 follow_deps [] acc_mods acc_pkgs
598 = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
599 follow_deps (mod:mods) acc_mods acc_pkgs
601 mb_iface <- initIfaceCheck hsc_env $
602 loadInterface msg mod (ImportByUser False)
603 iface <- case mb_iface of
604 Maybes.Failed err -> ghcError (ProgramError (showSDoc err))
605 Maybes.Succeeded iface -> return iface
607 when (mi_boot iface) $ link_boot_mod_error mod
610 pkg = modulePackageId mod
613 pkg_deps = dep_pkgs deps
614 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
615 where is_boot (m,True) = Left m
616 is_boot (m,False) = Right m
618 boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
619 acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
620 acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
623 then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
624 else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)
627 msg = text "need to link module" <+> ppr mod <+>
628 text "due to use of Template Haskell"
631 link_boot_mod_error mod =
632 ghcError (ProgramError (showSDoc (
633 text "module" <+> ppr mod <+>
634 text "cannot be linked; it is only available as a boot module")))
636 no_obj :: Outputable a => a -> IO b
637 no_obj mod = dieWith span $
638 ptext (sLit "cannot find object file for module ") <>
642 while_linking_expr = ptext (sLit "while linking an interpreted expression")
644 -- This one is a build-system bug
646 get_linkable maybe_normal_osuf mod_name -- A home-package module
647 | Just mod_info <- lookupUFM hpt mod_name
648 = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
650 = do -- It's not in the HPT because we are in one shot mode,
651 -- so use the Finder to get a ModLocation...
652 mb_stuff <- findHomeModule hsc_env mod_name
654 Found loc mod -> found loc mod
658 -- ...and then find the linkable for it
659 mb_lnk <- findObjectLinkableMaybe mod loc ;
661 Nothing -> no_obj mod ;
662 Just lnk -> adjust_linkable lnk
666 | Just osuf <- maybe_normal_osuf = do
667 new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
668 return lnk{ linkableUnlinked=new_uls }
672 adjust_ul osuf (DotO file) = do
673 let new_file = replaceExtension file osuf
674 ok <- doesFileExist new_file
677 ptext (sLit "cannot find normal object file ")
678 <> quotes (text new_file) $$ while_linking_expr
679 else return (DotO new_file)
680 adjust_ul _ _ = panic "adjust_ul"
684 %************************************************************************
687 The linkables may consist of a mixture of
688 byte-code modules and object modules
690 %************************************************************************
693 linkModules :: DynFlags -> PersistentLinkerState -> [Linkable]
694 -> IO (PersistentLinkerState, SuccessFlag)
695 linkModules dflags pls linkables
696 = mask_ $ do -- don't want to be interrupted by ^C in here
698 let (objs, bcos) = partition isObjectLinkable
699 (concatMap partitionLinkable linkables)
701 -- Load objects first; they can't depend on BCOs
702 (pls1, ok_flag) <- dynLinkObjs dflags pls objs
704 if failed ok_flag then
705 return (pls1, Failed)
707 pls2 <- dynLinkBCOs pls1 bcos
708 return (pls2, Succeeded)
711 -- HACK to support f-x-dynamic in the interpreter; no other purpose
712 partitionLinkable :: Linkable -> [Linkable]
714 = let li_uls = linkableUnlinked li
715 li_uls_obj = filter isObject li_uls
716 li_uls_bco = filter isInterpretable li_uls
718 case (li_uls_obj, li_uls_bco) of
719 (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
720 li {linkableUnlinked=li_uls_bco}]
723 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
724 findModuleLinkable_maybe lis mod
725 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
728 _ -> pprPanic "findModuleLinkable" (ppr mod)
730 linkableInSet :: Linkable -> [Linkable] -> Bool
731 linkableInSet l objs_loaded =
732 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
734 Just m -> linkableTime l == linkableTime m
738 %************************************************************************
740 \subsection{The object-code linker}
742 %************************************************************************
745 dynLinkObjs :: DynFlags -> PersistentLinkerState -> [Linkable]
746 -> IO (PersistentLinkerState, SuccessFlag)
747 dynLinkObjs dflags pls objs = do
748 -- Load the object files and link them
749 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
750 pls1 = pls { objs_loaded = objs_loaded' }
751 unlinkeds = concatMap linkableUnlinked new_objs
753 mapM_ loadObj (map nameOfObject unlinkeds)
755 -- Link the all together
758 -- If resolving failed, unload all our
759 -- object modules and carry on
760 if succeeded ok then do
761 return (pls1, Succeeded)
763 pls2 <- unload_wkr dflags [] pls1
764 return (pls2, Failed)
767 rmDupLinkables :: [Linkable] -- Already loaded
768 -> [Linkable] -- New linkables
769 -> ([Linkable], -- New loaded set (including new ones)
770 [Linkable]) -- New linkables (excluding dups)
771 rmDupLinkables already ls
774 go already extras [] = (already, extras)
775 go already extras (l:ls)
776 | linkableInSet l already = go already extras ls
777 | otherwise = go (l:already) (l:extras) ls
780 %************************************************************************
782 \subsection{The byte-code linker}
784 %************************************************************************
787 dynLinkBCOs :: PersistentLinkerState -> [Linkable] -> IO PersistentLinkerState
788 dynLinkBCOs pls bcos = do
790 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
791 pls1 = pls { bcos_loaded = bcos_loaded' }
792 unlinkeds :: [Unlinked]
793 unlinkeds = concatMap linkableUnlinked new_bcos
795 cbcs :: [CompiledByteCode]
796 cbcs = map byteCodeOfObject unlinkeds
799 ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
800 ies = [ie | ByteCode _ ie <- cbcs]
801 gce = closure_env pls
802 final_ie = foldr plusNameEnv (itbl_env pls) ies
804 (final_gce, _linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
805 -- XXX What happens to these linked_bcos?
807 let pls2 = pls1 { closure_env = final_gce,
808 itbl_env = final_ie }
812 -- Link a bunch of BCOs and return them + updated closure env.
813 linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
814 -- True <=> add only toplevel BCOs to closure env
818 -> IO (ClosureEnv, [HValue])
819 -- The returned HValues are associated 1-1 with
820 -- the incoming unlinked BCOs. Each gives the
821 -- value of the corresponding unlinked BCO
823 linkSomeBCOs toplevs_only ie ce_in ul_bcos
824 = do let nms = map unlinkedBCOName ul_bcos
826 ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
827 in mapM (linkBCO ie ce_out) ul_bcos )
828 let ce_all_additions = zip nms hvals
829 ce_top_additions = filter (isExternalName.fst) ce_all_additions
830 ce_additions = if toplevs_only then ce_top_additions
831 else ce_all_additions
832 ce_out = -- make sure we're not inserting duplicate names into the
833 -- closure environment, which leads to trouble.
834 ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
835 extendClosureEnv ce_in ce_additions
836 return (ce_out, hvals)
841 %************************************************************************
843 Unload some object modules
845 %************************************************************************
848 -- ---------------------------------------------------------------------------
849 -- | Unloading old objects ready for a new compilation sweep.
851 -- The compilation manager provides us with a list of linkables that it
852 -- considers \"stable\", i.e. won't be recompiled this time around. For
853 -- each of the modules current linked in memory,
855 -- * if the linkable is stable (and it's the same one -- the user may have
856 -- recompiled the module on the side), we keep it,
858 -- * otherwise, we unload it.
860 -- * we also implicitly unload all temporary bindings at this point.
863 -> [Linkable] -- ^ The linkables to *keep*.
865 unload dflags linkables
866 = mask_ $ do -- mask, so we're safe from Ctrl-C in here
868 -- Initialise the linker (if it's not been done already)
872 <- modifyMVar v_PersistentLinkerState $ \pls -> do
873 pls1 <- unload_wkr dflags linkables pls
876 debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
877 debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
880 unload_wkr :: DynFlags
881 -> [Linkable] -- stable linkables
882 -> PersistentLinkerState
883 -> IO PersistentLinkerState
884 -- Does the core unload business
885 -- (the wrapper blocks exceptions and deals with the PLS get and put)
887 unload_wkr _ linkables pls
888 = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
890 objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
891 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
893 let bcos_retained = map linkableModule bcos_loaded'
894 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
895 closure_env' = filterNameMap bcos_retained (closure_env pls)
896 new_pls = pls { itbl_env = itbl_env',
897 closure_env = closure_env',
898 bcos_loaded = bcos_loaded',
899 objs_loaded = objs_loaded' }
903 maybeUnload :: [Linkable] -> Linkable -> IO Bool
904 maybeUnload keep_linkables lnk
905 | linkableInSet lnk keep_linkables = return True
907 = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
908 -- The components of a BCO linkable may contain
909 -- dot-o files. Which is very confusing.
911 -- But the BCO parts can be unlinked just by
912 -- letting go of them (plus of course depopulating
913 -- the symbol table which is done in the main body)
918 %************************************************************************
922 %************************************************************************
927 = Object FilePath -- Full path name of a .o file, including trailing .o
928 -- For dynamic objects only, try to find the object
929 -- file in all the directories specified in
930 -- v_Library_paths before giving up.
932 | DLL String -- "Unadorned" name of a .DLL/.so
933 -- e.g. On unix "qt" denotes "libqt.so"
934 -- On WinDoze "burble" denotes "burble.DLL"
935 -- loadDLL is platform-specific and adds the lib/.so/.DLL
936 -- suffixes platform-dependently
938 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
939 -- (ends with .dll or .so).
941 | Framework String -- Only used for darwin, but does no harm
943 -- If this package is already part of the GHCi binary, we'll already
944 -- have the right DLLs for this package loaded, so don't try to
947 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
948 -- as far as the loader is concerned, but it does initialise the list
949 -- of DLL handles that rts/Linker.c maintains, and that in turn is
950 -- used by lookupSymbol. So we must call addDLL for each library
951 -- just to get the DLL handle into the list.
952 partOfGHCi :: [PackageName]
954 | isWindowsTarget || isDarwinTarget = []
955 | otherwise = map PackageName
956 ["base", "haskell98", "template-haskell", "editline"]
958 showLS :: LibrarySpec -> String
959 showLS (Object nm) = "(static) " ++ nm
960 showLS (DLL nm) = "(dynamic) " ++ nm
961 showLS (DLLPath nm) = "(dynamic) " ++ nm
962 showLS (Framework nm) = "(framework) " ++ nm
964 -- | Link exactly the specified packages, and their dependents (unless of
965 -- course they are already linked). The dependents are linked
966 -- automatically, and it doesn't matter what order you specify the input
969 linkPackages :: DynFlags -> [PackageId] -> IO ()
970 -- NOTE: in fact, since each module tracks all the packages it depends on,
971 -- we don't really need to use the package-config dependencies.
973 -- However we do need the package-config stuff (to find aux libs etc),
974 -- and following them lets us load libraries in the right order, which
975 -- perhaps makes the error message a bit more localised if we get a link
976 -- failure. So the dependency walking code is still here.
978 linkPackages dflags new_pkgs = do
979 -- It's probably not safe to try to load packages concurrently, so we take
981 modifyMVar_ v_PersistentLinkerState $ \pls -> do
982 linkPackages' dflags new_pkgs pls
984 linkPackages' :: DynFlags -> [PackageId] -> PersistentLinkerState
985 -> IO PersistentLinkerState
986 linkPackages' dflags new_pks pls = do
987 pkgs' <- link (pkgs_loaded pls) new_pks
988 return $! pls { pkgs_loaded = pkgs' }
990 pkg_map = pkgIdMap (pkgState dflags)
991 ipid_map = installedPackageIdMap (pkgState dflags)
993 link :: [PackageId] -> [PackageId] -> IO [PackageId]
995 foldM link_one pkgs new_pkgs
997 link_one pkgs new_pkg
998 | new_pkg `elem` pkgs -- Already linked
1001 | Just pkg_cfg <- lookupPackage pkg_map new_pkg
1002 = do { -- Link dependents first
1003 pkgs' <- link pkgs [ Maybes.expectJust "link_one" $
1004 lookupFM ipid_map ipid
1005 | ipid <- depends pkg_cfg ]
1006 -- Now link the package itself
1007 ; linkPackage dflags pkg_cfg
1008 ; return (new_pkg : pkgs') }
1011 = ghcError (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
1014 linkPackage :: DynFlags -> PackageConfig -> IO ()
1015 linkPackage dflags pkg
1017 let dirs = Packages.libraryDirs pkg
1019 let libs = Packages.hsLibraries pkg
1020 -- Because of slight differences between the GHC dynamic linker and
1021 -- the native system linker some packages have to link with a
1022 -- different list of libraries when using GHCi. Examples include: libs
1023 -- that are actually gnu ld scripts, and the possability that the .a
1024 -- libs do not exactly match the .so/.dll equivalents. So if the
1025 -- package file provides an "extra-ghci-libraries" field then we use
1026 -- that instead of the "extra-libraries" field.
1027 ++ (if null (Packages.extraGHCiLibraries pkg)
1028 then Packages.extraLibraries pkg
1029 else Packages.extraGHCiLibraries pkg)
1030 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
1031 classifieds <- mapM (locateOneObj dirs) libs
1033 -- Complication: all the .so's must be loaded before any of the .o's.
1034 let dlls = [ dll | DLL dll <- classifieds ]
1035 objs = [ obj | Object obj <- classifieds ]
1037 maybePutStr dflags ("Loading package " ++ display (sourcePackageId pkg) ++ " ... ")
1039 -- See comments with partOfGHCi
1040 when (packageName pkg `notElem` partOfGHCi) $ do
1042 -- When a library A needs symbols from a library B, the order in
1043 -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
1044 -- way ld expects it for static linking. Dynamic linking is a
1045 -- different story: When A has no dependency information for B,
1046 -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
1047 -- when B has not been loaded before. In a nutshell: Reverse the
1048 -- order of DLLs for dynamic linking.
1049 -- This fixes a problem with the HOpenGL package (see "Compiling
1050 -- HOpenGL under recent versions of GHC" on the HOpenGL list).
1051 mapM_ (load_dyn dirs) (reverse dlls)
1053 -- After loading all the DLLs, we can load the static objects.
1054 -- Ordering isn't important here, because we do one final link
1055 -- step to resolve everything.
1058 maybePutStr dflags "linking ... "
1060 if succeeded ok then maybePutStrLn dflags "done."
1061 else ghcError (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'"))
1063 load_dyn :: [FilePath] -> FilePath -> IO ()
1064 load_dyn dirs dll = do r <- loadDynamic dirs dll
1066 Nothing -> return ()
1067 Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: "
1068 ++ dll ++ " (" ++ err ++ ")" ))
1070 loadFrameworks :: InstalledPackageInfo_ ModuleName -> IO ()
1072 | isDarwinTarget = mapM_ load frameworks
1073 | otherwise = return ()
1075 fw_dirs = Packages.frameworkDirs pkg
1076 frameworks = Packages.frameworks pkg
1078 load fw = do r <- loadFramework fw_dirs fw
1080 Nothing -> return ()
1081 Just err -> ghcError (CmdLineError ("can't load framework: "
1082 ++ fw ++ " (" ++ err ++ ")" ))
1084 -- Try to find an object file for a given library in the given paths.
1085 -- If it isn't present, we assume it's a dynamic library.
1086 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1087 locateOneObj dirs lib
1088 | not isDynamicGhcLib
1089 -- When the GHC package was not compiled as dynamic library
1090 -- (=DYNAMIC not set), we search for .o libraries.
1091 = do { mb_obj_path <- findFile mk_obj_path dirs
1092 ; case mb_obj_path of
1093 Just obj_path -> return (Object obj_path)
1094 Nothing -> return (DLL lib) }
1097 -- When the GHC package was compiled as dynamic library (=DYNAMIC set),
1098 -- we search for .so libraries first.
1099 = do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1100 ; case mb_lib_path of
1101 Just _ -> return (DLL dyn_lib_name)
1103 do { mb_obj_path <- findFile mk_obj_path dirs
1104 ; case mb_obj_path of
1105 Just obj_path -> return (Object obj_path)
1106 Nothing -> return (DLL lib) }} -- We assume
1108 mk_obj_path dir = dir </> (lib <.> "o")
1109 dyn_lib_name = lib ++ "-ghc" ++ cProjectVersion
1110 mk_dyn_lib_path dir = dir </> mkSOName dyn_lib_name
1112 -- ----------------------------------------------------------------------------
1113 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1115 -- return Nothing == success, else Just error message from dlopen
1116 loadDynamic :: [FilePath] -> FilePath -> IO (Maybe String)
1117 loadDynamic paths rootname
1118 = do { mb_dll <- findFile mk_dll_path paths
1120 Just dll -> loadDLL dll
1121 Nothing -> loadDLL (mkSOName rootname) }
1122 -- Tried all our known library paths, so let
1123 -- dlopen() search its own builtin paths now.
1125 mk_dll_path dir = dir </> mkSOName rootname
1127 mkSOName :: FilePath -> FilePath
1129 | isDarwinTarget = ("lib" ++ root) <.> "dylib"
1130 | isWindowsTarget = -- Win32 DLLs have no .dll extension here, because
1131 -- addDLL tries both foo.dll and foo.drv
1133 | otherwise = ("lib" ++ root) <.> "so"
1135 -- Darwin / MacOS X only: load a framework
1136 -- a framework is a dynamic library packaged inside a directory of the same
1137 -- name. They are searched for in different paths than normal libraries.
1138 loadFramework :: [FilePath] -> FilePath -> IO (Maybe String)
1139 loadFramework extraPaths rootname
1140 = do { either_dir <- tryIO getHomeDirectory
1141 ; let homeFrameworkPath = case either_dir of
1143 Right dir -> [dir ++ "/Library/Frameworks"]
1144 ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
1145 ; mb_fwk <- findFile mk_fwk ps
1147 Just fwk_path -> loadDLL fwk_path
1148 Nothing -> return (Just "not found") }
1149 -- Tried all our known library paths, but dlopen()
1150 -- has no built-in paths for frameworks: give up
1152 mk_fwk dir = dir </> (rootname ++ ".framework/" ++ rootname)
1153 -- sorry for the hardcoded paths, I hope they won't change anytime soon:
1154 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1157 %************************************************************************
1161 %************************************************************************
1164 findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
1165 -> [FilePath] -- Directories to look in
1166 -> IO (Maybe FilePath) -- The first file path to match
1169 findFile mk_file_path (dir:dirs)
1170 = do { let file_path = mk_file_path dir
1171 ; b <- doesFileExist file_path
1173 return (Just file_path)
1175 findFile mk_file_path dirs }
1179 maybePutStr :: DynFlags -> String -> IO ()
1180 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1181 | otherwise = return ()
1183 maybePutStrLn :: DynFlags -> String -> IO ()
1184 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1185 | otherwise = return ()