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
64 import qualified Data.Map as Map
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])
248 -- We only look for dots if str could start with a module name,
249 -- i.e. if it starts with an upper case character.
250 -- Otherwise we might think that "X.:->" is the module name in
251 -- "X.:->.+", whereas actually "X" is the module name and
252 -- ":->.+" is a constructor name.
253 parseModOcc acc str@(c : _)
254 | isUpper $ chr $ fromIntegral c
255 = case break (== dot) str of
256 (top, []) -> (acc, top)
257 (top, _ : bot) -> parseModOcc (top : acc) bot
258 parseModOcc acc str = (acc, str)
260 -- | Get the 'HValue' associated with the given name.
262 -- May cause loading the module that contains the name.
264 -- Throws a 'ProgramError' if loading fails or the name cannot be found.
265 getHValue :: HscEnv -> Name -> IO HValue
266 getHValue hsc_env name = do
267 pls <- modifyMVar v_PersistentLinkerState $ \pls -> do
268 if (isExternalName name) then do
269 (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name]
270 if (failed ok) then ghcError (ProgramError "")
271 else return (pls', pls')
274 lookupName (closure_env pls) name
276 linkDependencies :: HscEnv -> PersistentLinkerState
277 -> SrcSpan -> [Module]
278 -> IO (PersistentLinkerState, SuccessFlag)
279 linkDependencies hsc_env pls span needed_mods = do
280 let hpt = hsc_HPT hsc_env
281 dflags = hsc_dflags hsc_env
282 -- The interpreter and dynamic linker can only handle object code built
283 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
284 -- So here we check the build tag: if we're building a non-standard way
285 -- then we need to find & link object files built the "normal" way.
286 maybe_normal_osuf <- checkNonStdWay dflags span
288 -- Find what packages and linkables are required
289 (lnks, pkgs) <- getLinkDeps hsc_env hpt pls
290 maybe_normal_osuf span needed_mods
292 -- Link the packages and modules required
293 pls1 <- linkPackages' dflags pkgs pls
294 linkModules dflags pls1 lnks
297 -- | Temporarily extend the linker state.
299 withExtendedLinkEnv :: (MonadIO m, ExceptionMonad m) =>
300 [(Name,HValue)] -> m a -> m a
301 withExtendedLinkEnv new_env action
302 = gbracket (liftIO $ extendLinkEnv new_env)
303 (\_ -> reset_old_env)
306 -- Remember that the linker state might be side-effected
307 -- during the execution of the IO action, and we don't want to
308 -- lose those changes (we might have linked a new module or
309 -- package), so the reset action only removes the names we
311 reset_old_env = liftIO $ do
312 modifyMVar_ v_PersistentLinkerState $ \pls ->
313 let cur = closure_env pls
314 new = delListFromNameEnv cur (map fst new_env)
315 in return pls{ closure_env = new }
317 -- filterNameMap removes from the environment all entries except
318 -- those for a given set of modules;
319 -- Note that this removes all *local* (i.e. non-isExternal) names too
320 -- (these are the temporary bindings from the command line).
321 -- Used to filter both the ClosureEnv and ItblEnv
323 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
324 filterNameMap mods env
325 = filterNameEnv keep_elt env
327 keep_elt (n,_) = isExternalName n
328 && (nameModule n `elem` mods)
333 -- | Display the persistent linker state.
334 showLinkerState :: IO ()
336 = do pls <- readMVar v_PersistentLinkerState
337 printDump (vcat [text "----- Linker state -----",
338 text "Pkgs:" <+> ppr (pkgs_loaded pls),
339 text "Objs:" <+> ppr (objs_loaded pls),
340 text "BCOs:" <+> ppr (bcos_loaded pls)])
346 %************************************************************************
348 \subsection{Initialisation}
350 %************************************************************************
353 -- | Initialise the dynamic linker. This entails
355 -- a) Calling the C initialisation procedure,
357 -- b) Loading any packages specified on the command line,
359 -- c) Loading any packages specified on the command line, now held in the
360 -- @-l@ options in @v_Opt_l@,
362 -- d) Loading any @.o\/.dll@ files specified on the command line, now held
365 -- e) Loading any MacOS frameworks.
367 -- NOTE: This function is idempotent; if called more than once, it does
368 -- nothing. This is useful in Template Haskell, where we call it before
371 initDynLinker :: DynFlags -> IO ()
372 initDynLinker dflags =
373 modifyMVar_ v_PersistentLinkerState $ \pls0 -> do
374 done <- readIORef v_InitLinkerDone
375 if done then return pls0
376 else do writeIORef v_InitLinkerDone True
377 reallyInitDynLinker dflags
379 reallyInitDynLinker :: DynFlags -> IO PersistentLinkerState
380 reallyInitDynLinker dflags =
381 do { -- Initialise the linker state
382 let pls0 = emptyPLS dflags
384 -- (a) initialise the C dynamic linker
387 -- (b) Load packages from the command-line
388 ; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0
390 -- (c) Link libraries from the command-line
391 ; let optl = getOpts dflags opt_l
392 ; let minus_ls = [ lib | '-':'l':lib <- optl ]
394 -- (d) Link .o files from the command-line
395 ; let lib_paths = libraryPaths dflags
396 ; cmdline_ld_inputs <- readIORef v_Ld_inputs
398 ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
400 -- (e) Link any MacOS frameworks
401 ; let framework_paths
402 | isDarwinTarget = frameworkPaths dflags
405 | isDarwinTarget = cmdlineFrameworks dflags
407 -- Finally do (c),(d),(e)
408 ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
410 ++ map Framework frameworks
411 ; if null cmdline_lib_specs then return pls
414 { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
415 ; maybePutStr dflags "final link ... "
418 ; if succeeded ok then maybePutStrLn dflags "done"
419 else ghcError (ProgramError "linking extra libraries/objects failed")
424 classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
426 | isObjectFilename f = return (Just (Object f))
427 | isDynLibFilename f = return (Just (DLLPath f))
429 hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
432 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
433 preloadLib dflags lib_paths framework_paths lib_spec
434 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
437 -> do b <- preload_static lib_paths static_ish
438 maybePutStrLn dflags (if b then "done"
442 -> do b <- preload_static_archive lib_paths static_ish
443 maybePutStrLn dflags (if b then "done"
447 -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
449 Nothing -> maybePutStrLn dflags "done"
450 Just mm -> preloadFailed mm lib_paths lib_spec
453 -> do maybe_errstr <- loadDLL dll_path
455 Nothing -> maybePutStrLn dflags "done"
456 Just mm -> preloadFailed mm lib_paths lib_spec
460 -> do maybe_errstr <- loadFramework framework_paths framework
462 Nothing -> maybePutStrLn dflags "done"
463 Just mm -> preloadFailed mm framework_paths lib_spec
464 | otherwise -> panic "preloadLib Framework"
467 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
468 preloadFailed sys_errmsg paths spec
469 = do maybePutStr dflags "failed.\n"
472 "user specified .o/.so/.DLL could not be loaded ("
473 ++ sys_errmsg ++ ")\nWhilst trying to load: "
474 ++ showLS spec ++ "\nAdditional directories searched:"
475 ++ (if null paths then " (none)" else
476 (concat (intersperse "\n" (map (" "++) paths)))))
478 -- Not interested in the paths in the static case.
479 preload_static _paths name
480 = do b <- doesFileExist name
481 if not b then return False
482 else loadObj name >> return True
483 preload_static_archive _paths name
484 = do b <- doesFileExist name
485 if not b then return False
486 else loadArchive name >> return True
490 %************************************************************************
492 Link a byte-code expression
494 %************************************************************************
497 -- | Link a single expression, /including/ first linking packages and
498 -- modules that this expression depends on.
500 -- Raises an IO exception ('ProgramError') if it can't find a compiled
501 -- version of the dependents to link.
503 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
504 linkExpr hsc_env span root_ul_bco
506 -- Initialise the linker (if it's not been done already)
507 let dflags = hsc_dflags hsc_env
508 ; initDynLinker dflags
510 -- Take lock for the actual work.
511 ; modifyMVar v_PersistentLinkerState $ \pls0 -> do {
513 -- Link the packages and modules required
514 ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
516 ghcError (ProgramError "")
519 -- Link the expression itself
520 let ie = itbl_env pls
523 -- Link the necessary packages and linkables
524 ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
525 ; return (pls, root_hval)
528 free_names = nameSetToList (bcoFreeNames root_ul_bco)
530 needed_mods :: [Module]
531 needed_mods = [ nameModule n | n <- free_names,
532 isExternalName n, -- Names from other modules
533 not (isWiredInName n) -- Exclude wired-in names
534 ] -- (see note below)
535 -- Exclude wired-in names because we may not have read
536 -- their interface files, so getLinkDeps will fail
537 -- All wired-in names are in the base package, which we link
538 -- by default, so we can safely ignore them here.
540 dieWith :: SrcSpan -> Message -> IO a
541 dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage span msg)))
544 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
545 checkNonStdWay dflags srcspan = do
546 let tag = buildTag dflags
547 if null tag {- || tag == "dyn" -} then return Nothing else do
548 -- see #3604: object files compiled for way "dyn" need to link to the
549 -- dynamic packages, so we can't load them into a statically-linked GHCi.
550 -- we have to treat "dyn" in the same way as "prof".
552 -- In the future when GHCi is dynamically linked we should be able to relax
553 -- this, but they we may have to make it possible to load either ordinary
554 -- .o files or -dynamic .o files into GHCi (currently that's not possible
555 -- because the dynamic objects contain refs to e.g. __stginit_base_Prelude_dyn
556 -- whereas we have __stginit_base_Prelude_.
557 let default_osuf = phaseInputExt StopLn
558 if objectSuf dflags == default_osuf
559 then failNonStd srcspan
560 else return (Just default_osuf)
562 failNonStd :: SrcSpan -> IO (Maybe String)
563 failNonStd srcspan = dieWith srcspan $
564 ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$
565 ptext (sLit "You need to build the program twice: once the normal way, and then") $$
566 ptext (sLit "in the desired way using -osuf to set the object file suffix.")
569 getLinkDeps :: HscEnv -> HomePackageTable
570 -> PersistentLinkerState
571 -> Maybe String -- the "normal" object suffix
572 -> SrcSpan -- for error messages
573 -> [Module] -- If you need these
574 -> IO ([Linkable], [PackageId]) -- ... then link these first
575 -- Fails with an IO exception if it can't find enough files
577 getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
578 -- Find all the packages and linkables that a set of modules depends on
580 -- 1. Find the dependent home-pkg-modules/packages from each iface
581 (mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet;
584 -- 2. Exclude ones already linked
585 -- Main reason: avoid findModule calls in get_linkable
586 mods_needed = mods_s `minusList` linked_mods ;
587 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
589 linked_mods = map (moduleName.linkableModule)
590 (objs_loaded pls ++ bcos_loaded pls)
593 -- putStrLn (showSDoc (ppr mods_s)) ;
594 -- 3. For each dependent module, find its linkable
595 -- This will either be in the HPT or (in the case of one-shot
596 -- compilation) we may need to use maybe_getFileLinkable
597 lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
599 return (lnks_needed, pkgs_needed) }
601 dflags = hsc_dflags hsc_env
602 this_pkg = thisPackage dflags
604 -- The ModIface contains the transitive closure of the module dependencies
605 -- within the current package, *except* for boot modules: if we encounter
606 -- a boot module, we have to find its real interface and discover the
607 -- dependencies of that. Hence we need to traverse the dependency
608 -- tree recursively. See bug #936, testcase ghci/prog007.
609 follow_deps :: [Module] -- modules to follow
610 -> UniqSet ModuleName -- accum. module dependencies
611 -> UniqSet PackageId -- accum. package dependencies
612 -> IO ([ModuleName], [PackageId]) -- result
613 follow_deps [] acc_mods acc_pkgs
614 = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
615 follow_deps (mod:mods) acc_mods acc_pkgs
617 mb_iface <- initIfaceCheck hsc_env $
618 loadInterface msg mod (ImportByUser False)
619 iface <- case mb_iface of
620 Maybes.Failed err -> ghcError (ProgramError (showSDoc err))
621 Maybes.Succeeded iface -> return iface
623 when (mi_boot iface) $ link_boot_mod_error mod
626 pkg = modulePackageId mod
629 pkg_deps = dep_pkgs deps
630 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
631 where is_boot (m,True) = Left m
632 is_boot (m,False) = Right m
634 boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
635 acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
636 acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
639 then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
640 else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)
643 msg = text "need to link module" <+> ppr mod <+>
644 text "due to use of Template Haskell"
647 link_boot_mod_error mod =
648 ghcError (ProgramError (showSDoc (
649 text "module" <+> ppr mod <+>
650 text "cannot be linked; it is only available as a boot module")))
652 no_obj :: Outputable a => a -> IO b
653 no_obj mod = dieWith span $
654 ptext (sLit "cannot find object file for module ") <>
658 while_linking_expr = ptext (sLit "while linking an interpreted expression")
660 -- This one is a build-system bug
662 get_linkable maybe_normal_osuf mod_name -- A home-package module
663 | Just mod_info <- lookupUFM hpt mod_name
664 = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
666 = do -- It's not in the HPT because we are in one shot mode,
667 -- so use the Finder to get a ModLocation...
668 mb_stuff <- findHomeModule hsc_env mod_name
670 Found loc mod -> found loc mod
674 -- ...and then find the linkable for it
675 mb_lnk <- findObjectLinkableMaybe mod loc ;
677 Nothing -> no_obj mod ;
678 Just lnk -> adjust_linkable lnk
682 | Just osuf <- maybe_normal_osuf = do
683 new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
684 return lnk{ linkableUnlinked=new_uls }
688 adjust_ul osuf (DotO file) = do
689 let new_file = replaceExtension file osuf
690 ok <- doesFileExist new_file
693 ptext (sLit "cannot find normal object file ")
694 <> quotes (text new_file) $$ while_linking_expr
695 else return (DotO new_file)
696 adjust_ul _ _ = panic "adjust_ul"
700 %************************************************************************
703 The linkables may consist of a mixture of
704 byte-code modules and object modules
706 %************************************************************************
709 linkModules :: DynFlags -> PersistentLinkerState -> [Linkable]
710 -> IO (PersistentLinkerState, SuccessFlag)
711 linkModules dflags pls linkables
712 = mask_ $ do -- don't want to be interrupted by ^C in here
714 let (objs, bcos) = partition isObjectLinkable
715 (concatMap partitionLinkable linkables)
717 -- Load objects first; they can't depend on BCOs
718 (pls1, ok_flag) <- dynLinkObjs dflags pls objs
720 if failed ok_flag then
721 return (pls1, Failed)
723 pls2 <- dynLinkBCOs pls1 bcos
724 return (pls2, Succeeded)
727 -- HACK to support f-x-dynamic in the interpreter; no other purpose
728 partitionLinkable :: Linkable -> [Linkable]
730 = let li_uls = linkableUnlinked li
731 li_uls_obj = filter isObject li_uls
732 li_uls_bco = filter isInterpretable li_uls
734 case (li_uls_obj, li_uls_bco) of
735 (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
736 li {linkableUnlinked=li_uls_bco}]
739 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
740 findModuleLinkable_maybe lis mod
741 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
744 _ -> pprPanic "findModuleLinkable" (ppr mod)
746 linkableInSet :: Linkable -> [Linkable] -> Bool
747 linkableInSet l objs_loaded =
748 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
750 Just m -> linkableTime l == linkableTime m
754 %************************************************************************
756 \subsection{The object-code linker}
758 %************************************************************************
761 dynLinkObjs :: DynFlags -> PersistentLinkerState -> [Linkable]
762 -> IO (PersistentLinkerState, SuccessFlag)
763 dynLinkObjs dflags pls objs = do
764 -- Load the object files and link them
765 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
766 pls1 = pls { objs_loaded = objs_loaded' }
767 unlinkeds = concatMap linkableUnlinked new_objs
769 mapM_ loadObj (map nameOfObject unlinkeds)
771 -- Link the all together
774 -- If resolving failed, unload all our
775 -- object modules and carry on
776 if succeeded ok then do
777 return (pls1, Succeeded)
779 pls2 <- unload_wkr dflags [] pls1
780 return (pls2, Failed)
783 rmDupLinkables :: [Linkable] -- Already loaded
784 -> [Linkable] -- New linkables
785 -> ([Linkable], -- New loaded set (including new ones)
786 [Linkable]) -- New linkables (excluding dups)
787 rmDupLinkables already ls
790 go already extras [] = (already, extras)
791 go already extras (l:ls)
792 | linkableInSet l already = go already extras ls
793 | otherwise = go (l:already) (l:extras) ls
796 %************************************************************************
798 \subsection{The byte-code linker}
800 %************************************************************************
803 dynLinkBCOs :: PersistentLinkerState -> [Linkable] -> IO PersistentLinkerState
804 dynLinkBCOs pls bcos = do
806 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
807 pls1 = pls { bcos_loaded = bcos_loaded' }
808 unlinkeds :: [Unlinked]
809 unlinkeds = concatMap linkableUnlinked new_bcos
811 cbcs :: [CompiledByteCode]
812 cbcs = map byteCodeOfObject unlinkeds
815 ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
816 ies = [ie | ByteCode _ ie <- cbcs]
817 gce = closure_env pls
818 final_ie = foldr plusNameEnv (itbl_env pls) ies
820 (final_gce, _linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
821 -- XXX What happens to these linked_bcos?
823 let pls2 = pls1 { closure_env = final_gce,
824 itbl_env = final_ie }
828 -- Link a bunch of BCOs and return them + updated closure env.
829 linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
830 -- True <=> add only toplevel BCOs to closure env
834 -> IO (ClosureEnv, [HValue])
835 -- The returned HValues are associated 1-1 with
836 -- the incoming unlinked BCOs. Each gives the
837 -- value of the corresponding unlinked BCO
839 linkSomeBCOs toplevs_only ie ce_in ul_bcos
840 = do let nms = map unlinkedBCOName ul_bcos
842 ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
843 in mapM (linkBCO ie ce_out) ul_bcos )
844 let ce_all_additions = zip nms hvals
845 ce_top_additions = filter (isExternalName.fst) ce_all_additions
846 ce_additions = if toplevs_only then ce_top_additions
847 else ce_all_additions
848 ce_out = -- make sure we're not inserting duplicate names into the
849 -- closure environment, which leads to trouble.
850 ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
851 extendClosureEnv ce_in ce_additions
852 return (ce_out, hvals)
857 %************************************************************************
859 Unload some object modules
861 %************************************************************************
864 -- ---------------------------------------------------------------------------
865 -- | Unloading old objects ready for a new compilation sweep.
867 -- The compilation manager provides us with a list of linkables that it
868 -- considers \"stable\", i.e. won't be recompiled this time around. For
869 -- each of the modules current linked in memory,
871 -- * if the linkable is stable (and it's the same one -- the user may have
872 -- recompiled the module on the side), we keep it,
874 -- * otherwise, we unload it.
876 -- * we also implicitly unload all temporary bindings at this point.
879 -> [Linkable] -- ^ The linkables to *keep*.
881 unload dflags linkables
882 = mask_ $ do -- mask, so we're safe from Ctrl-C in here
884 -- Initialise the linker (if it's not been done already)
888 <- modifyMVar v_PersistentLinkerState $ \pls -> do
889 pls1 <- unload_wkr dflags linkables pls
892 debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
893 debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
896 unload_wkr :: DynFlags
897 -> [Linkable] -- stable linkables
898 -> PersistentLinkerState
899 -> IO PersistentLinkerState
900 -- Does the core unload business
901 -- (the wrapper blocks exceptions and deals with the PLS get and put)
903 unload_wkr _ linkables pls
904 = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
906 objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
907 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
909 let bcos_retained = map linkableModule bcos_loaded'
910 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
911 closure_env' = filterNameMap bcos_retained (closure_env pls)
912 new_pls = pls { itbl_env = itbl_env',
913 closure_env = closure_env',
914 bcos_loaded = bcos_loaded',
915 objs_loaded = objs_loaded' }
919 maybeUnload :: [Linkable] -> Linkable -> IO Bool
920 maybeUnload keep_linkables lnk
921 | linkableInSet lnk keep_linkables = return True
923 = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
924 -- The components of a BCO linkable may contain
925 -- dot-o files. Which is very confusing.
927 -- But the BCO parts can be unlinked just by
928 -- letting go of them (plus of course depopulating
929 -- the symbol table which is done in the main body)
934 %************************************************************************
938 %************************************************************************
943 = Object FilePath -- Full path name of a .o file, including trailing .o
944 -- For dynamic objects only, try to find the object
945 -- file in all the directories specified in
946 -- v_Library_paths before giving up.
948 | Archive FilePath -- Full path name of a .a file, including trailing .a
950 | DLL String -- "Unadorned" name of a .DLL/.so
951 -- e.g. On unix "qt" denotes "libqt.so"
952 -- On WinDoze "burble" denotes "burble.DLL"
953 -- loadDLL is platform-specific and adds the lib/.so/.DLL
954 -- suffixes platform-dependently
956 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
957 -- (ends with .dll or .so).
959 | Framework String -- Only used for darwin, but does no harm
961 -- If this package is already part of the GHCi binary, we'll already
962 -- have the right DLLs for this package loaded, so don't try to
965 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
966 -- as far as the loader is concerned, but it does initialise the list
967 -- of DLL handles that rts/Linker.c maintains, and that in turn is
968 -- used by lookupSymbol. So we must call addDLL for each library
969 -- just to get the DLL handle into the list.
970 partOfGHCi :: [PackageName]
972 | isWindowsTarget || isDarwinTarget = []
973 | otherwise = map PackageName
974 ["base", "template-haskell", "editline"]
976 showLS :: LibrarySpec -> String
977 showLS (Object nm) = "(static) " ++ nm
978 showLS (Archive nm) = "(static archive) " ++ nm
979 showLS (DLL nm) = "(dynamic) " ++ nm
980 showLS (DLLPath nm) = "(dynamic) " ++ nm
981 showLS (Framework nm) = "(framework) " ++ nm
983 -- | Link exactly the specified packages, and their dependents (unless of
984 -- course they are already linked). The dependents are linked
985 -- automatically, and it doesn't matter what order you specify the input
988 linkPackages :: DynFlags -> [PackageId] -> IO ()
989 -- NOTE: in fact, since each module tracks all the packages it depends on,
990 -- we don't really need to use the package-config dependencies.
992 -- However we do need the package-config stuff (to find aux libs etc),
993 -- and following them lets us load libraries in the right order, which
994 -- perhaps makes the error message a bit more localised if we get a link
995 -- failure. So the dependency walking code is still here.
997 linkPackages dflags new_pkgs = do
998 -- It's probably not safe to try to load packages concurrently, so we take
1000 modifyMVar_ v_PersistentLinkerState $ \pls -> do
1001 linkPackages' dflags new_pkgs pls
1003 linkPackages' :: DynFlags -> [PackageId] -> PersistentLinkerState
1004 -> IO PersistentLinkerState
1005 linkPackages' dflags new_pks pls = do
1006 pkgs' <- link (pkgs_loaded pls) new_pks
1007 return $! pls { pkgs_loaded = pkgs' }
1009 pkg_map = pkgIdMap (pkgState dflags)
1010 ipid_map = installedPackageIdMap (pkgState dflags)
1012 link :: [PackageId] -> [PackageId] -> IO [PackageId]
1013 link pkgs new_pkgs =
1014 foldM link_one pkgs new_pkgs
1016 link_one pkgs new_pkg
1017 | new_pkg `elem` pkgs -- Already linked
1020 | Just pkg_cfg <- lookupPackage pkg_map new_pkg
1021 = do { -- Link dependents first
1022 pkgs' <- link pkgs [ Maybes.expectJust "link_one" $
1023 Map.lookup ipid ipid_map
1024 | ipid <- depends pkg_cfg ]
1025 -- Now link the package itself
1026 ; linkPackage dflags pkg_cfg
1027 ; return (new_pkg : pkgs') }
1030 = ghcError (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
1033 linkPackage :: DynFlags -> PackageConfig -> IO ()
1034 linkPackage dflags pkg
1036 let dirs = Packages.libraryDirs pkg
1038 let libs = Packages.hsLibraries pkg
1039 -- The FFI GHCi import lib isn't needed as
1040 -- compiler/ghci/Linker.lhs + rts/Linker.c link the
1041 -- interpreted references to FFI to the compiled FFI.
1042 -- We therefore filter it out so that we don't get
1043 -- duplicate symbol errors.
1044 libs' = filter ("HSffi" /=) libs
1045 -- Because of slight differences between the GHC dynamic linker and
1046 -- the native system linker some packages have to link with a
1047 -- different list of libraries when using GHCi. Examples include: libs
1048 -- that are actually gnu ld scripts, and the possability that the .a
1049 -- libs do not exactly match the .so/.dll equivalents. So if the
1050 -- package file provides an "extra-ghci-libraries" field then we use
1051 -- that instead of the "extra-libraries" field.
1052 ++ (if null (Packages.extraGHCiLibraries pkg)
1053 then Packages.extraLibraries pkg
1054 else Packages.extraGHCiLibraries pkg)
1055 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
1056 classifieds <- mapM (locateOneObj dirs) libs'
1058 -- Complication: all the .so's must be loaded before any of the .o's.
1059 let dlls = [ dll | DLL dll <- classifieds ]
1060 objs = [ obj | Object obj <- classifieds ]
1061 archs = [ arch | Archive arch <- classifieds ]
1063 maybePutStr dflags ("Loading package " ++ display (sourcePackageId pkg) ++ " ... ")
1065 -- See comments with partOfGHCi
1066 when (packageName pkg `notElem` partOfGHCi) $ do
1068 -- When a library A needs symbols from a library B, the order in
1069 -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
1070 -- way ld expects it for static linking. Dynamic linking is a
1071 -- different story: When A has no dependency information for B,
1072 -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
1073 -- when B has not been loaded before. In a nutshell: Reverse the
1074 -- order of DLLs for dynamic linking.
1075 -- This fixes a problem with the HOpenGL package (see "Compiling
1076 -- HOpenGL under recent versions of GHC" on the HOpenGL list).
1077 mapM_ (load_dyn dirs) (reverse dlls)
1079 -- After loading all the DLLs, we can load the static objects.
1080 -- Ordering isn't important here, because we do one final link
1081 -- step to resolve everything.
1083 mapM_ loadArchive archs
1085 maybePutStr dflags "linking ... "
1087 if succeeded ok then maybePutStrLn dflags "done."
1088 else ghcError (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'"))
1090 load_dyn :: [FilePath] -> FilePath -> IO ()
1091 load_dyn dirs dll = do r <- loadDynamic dirs dll
1093 Nothing -> return ()
1094 Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: "
1095 ++ dll ++ " (" ++ err ++ ")" ))
1097 loadFrameworks :: InstalledPackageInfo_ ModuleName -> IO ()
1099 | isDarwinTarget = mapM_ load frameworks
1100 | otherwise = return ()
1102 fw_dirs = Packages.frameworkDirs pkg
1103 frameworks = Packages.frameworks pkg
1105 load fw = do r <- loadFramework fw_dirs fw
1107 Nothing -> return ()
1108 Just err -> ghcError (CmdLineError ("can't load framework: "
1109 ++ fw ++ " (" ++ err ++ ")" ))
1111 -- Try to find an object file for a given library in the given paths.
1112 -- If it isn't present, we assume it's a dynamic library.
1113 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1114 locateOneObj dirs lib
1115 | not ("HS" `isPrefixOf` lib)
1116 -- For non-Haskell libraries (e.g. gmp, iconv) we assume dynamic library
1118 | not isDynamicGhcLib
1119 -- When the GHC package was not compiled as dynamic library
1120 -- (=DYNAMIC not set), we search for .o libraries or, if they
1121 -- don't exist, .a libraries.
1122 = findObject `orElse` findArchive `orElse` assumeDll
1124 -- When the GHC package was compiled as dynamic library (=DYNAMIC set),
1125 -- we search for .so libraries first.
1126 = findDll `orElse` findObject `orElse` findArchive `orElse` assumeDll
1128 mk_obj_path dir = dir </> (lib <.> "o")
1129 mk_arch_path dir = dir </> ("lib" ++ lib <.> "a")
1130 dyn_lib_name = lib ++ "-ghc" ++ cProjectVersion
1131 mk_dyn_lib_path dir = dir </> mkSOName dyn_lib_name
1132 findObject = liftM (fmap Object) $ findFile mk_obj_path dirs
1133 findArchive = liftM (fmap Archive) $ findFile mk_arch_path dirs
1134 findDll = liftM (fmap DLL) $ findFile mk_dyn_lib_path dirs
1135 assumeDll = return (DLL lib)
1137 f `orElse` g = do m <- f
1142 -- ----------------------------------------------------------------------------
1143 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1145 -- return Nothing == success, else Just error message from dlopen
1146 loadDynamic :: [FilePath] -> FilePath -> IO (Maybe String)
1147 loadDynamic paths rootname
1148 = do { mb_dll <- findFile mk_dll_path paths
1150 Just dll -> loadDLL dll
1151 Nothing -> loadDLL (mkSOName rootname) }
1152 -- Tried all our known library paths, so let
1153 -- dlopen() search its own builtin paths now.
1155 mk_dll_path dir = dir </> mkSOName rootname
1157 mkSOName :: FilePath -> FilePath
1159 | isDarwinTarget = ("lib" ++ root) <.> "dylib"
1160 | isWindowsTarget = -- Win32 DLLs have no .dll extension here, because
1161 -- addDLL tries both foo.dll and foo.drv
1163 | otherwise = ("lib" ++ root) <.> "so"
1165 -- Darwin / MacOS X only: load a framework
1166 -- a framework is a dynamic library packaged inside a directory of the same
1167 -- name. They are searched for in different paths than normal libraries.
1168 loadFramework :: [FilePath] -> FilePath -> IO (Maybe String)
1169 loadFramework extraPaths rootname
1170 = do { either_dir <- tryIO getHomeDirectory
1171 ; let homeFrameworkPath = case either_dir of
1173 Right dir -> [dir ++ "/Library/Frameworks"]
1174 ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
1175 ; mb_fwk <- findFile mk_fwk ps
1177 Just fwk_path -> loadDLL fwk_path
1178 Nothing -> return (Just "not found") }
1179 -- Tried all our known library paths, but dlopen()
1180 -- has no built-in paths for frameworks: give up
1182 mk_fwk dir = dir </> (rootname ++ ".framework/" ++ rootname)
1183 -- sorry for the hardcoded paths, I hope they won't change anytime soon:
1184 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1187 %************************************************************************
1191 %************************************************************************
1194 findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
1195 -> [FilePath] -- Directories to look in
1196 -> IO (Maybe FilePath) -- The first file path to match
1199 findFile mk_file_path (dir:dirs)
1200 = do { let file_path = mk_file_path dir
1201 ; b <- doesFileExist file_path
1203 return (Just file_path)
1205 findFile mk_file_path dirs }
1209 maybePutStr :: DynFlags -> String -> IO ()
1210 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1211 | otherwise = return ()
1213 maybePutStrLn :: DynFlags -> String -> IO ()
1214 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1215 | otherwise = return ()