Use the right set of linkables in unload_wkr
[ghc.git] / compiler / ghci / Linker.lhs
1 %
2 % (c) The University of Glasgow 2005-2006
3 %
4
5 -- --------------------------------------
6 --      The dynamic linker for GHCi      
7 -- --------------------------------------
8
9 This module deals with the top-level issues of dynamic linking,
10 calling the object-code linker and the byte-code linker where
11 necessary.
12
13
14 \begin{code}
15 {-# OPTIONS -optc-DNON_POSIX_SOURCE -#include "Linker.h" #-}
16
17 {-# OPTIONS -w #-}
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
22 -- for details
23
24 module Linker ( HValue, getHValue, showLinkerState,
25                 linkExpr, unload, withExtendedLinkEnv,
26                 extendLinkEnv, deleteFromLinkEnv,
27                 extendLoadedPkgs, 
28                 linkPackages,initDynLinker,
29                 dataConInfoPtrToName
30         ) where
31
32 #include "HsVersions.h"
33
34 import LoadIface
35 import ObjLink
36 import ByteCodeLink
37 import ByteCodeItbls
38 import ByteCodeAsm
39 import CgInfoTbls
40 import SMRep
41 import IfaceEnv
42 import TcRnMonad
43 import Packages
44 import DriverPhases
45 import Finder
46 import HscTypes
47 import Name
48 import NameEnv
49 import NameSet
50 import qualified OccName
51 import LazyUniqFM
52 import Module
53 import ListSetOps
54 import DynFlags
55 import BasicTypes
56 import Outputable
57 import PackageConfig
58 import Panic
59 import Util
60 import StaticFlags
61 import ErrUtils
62 import DriverPhases
63 import SrcLoc
64 import qualified Maybes
65 import UniqSet
66 import Constants
67 import FastString
68 import Config           ( cProjectVersion )
69
70 -- Standard libraries
71 import Control.Monad
72
73 import Data.Char
74 import Data.IORef
75 import Data.List
76 import Foreign
77
78 import System.FilePath
79 import System.IO
80 import System.Directory
81
82 import Control.Exception
83 import Data.Maybe
84 \end{code}
85
86
87 %************************************************************************
88 %*                                                                      *
89                         The Linker's state
90 %*                                                                      *
91 %************************************************************************
92
93 The persistent linker state *must* match the actual state of the 
94 C dynamic linker at all times, so we keep it in a private global variable.
95
96
97 The PersistentLinkerState maps Names to actual closures (for
98 interpreted code only), for use during linking.
99
100 \begin{code}
101 GLOBAL_VAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState)
102 GLOBAL_VAR(v_InitLinkerDone, False, Bool)       -- Set True when dynamic linker is initialised
103
104 data PersistentLinkerState
105    = PersistentLinkerState {
106
107         -- Current global mapping from Names to their true values
108         closure_env :: ClosureEnv,
109
110         -- The current global mapping from RdrNames of DataCons to
111         -- info table addresses.
112         -- When a new Unlinked is linked into the running image, or an existing
113         -- module in the image is replaced, the itbl_env must be updated
114         -- appropriately.
115         itbl_env    :: ItblEnv,
116
117         -- The currently loaded interpreted modules (home package)
118         bcos_loaded :: [Linkable],
119
120         -- And the currently-loaded compiled modules (home package)
121         objs_loaded :: [Linkable],
122
123         -- The currently-loaded packages; always object code
124         -- Held, as usual, in dependency order; though I am not sure if
125         -- that is really important
126         pkgs_loaded :: [PackageId]
127      }
128
129 emptyPLS :: DynFlags -> PersistentLinkerState
130 emptyPLS dflags = PersistentLinkerState { 
131                         closure_env = emptyNameEnv,
132                         itbl_env    = emptyNameEnv,
133                         pkgs_loaded = init_pkgs,
134                         bcos_loaded = [],
135                         objs_loaded = [] }
136                     
137   -- Packages that don't need loading, because the compiler 
138   -- shares them with the interpreted program.
139   --
140   -- The linker's symbol table is populated with RTS symbols using an
141   -- explicit list.  See rts/Linker.c for details.
142   where init_pkgs = [rtsPackageId]
143 \end{code}
144
145 \begin{code}
146 extendLoadedPkgs :: [PackageId] -> IO ()
147 extendLoadedPkgs pkgs
148     = modifyIORef v_PersistentLinkerState (\s -> s{pkgs_loaded = pkgs ++ pkgs_loaded s})
149
150 extendLinkEnv :: [(Name,HValue)] -> IO ()
151 -- Automatically discards shadowed bindings
152 extendLinkEnv new_bindings
153   = do  pls <- readIORef v_PersistentLinkerState
154         let new_closure_env = extendClosureEnv (closure_env pls) new_bindings
155             new_pls = pls { closure_env = new_closure_env }
156         writeIORef v_PersistentLinkerState new_pls
157
158 deleteFromLinkEnv :: [Name] -> IO ()
159 deleteFromLinkEnv to_remove
160   = do  pls <- readIORef v_PersistentLinkerState
161         let new_closure_env = delListFromNameEnv (closure_env pls) to_remove
162             new_pls = pls { closure_env = new_closure_env }
163         writeIORef v_PersistentLinkerState new_pls
164
165 -- | Given a data constructor in the heap, find its Name.
166 --   The info tables for data constructors have a field which records
167 --   the source name of the constructor as a Ptr Word8 (UTF-8 encoded
168 --   string). The format is:
169 --
170 --    Package:Module.Name
171 --
172 --   We use this string to lookup the interpreter's internal representation of the name
173 --   using the lookupOrig.    
174
175 dataConInfoPtrToName :: Ptr () -> TcM (Either String Name)
176 dataConInfoPtrToName x = do 
177    theString <- liftIO $ do
178       let ptr = castPtr x :: Ptr StgInfoTable
179       conDescAddress <- getConDescAddress ptr 
180       peekArray0 0 conDescAddress  
181    let (pkg, mod, occ) = parse theString 
182        pkgFS = mkFastStringByteList pkg
183        modFS = mkFastStringByteList mod
184        occFS = mkFastStringByteList occ
185        occName = mkOccNameFS OccName.dataName occFS
186        modName = mkModule (fsToPackageId pkgFS) (mkModuleNameFS modFS) 
187    return (Left$ showSDoc$ ppr modName <> dot <> ppr occName ) 
188     `recoverM` (Right `fmap` lookupOrig modName occName)
189
190    where
191
192    {- To find the string in the constructor's info table we need to consider 
193       the layout of info tables relative to the entry code for a closure.
194
195       An info table can be next to the entry code for the closure, or it can
196       be separate. The former (faster) is used in registerised versions of ghc, 
197       and the latter (portable) is for non-registerised versions. 
198
199       The diagrams below show where the string is to be found relative to 
200       the normal info table of the closure.
201
202       1) Code next to table:
203
204          --------------
205          |            |   <- pointer to the start of the string
206          --------------
207          |            |   <- the (start of the) info table structure
208          |            |
209          |            |
210          --------------
211          | entry code | 
212          |    ....    |
213
214          In this case the pointer to the start of the string can be found in
215          the memory location _one word before_ the first entry in the normal info 
216          table.
217
218       2) Code NOT next to table:
219
220                                  --------------
221          info table structure -> |     *------------------> --------------
222                                  |            |             | entry code |
223                                  |            |             |    ....    | 
224                                  --------------
225          ptr to start of str ->  |            |   
226                                  --------------
227
228          In this case the pointer to the start of the string can be found
229          in the memory location: info_table_ptr + info_table_size
230    -}
231
232    getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
233    getConDescAddress ptr
234     | ghciTablesNextToCode = do
235        offsetToString <- peek $ ptr `plusPtr` (- wORD_SIZE)
236        return $ (ptr `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: StgWord))
237     | otherwise =
238        peek $ intPtrToPtr $ (ptrToIntPtr ptr) + fromIntegral stdInfoTableSizeB
239
240    -- parsing names is a little bit fiddly because we have a string in the form: 
241    -- pkg:A.B.C.foo, and we want to split it into three parts: ("pkg", "A.B.C", "foo").
242    -- Thus we split at the leftmost colon and the rightmost occurrence of the dot.
243    -- It would be easier if the string was in the form pkg:A.B.C:foo, but alas
244    -- this is not the conventional way of writing Haskell names. We stick with
245    -- convention, even though it makes the parsing code more troublesome.
246    -- Warning: this code assumes that the string is well formed.
247    parse :: [Word8] -> ([Word8], [Word8], [Word8])
248    parse input 
249       = ASSERT (all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
250       where
251       dot = fromIntegral (ord '.')
252       (pkg, rest1) = break (== fromIntegral (ord ':')) input 
253       (mod, occ) 
254          = (concat $ intersperse [dot] $ reverse modWords, occWord)
255          where
256          (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
257       parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
258       parseModOcc acc str
259          = case break (== dot) str of
260               (top, []) -> (acc, top)
261               (top, _:bot) -> parseModOcc (top : acc) bot
262        
263
264 getHValue :: HscEnv -> Name -> IO HValue
265 getHValue hsc_env name = do
266    when (isExternalName name) $ do
267         ok <- linkDependencies hsc_env noSrcSpan [nameModule name]
268         when (failed ok) $ throwDyn (ProgramError "")
269    pls <- readIORef v_PersistentLinkerState
270    lookupName (closure_env pls) name
271         
272 linkDependencies :: HscEnv -> SrcSpan -> [Module] -> IO SuccessFlag
273 linkDependencies hsc_env span needed_mods = do
274    let hpt = hsc_HPT hsc_env
275        dflags = hsc_dflags hsc_env
276         -- The interpreter and dynamic linker can only handle object code built
277         -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.
278         -- So here we check the build tag: if we're building a non-standard way
279         -- then we need to find & link object files built the "normal" way.
280    maybe_normal_osuf <- checkNonStdWay dflags span
281
282         -- Find what packages and linkables are required
283    eps <- readIORef (hsc_EPS hsc_env)
284    (lnks, pkgs) <- getLinkDeps hsc_env hpt (eps_PIT eps) 
285                                 maybe_normal_osuf span needed_mods
286
287         -- Link the packages and modules required
288    linkPackages dflags pkgs
289    linkModules dflags lnks
290
291
292 -- | Temporarily extend the linker state.
293
294 withExtendedLinkEnv :: [(Name,HValue)] -> IO a -> IO a
295 withExtendedLinkEnv new_env action
296     = bracket_ set_new_env
297                reset_old_env
298                action
299     where set_new_env = do 
300             pls <- readIORef v_PersistentLinkerState
301             let new_closure_env = extendClosureEnv (closure_env pls) new_env
302                 new_pls = pls { closure_env = new_closure_env }
303             writeIORef v_PersistentLinkerState new_pls
304             return ()
305
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
310         -- added earlier.
311           reset_old_env = do
312             modifyIORef v_PersistentLinkerState $ \pls ->
313                 let cur = closure_env pls
314                     new = delListFromNameEnv cur (map fst new_env)
315                 in
316                 pls{ closure_env = new }
317
318 -- filterNameMap removes from the environment all entries except 
319 --      those for a given set of modules;
320 -- Note that this removes all *local* (i.e. non-isExternal) names too 
321 --      (these are the temporary bindings from the command line).
322 -- Used to filter both the ClosureEnv and ItblEnv
323
324 filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a)
325 filterNameMap mods env 
326    = filterNameEnv keep_elt env
327    where
328      keep_elt (n,_) = isExternalName n 
329                       && (nameModule n `elem` mods)
330 \end{code}
331
332
333 \begin{code}
334 showLinkerState :: IO ()
335 -- Display the persistent linker state
336 showLinkerState
337   = do pls <- readIORef v_PersistentLinkerState
338        printDump (vcat [text "----- Linker state -----",
339                         text "Pkgs:" <+> ppr (pkgs_loaded pls),
340                         text "Objs:" <+> ppr (objs_loaded pls),
341                         text "BCOs:" <+> ppr (bcos_loaded pls)])
342 \end{code}
343                         
344         
345
346
347 %************************************************************************
348 %*                                                                      *
349 \subsection{Initialisation}
350 %*                                                                      *
351 %************************************************************************
352
353 We initialise the dynamic linker by
354
355 a) calling the C initialisation procedure
356
357 b) Loading any packages specified on the command line,
358
359 c) Loading any packages specified on the command line,
360    now held in the -l options in v_Opt_l
361
362 d) Loading any .o/.dll files specified on the command line,
363    now held in v_Ld_inputs
364
365 e) Loading any MacOS frameworks
366
367 \begin{code}
368 initDynLinker :: DynFlags -> IO ()
369 -- This function is idempotent; if called more than once, it does nothing
370 -- This is useful in Template Haskell, where we call it before trying to link
371 initDynLinker dflags
372   = do  { done <- readIORef v_InitLinkerDone
373         ; if done then return () 
374                   else do { writeIORef v_InitLinkerDone True
375                           ; reallyInitDynLinker dflags }
376         }
377
378 reallyInitDynLinker dflags
379   = do  {  -- Initialise the linker state
380         ; writeIORef v_PersistentLinkerState (emptyPLS dflags)
381
382                 -- (a) initialise the C dynamic linker
383         ; initObjLinker 
384
385                 -- (b) Load packages from the command-line
386         ; linkPackages dflags (preloadPackages (pkgState dflags))
387
388                 -- (c) Link libraries from the command-line
389         ; let optl = getOpts dflags opt_l
390         ; let minus_ls = [ lib | '-':'l':lib <- optl ]
391
392                 -- (d) Link .o files from the command-line
393         ; let lib_paths = libraryPaths dflags
394         ; cmdline_ld_inputs <- readIORef v_Ld_inputs
395
396         ; classified_ld_inputs <- mapM classifyLdInput cmdline_ld_inputs
397
398                 -- (e) Link any MacOS frameworks
399         ; let framework_paths
400                | isDarwinTarget = frameworkPaths dflags
401                | otherwise      = []
402         ; let frameworks
403                | isDarwinTarget = cmdlineFrameworks dflags
404                | otherwise      = []
405                 -- Finally do (c),(d),(e)       
406         ; let cmdline_lib_specs = [ l | Just l <- classified_ld_inputs ]
407                                ++ map DLL       minus_ls 
408                                ++ map Framework frameworks
409         ; if null cmdline_lib_specs then return ()
410                                     else do
411
412         { mapM_ (preloadLib dflags lib_paths framework_paths) cmdline_lib_specs
413         ; maybePutStr dflags "final link ... "
414         ; ok <- resolveObjs
415
416         ; if succeeded ok then maybePutStrLn dflags "done"
417           else throwDyn (InstallationError "linking extra libraries/objects failed")
418         }}
419
420 classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
421 classifyLdInput f
422   | isObjectFilename f = return (Just (Object f))
423   | isDynLibFilename f = return (Just (DLLPath f))
424   | otherwise          = do
425         hPutStrLn stderr ("Warning: ignoring unrecognised input `" ++ f ++ "'")
426         return Nothing
427
428 preloadLib :: DynFlags -> [String] -> [String] -> LibrarySpec -> IO ()
429 preloadLib dflags lib_paths framework_paths lib_spec
430   = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")
431        case lib_spec of
432           Object static_ish
433              -> do b <- preload_static lib_paths static_ish
434                    maybePutStrLn dflags (if b  then "done"
435                                                 else "not found")
436          
437           DLL dll_unadorned
438              -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned
439                    case maybe_errstr of
440                       Nothing -> maybePutStrLn dflags "done"
441                       Just mm -> preloadFailed mm lib_paths lib_spec
442
443           DLLPath dll_path
444              -> do maybe_errstr <- loadDLL dll_path
445                    case maybe_errstr of
446                       Nothing -> maybePutStrLn dflags "done"
447                       Just mm -> preloadFailed mm lib_paths lib_spec
448
449           Framework framework
450            | isDarwinTarget
451              -> do maybe_errstr <- loadFramework framework_paths framework
452                    case maybe_errstr of
453                       Nothing -> maybePutStrLn dflags "done"
454                       Just mm -> preloadFailed mm framework_paths lib_spec
455            | otherwise -> panic "preloadLib Framework"
456
457   where
458     preloadFailed :: String -> [String] -> LibrarySpec -> IO ()
459     preloadFailed sys_errmsg paths spec
460        = do maybePutStr dflags
461                ("failed.\nDynamic linker error message was:\n   " 
462                     ++ sys_errmsg  ++ "\nWhilst trying to load:  " 
463                     ++ showLS spec ++ "\nDirectories to search are:\n"
464                     ++ unlines (map ("   "++) paths) )
465             give_up
466     
467     -- Not interested in the paths in the static case.
468     preload_static paths name
469        = do b <- doesFileExist name
470             if not b then return False
471                      else loadObj name >> return True
472     
473     give_up = throwDyn $ 
474               CmdLineError "user specified .o/.so/.DLL could not be loaded."
475 \end{code}
476
477
478 %************************************************************************
479 %*                                                                      *
480                 Link a byte-code expression
481 %*                                                                      *
482 %************************************************************************
483
484 \begin{code}
485 linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO HValue
486
487 -- Link a single expression, *including* first linking packages and 
488 -- modules that this expression depends on.
489 --
490 -- Raises an IO exception if it can't find a compiled version of the
491 -- dependents to link.
492 --
493 -- Note: This function side-effects the linker state (Pepe)
494
495 linkExpr hsc_env span root_ul_bco
496   = do {  
497         -- Initialise the linker (if it's not been done already)
498      let dflags = hsc_dflags hsc_env
499    ; initDynLinker dflags
500
501         -- Link the packages and modules required
502    ; ok <- linkDependencies hsc_env span needed_mods
503    ; if failed ok then
504         throwDyn (ProgramError "")
505      else do {
506
507         -- Link the expression itself
508      pls <- readIORef v_PersistentLinkerState
509    ; let ie = itbl_env pls
510          ce = closure_env pls
511
512         -- Link the necessary packages and linkables
513    ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce [root_ul_bco]
514    ; return root_hval
515    }}
516    where
517      free_names = nameSetToList (bcoFreeNames root_ul_bco)
518
519      needed_mods :: [Module]
520      needed_mods = [ nameModule n | n <- free_names, 
521                                     isExternalName n,           -- Names from other modules
522                                     not (isWiredInName n)       -- Exclude wired-in names
523                    ]                                            -- (see note below)
524         -- Exclude wired-in names because we may not have read
525         -- their interface files, so getLinkDeps will fail
526         -- All wired-in names are in the base package, which we link
527         -- by default, so we can safely ignore them here.
528  
529 dieWith span msg = throwDyn (ProgramError (showSDoc (mkLocMessage span msg)))
530
531
532 checkNonStdWay :: DynFlags -> SrcSpan -> IO (Maybe String)
533 checkNonStdWay dflags srcspan = do
534   tag <- readIORef v_Build_tag
535   if null tag then return Nothing else do
536   let default_osuf = phaseInputExt StopLn
537   if objectSuf dflags == default_osuf
538         then failNonStd srcspan
539         else return (Just default_osuf)
540
541 failNonStd srcspan = dieWith srcspan $
542   ptext (sLit "Dynamic linking required, but this is a non-standard build (eg. prof).") $$
543   ptext (sLit "You need to build the program twice: once the normal way, and then") $$
544   ptext (sLit "in the desired way using -osuf to set the object file suffix.")
545   
546
547 getLinkDeps :: HscEnv -> HomePackageTable -> PackageIfaceTable
548             -> Maybe String                     -- the "normal" object suffix
549             -> SrcSpan                          -- for error messages
550             -> [Module]                         -- If you need these
551             -> IO ([Linkable], [PackageId])     -- ... then link these first
552 -- Fails with an IO exception if it can't find enough files
553
554 getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods
555 -- Find all the packages and linkables that a set of modules depends on
556  = do { pls <- readIORef v_PersistentLinkerState ;
557         -- 1.  Find the dependent home-pkg-modules/packages from each iface
558         (mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet;
559
560         let {
561         -- 2.  Exclude ones already linked
562         --      Main reason: avoid findModule calls in get_linkable
563             mods_needed = mods_s `minusList` linked_mods     ;
564             pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;
565
566             linked_mods = map (moduleName.linkableModule) 
567                                 (objs_loaded pls ++ bcos_loaded pls)
568         } ;
569         
570 --        putStrLn (showSDoc (ppr mods_s)) ;
571         -- 3.  For each dependent module, find its linkable
572         --     This will either be in the HPT or (in the case of one-shot
573         --     compilation) we may need to use maybe_getFileLinkable
574         lnks_needed <- mapM (get_linkable maybe_normal_osuf) mods_needed ;
575
576         return (lnks_needed, pkgs_needed) }
577   where
578     dflags = hsc_dflags hsc_env
579     this_pkg = thisPackage dflags
580
581         -- The ModIface contains the transitive closure of the module dependencies
582         -- within the current package, *except* for boot modules: if we encounter
583         -- a boot module, we have to find its real interface and discover the
584         -- dependencies of that.  Hence we need to traverse the dependency
585         -- tree recursively.  See bug #936, testcase ghci/prog007.
586     follow_deps :: [Module]             -- modules to follow
587                 -> UniqSet ModuleName         -- accum. module dependencies
588                 -> UniqSet PackageId          -- accum. package dependencies
589                 -> IO ([ModuleName], [PackageId]) -- result
590     follow_deps []     acc_mods acc_pkgs
591         = return (uniqSetToList acc_mods, uniqSetToList acc_pkgs)
592     follow_deps (mod:mods) acc_mods acc_pkgs
593         = do
594           mb_iface <- initIfaceCheck hsc_env $
595                         loadInterface msg mod (ImportByUser False)
596           iface <- case mb_iface of
597                     Maybes.Failed err      -> ghcError (ProgramError (showSDoc err))
598                     Maybes.Succeeded iface -> return iface
599
600           when (mi_boot iface) $ link_boot_mod_error mod
601
602           let
603             pkg = modulePackageId mod
604             deps  = mi_deps iface
605
606             pkg_deps = dep_pkgs deps
607             (boot_deps, mod_deps) = partitionWith is_boot (dep_mods deps)
608                     where is_boot (m,True)  = Left m
609                           is_boot (m,False) = Right m
610
611             boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps
612             acc_mods'  = addListToUniqSet acc_mods (moduleName mod : mod_deps)
613             acc_pkgs'  = addListToUniqSet acc_pkgs pkg_deps
614           --
615           if pkg /= this_pkg
616              then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg)
617              else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)
618                               acc_mods' acc_pkgs'
619         where
620             msg = text "need to link module" <+> ppr mod <+>
621                   text "due to use of Template Haskell"
622
623
624     link_boot_mod_error mod = 
625         throwDyn (ProgramError (showSDoc (
626             text "module" <+> ppr mod <+> 
627             text "cannot be linked; it is only available as a boot module")))
628
629     no_obj mod = dieWith span $
630                      ptext (sLit "cannot find object file for module ") <> 
631                         quotes (ppr mod) $$
632                      while_linking_expr
633                 
634     while_linking_expr = ptext (sLit "while linking an interpreted expression")
635
636         -- This one is a build-system bug
637
638     get_linkable maybe_normal_osuf mod_name     -- A home-package module
639         | Just mod_info <- lookupUFM hpt mod_name 
640         = ASSERT(isJust (hm_linkable mod_info))
641           adjust_linkable (fromJust (hm_linkable mod_info))
642         | otherwise     
643         = do    -- It's not in the HPT because we are in one shot mode, 
644                 -- so use the Finder to get a ModLocation...
645              mb_stuff <- findHomeModule hsc_env mod_name
646              case mb_stuff of
647                   Found loc mod -> found loc mod
648                   _ -> no_obj mod_name
649         where
650             found loc mod = do {
651                 -- ...and then find the linkable for it
652                mb_lnk <- findObjectLinkableMaybe mod loc ;
653                case mb_lnk of {
654                   Nothing -> no_obj mod ;
655                   Just lnk -> adjust_linkable lnk
656               }}
657
658             adjust_linkable lnk
659                 | Just osuf <- maybe_normal_osuf = do
660                         new_uls <- mapM (adjust_ul osuf) (linkableUnlinked lnk)
661                         return lnk{ linkableUnlinked=new_uls }
662                 | otherwise =
663                         return lnk
664
665             adjust_ul osuf (DotO file) = do
666                 let new_file = replaceExtension file osuf
667                 ok <- doesFileExist new_file
668                 if (not ok)
669                    then dieWith span $
670                           ptext (sLit "cannot find normal object file ")
671                                 <> quotes (text new_file) $$ while_linking_expr
672                    else return (DotO new_file)
673 \end{code}
674
675
676 %************************************************************************
677 %*                                                                      *
678                 Link some linkables
679         The linkables may consist of a mixture of 
680         byte-code modules and object modules
681 %*                                                                      *
682 %************************************************************************
683
684 \begin{code}
685 linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag
686 linkModules dflags linkables
687   = block $ do  -- don't want to be interrupted by ^C in here
688         
689         let (objs, bcos) = partition isObjectLinkable 
690                               (concatMap partitionLinkable linkables)
691
692                 -- Load objects first; they can't depend on BCOs
693         ok_flag <- dynLinkObjs dflags objs
694
695         if failed ok_flag then 
696                 return Failed
697           else do
698                 dynLinkBCOs bcos
699                 return Succeeded
700                 
701
702 -- HACK to support f-x-dynamic in the interpreter; no other purpose
703 partitionLinkable :: Linkable -> [Linkable]
704 partitionLinkable li
705    = let li_uls = linkableUnlinked li
706          li_uls_obj = filter isObject li_uls
707          li_uls_bco = filter isInterpretable li_uls
708      in 
709          case (li_uls_obj, li_uls_bco) of
710             (objs@(_:_), bcos@(_:_)) 
711                -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}]
712             other
713                -> [li]
714
715 findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable
716 findModuleLinkable_maybe lis mod
717    = case [LM time nm us | LM time nm us <- lis, nm == mod] of
718         []   -> Nothing
719         [li] -> Just li
720         many -> pprPanic "findModuleLinkable" (ppr mod)
721
722 linkableInSet :: Linkable -> [Linkable] -> Bool
723 linkableInSet l objs_loaded =
724   case findModuleLinkable_maybe objs_loaded (linkableModule l) of
725         Nothing -> False
726         Just m  -> linkableTime l == linkableTime m
727 \end{code}
728
729
730 %************************************************************************
731 %*                                                                      *
732 \subsection{The object-code linker}
733 %*                                                                      *
734 %************************************************************************
735
736 \begin{code}
737 dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag
738         -- Side-effects the PersistentLinkerState
739
740 dynLinkObjs dflags objs
741   = do  pls <- readIORef v_PersistentLinkerState
742
743         -- Load the object files and link them
744         let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs
745             pls1                     = pls { objs_loaded = objs_loaded' }
746             unlinkeds                = concatMap linkableUnlinked new_objs
747
748         mapM loadObj (map nameOfObject unlinkeds)
749
750         -- Link the all together
751         ok <- resolveObjs
752
753         -- If resolving failed, unload all our 
754         -- object modules and carry on
755         if succeeded ok then do
756                 writeIORef v_PersistentLinkerState pls1
757                 return Succeeded
758           else do
759                 pls2 <- unload_wkr dflags [] pls1
760                 writeIORef v_PersistentLinkerState pls2
761                 return Failed
762
763
764 rmDupLinkables :: [Linkable]    -- Already loaded
765                -> [Linkable]    -- New linkables
766                -> ([Linkable],  -- New loaded set (including new ones)
767                    [Linkable])  -- New linkables (excluding dups)
768 rmDupLinkables already ls
769   = go already [] ls
770   where
771     go already extras [] = (already, extras)
772     go already extras (l:ls)
773         | linkableInSet l already = go already     extras     ls
774         | otherwise               = go (l:already) (l:extras) ls
775 \end{code}
776
777 %************************************************************************
778 %*                                                                      *
779 \subsection{The byte-code linker}
780 %*                                                                      *
781 %************************************************************************
782
783 \begin{code}
784 dynLinkBCOs :: [Linkable] -> IO ()
785         -- Side-effects the persistent linker state
786 dynLinkBCOs bcos
787   = do  pls <- readIORef v_PersistentLinkerState
788
789         let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
790             pls1                     = pls { bcos_loaded = bcos_loaded' }
791             unlinkeds :: [Unlinked]
792             unlinkeds                = concatMap linkableUnlinked new_bcos
793
794             cbcs :: [CompiledByteCode]
795             cbcs      = map byteCodeOfObject unlinkeds
796                       
797                       
798             ul_bcos    = [b | ByteCode bs _  <- cbcs, b <- bs]
799             ies        = [ie | ByteCode _ ie <- cbcs]
800             gce       = closure_env pls
801             final_ie  = foldr plusNameEnv (itbl_env pls) ies
802
803         (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos
804                 -- What happens to these linked_bcos?
805
806         let pls2 = pls1 { closure_env = final_gce,
807                           itbl_env    = final_ie }
808
809         writeIORef v_PersistentLinkerState pls2
810         return ()
811
812 -- Link a bunch of BCOs and return them + updated closure env.
813 linkSomeBCOs :: Bool    -- False <=> add _all_ BCOs to returned closure env
814                         -- True  <=> add only toplevel BCOs to closure env
815              -> ItblEnv 
816              -> ClosureEnv 
817              -> [UnlinkedBCO]
818              -> IO (ClosureEnv, [HValue])
819                         -- The returned HValues are associated 1-1 with
820                         -- the incoming unlinked BCOs.  Each gives the
821                         -- value of the corresponding unlinked BCO
822                                         
823 linkSomeBCOs toplevs_only ie ce_in ul_bcos
824    = do let nms = map unlinkedBCOName ul_bcos
825         hvals <- fixIO 
826                     ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs)
827                                in  mapM (linkBCO ie ce_out) ul_bcos )
828         let ce_all_additions = zip nms hvals
829             ce_top_additions = filter (isExternalName.fst) ce_all_additions
830             ce_additions     = if toplevs_only then ce_top_additions 
831                                                else ce_all_additions
832             ce_out = -- make sure we're not inserting duplicate names into the 
833                      -- closure environment, which leads to trouble.
834                      ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions))
835                      extendClosureEnv ce_in ce_additions
836         return (ce_out, hvals)
837
838 \end{code}
839
840
841 %************************************************************************
842 %*                                                                      *
843                 Unload some object modules
844 %*                                                                      *
845 %************************************************************************
846
847 \begin{code}
848 -- ---------------------------------------------------------------------------
849 -- Unloading old objects ready for a new compilation sweep.
850 --
851 -- The compilation manager provides us with a list of linkables that it
852 -- considers "stable", i.e. won't be recompiled this time around.  For
853 -- each of the modules current linked in memory,
854 --
855 --      * if the linkable is stable (and it's the same one - the
856 --        user may have recompiled the module on the side), we keep it,
857 --
858 --      * otherwise, we unload it.
859 --
860 --      * we also implicitly unload all temporary bindings at this point.
861
862 unload :: DynFlags -> [Linkable] -> IO ()
863 -- The 'linkables' are the ones to *keep*
864
865 unload dflags linkables
866   = block $ do -- block, so we're safe from Ctrl-C in here
867   
868         -- Initialise the linker (if it's not been done already)
869         initDynLinker dflags
870
871         pls     <- readIORef v_PersistentLinkerState
872         new_pls <- unload_wkr dflags linkables pls
873         writeIORef v_PersistentLinkerState new_pls
874
875         debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
876         debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
877         return ()
878
879 unload_wkr :: DynFlags
880            -> [Linkable]                -- stable linkables
881            -> PersistentLinkerState
882            -> IO PersistentLinkerState
883 -- Does the core unload business
884 -- (the wrapper blocks exceptions and deals with the PLS get and put)
885
886 unload_wkr dflags linkables pls
887   = do  let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables
888
889         objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls)
890         bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls)
891
892         let bcos_retained = map linkableModule bcos_loaded'
893             itbl_env'     = filterNameMap bcos_retained (itbl_env pls)
894             closure_env'  = filterNameMap bcos_retained (closure_env pls)
895             new_pls = pls { itbl_env = itbl_env',
896                             closure_env = closure_env',
897                             bcos_loaded = bcos_loaded',
898                             objs_loaded = objs_loaded' }
899
900         return new_pls
901   where
902     maybeUnload :: [Linkable] -> Linkable -> IO Bool
903     maybeUnload keep_linkables lnk
904       | linkableInSet lnk keep_linkables = return True
905       | otherwise                   
906       = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk]
907                 -- The components of a BCO linkable may contain
908                 -- dot-o files.  Which is very confusing.
909                 --
910                 -- But the BCO parts can be unlinked just by 
911                 -- letting go of them (plus of course depopulating
912                 -- the symbol table which is done in the main body)
913            return False
914 \end{code}
915
916
917 %************************************************************************
918 %*                                                                      *
919                 Loading packages
920 %*                                                                      *
921 %************************************************************************
922
923
924 \begin{code}
925 data LibrarySpec 
926    = Object FilePath    -- Full path name of a .o file, including trailing .o
927                         -- For dynamic objects only, try to find the object 
928                         -- file in all the directories specified in 
929                         -- v_Library_paths before giving up.
930
931    | DLL String         -- "Unadorned" name of a .DLL/.so
932                         --  e.g.    On unix     "qt"  denotes "libqt.so"
933                         --          On WinDoze  "burble"  denotes "burble.DLL"
934                         --  loadDLL is platform-specific and adds the lib/.so/.DLL
935                         --  suffixes platform-dependently
936
937    | DLLPath FilePath   -- Absolute or relative pathname to a dynamic library
938                         -- (ends with .dll or .so).
939
940    | Framework String   -- Only used for darwin, but does no harm
941
942 -- If this package is already part of the GHCi binary, we'll already
943 -- have the right DLLs for this package loaded, so don't try to
944 -- load them again.
945 -- 
946 -- But on Win32 we must load them 'again'; doing so is a harmless no-op
947 -- as far as the loader is concerned, but it does initialise the list
948 -- of DLL handles that rts/Linker.c maintains, and that in turn is 
949 -- used by lookupSymbol.  So we must call addDLL for each library 
950 -- just to get the DLL handle into the list.
951 partOfGHCi
952  | isWindowsTarget || isDarwinTarget = []
953  | otherwise = [ "base", "haskell98", "template-haskell", "editline" ]
954
955 showLS (Object nm)    = "(static) " ++ nm
956 showLS (DLL nm)       = "(dynamic) " ++ nm
957 showLS (DLLPath nm)   = "(dynamic) " ++ nm
958 showLS (Framework nm) = "(framework) " ++ nm
959
960 linkPackages :: DynFlags -> [PackageId] -> IO ()
961 -- Link exactly the specified packages, and their dependents
962 -- (unless of course they are already linked)
963 -- The dependents are linked automatically, and it doesn't matter
964 -- what order you specify the input packages.
965 --
966 -- NOTE: in fact, since each module tracks all the packages it depends on,
967 --       we don't really need to use the package-config dependencies.
968 -- However we do need the package-config stuff (to find aux libs etc),
969 -- and following them lets us load libraries in the right order, which 
970 -- perhaps makes the error message a bit more localised if we get a link
971 -- failure.  So the dependency walking code is still here.
972
973 linkPackages dflags new_pkgs
974    = do { pls     <- readIORef v_PersistentLinkerState
975         ; let pkg_map = pkgIdMap (pkgState dflags)
976
977         ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs
978
979         ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' })
980         }
981    where
982      link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId]
983      link pkg_map pkgs new_pkgs 
984         = foldM (link_one pkg_map) pkgs new_pkgs
985
986      link_one pkg_map pkgs new_pkg
987         | new_pkg `elem` pkgs   -- Already linked
988         = return pkgs
989
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') }
996
997         | otherwise
998         = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg))
999
1000
1001 linkPackage :: DynFlags -> PackageConfig -> IO ()
1002 linkPackage dflags pkg
1003    = do 
1004         let dirs      =  Packages.libraryDirs pkg
1005
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
1019
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 ]
1023
1024         maybePutStr dflags ("Loading package " ++ display (package pkg) ++ " ... ")
1025
1026         -- See comments with partOfGHCi
1027         when (pkgName (package pkg) `notElem` partOfGHCi) $ do
1028             loadFrameworks pkg
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)
1039         
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.
1043         mapM_ loadObj objs
1044
1045         maybePutStr dflags "linking ... "
1046         ok <- resolveObjs
1047         if succeeded ok then maybePutStrLn dflags "done."
1048               else throwDyn (InstallationError ("unable to load package `" ++ display (package pkg) ++ "'"))
1049
1050 load_dyn dirs dll = do r <- loadDynamic dirs dll
1051                        case r of
1052                          Nothing  -> return ()
1053                          Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: " 
1054                                                               ++ dll ++ " (" ++ err ++ ")" ))
1055
1056 loadFrameworks pkg
1057  | isDarwinTarget = mapM_ load frameworks
1058  | otherwise = return ()
1059   where
1060     fw_dirs    = Packages.frameworkDirs pkg
1061     frameworks = Packages.frameworks pkg
1062
1063     load fw = do  r <- loadFramework fw_dirs fw
1064                   case r of
1065                     Nothing  -> return ()
1066                     Just err -> throwDyn (CmdLineError ("can't load framework: " 
1067                                                         ++ fw ++ " (" ++ err ++ ")" ))
1068
1069 -- Try to find an object file for a given library in the given paths.
1070 -- If it isn't present, we assume it's a dynamic library.
1071 locateOneObj :: [FilePath] -> String -> IO LibrarySpec
1072 locateOneObj dirs lib
1073  | not picIsOn
1074     -- When the GHC package was not compiled as dynamic library 
1075     -- (=__PIC__ not set), we search for .o libraries first.
1076   = do  { mb_obj_path <- findFile mk_obj_path dirs 
1077         ; case mb_obj_path of
1078             Just obj_path -> return (Object obj_path)
1079             Nothing       -> 
1080                 do { mb_lib_path <- findFile mk_dyn_lib_path dirs
1081                    ; case mb_lib_path of
1082                        Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
1083                        Nothing       -> return (DLL lib) }}             -- We assume
1084  | otherwise
1085     -- When the GHC package was compiled as dynamic library (=__PIC__ set),
1086     -- we search for .so libraries first.
1087   = do  { mb_lib_path <- findFile mk_dyn_lib_path dirs
1088         ; case mb_lib_path of
1089             Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
1090             Nothing       ->
1091                 do { mb_obj_path <- findFile mk_obj_path dirs
1092                    ; case mb_obj_path of
1093                        Just obj_path -> return (Object obj_path)
1094                        Nothing       -> return (DLL lib) }}             -- We assume
1095    where
1096      mk_obj_path dir = dir </> (lib <.> "o")
1097      mk_dyn_lib_path dir = dir </> mkSOName (lib ++ "-ghc" ++ cProjectVersion)
1098
1099 -- ----------------------------------------------------------------------------
1100 -- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)
1101
1102 -- return Nothing == success, else Just error message from dlopen
1103 loadDynamic paths rootname
1104   = do  { mb_dll <- findFile mk_dll_path paths
1105         ; case mb_dll of
1106             Just dll -> loadDLL dll
1107             Nothing  -> loadDLL (mkSOName rootname) }
1108                         -- Tried all our known library paths, so let 
1109                         -- dlopen() search its own builtin paths now.
1110   where
1111     mk_dll_path dir = dir </> mkSOName rootname
1112
1113 mkSOName root
1114  | isDarwinTarget  = ("lib" ++ root) <.> "dylib"
1115  | isWindowsTarget = -- Win32 DLLs have no .dll extension here, because
1116                      -- addDLL tries both foo.dll and foo.drv
1117                      root
1118  | otherwise       = ("lib" ++ root) <.> "so"
1119
1120 -- Darwin / MacOS X only: load a framework
1121 -- a framework is a dynamic library packaged inside a directory of the same
1122 -- name. They are searched for in different paths than normal libraries.
1123 loadFramework extraPaths rootname
1124    = do { either_dir <- Control.Exception.try getHomeDirectory
1125         ; let homeFrameworkPath = case either_dir of
1126                                   Left _ -> []
1127                                   Right dir -> [dir ++ "/Library/Frameworks"]
1128               ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths
1129         ; mb_fwk <- findFile mk_fwk ps
1130         ; case mb_fwk of
1131             Just fwk_path -> loadDLL fwk_path
1132             Nothing       -> return (Just "not found") }
1133                 -- Tried all our known library paths, but dlopen()
1134                 -- has no built-in paths for frameworks: give up
1135    where
1136      mk_fwk dir = dir </> (rootname ++ ".framework/" ++ rootname)
1137         -- sorry for the hardcoded paths, I hope they won't change anytime soon:
1138      defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
1139 \end{code}
1140
1141 %************************************************************************
1142 %*                                                                      *
1143                 Helper functions
1144 %*                                                                      *
1145 %************************************************************************
1146
1147 \begin{code}
1148 findFile :: (FilePath -> FilePath)      -- Maps a directory path to a file path
1149          -> [FilePath]                  -- Directories to look in
1150          -> IO (Maybe FilePath)         -- The first file path to match
1151 findFile mk_file_path [] 
1152   = return Nothing
1153 findFile mk_file_path (dir:dirs)
1154   = do  { let file_path = mk_file_path dir
1155         ; b <- doesFileExist file_path
1156         ; if b then 
1157              return (Just file_path)
1158           else
1159              findFile mk_file_path dirs }
1160 \end{code}
1161
1162 \begin{code}
1163 maybePutStr dflags s | verbosity dflags > 0 = putStr s
1164                      | otherwise            = return ()
1165
1166 maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
1167                        | otherwise            = return ()
1168 \end{code}