2 % (c) The University of Glasgow 2005-2006
5 -- --------------------------------------
6 -- The dynamic linker for GHCi
7 -- --------------------------------------
9 This module deals with the top-level issues of dynamic linking,
10 calling the object-code linker and the byte-code linker where
15 {-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-}
18 -- The above warning supression flag is a temporary kludge.
19 -- While working on this module you are encouraged to remove it and fix
20 -- any warnings in the module. See
21 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
24 module Linker ( HValue, getHValue, showLinkerState,
25 linkExpr, unload, withExtendedLinkEnv,
26 extendLinkEnv, deleteFromLinkEnv,
28 linkPackages,initDynLinker,
32 #include "HsVersions.h"
49 import qualified OccName
66 import Config ( cProjectVersion )
77 import System.Directory
79 import Control.Exception
84 %************************************************************************
88 %************************************************************************
90 The persistent linker state *must* match the actual state of the
91 C dynamic linker at all times, so we keep it in a private global variable.
94 The PersistentLinkerState maps Names to actual closures (for
95 interpreted code only), for use during linking.
98 GLOBAL_VAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState)
99 GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised
101 data PersistentLinkerState
102 = PersistentLinkerState {
104 -- Current global mapping from Names to their true values
105 closure_env :: ClosureEnv,
107 -- The current global mapping from RdrNames of DataCons to
108 -- info table addresses.
109 -- When a new Unlinked is linked into the running image, or an existing
110 -- module in the image is replaced, the itbl_env must be updated
114 -- The currently loaded interpreted modules (home package)
115 bcos_loaded :: [Linkable],
117 -- And the currently-loaded compiled modules (home package)
118 objs_loaded :: [Linkable],
120 -- The currently-loaded packages; always object code
121 -- Held, as usual, in dependency order; though I am not sure if
122 -- that is really important
123 pkgs_loaded :: [PackageId]
126 emptyPLS :: DynFlags -> PersistentLinkerState
127 emptyPLS dflags = PersistentLinkerState {
128 closure_env = emptyNameEnv,
129 itbl_env = emptyNameEnv,
130 pkgs_loaded = init_pkgs,
134 -- Packages that don't need loading, because the compiler
135 -- shares them with the interpreted program.
137 -- The linker's symbol table is populated with RTS symbols using an
138 -- explicit list. See rts/Linker.c for details.
139 where init_pkgs = [rtsPackageId]
143 extendLoadedPkgs :: [PackageId] -> IO ()
144 extendLoadedPkgs pkgs
145 = modifyIORef v_PersistentLinkerState (\s -> s{pkgs_loaded = pkgs ++ pkgs_loaded s})
147 extendLinkEnv :: [(Name,HValue)] -> IO ()
148 -- Automatically discards shadowed bindings
149 extendLinkEnv new_bindings
150 = do pls <- readIORef v_PersistentLinkerState
151 let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
152 new_pls = pls { closure_env = new_closure_env }
153 writeIORef v_PersistentLinkerState new_pls
155 deleteFromLinkEnv :: [Name] -> IO ()
156 deleteFromLinkEnv to_remove
157 = do pls <- readIORef v_PersistentLinkerState
158 let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
159 new_pls = pls { closure_env = new_closure_env }
160 writeIORef v_PersistentLinkerState new_pls
162 -- | Given a data constructor in the heap, find its Name.
163 -- The info tables for data constructors have a field which records
164 -- the source name of the constructor as a Ptr Word8 (UTF-8 encoded
165 -- string). The format is:
167 -- Package:Module.Name
169 -- We use this string to lookup the interpreter's internal representation of the name
170 -- using the lookupOrig.
172 dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
173 dataConInfoPtrToName x = do
174 theString <- ioToTcRn $ do
175 let ptr = castPtr x :: Ptr StgInfoTable
176 conDescAddress <- getConDescAddress ptr
177 peekArray0 0 conDescAddress
178 let (pkg, mod, occ) = parse theString
179 pkgFS = mkFastStringByteList pkg
180 modFS = mkFastStringByteList mod
181 occFS = mkFastStringByteList occ
182 occName = mkOccNameFS OccName.dataName occFS
183 modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS)
184 return (Left$ showSDoc$ ppr modName <> dot <> ppr occName )
185 `recoverM` (Right `fmap` lookupOrig modName occName)
189 {- To find the string in the constructor's info table we need to consider
190 the layout of info tables relative to the entry code for a closure.
192 An info table can be next to the entry code for the closure, or it can
193 be separate. The former (faster) is used in registerised versions of ghc,
194 and the latter (portable) is for non-registerised versions.
196 The diagrams below show where the string is to be found relative to
197 the normal info table of the closure.
199 1) Code next to table:
202 | | <- pointer to the start of the string
204 | | <- the (start of the) info table structure
211 In this case the pointer to the start of the string can be found in
212 the memory location _one word before_ the first entry in the normal info
215 2) Code NOT next to table:
218 info table structure -> | *------------------> --------------
222 ptr to start of str -> | |
225 In this case the pointer to the start of the string can be found
226 in the memory location: info_table_ptr + info_table_size
229 getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
230 getConDescAddress ptr = do
231 #ifdef GHCI_TABLES_NEXT_TO_CODE
232 offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
233 return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
235 peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
238 -- parsing names is a little bit fiddly because we have a string in the form:
239 -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
240 -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
241 -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
242 -- this is not the conventional way of writing Haskell names. We stick with
243 -- convention, even though it makes the parsing code more troublesome.
244 -- Warning: this code assumes that the string is well formed.
245 parse :: [Word8] -> ([Word8], [Word8], [Word8])
247 = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
249 dot = fromIntegral (ord '.')
250 (pkg, rest1) = break (== fromIntegral (ord ':')) input
252 = (concat $ intersperse [dot] $ reverse modWords, occWord)
254 (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
255 parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
257 = case break (== dot) str of
258 (top, []) -> (acc, top)
259 (top, _:bot) -> parseModOcc (top : acc) bot
262 getHValue :: HscEnv -> Name -> IO HValue
263 getHValue hsc_env name = do
264 when (isExternalName name) $ do
265 ok <- linkDependencies hsc_env noSrcSpan [nameModule name]
266 when (failed ok) $ throwDyn (ProgramError "")
267 pls <- readIORef v_PersistentLinkerState
268 lookupName (closure_env pls) name
270 linkDependencies :: HscEnv -> SrcSpan -> [Module] -> IO SuccessFlag
271 linkDependencies hsc_env 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 eps <- readIORef (hsc_EPS hsc_env)
282 (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps)
283 maybe_normal_osuf span needed_mods
285 -- Link the packages and modules required
286 linkPackages dflags pkgs
287 linkModules dflags lnks
290 -- | Temporarily extend the linker state.
292 withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
293 withExtendedLinkEnv new_env action
294 = bracket set_new_env
297 where set_new_env = do
298 pls <- readIORef v_PersistentLinkerState
299 let new_closure_env = extendClosureEnv (closure_env pls) new_env
300 new_pls = pls { closure_env = new_closure_env }
301 writeIORef v_PersistentLinkerState new_pls
302 return (closure_env pls)
304 -- Remember that the linker state might be side-effected
305 -- during the execution of the IO action, and we don't want to
306 -- lose those changes (we might have linked a new module or
307 -- package), so the reset action only removes the names we
309 reset_old_env env = do
310 modifyIORef v_PersistentLinkerState $ \pls ->
311 let cur = closure_env pls
312 new = delListFromNameEnv cur (map fst new_env)
314 pls{ closure_env = new }
316 -- filterNameMap removes from the environment all entries except
317 -- those for a given set of modules;
318 -- Note that this removes all *local* (i.e. non-isExternal) names too
319 -- (these are the temporary bindings from the command line).
320 -- Used to filter both the ClosureEnv and ItblEnv
322 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
323 filterNameMap mods env
324 = filterNameEnv keep_elt env
326 keep_elt (n,_) = isExternalName n
327 && (nameModule n `elem` mods)
332 showLinkerState :: IO ()
333 -- Display the persistent linker state
335 = do pls <- readIORef v_PersistentLinkerState
336 printDump (vcat [text "----- Linker state -----",
337 text "Pkgs:" <+> ppr (pkgs_loaded pls),
338 text "Objs:" <+> ppr (objs_loaded pls),
339 text "BCOs:" <+> ppr (bcos_loaded pls)])
345 %************************************************************************
347 \subsection{Initialisation}
349 %************************************************************************
351 We initialise the dynamic linker by
353 a) calling the C initialisation procedure
355 b) Loading any packages specified on the command line,
357 c) Loading any packages specified on the command line,
358 now held in the -l options in v_Opt_l
360 d) Loading any .o/.dll files specified on the command line,
361 now held in v_Ld_inputs
363 e) Loading any MacOS frameworks
366 initDynLinker :: DynFlags -> IO ()
367 -- This function is idempotent; if called more than once, it does nothing
368 -- This is useful in Template Haskell, where we call it before trying to link
370 = do { done <- readIORef v_InitLinkerDone
371 ; if done then return ()
372 else do { writeIORef v_InitLinkerDone True
373 ; reallyInitDynLinker dflags }
376 reallyInitDynLinker dflags
377 = do { -- Initialise the linker state
378 ; writeIORef v_PersistentLinkerState (emptyPLS dflags)
380 -- (a) initialise the C dynamic linker
383 -- (b) Load packages from the command-line
384 ; linkPackages dflags (preloadPackages (pkgState dflags))
386 -- (c) Link libraries from the command-line
387 ; let optl = getOpts dflags opt_l
388 ; let minus_ls = [ lib | '-':'l':lib <- optl ]
390 -- (d) Link .o files from the command-line
391 ; let lib_paths = libraryPaths dflags
392 ; cmdline_ld_inputs <- readIORef v_Ld_inputs
394 ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
396 -- (e) Link any MacOS frameworks
397 #ifdef darwin_TARGET_OS
398 ; let framework_paths = frameworkPaths dflags
399 ; let frameworks = cmdlineFrameworks dflags
401 ; let frameworks = []
402 ; let framework_paths = []
404 -- Finally do (c),(d),(e)
405 ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
407 ++ map Framework frameworks
408 ; if null cmdline_lib_specs then return ()
411 { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
412 ; maybePutStr dflags "final link ... "
415 ; if succeeded ok then maybePutStrLn dflags "done"
416 else throwDyn (InstallationError "linking extra libraries/objects failed")
419 classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
421 | isObjectFilename f = return (Just (Object f))
422 | isDynLibFilename f = return (Just (DLLPath f))
424 hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
427 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
428 preloadLib dflags lib_paths framework_paths lib_spec
429 = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
432 -> do b <- preload_static lib_paths static_ish
433 maybePutStrLn dflags (if b then "done"
437 -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
439 Nothing -> maybePutStrLn dflags "done"
440 Just mm -> preloadFailed mm lib_paths lib_spec
443 -> do maybe_errstr <- loadDLL dll_path
445 Nothing -> maybePutStrLn dflags "done"
446 Just mm -> preloadFailed mm lib_paths lib_spec
448 #ifdef darwin_TARGET_OS
450 -> do maybe_errstr <- loadFramework framework_paths framework
452 Nothing -> maybePutStrLn dflags "done"
453 Just mm -> preloadFailed mm framework_paths lib_spec
456 preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
457 preloadFailed sys_errmsg paths spec
458 = do maybePutStr dflags
459 ("failed.\nDynamic linker error message was:\n "
460 ++ sys_errmsg ++ "\nWhilst trying to load: "
461 ++ showLS spec ++ "\nDirectories to search are:\n"
462 ++ unlines (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
472 CmdLineError "user specified .o/.so/.DLL could not be loaded."
476 %************************************************************************
478 Link a byte-code expression
480 %************************************************************************
483 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
485 -- Link a single expression, *including* first linking packages and
486 -- modules that this expression depends on.
488 -- Raises an IO exception if it can't find a compiled version of the
489 -- dependents to link.
491 -- Note: This function side-effects the linker state (Pepe)
493 linkExpr hsc_env span root_ul_bco
495 -- Initialise the linker (if it's not been done already)
496 let dflags = hsc_dflags hsc_env
497 ; initDynLinker dflags
499 -- Link the packages and modules required
500 ; ok <- linkDependencies hsc_env span needed_mods
502 throwDyn (ProgramError "")
505 -- Link the expression itself
506 pls <- readIORef v_PersistentLinkerState
507 ; let ie = itbl_env pls
510 -- Link the necessary packages and linkables
511 ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
515 free_names = nameSetToList (bcoFreeNames root_ul_bco)
517 needed_mods :: [Module]
518 needed_mods = [ nameModule n | n <- free_names,
519 isExternalName n, -- Names from other modules
520 not (isWiredInName n) -- Exclude wired-in names
521 ] -- (see note below)
522 -- Exclude wired-in names because we may not have read
523 -- their interface files, so getLinkDeps will fail
524 -- All wired-in names are in the base package, which we link
525 -- by default, so we can safely ignore them here.
527 dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg)))
530 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
531 checkNonStdWay dflags srcspan = do
532 tag <- readIORef v_Build_tag
533 if null tag then return Nothing else do
534 let default_osuf = phaseInputExt StopLn
535 if objectSuf dflags == default_osuf
536 then failNonStd srcspan
537 else return (Just default_osuf)
539 failNonStd srcspan = dieWith srcspan $
540 ptext SLIT("Dynamic linking required, but this is a non-standard build (eg. prof).") $$
541 ptext SLIT("You need to build the program twice: once the normal way, and then") $$
542 ptext SLIT("in the desired way using -osuf to set the object file suffix.")
545 getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable
546 -> Maybe String -- the "normal" object suffix
547 -> SrcSpan -- for error messages
548 -> [Module] -- If you need these
549 -> IO ([Linkable], [PackageId]) -- ... then link these first
550 -- Fails with an IO exception if it can't find enough files
552 getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
553 -- Find all the packages and linkables that a set of modules depends on
554 = do { pls <- readIORef v_PersistentLinkerState ;
556 -- 1. Find the dependent home-pkg-modules/packages from each iface
557 (mods_s, pkgs_s) = follow_deps mods emptyUniqSet emptyUniqSet;
559 -- 2. Exclude ones already linked
560 -- Main reason: avoid findModule calls in get_linkable
561 mods_needed = mods_s `minusList` linked_mods ;
562 pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
564 linked_mods = map (moduleName.linkableModule)
565 (objs_loaded pls ++ bcos_loaded pls)
568 -- putStrLn (showSDoc (ppr mods_s)) ;
569 -- 3. For each dependent module, find its linkable
570 -- This will either be in the HPT or (in the case of one-shot
571 -- compilation) we may need to use maybe_getFileLinkable
572 lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
574 return (lnks_needed, pkgs_needed) }
576 dflags = hsc_dflags hsc_env
577 this_pkg = thisPackage dflags
579 -- The ModIface contains the transitive closure of the module dependencies
580 -- within the current package, *except* for boot modules: if we encounter
581 -- a boot module, we have to find its real interface and discover the
582 -- dependencies of that. Hence we need to traverse the dependency
583 -- tree recursively. See bug #936, testcase ghci/prog007.
584 follow_deps :: [Module] -- modules to follow
585 -> UniqSet ModuleName -- accum. module dependencies
586 -> UniqSet PackageId -- accum. package dependencies
587 -> ([ModuleName], [PackageId]) -- result
588 follow_deps [] acc_mods acc_pkgs
589 = (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
590 follow_deps (mod:mods) acc_mods acc_pkgs
592 = follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
594 = link_boot_mod_error mod
596 = follow_deps (map (mkModule this_pkg) boot_deps' ++ mods) acc_mods' acc_pkgs'
598 pkg = modulePackageId mod
599 iface = get_iface mod
602 pkg_deps = dep_pkgs deps
603 (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
604 where is_boot (m,True) = Left m
605 is_boot (m,False) = Right m
607 boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
608 acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps)
609 acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps
612 link_boot_mod_error mod =
613 throwDyn (ProgramError (showSDoc (
614 text "module" <+> ppr mod <+>
615 text "cannot be linked; it is only available as a boot module")))
617 get_iface mod = case lookupIfaceByModule dflags hpt pit mod of
619 Nothing -> pprPanic "getLinkDeps" (no_iface mod)
620 no_iface mod = ptext SLIT("No iface for") <+> ppr mod
621 -- This one is a GHC bug
623 no_obj mod = dieWith span $
624 ptext SLIT("cannot find object file for module ") <>
628 while_linking_expr = ptext SLIT("while linking an interpreted expression")
630 -- This one is a build-system bug
632 get_linkable maybe_normal_osuf mod_name -- A home-package module
633 | Just mod_info <- lookupUFM hpt mod_name
634 = ASSERT(isJust (hm_linkable mod_info))
635 adjust_linkable (fromJust (hm_linkable mod_info))
637 = do -- It's not in the HPT because we are in one shot mode,
638 -- so use the Finder to get a ModLocation...
639 mb_stuff <- findHomeModule hsc_env mod_name
641 Found loc mod -> found loc mod
645 -- ...and then find the linkable for it
646 mb_lnk <- findObjectLinkableMaybe mod loc ;
648 Nothing -> no_obj mod ;
649 Just lnk -> adjust_linkable lnk
653 | Just osuf <- maybe_normal_osuf = do
654 new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
655 return lnk{ linkableUnlinked=new_uls }
659 adjust_ul osuf (DotO file) = do
660 let new_file = replaceFilenameSuffix file osuf
661 ok <- doesFileExist new_file
664 ptext SLIT("cannot find normal object file ")
665 <> quotes (text new_file) $$ while_linking_expr
666 else return (DotO new_file)
670 %************************************************************************
673 The linkables may consist of a mixture of
674 byte-code modules and object modules
676 %************************************************************************
679 linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
680 linkModules dflags linkables
681 = block $ do -- don't want to be interrupted by ^C in here
683 let (objs, bcos) = partition isObjectLinkable
684 (concatMap partitionLinkable linkables)
686 -- Load objects first; they can't depend on BCOs
687 ok_flag <- dynLinkObjs dflags objs
689 if failed ok_flag then
696 -- HACK to support f-x-dynamic in the interpreter; no other purpose
697 partitionLinkable :: Linkable -> [Linkable]
699 = let li_uls = linkableUnlinked li
700 li_uls_obj = filter isObject li_uls
701 li_uls_bco = filter isInterpretable li_uls
703 case (li_uls_obj, li_uls_bco) of
704 (objs@(_:_), bcos@(_:_))
705 -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
709 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
710 findModuleLinkable_maybe lis mod
711 = case [LM time nm us | LM time nm us <- lis, nm == mod] of
714 many -> pprPanic "findModuleLinkable" (ppr mod)
716 linkableInSet :: Linkable -> [Linkable] -> Bool
717 linkableInSet l objs_loaded =
718 case findModuleLinkable_maybe objs_loaded (linkableModule l) of
720 Just m -> linkableTime l == linkableTime m
724 %************************************************************************
726 \subsection{The object-code linker}
728 %************************************************************************
731 dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
732 -- Side-effects the PersistentLinkerState
734 dynLinkObjs dflags objs
735 = do pls <- readIORef v_PersistentLinkerState
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 writeIORef v_PersistentLinkerState pls1
753 pls2 <- unload_wkr dflags [] pls1
754 writeIORef v_PersistentLinkerState pls2
758 rmDupLinkables :: [Linkable] -- Already loaded
759 -> [Linkable] -- New linkables
760 -> ([Linkable], -- New loaded set (including new ones)
761 [Linkable]) -- New linkables (excluding dups)
762 rmDupLinkables already ls
765 go already extras [] = (already, extras)
766 go already extras (l:ls)
767 | linkableInSet l already = go already extras ls
768 | otherwise = go (l:already) (l:extras) ls
771 %************************************************************************
773 \subsection{The byte-code linker}
775 %************************************************************************
778 dynLinkBCOs :: [Linkable] -> IO ()
779 -- Side-effects the persistent linker state
781 = do pls <- readIORef v_PersistentLinkerState
783 let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
784 pls1 = pls { bcos_loaded = bcos_loaded' }
785 unlinkeds :: [Unlinked]
786 unlinkeds = concatMap linkableUnlinked new_bcos
788 cbcs :: [CompiledByteCode]
789 cbcs = map byteCodeOfObject unlinkeds
792 ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs]
793 ies = [ie | ByteCode _ ie <- cbcs]
794 gce = closure_env pls
795 final_ie = foldr plusNameEnv (itbl_env pls) ies
797 (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
798 -- What happens to these linked_bcos?
800 let pls2 = pls1 { closure_env = final_gce,
801 itbl_env = final_ie }
803 writeIORef v_PersistentLinkerState pls2
806 -- Link a bunch of BCOs and return them + updated closure env.
807 linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env
808 -- True <=> add only toplevel BCOs to closure env
812 -> IO (ClosureEnv, [HValue])
813 -- The returned HValues are associated 1-1 with
814 -- the incoming unlinked BCOs. Each gives the
815 -- value of the corresponding unlinked BCO
817 linkSomeBCOs toplevs_only ie ce_in ul_bcos
818 = do let nms = map unlinkedBCOName ul_bcos
820 ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
821 in mapM (linkBCO ie ce_out) ul_bcos )
822 let ce_all_additions = zip nms hvals
823 ce_top_additions = filter (isExternalName.fst) ce_all_additions
824 ce_additions = if toplevs_only then ce_top_additions
825 else ce_all_additions
826 ce_out = -- make sure we're not inserting duplicate names into the
827 -- closure environment, which leads to trouble.
828 ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
829 extendClosureEnv ce_in ce_additions
830 return (ce_out, hvals)
835 %************************************************************************
837 Unload some object modules
839 %************************************************************************
842 -- ---------------------------------------------------------------------------
843 -- Unloading old objects ready for a new compilation sweep.
845 -- The compilation manager provides us with a list of linkables that it
846 -- considers "stable", i.e. won't be recompiled this time around. For
847 -- each of the modules current linked in memory,
849 -- * if the linkable is stable (and it's the same one - the
850 -- user may have recompiled the module on the side), we keep it,
852 -- * otherwise, we unload it.
854 -- * we also implicitly unload all temporary bindings at this point.
856 unload :: DynFlags -> [Linkable] -> IO ()
857 -- The 'linkables' are the ones to *keep*
859 unload dflags linkables
860 = block $ do -- block, so we're safe from Ctrl-C in here
862 -- Initialise the linker (if it's not been done already)
865 pls <- readIORef v_PersistentLinkerState
866 new_pls <- unload_wkr dflags linkables pls
867 writeIORef v_PersistentLinkerState new_pls
869 debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
870 debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
873 unload_wkr :: DynFlags
874 -> [Linkable] -- stable linkables
875 -> PersistentLinkerState
876 -> IO PersistentLinkerState
877 -- Does the core unload business
878 -- (the wrapper blocks exceptions and deals with the PLS get and put)
880 unload_wkr dflags linkables pls
881 = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
883 objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
884 bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
886 let bcos_retained = map linkableModule bcos_loaded'
887 itbl_env' = filterNameMap bcos_retained (itbl_env pls)
888 closure_env' = filterNameMap bcos_retained (closure_env pls)
889 new_pls = pls { itbl_env = itbl_env',
890 closure_env = closure_env',
891 bcos_loaded = bcos_loaded',
892 objs_loaded = objs_loaded' }
896 maybeUnload :: [Linkable] -> Linkable -> IO Bool
897 maybeUnload keep_linkables lnk
898 | linkableInSet lnk linkables = return True
900 = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
901 -- The components of a BCO linkable may contain
902 -- dot-o files. Which is very confusing.
904 -- But the BCO parts can be unlinked just by
905 -- letting go of them (plus of course depopulating
906 -- the symbol table which is done in the main body)
911 %************************************************************************
915 %************************************************************************
920 = Object FilePath -- Full path name of a .o file, including trailing .o
921 -- For dynamic objects only, try to find the object
922 -- file in all the directories specified in
923 -- v_Library_paths before giving up.
925 | DLL String -- "Unadorned" name of a .DLL/.so
926 -- e.g. On unix "qt" denotes "libqt.so"
927 -- On WinDoze "burble" denotes "burble.DLL"
928 -- loadDLL is platform-specific and adds the lib/.so/.DLL
929 -- suffixes platform-dependently
931 | DLLPath FilePath -- Absolute or relative pathname to a dynamic library
932 -- (ends with .dll or .so).
934 | Framework String -- Only used for darwin, but does no harm
936 -- If this package is already part of the GHCi binary, we'll already
937 -- have the right DLLs for this package loaded, so don't try to
940 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
941 -- as far as the loader is concerned, but it does initialise the list
942 -- of DLL handles that rts/Linker.c maintains, and that in turn is
943 -- used by lookupSymbol. So we must call addDLL for each library
944 -- just to get the DLL handle into the list.
946 # if defined(mingw32_TARGET_OS) || defined(darwin_TARGET_OS)
949 = [ "base", "haskell98", "template-haskell", "readline" ]
952 showLS (Object nm) = "(static) " ++ nm
953 showLS (DLL nm) = "(dynamic) " ++ nm
954 showLS (DLLPath nm) = "(dynamic) " ++ nm
955 showLS (Framework nm) = "(framework) " ++ nm
957 linkPackages :: DynFlags -> [PackageId] -> IO ()
958 -- Link exactly the specified packages, and their dependents
959 -- (unless of course they are already linked)
960 -- The dependents are linked automatically, and it doesn't matter
961 -- what order you specify the input packages.
963 -- NOTE: in fact, since each module tracks all the packages it depends on,
964 -- we don't really need to use the package-config dependencies.
965 -- However we do need the package-config stuff (to find aux libs etc),
966 -- and following them lets us load libraries in the right order, which
967 -- perhaps makes the error message a bit more localised if we get a link
968 -- failure. So the dependency walking code is still here.
970 linkPackages dflags new_pkgs
971 = do { pls <- readIORef v_PersistentLinkerState
972 ; let pkg_map = pkgIdMap (pkgState dflags)
974 ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
976 ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
979 link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
980 link pkg_map pkgs new_pkgs
981 = foldM (link_one pkg_map) pkgs new_pkgs
983 link_one pkg_map pkgs new_pkg
984 | new_pkg `elem` pkgs -- Already linked
987 | Just pkg_cfg <- lookupPackage pkg_map new_pkg
988 = do { -- Link dependents first
989 pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg))
990 -- Now link the package itself
991 ; linkPackage dflags pkg_cfg
992 ; return (new_pkg : pkgs') }
995 = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
998 linkPackage :: DynFlags -> PackageConfig -> IO ()
999 linkPackage dflags pkg
1001 let dirs = Packages.libraryDirs pkg
1003 let libs = Packages.hsLibraries pkg
1004 -- Because of slight differences between the GHC dynamic linker and
1005 -- the native system linker some packages have to link with a
1006 -- different list of libraries when using GHCi. Examples include: libs
1007 -- that are actually gnu ld scripts, and the possability that the .a
1008 -- libs do not exactly match the .so/.dll equivalents. So if the
1009 -- package file provides an "extra-ghci-libraries" field then we use
1010 -- that instead of the "extra-libraries" field.
1011 ++ (if null (Packages.extraGHCiLibraries pkg)
1012 then Packages.extraLibraries pkg
1013 else Packages.extraGHCiLibraries pkg)
1014 ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]
1015 classifieds <- mapM (locateOneObj dirs) libs
1017 -- Complication: all the .so's must be loaded before any of the .o's.
1018 let dlls = [ dll | DLL dll <- classifieds ]
1019 objs = [ obj | Object obj <- classifieds ]
1021 maybePutStr dflags ("Loading package " ++ showPackageId (package pkg) ++ " ... ")
1023 -- See comments with partOfGHCi
1024 when (pkgName (package pkg) `notElem` partOfGHCi) $ do
1026 -- When a library A needs symbols from a library B, the order in
1027 -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the
1028 -- way ld expects it for static linking. Dynamic linking is a
1029 -- different story: When A has no dependency information for B,
1030 -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail
1031 -- when B has not been loaded before. In a nutshell: Reverse the
1032 -- order of DLLs for dynamic linking.
1033 -- This fixes a problem with the HOpenGL package (see "Compiling
1034 -- HOpenGL under recent versions of GHC" on the HOpenGL list).
1035 mapM_ (load_dyn dirs) (reverse dlls)
1037 -- After loading all the DLLs, we can load the static objects.
1038 -- Ordering isn't important here, because we do one final link
1039 -- step to resolve everything.
1042 maybePutStr dflags "linking ... "
1044 if succeeded ok then maybePutStrLn dflags "done."
1045 else throwDyn (InstallationError ("unable to load package `" ++ showPackageId (package pkg) ++ "'"))
1047 load_dyn dirs dll = do r <- loadDynamic dirs dll
1049 Nothing -> return ()
1050 Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: "
1051 ++ dll ++ " (" ++ err ++ ")" ))
1052 #ifndef darwin_TARGET_OS
1053 loadFrameworks pkg = return ()
1055 loadFrameworks pkg = mapM_ load frameworks
1057 fw_dirs = Packages.frameworkDirs pkg
1058 frameworks = Packages.frameworks pkg
1060 load fw = do r <- loadFramework fw_dirs fw
1062 Nothing -> return ()
1063 Just err -> throwDyn (CmdLineError ("can't load framework: "
1064 ++ fw ++ " (" ++ err ++ ")" ))
1067 -- Try to find an object file for a given library in the given paths.
1068 -- If it isn't present, we assume it's a dynamic library.
1070 -- When the GHC package was not compiled as dynamic library (=__PIC__ not set),
1071 -- we search for .o libraries first.
1072 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1073 locateOneObj dirs lib
1074 = do { mb_obj_path <- findFile mk_obj_path dirs
1075 ; case mb_obj_path of
1076 Just obj_path -> return (Object obj_path)
1078 do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1079 ; case mb_lib_path of
1080 Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
1081 Nothing -> return (DLL lib) }} -- We assume
1083 mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o")
1084 mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "-ghc" ++ cProjectVersion)
1086 -- When the GHC package was compiled as dynamic library (=__PIC__ set),
1087 -- we search for .so libraries first.
1088 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1089 locateOneObj dirs lib
1090 = do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1091 ; case mb_lib_path of
1092 Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
1094 do { mb_obj_path <- findFile mk_obj_path dirs
1095 ; case mb_obj_path of
1096 Just obj_path -> return (Object obj_path)
1097 Nothing -> return (DLL lib) }} -- We assume
1099 mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o")
1100 mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "-ghc" ++ cProjectVersion)
1103 -- ----------------------------------------------------------------------------
1104 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1106 -- return Nothing == success, else Just error message from dlopen
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 `joinFileName` mkSOName rootname
1117 #if defined(darwin_TARGET_OS)
1118 mkSOName root = ("lib" ++ root) `joinFileExt` "dylib"
1119 #elif defined(mingw32_TARGET_OS)
1120 -- Win32 DLLs have no .dll extension here, because addDLL tries
1121 -- both foo.dll and foo.drv
1122 mkSOName root = root
1124 mkSOName root = ("lib" ++ root) `joinFileExt` "so"
1127 -- Darwin / MacOS X only: load a framework
1128 -- a framework is a dynamic library packaged inside a directory of the same
1129 -- name. They are searched for in different paths than normal libraries.
1130 #ifdef darwin_TARGET_OS
1131 loadFramework extraPaths rootname
1132 = do { mb_fwk <- findFile mk_fwk (extraPaths ++ defaultFrameworkPaths)
1134 Just fwk_path -> loadDLL fwk_path
1135 Nothing -> return (Just "not found") }
1136 -- Tried all our known library paths, but dlopen()
1137 -- has no built-in paths for frameworks: give up
1139 mk_fwk dir = dir `joinFileName` (rootname ++ ".framework/" ++ rootname)
1140 -- sorry for the hardcoded paths, I hope they won't change anytime soon:
1141 defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1145 %************************************************************************
1149 %************************************************************************
1152 findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path
1153 -> [FilePath] -- Directories to look in
1154 -> IO (Maybe FilePath) -- The first file path to match
1155 findFile mk_file_path []
1157 findFile mk_file_path (dir:dirs)
1158 = do { let file_path = mk_file_path dir
1159 ; b <- doesFileExist file_path
1161 return (Just file_path)
1163 findFile mk_file_path dirs }
1167 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1168 | otherwise = return ()
1170 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1171 | otherwise = return ()