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
56 import Config ( cProjectVersion )
65 import Control.Concurrent.MVar
67 import System.FilePath
69 import System.Directory
71 import Distribution.Package hiding (depends, PackageId)
77 %************************************************************************
81 %************************************************************************
83 The persistent linker state *must* match the actual state of the
84 C dynamic linker at all times, so we keep it in a private global variable.
87 The PersistentLinkerState maps Names to actual closures (for
88 interpreted code only), for use during linking.
91 GLOBAL_MVAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState)
92 GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
94 data PersistentLinkerState
95 = PersistentLinkerState {
97 -- Current global mapping from Names to their true values
98 closure_env :: ClosureEnv,
100 -- The current global mapping from RdrNames of DataCons to
101 -- info table addresses.
102 -- When a new Unlinked is linked into the running image, or an existing
103 -- module in the image is replaced, the itbl_env must be updated
107 -- The currently loaded interpreted modules (home package)
108 bcos_loaded :: [Linkable],
110 -- And the currently-loaded compiled modules (home package)
111 objs_loaded :: [Linkable],
113 -- The currently-loaded packages; always object code
114 -- Held, as usual, in dependency order; though I am not sure if
115 -- that is really important
116 pkgs_loaded :: [PackageId]
119 emptyPLS :: DynFlags -> PersistentLinkerState
120 emptyPLS _ = PersistentLinkerState {
121 closure_env = emptyNameEnv,
122 itbl_env = emptyNameEnv,
123 pkgs_loaded = init_pkgs,
127 -- Packages that don't need loading, because the compiler
128 -- shares them with the interpreted program.
130 -- The linker's symbol table is populated with RTS symbols using an
131 -- explicit list. See rts/Linker.c for details.
132 where init_pkgs = [rtsPackageId]
136 extendLoadedPkgs :: [PackageId] -> IO ()
137 extendLoadedPkgs pkgs =
138 modifyMVar_ v_PersistentLinkerState $ \s ->
139 return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }
141 extendLinkEnv :: [(Name,HValue)] -> IO ()
142 -- Automatically discards shadowed bindings
143 extendLinkEnv new_bindings =
144 modifyMVar_ v_PersistentLinkerState $ \pls ->
145 let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
146 in return pls{ closure_env = new_closure_env }
148 deleteFromLinkEnv :: [Name] -> IO ()
149 deleteFromLinkEnv to_remove =
150 modifyMVar_ v_PersistentLinkerState $ \pls ->
151 let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
152 in return pls{ closure_env = new_closure_env }
154 -- | Given a data constructor in the heap, find its Name.
155 -- The info tables for data constructors have a field which records
156 -- the source name of the constructor as a Ptr Word8 (UTF-8 encoded
157 -- string). The format is:
159 -- > Package:Module.Name
161 -- We use this string to lookup the interpreter's internal representation of the name
162 -- using the lookupOrig.
164 dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
165 dataConInfoPtrToName x = do
166 theString <- liftIO $ do
167 let ptr = castPtr x :: Ptr StgInfoTable
168 conDescAddress <- getConDescAddress ptr
169 peekArray0 0 conDescAddress
170 let (pkg, mod, occ) = parse theString
171 pkgFS = mkFastStringByteList pkg
172 modFS = mkFastStringByteList mod
173 occFS = mkFastStringByteList occ
174 occName = mkOccNameFS OccName.dataName occFS
175 modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS)
176 return (Left$ showSDoc$ ppr modName <> dot <> ppr occName )
177 `recoverM` (Right `fmap` lookupOrig modName occName)
181 {- To find the string in the constructor's info table we need to consider
182 the layout of info tables relative to the entry code for a closure.
184 An info table can be next to the entry code for the closure, or it can
185 be separate. The former (faster) is used in registerised versions of ghc,
186 and the latter (portable) is for non-registerised versions.
188 The diagrams below show where the string is to be found relative to
189 the normal info table of the closure.
191 1) Code next to table:
194 | | <- pointer to the start of the string
196 | | <- the (start of the) info table structure
203 In this case the pointer to the start of the string can be found in
204 the memory location _one word before_ the first entry in the normal info
207 2) Code NOT next to table:
210 info table structure -> | *------------------> --------------
214 ptr to start of str -> | |
217 In this case the pointer to the start of the string can be found
218 in the memory location: info_table_ptr + info_table_size
221 getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
222 getConDescAddress ptr
223 | ghciTablesNextToCode = do
224 offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
225 return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
227 peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
229 -- parsing names is a little bit fiddly because we have a string in the form:
230 -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
231 -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
232 -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
233 -- this is not the conventional way of writing Haskell names. We stick with
234 -- convention, even though it makes the parsing code more troublesome.
235 -- Warning: this code assumes that the string is well formed.
236 parse :: [Word8] -> ([Word8], [Word8], [Word8])
238 = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
240 dot = fromIntegral (ord '.')
241 (pkg, rest1) = break (== fromIntegral (ord ':')) input
243 = (concat $ intersperse [dot] $ reverse modWords, occWord)
245 (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
246 parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
248 = case break (== dot) str of
249 (top, []) -> (acc, top)
250 (top, _:bot) -> parseModOcc (top : acc) bot
252 -- | Get the 'HValue' associated with the given name.
254 -- May cause loading the module that contains the name.
256 -- Throws a 'ProgramError' if loading fails or the name cannot be found.
257 getHValue :: HscEnv -> Name -> IO HValue
258 getHValue hsc_env name = do
259 pls <- modifyMVar v_PersistentLinkerState $ \pls -> do
260 if (isExternalName name) then do
261 (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name]
262 if (failed ok) then ghcError (ProgramError "")
263 else return (pls', pls')
266 lookupName (closure_env pls) name
268 linkDependencies :: HscEnv -> PersistentLinkerState
269 -> SrcSpan -> [Module]
270 -> IO (PersistentLinkerState, SuccessFlag)
271 linkDependencies hsc_env pls span needed_mods = do
272 let hpt = hsc_HPT hsc_env
273 dflags = hsc_dflags hsc_env
274 -- The interpreter and dynamic linker can only handle object code built
275 -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
276 -- So here we check the build tag: if we're building a non-standard way
277 -- then we need to find & link object files built the "normal" way.
278 maybe_normal_osuf <- checkNonStdWay dflags span
280 -- Find what packages and linkables are required
281 (lnks, pkgs) <- getLinkDeps hsc_env hpt pls
282 maybe_normal_osuf span needed_mods
284 -- Link the packages and modules required
285 pls1 <- linkPackages' dflags pkgs pls
286 linkModules dflags pls1 lnks
289 -- | Temporarily extend the linker state.
291 withExtendedLinkEnv :: (MonadIO m, ExceptionMonad m) =>
292 [(Name,HValue)] -> m a -> m a
293 withExtendedLinkEnv new_env action
294 = gbracket (liftIO $ extendLinkEnv new_env)
295 (\_ -> reset_old_env)
298 -- Remember that the linker state might be side-effected
299 -- during the execution of the IO action, and we don't want to
300 -- lose those changes (we might have linked a new module or
301 -- package), so the reset action only removes the names we
303 reset_old_env = liftIO $ do
304 modifyMVar_ v_PersistentLinkerState $ \pls ->
305 let cur = closure_env pls
306 new = delListFromNameEnv cur (map fst new_env)
307 in return pls{ closure_env = new }
309 -- filterNameMap removes from the environment all entries except
310 -- those for a given set of modules;
311 -- Note that this removes all *local* (i.e. non-isExternal) names too
312 -- (these are the temporary bindings from the command line).
313 -- Used to filter both the ClosureEnv and ItblEnv
315 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
316 filterNameMap mods env
317 = filterNameEnv keep_elt env
319 keep_elt (n,_) = isExternalName n
320 && (nameModule n `elem` mods)
325 -- | Display the persistent linker state.
326 showLinkerState :: IO ()
328 = do pls <- readMVar v_PersistentLinkerState
329 printDump (vcat [text "----- Linker state -----",
330 text "Pkgs:" <+> ppr (pkgs_loaded pls),
331 text "Objs:" <+> ppr (objs_loaded pls),
332 text "BCOs:" <+> ppr (bcos_loaded pls)])
338 %************************************************************************
340 \subsection{Initialisation}
342 %************************************************************************
345 -- | Initialise the dynamic linker. This entails
347 -- a) Calling the C initialisation procedure,
349 -- b) Loading any packages specified on the command line,
351 -- c) Loading any packages specified on the command line, now held in the
352 -- @-l@ options in @v_Opt_l@,
354 -- d) Loading any @.o\/.dll@ files specified on the command line, now held
357 -- e) Loading any MacOS frameworks.
359 -- NOTE: This function is idempotent; if called more than once, it does
360 -- nothing. This is useful in Template Haskell, where we call it before
363 initDynLinker :: DynFlags -> IO ()
364 initDynLinker dflags =
365 modifyMVar_ v_PersistentLinkerState $ \pls0 -> do
366 done <- readIORef v_InitLinkerDone
367 if done then return pls0
368 else do writeIORef v_InitLinkerDone True
369 reallyInitDynLinker dflags
371 reallyInitDynLinker :: DynFlags -> IO PersistentLinkerState
372 reallyInitDynLinker dflags =
373 do { -- Initialise the linker state
374 let pls0 = emptyPLS dflags
376 -- (a) initialise the C dynamic linker
379 -- (b) Load packages from the command-line
380 ; pls <- linkPackages' dflags (preloadPackages (pkgState dflags)) pls0
382 -- (c) Link libraries from the command-line
383 ; let optl = getOpts dflags opt_l
384 ; let minus_ls = [ lib | '-':'l':lib <- optl ]
386 -- (d) Link .o files from the command-line
387 ; let lib_paths = libraryPaths dflags
388 ; cmdline_ld_inputs <- readIORef v_Ld_inputs
390 ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
392 -- (e) Link any MacOS frameworks
393 ; let framework_paths
394 | isDarwinTarget = frameworkPaths dflags
397 | isDarwinTarget = cmdlineFrameworks dflags
399 -- Finally do (c),(d),(e)
400 ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
402 ++ map Framework frameworks
403 ; if null cmdline_lib_specs then return pls
406 { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
407 ; maybePutStr dflags "final link ... "
410 ; if succeeded ok then maybePutStrLn dflags "done"
411 else ghcError (ProgramError "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 "failed.\n"
459 "user specified .o/.so/.DLL could not be loaded ("
460 ++ sys_errmsg ++ ")\nWhilst trying to load: "
461 ++ showLS spec ++ "\nAdditional directories searched:"
462 ++ (if null paths then " (none)" else
463 (concat (intersperse "\n" (map (" "++) paths)))))
465 -- Not interested in the paths in the static case.
466 preload_static _paths name
467 = do b <- doesFileExist name
468 if not b then return False
469 else loadObj name >> return True
473 %************************************************************************
475 Link a byte-code expression
477 %************************************************************************
480 -- | Link a single expression, /including/ first linking packages and
481 -- modules that this expression depends on.
483 -- Raises an IO exception ('ProgramError') if it can't find a compiled
484 -- version of the dependents to link.
486 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
487 linkExpr hsc_env span root_ul_bco
489 -- Initialise the linker (if it's not been done already)
490 let dflags = hsc_dflags hsc_env
491 ; initDynLinker dflags
493 -- Take lock for the actual work.
494 ; modifyMVar v_PersistentLinkerState $ \pls0 -> do {
496 -- Link the packages and modules required
497 ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods
499 ghcError (ProgramError "")
502 -- Link the expression itself
503 let ie = itbl_env pls
506 -- Link the necessary packages and linkables
507 ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
508 ; return (pls, root_hval)
511 free_names = nameSetToList (bcoFreeNames root_ul_bco)
513 needed_mods :: [Module]
514 needed_mods = [ nameModule n | n <- free_names,
515 isExternalName n, -- Names from other modules
516 not (isWiredInName n) -- Exclude wired-in names
517 ] -- (see note below)
518 -- Exclude wired-in names because we may not have read
519 -- their interface files, so getLinkDeps will fail
520 -- All wired-in names are in the base package, which we link
521 -- by default, so we can safely ignore them here.
523 dieWith :: SrcSpan -> Message -> IO a
524 dieWith span msg = ghcError (ProgramError (showSDoc (mkLocMessage span msg)))
527 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
528 checkNonStdWay dflags srcspan = do
529 let tag = buildTag dflags
530 if null tag then return Nothing else do
531 let default_osuf = phaseInputExt StopLn
532 if objectSuf dflags == default_osuf
533 then failNonStd srcspan
534 else return (Just default_osuf)
536 failNonStd :: SrcSpan -> IO (Maybe String)
537 failNonStd srcspan = dieWith srcspan $
538 ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$
539 ptext (sLit "You need to build the program twice: once the normal way, and then") $$
540 ptext (sLit "in the desired way using -osuf to set the object file suffix.")
543 getLinkDeps :: HscEnv -> HomePackageTable
544 -> PersistentLinkerState
545 -> Maybe String -- the "normal" object suffix
546 -> SrcSpan -- for error messages
547 -> [Module] -- If you need these
548 -> IO ([Linkable], [PackageId]) -- ... then link these first
549 -- Fails with an IO exception if it can't find enough files
551 getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
552 -- Find all the packages and linkables that a set of modules depends on
554 -- 1. Find the dependent home-pkg-modules/packages from each iface
555 (mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet;
558 -- 2. Exclude ones already linked
559 -- Main reason: avoid findModule calls in get_linkable
560 mods_needed = mods_s `minusList` linked_mods ;
561 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
563 linked_mods = map (moduleName.linkableModule)
564 (objs_loaded pls ++ bcos_loaded pls)
567 -- putStrLn (showSDoc (ppr mods_s)) ;
568 -- 3. For each dependent module, find its linkable
569 -- This will either be in the HPT or (in the case of one-shot
570 -- compilation) we may need to use maybe_getFileLinkable
571 lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
573 return (lnks_needed, pkgs_needed) }
575 dflags = hsc_dflags hsc_env
576 this_pkg = thisPackage dflags
578 -- The ModIface contains the transitive closure of the module dependencies
579 -- within the current package, *except* for boot modules: if we encounter
580 -- a boot module, we have to find its real interface and discover the
581 -- dependencies of that. Hence we need to traverse the dependency
582 -- tree recursively. See bug #936, testcase ghci/prog007.
583 follow_deps :: [Module] -- modules to follow
584 -> UniqSet ModuleName -- accum. module dependencies
585 -> UniqSet PackageId -- accum. package dependencies
586 -> IO ([ModuleName], [PackageId]) -- result
587 follow_deps [] acc_mods acc_pkgs
588 = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
589 follow_deps (mod:mods) acc_mods acc_pkgs
591 mb_iface <- initIfaceCheck hsc_env $
592 loadInterface msg mod (ImportByUser False)
593 iface <- case mb_iface of
594 Maybes.Failed err -> ghcError (ProgramError (showSDoc err))
595 Maybes.Succeeded iface -> return iface
597 when (mi_boot iface) $ link_boot_mod_error mod
600 pkg = modulePackageId mod
603 pkg_deps = dep_pkgs deps
604 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
605 where is_boot (m,True) = Left m
606 is_boot (m,False) = Right m
608 boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
609 acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
610 acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
613 then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
614 else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)
617 msg = text "need to link module" <+> ppr mod <+>
618 text "due to use of Template Haskell"
621 link_boot_mod_error mod =
622 ghcError (ProgramError (showSDoc (
623 text "module" <+> ppr mod <+>
624 text "cannot be linked; it is only available as a boot module")))
626 no_obj mod = dieWith span $
627 ptext (sLit "cannot find object file for module ") <>
631 while_linking_expr = ptext (sLit "while linking an interpreted expression")
633 -- This one is a build-system bug
635 get_linkable maybe_normal_osuf mod_name -- A home-package module
636 | Just mod_info <- lookupUFM hpt mod_name
637 = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))
639 = do -- It's not in the HPT because we are in one shot mode,
640 -- so use the Finder to get a ModLocation...
641 mb_stuff <- findHomeModule hsc_env mod_name
643 Found loc mod -> found loc mod
647 -- ...and then find the linkable for it
648 mb_lnk <- findObjectLinkableMaybe mod loc ;
650 Nothing -> no_obj mod ;
651 Just lnk -> adjust_linkable lnk
655 | Just osuf <- maybe_normal_osuf = do
656 new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
657 return lnk{ linkableUnlinked=new_uls }
661 adjust_ul osuf (DotO file) = do
662 let new_file = replaceExtension file osuf
663 ok <- doesFileExist new_file
666 ptext (sLit "cannot find normal object file ")
667 <> quotes (text new_file) $$ while_linking_expr
668 else return (DotO new_file)
669 adjust_ul _ _ = panic "adjust_ul"
673 %************************************************************************
676 The linkables may consist of a mixture of
677 byte-code modules and object modules
679 %************************************************************************
682 linkModules :: DynFlags -> PersistentLinkerState -> [Linkable]
683 -> IO (PersistentLinkerState, SuccessFlag)
684 linkModules dflags pls linkables
685 = block $ do -- don't want to be interrupted by ^C in here
687 let (objs, bcos) = partition isObjectLinkable
688 (concatMap partitionLinkable linkables)
690 -- Load objects first; they can't depend on BCOs
691 (pls1, ok_flag) <- dynLinkObjs dflags pls objs
693 if failed ok_flag then
694 return (pls1, Failed)
696 pls2 <- dynLinkBCOs pls1 bcos
697 return (pls2, Succeeded)
700 -- HACK to support f-x-dynamic in the interpreter; no other purpose
701 partitionLinkable :: Linkable -> [Linkable]
703 = let li_uls = linkableUnlinked li
704 li_uls_obj = filter isObject li_uls
705 li_uls_bco = filter isInterpretable li_uls
707 case (li_uls_obj, li_uls_bco) of
708 (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},
709 li {linkableUnlinked=li_uls_bco}]
712 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
713 findModuleLinkable_maybe lis mod
714 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
717 _ -> pprPanic "findModuleLinkable" (ppr mod)
719 linkableInSet :: Linkable -> [Linkable] -> Bool
720 linkableInSet l objs_loaded =
721 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
723 Just m -> linkableTime l == linkableTime m
727 %************************************************************************
729 \subsection{The object-code linker}
731 %************************************************************************
734 dynLinkObjs :: DynFlags -> PersistentLinkerState -> [Linkable]
735 -> IO (PersistentLinkerState, SuccessFlag)
736 dynLinkObjs dflags pls objs = do
737 -- Load the object files and link them
738 let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
739 pls1 = pls { objs_loaded = objs_loaded' }
740 unlinkeds = concatMap linkableUnlinked new_objs
742 mapM_ loadObj (map nameOfObject unlinkeds)
744 -- Link the all together
747 -- If resolving failed, unload all our
748 -- object modules and carry on
749 if succeeded ok then do
750 return (pls1, Succeeded)
752 pls2 <- unload_wkr dflags [] pls1
753 return (pls2, Failed)
756 rmDupLinkables :: [Linkable] -- Already loaded
757 -> [Linkable] -- New linkables
758 -> ([Linkable], -- New loaded set (including new ones)
759 [Linkable]) -- New linkables (excluding dups)
760 rmDupLinkables already ls
763 go already extras [] = (already, extras)
764 go already extras (l:ls)
765 | linkableInSet l already = go already extras ls
766 | otherwise = go (l:already) (l:extras) ls
769 %************************************************************************
771 \subsection{The byte-code linker}
773 %************************************************************************
776 dynLinkBCOs :: PersistentLinkerState -> [Linkable] -> IO PersistentLinkerState
777 dynLinkBCOs pls bcos = do
779 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
780 pls1 = pls { bcos_loaded = bcos_loaded' }
781 unlinkeds :: [Unlinked]
782 unlinkeds = concatMap linkableUnlinked new_bcos
784 cbcs :: [CompiledByteCode]
785 cbcs = map byteCodeOfObject unlinkeds
788 ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
789 ies = [ie | ByteCode _ ie <- cbcs]
790 gce = closure_env pls
791 final_ie = foldr plusNameEnv (itbl_env pls) ies
793 (final_gce, _linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
794 -- XXX What happens to these linked_bcos?
796 let pls2 = pls1 { closure_env = final_gce,
797 itbl_env = final_ie }
801 -- Link a bunch of BCOs and return them + updated closure env.
802 linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
803 -- True <=> add only toplevel BCOs to closure env
807 -> IO (ClosureEnv, [HValue])
808 -- The returned HValues are associated 1-1 with
809 -- the incoming unlinked BCOs. Each gives the
810 -- value of the corresponding unlinked BCO
812 linkSomeBCOs toplevs_only ie ce_in ul_bcos
813 = do let nms = map unlinkedBCOName ul_bcos
815 ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
816 in mapM (linkBCO ie ce_out) ul_bcos )
817 let ce_all_additions = zip nms hvals
818 ce_top_additions = filter (isExternalName.fst) ce_all_additions
819 ce_additions = if toplevs_only then ce_top_additions
820 else ce_all_additions
821 ce_out = -- make sure we're not inserting duplicate names into the
822 -- closure environment, which leads to trouble.
823 ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
824 extendClosureEnv ce_in ce_additions
825 return (ce_out, hvals)
830 %************************************************************************
832 Unload some object modules
834 %************************************************************************
837 -- ---------------------------------------------------------------------------
838 -- | Unloading old objects ready for a new compilation sweep.
840 -- The compilation manager provides us with a list of linkables that it
841 -- considers \"stable\", i.e. won't be recompiled this time around. For
842 -- each of the modules current linked in memory,
844 -- * if the linkable is stable (and it's the same one -- the user may have
845 -- recompiled the module on the side), we keep it,
847 -- * otherwise, we unload it.
849 -- * we also implicitly unload all temporary bindings at this point.
852 -> [Linkable] -- ^ The linkables to *keep*.
854 unload dflags linkables
855 = block $ do -- block, so we're safe from Ctrl-C in here
857 -- Initialise the linker (if it's not been done already)
861 <- modifyMVar v_PersistentLinkerState $ \pls -> do
862 pls1 <- unload_wkr dflags linkables pls
865 debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
866 debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
869 unload_wkr :: DynFlags
870 -> [Linkable] -- stable linkables
871 -> PersistentLinkerState
872 -> IO PersistentLinkerState
873 -- Does the core unload business
874 -- (the wrapper blocks exceptions and deals with the PLS get and put)
876 unload_wkr _ linkables pls
877 = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
879 objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
880 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
882 let bcos_retained = map linkableModule bcos_loaded'
883 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
884 closure_env' = filterNameMap bcos_retained (closure_env pls)
885 new_pls = pls { itbl_env = itbl_env',
886 closure_env = closure_env',
887 bcos_loaded = bcos_loaded',
888 objs_loaded = objs_loaded' }
892 maybeUnload :: [Linkable] -> Linkable -> IO Bool
893 maybeUnload keep_linkables lnk
894 | linkableInSet lnk keep_linkables = return True
896 = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
897 -- The components of a BCO linkable may contain
898 -- dot-o files. Which is very confusing.
900 -- But the BCO parts can be unlinked just by
901 -- letting go of them (plus of course depopulating
902 -- the symbol table which is done in the main body)
907 %************************************************************************
911 %************************************************************************
916 = Object FilePath -- Full path name of a .o file, including trailing .o
917 -- For dynamic objects only, try to find the object
918 -- file in all the directories specified in
919 -- v_Library_paths before giving up.
921 | DLL String -- "Unadorned" name of a .DLL/.so
922 -- e.g. On unix "qt" denotes "libqt.so"
923 -- On WinDoze "burble" denotes "burble.DLL"
924 -- loadDLL is platform-specific and adds the lib/.so/.DLL
925 -- suffixes platform-dependently
927 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
928 -- (ends with .dll or .so).
930 | Framework String -- Only used for darwin, but does no harm
932 -- If this package is already part of the GHCi binary, we'll already
933 -- have the right DLLs for this package loaded, so don't try to
936 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
937 -- as far as the loader is concerned, but it does initialise the list
938 -- of DLL handles that rts/Linker.c maintains, and that in turn is
939 -- used by lookupSymbol. So we must call addDLL for each library
940 -- just to get the DLL handle into the list.
941 partOfGHCi :: [PackageName]
943 | isWindowsTarget || isDarwinTarget = []
944 | otherwise = map PackageName
945 ["base", "haskell98", "template-haskell", "editline"]
947 showLS :: LibrarySpec -> String
948 showLS (Object nm) = "(static) " ++ nm
949 showLS (DLL nm) = "(dynamic) " ++ nm
950 showLS (DLLPath nm) = "(dynamic) " ++ nm
951 showLS (Framework nm) = "(framework) " ++ nm
953 -- | Link exactly the specified packages, and their dependents (unless of
954 -- course they are already linked). The dependents are linked
955 -- automatically, and it doesn't matter what order you specify the input
958 linkPackages :: DynFlags -> [PackageId] -> IO ()
959 -- NOTE: in fact, since each module tracks all the packages it depends on,
960 -- we don't really need to use the package-config dependencies.
962 -- However we do need the package-config stuff (to find aux libs etc),
963 -- and following them lets us load libraries in the right order, which
964 -- perhaps makes the error message a bit more localised if we get a link
965 -- failure. So the dependency walking code is still here.
967 linkPackages dflags new_pkgs = do
968 -- It's probably not safe to try to load packages concurrently, so we take
970 modifyMVar_ v_PersistentLinkerState $ \pls -> do
971 linkPackages' dflags new_pkgs pls
973 linkPackages' :: DynFlags -> [PackageId] -> PersistentLinkerState
974 -> IO PersistentLinkerState
975 linkPackages' dflags new_pks pls = do
976 let pkg_map = pkgIdMap (pkgState dflags)
978 pkgs' <- link pkg_map (pkgs_loaded pls) new_pks
980 return $! pls { pkgs_loaded = pkgs' }
982 link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
983 link pkg_map pkgs new_pkgs =
984 foldM (link_one pkg_map) pkgs new_pkgs
986 link_one pkg_map pkgs new_pkg
987 | new_pkg `elem` pkgs -- Already linked
990 | Just pkg_cfg <- lookupPackage pkg_map new_pkg
991 = do { -- Link dependents first
992 pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
993 -- Now link the package itself
994 ; linkPackage dflags pkg_cfg
995 ; return (new_pkg : pkgs') }
998 = ghcError (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
1001 linkPackage :: DynFlags -> PackageConfig -> IO ()
1002 linkPackage dflags pkg
1004 let dirs = Packages.libraryDirs pkg
1006 let libs = Packages.hsLibraries pkg
1007 -- Because of slight differences between the GHC dynamic linker and
1008 -- the native system linker some packages have to link with a
1009 -- different list of libraries when using GHCi. Examples include: libs
1010 -- that are actually gnu ld scripts, and the possability that the .a
1011 -- libs do not exactly match the .so/.dll equivalents. So if the
1012 -- package file provides an "extra-ghci-libraries" field then we use
1013 -- that instead of the "extra-libraries" field.
1014 ++ (if null (Packages.extraGHCiLibraries pkg)
1015 then Packages.extraLibraries pkg
1016 else Packages.extraGHCiLibraries pkg)
1017 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
1018 classifieds <- mapM (locateOneObj dirs) libs
1020 -- Complication: all the .so's must be loaded before any of the .o's.
1021 let dlls = [ dll | DLL dll <- classifieds ]
1022 objs = [ obj | Object obj <- classifieds ]
1024 maybePutStr dflags ("Loading package " ++ display (package pkg) ++ " ... ")
1026 -- See comments with partOfGHCi
1027 when (packageName pkg `notElem` partOfGHCi) $ do
1029 -- When a library A needs symbols from a library B, the order in
1030 -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
1031 -- way ld expects it for static linking. Dynamic linking is a
1032 -- different story: When A has no dependency information for B,
1033 -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
1034 -- when B has not been loaded before. In a nutshell: Reverse the
1035 -- order of DLLs for dynamic linking.
1036 -- This fixes a problem with the HOpenGL package (see "Compiling
1037 -- HOpenGL under recent versions of GHC" on the HOpenGL list).
1038 mapM_ (load_dyn dirs) (reverse dlls)
1040 -- After loading all the DLLs, we can load the static objects.
1041 -- Ordering isn't important here, because we do one final link
1042 -- step to resolve everything.
1045 maybePutStr dflags "linking ... "
1047 if succeeded ok then maybePutStrLn dflags "done."
1048 else ghcError (InstallationError ("unable to load package `" ++ display (package pkg) ++ "'"))
1050 load_dyn :: [FilePath] -> FilePath -> IO ()
1051 load_dyn dirs dll = do r <- loadDynamic dirs dll
1053 Nothing -> return ()
1054 Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: "
1055 ++ dll ++ " (" ++ err ++ ")" ))
1057 loadFrameworks :: InstalledPackageInfo_ ModuleName -> IO ()
1059 | isDarwinTarget = mapM_ load frameworks
1060 | otherwise = return ()
1062 fw_dirs = Packages.frameworkDirs pkg
1063 frameworks = Packages.frameworks pkg
1065 load fw = do r <- loadFramework fw_dirs fw
1067 Nothing -> return ()
1068 Just err -> ghcError (CmdLineError ("can't load framework: "
1069 ++ fw ++ " (" ++ err ++ ")" ))
1071 -- Try to find an object file for a given library in the given paths.
1072 -- If it isn't present, we assume it's a dynamic library.
1073 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1074 locateOneObj dirs lib
1076 -- When the GHC package was not compiled as dynamic library
1077 -- (=__PIC__ not set), we search for .o libraries first.
1078 = do { mb_obj_path <- findFile mk_obj_path dirs
1079 ; case mb_obj_path of
1080 Just obj_path -> return (Object obj_path)
1082 do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1083 ; case mb_lib_path of
1084 Just _ -> return (DLL dyn_lib_name)
1085 Nothing -> return (DLL lib) }} -- We assume
1087 -- When the GHC package was compiled as dynamic library (=__PIC__ set),
1088 -- we search for .so libraries first.
1089 = do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1090 ; case mb_lib_path of
1091 Just _ -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
1093 do { mb_obj_path <- findFile mk_obj_path dirs
1094 ; case mb_obj_path of
1095 Just obj_path -> return (Object obj_path)
1096 Nothing -> return (DLL lib) }} -- We assume
1098 mk_obj_path dir = dir </> (lib <.> "o")
1099 dyn_lib_name = lib ++ "-ghc" ++ cProjectVersion
1100 mk_dyn_lib_path dir = dir </> mkSOName dyn_lib_name
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 <- tryIO 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 ()