Make updates to the Finder caches atomic. Well, almost.
[ghc.git] / compiler / main / Finder.lhs
1 %
2 % (c) The University of Glasgow, 2000-2006
3 %
4 \section[Finder]{Module Finder}
5
6 \begin{code}
7 module Finder (
8     flushFinderCaches,
9     FindResult(..),
10     findImportedModule,
11     findExactModule,
12     findHomeModule,
13     findExposedPackageModule,
14     mkHomeModLocation,
15     mkHomeModLocation2,
16     mkHiOnlyModLocation,
17     addHomeModuleToFinder,
18     uncacheModule,
19     mkStubPaths,
20
21     findObjectLinkableMaybe,
22     findObjectLinkable,
23
24     cannotFindModule,
25     cannotFindInterface,
26
27   ) where
28
29 import Module
30 import HscTypes
31 import Packages
32 import FastString
33 import Util
34 import PrelNames        ( gHC_PRIM )
35 import DynFlags
36 import Outputable
37 import FiniteMap
38 import LazyUniqFM
39 import Maybes           ( expectJust )
40 import Exception        ( evaluate )
41
42 import Distribution.Text
43 import Distribution.Package hiding (PackageId)
44 import Data.IORef       ( IORef, writeIORef, readIORef, atomicModifyIORef )
45 import System.Directory
46 import System.FilePath
47 import Control.Monad
48 import System.Time      ( ClockTime )
49
50
51 type FileExt = String   -- Filename extension
52 type BaseName = String  -- Basename of file
53
54 -- -----------------------------------------------------------------------------
55 -- The Finder
56
57 -- The Finder provides a thin filesystem abstraction to the rest of
58 -- the compiler.  For a given module, it can tell you where the
59 -- source, interface, and object files for that module live.
60
61 -- It does *not* know which particular package a module lives in.  Use
62 -- Packages.lookupModuleInAllPackages for that.
63
64 -- -----------------------------------------------------------------------------
65 -- The finder's cache
66
67 -- remove all the home modules from the cache; package modules are
68 -- assumed to not move around during a session.
69 flushFinderCaches :: HscEnv -> IO ()
70 flushFinderCaches hsc_env = do
71   -- Ideally the update to both caches be a single atomic operation.
72   writeIORef fc_ref emptyUFM
73   flushModLocationCache this_pkg mlc_ref
74  where
75         this_pkg = thisPackage (hsc_dflags hsc_env)
76         fc_ref = hsc_FC hsc_env
77         mlc_ref = hsc_MLC hsc_env
78
79 flushModLocationCache :: PackageId -> IORef ModLocationCache -> IO ()
80 flushModLocationCache this_pkg ref = do
81   atomicModifyIORef ref $ \fm -> (filterFM is_ext fm, ())
82   _ <- evaluate =<< readIORef ref
83   return ()
84   where is_ext mod _ | modulePackageId mod /= this_pkg = True
85                      | otherwise = False
86
87 addToFinderCache :: IORef FinderCache -> ModuleName -> FindResult -> IO ()
88 addToFinderCache ref key val =
89   atomicModifyIORef ref $ \c -> (addToUFM c key val, ())
90
91 addToModLocationCache :: IORef ModLocationCache -> Module -> ModLocation -> IO ()
92 addToModLocationCache ref key val =
93   atomicModifyIORef ref $ \c -> (addToFM c key val, ())
94
95 removeFromFinderCache :: IORef FinderCache -> ModuleName -> IO ()
96 removeFromFinderCache ref key =
97   atomicModifyIORef ref $ \c -> (delFromUFM c key, ())
98
99 removeFromModLocationCache :: IORef ModLocationCache -> Module -> IO ()
100 removeFromModLocationCache ref key =
101   atomicModifyIORef ref $ \c -> (delFromFM c key, ())
102
103 lookupFinderCache :: IORef FinderCache -> ModuleName -> IO (Maybe FindResult)
104 lookupFinderCache ref key = do 
105    c <- readIORef ref
106    return $! lookupUFM c key
107
108 lookupModLocationCache :: IORef ModLocationCache -> Module
109                        -> IO (Maybe ModLocation)
110 lookupModLocationCache ref key = do
111    c <- readIORef ref
112    return $! lookupFM c key
113
114 -- -----------------------------------------------------------------------------
115 -- The two external entry points
116
117 -- | Locate a module that was imported by the user.  We have the
118 -- module's name, and possibly a package name.  Without a package
119 -- name, this function will use the search path and the known exposed
120 -- packages to find the module, if a package is specified then only
121 -- that package is searched for the module.
122
123 findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult
124 findImportedModule hsc_env mod_name mb_pkg =
125   case mb_pkg of
126         Nothing                        -> unqual_import
127         Just pkg | pkg == fsLit "this" -> home_import -- "this" is special
128                  | otherwise           -> pkg_import
129   where
130     home_import   = findHomeModule hsc_env mod_name
131
132     pkg_import    = findExposedPackageModule hsc_env mod_name mb_pkg
133
134     unqual_import = home_import 
135                         `orIfNotFound`
136                       findExposedPackageModule hsc_env mod_name Nothing
137
138 -- | Locate a specific 'Module'.  The purpose of this function is to
139 -- create a 'ModLocation' for a given 'Module', that is to find out
140 -- where the files associated with this module live.  It is used when
141 -- reading the interface for a module mentioned by another interface, 
142 -- for example (a "system import").
143
144 findExactModule :: HscEnv -> Module -> IO FindResult
145 findExactModule hsc_env mod =
146    let dflags = hsc_dflags hsc_env in
147    if modulePackageId mod == thisPackage dflags
148         then findHomeModule hsc_env (moduleName mod)
149         else findPackageModule hsc_env mod
150
151 -- -----------------------------------------------------------------------------
152 -- Helpers
153
154 orIfNotFound :: IO FindResult -> IO FindResult -> IO FindResult
155 this `orIfNotFound` or_this = do
156   res <- this
157   case res of
158     NotFound places1 _mb_pkg1 mod_hiddens1 pkg_hiddens1 -> do
159         res2 <- or_this
160         case res2 of
161            NotFound places2 mb_pkg2 mod_hiddens2 pkg_hiddens2 -> 
162               return (NotFound (places1 ++ places2)
163                                mb_pkg2 -- snd arg is the package search
164                                (mod_hiddens1 ++ mod_hiddens2)
165                                (pkg_hiddens1 ++ pkg_hiddens2))
166            _other -> return res2
167     _other -> return res
168
169
170 homeSearchCache :: HscEnv -> ModuleName -> IO FindResult -> IO FindResult
171 homeSearchCache hsc_env mod_name do_this = do
172   m <- lookupFinderCache (hsc_FC hsc_env) mod_name
173   case m of 
174     Just result -> return result
175     Nothing     -> do
176         result <- do_this
177         addToFinderCache (hsc_FC hsc_env) mod_name result
178         case result of
179            Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc
180            _other        -> return ()
181         return result
182
183 findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString
184                          -> IO FindResult
185 findExposedPackageModule hsc_env mod_name mb_pkg
186         -- not found in any package:
187   | null found_exposed = return (NotFound [] Nothing mod_hiddens pkg_hiddens)
188         -- found in just one exposed package:
189   | [(pkg_conf, _)] <- found_exposed
190         = let pkgid = packageConfigId pkg_conf in
191           findPackageModule_ hsc_env (mkModule pkgid mod_name) pkg_conf
192   | otherwise
193         = return (FoundMultiple (map (packageConfigId.fst) found_exposed))
194   where
195         dflags = hsc_dflags hsc_env
196         found = lookupModuleInAllPackages dflags mod_name
197
198         for_this_pkg = filter ((`matches` mb_pkg) . fst) found
199
200         found_exposed = [ (pkg_conf,exposed_mod) 
201                         | x@(pkg_conf,exposed_mod) <- for_this_pkg,
202                           is_exposed x ]
203
204         is_exposed (pkg_conf,exposed_mod) = exposed pkg_conf && exposed_mod
205
206         mod_hiddens = [ packageConfigId pkg_conf
207                       | (pkg_conf,False) <- found ]
208
209         pkg_hiddens = [ packageConfigId pkg_conf
210                       | (pkg_conf,_) <- found, not (exposed pkg_conf) ]
211
212         _pkg_conf `matches` Nothing  = True
213         pkg_conf  `matches` Just pkg =
214            case packageName pkg_conf of 
215               PackageName n -> pkg == mkFastString n
216
217
218 modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult
219 modLocationCache hsc_env mod do_this = do
220   mb_loc <- lookupModLocationCache mlc mod
221   case mb_loc of
222      Just loc -> return (Found loc mod)
223      Nothing  -> do
224         result <- do_this
225         case result of
226             Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc
227             _other -> return ()
228         return result
229   where
230     mlc = hsc_MLC hsc_env
231
232 addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module
233 addHomeModuleToFinder hsc_env mod_name loc = do
234   let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name
235   addToFinderCache (hsc_FC hsc_env) mod_name (Found loc mod)
236   addToModLocationCache (hsc_MLC hsc_env) mod loc
237   return mod
238
239 uncacheModule :: HscEnv -> ModuleName -> IO ()
240 uncacheModule hsc_env mod = do
241   let this_pkg = thisPackage (hsc_dflags hsc_env)
242   removeFromFinderCache (hsc_FC hsc_env) mod
243   removeFromModLocationCache (hsc_MLC hsc_env) (mkModule this_pkg mod)
244
245 -- -----------------------------------------------------------------------------
246 --      The internal workers
247
248 -- | Search for a module in the home package only.
249 findHomeModule :: HscEnv -> ModuleName -> IO FindResult
250 findHomeModule hsc_env mod_name =
251    homeSearchCache hsc_env mod_name $
252    let 
253      dflags = hsc_dflags hsc_env
254      home_path = importPaths dflags
255      hisuf = hiSuf dflags
256      mod = mkModule (thisPackage dflags) mod_name
257
258      source_exts = 
259       [ ("hs",   mkHomeModLocationSearched dflags mod_name "hs")
260       , ("lhs",  mkHomeModLocationSearched dflags mod_name "lhs")
261       ]
262      
263      hi_exts = [ (hisuf,                mkHiOnlyModLocation dflags hisuf)
264                , (addBootSuffix hisuf,  mkHiOnlyModLocation dflags hisuf)
265                ]
266      
267         -- In compilation manager modes, we look for source files in the home
268         -- package because we can compile these automatically.  In one-shot
269         -- compilation mode we look for .hi and .hi-boot files only.
270      exts | isOneShot (ghcMode dflags) = hi_exts
271           | otherwise                  = source_exts
272    in
273
274   -- special case for GHC.Prim; we won't find it in the filesystem.
275   -- This is important only when compiling the base package (where GHC.Prim
276   -- is a home module).
277   if mod == gHC_PRIM 
278         then return (Found (error "GHC.Prim ModLocation") mod)
279         else 
280
281    searchPathExts home_path mod exts
282
283
284 -- | Search for a module in external packages only.
285 findPackageModule :: HscEnv -> Module -> IO FindResult
286 findPackageModule hsc_env mod = do
287   let
288         dflags = hsc_dflags hsc_env
289         pkg_id = modulePackageId mod
290         pkg_map = pkgIdMap (pkgState dflags)
291   --
292   case lookupPackage pkg_map pkg_id of
293      Nothing -> return (NoPackage pkg_id)
294      Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf
295       
296 findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult
297 findPackageModule_ hsc_env mod pkg_conf = 
298   modLocationCache hsc_env mod $
299
300   -- special case for GHC.Prim; we won't find it in the filesystem.
301   if mod == gHC_PRIM 
302         then return (Found (error "GHC.Prim ModLocation") mod)
303         else 
304
305   let
306      dflags = hsc_dflags hsc_env
307      tag = buildTag dflags
308
309            -- hi-suffix for packages depends on the build tag.
310      package_hisuf | null tag  = "hi"
311                    | otherwise = tag ++ "_hi"
312
313      mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf
314
315      import_dirs = importDirs pkg_conf
316       -- we never look for a .hi-boot file in an external package;
317       -- .hi-boot files only make sense for the home package.
318   in
319   case import_dirs of
320     [one] | MkDepend <- ghcMode dflags -> do
321           -- there's only one place that this .hi file can be, so
322           -- don't bother looking for it.
323           let basename = moduleNameSlashes (moduleName mod)
324           loc <- mk_hi_loc one basename
325           return (Found loc mod)
326     _otherwise ->
327           searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]
328
329 -- -----------------------------------------------------------------------------
330 -- General path searching
331
332 searchPathExts
333   :: [FilePath]         -- paths to search
334   -> Module             -- module name
335   -> [ (
336         FileExt,                                -- suffix
337         FilePath -> BaseName -> IO ModLocation  -- action
338        )
339      ] 
340   -> IO FindResult
341
342 searchPathExts paths mod exts 
343    = do result <- search to_search
344 {-
345         hPutStrLn stderr (showSDoc $
346                 vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts)
347                     , nest 2 (vcat (map text paths))
348                     , case result of
349                         Succeeded (loc, p) -> text "Found" <+> ppr loc
350                         Failed fs          -> text "not found"])
351 -}      
352         return result
353
354   where
355     basename = moduleNameSlashes (moduleName mod)
356
357     to_search :: [(FilePath, IO ModLocation)]
358     to_search = [ (file, fn path basename)
359                 | path <- paths, 
360                   (ext,fn) <- exts,
361                   let base | path == "." = basename
362                            | otherwise   = path </> basename
363                       file = base <.> ext
364                 ]
365
366     search [] = return (NotFound (map fst to_search) (Just (modulePackageId mod))
367                         [] [])
368     search ((file, mk_result) : rest) = do
369       b <- doesFileExist file
370       if b 
371         then do { loc <- mk_result; return (Found loc mod) }
372         else search rest
373
374 mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt
375                           -> FilePath -> BaseName -> IO ModLocation
376 mkHomeModLocationSearched dflags mod suff path basename = do
377    mkHomeModLocation2 dflags mod (path </> basename) suff
378
379 -- -----------------------------------------------------------------------------
380 -- Constructing a home module location
381
382 -- This is where we construct the ModLocation for a module in the home
383 -- package, for which we have a source file.  It is called from three
384 -- places:
385 --
386 --  (a) Here in the finder, when we are searching for a module to import,
387 --      using the search path (-i option).
388 --
389 --  (b) The compilation manager, when constructing the ModLocation for
390 --      a "root" module (a source file named explicitly on the command line
391 --      or in a :load command in GHCi).
392 --
393 --  (c) The driver in one-shot mode, when we need to construct a
394 --      ModLocation for a source file named on the command-line.
395 --
396 -- Parameters are:
397 --
398 -- mod
399 --      The name of the module
400 --
401 -- path
402 --      (a): The search path component where the source file was found.
403 --      (b) and (c): "."
404 --
405 -- src_basename
406 --      (a): (moduleNameSlashes mod)
407 --      (b) and (c): The filename of the source file, minus its extension
408 --
409 -- ext
410 --      The filename extension of the source file (usually "hs" or "lhs").
411
412 mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation
413 mkHomeModLocation dflags mod src_filename = do
414    let (basename,extension) = splitExtension src_filename
415    mkHomeModLocation2 dflags mod basename extension
416
417 mkHomeModLocation2 :: DynFlags
418                    -> ModuleName
419                    -> FilePath  -- Of source module, without suffix
420                    -> String    -- Suffix
421                    -> IO ModLocation
422 mkHomeModLocation2 dflags mod src_basename ext = do
423    let mod_basename = moduleNameSlashes mod
424
425    obj_fn  <- mkObjPath  dflags src_basename mod_basename
426    hi_fn   <- mkHiPath   dflags src_basename mod_basename
427
428    return (ModLocation{ ml_hs_file   = Just (src_basename <.> ext),
429                         ml_hi_file   = hi_fn,
430                         ml_obj_file  = obj_fn })
431
432 mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String
433                     -> IO ModLocation
434 mkHiOnlyModLocation dflags hisuf path basename
435  = do let full_basename = path </> basename
436       obj_fn  <- mkObjPath  dflags full_basename basename
437       return ModLocation{    ml_hs_file   = Nothing,
438                              ml_hi_file   = full_basename <.> hisuf,
439                                 -- Remove the .hi-boot suffix from
440                                 -- hi_file, if it had one.  We always
441                                 -- want the name of the real .hi file
442                                 -- in the ml_hi_file field.
443                              ml_obj_file  = obj_fn
444                   }
445
446 -- | Constructs the filename of a .o file for a given source file.
447 -- Does /not/ check whether the .o file exists
448 mkObjPath
449   :: DynFlags
450   -> FilePath           -- the filename of the source file, minus the extension
451   -> String             -- the module name with dots replaced by slashes
452   -> IO FilePath
453 mkObjPath dflags basename mod_basename
454   = do  let
455                 odir = objectDir dflags
456                 osuf = objectSuf dflags
457         
458                 obj_basename | Just dir <- odir = dir </> mod_basename
459                              | otherwise        = basename
460
461         return (obj_basename <.> osuf)
462
463 -- | Constructs the filename of a .hi file for a given source file.
464 -- Does /not/ check whether the .hi file exists
465 mkHiPath
466   :: DynFlags
467   -> FilePath           -- the filename of the source file, minus the extension
468   -> String             -- the module name with dots replaced by slashes
469   -> IO FilePath
470 mkHiPath dflags basename mod_basename
471   = do  let
472                 hidir = hiDir dflags
473                 hisuf = hiSuf dflags
474
475                 hi_basename | Just dir <- hidir = dir </> mod_basename
476                             | otherwise         = basename
477
478         return (hi_basename <.> hisuf)
479
480
481 -- -----------------------------------------------------------------------------
482 -- Filenames of the stub files
483
484 -- We don't have to store these in ModLocations, because they can be derived
485 -- from other available information, and they're only rarely needed.
486
487 mkStubPaths
488   :: DynFlags
489   -> ModuleName
490   -> ModLocation
491   -> (FilePath,FilePath,FilePath)
492
493 mkStubPaths dflags mod location
494   = let
495         stubdir = stubDir dflags
496
497         mod_basename = moduleNameSlashes mod
498         src_basename = dropExtension $ expectJust "mkStubPaths" 
499                                                   (ml_hs_file location)
500
501         stub_basename0
502             | Just dir <- stubdir = dir </> mod_basename
503             | otherwise           = src_basename
504
505         stub_basename = stub_basename0 ++ "_stub"
506
507         obj  = ml_obj_file location
508         osuf = objectSuf dflags
509         stub_obj_base = dropTail (length osuf + 1) obj ++ "_stub"
510                         -- NB. not takeFileName, see #3093
511      in
512         (stub_basename <.> "c",
513          stub_basename <.> "h",
514          stub_obj_base <.> objectSuf dflags)
515
516 -- -----------------------------------------------------------------------------
517 -- findLinkable isn't related to the other stuff in here, 
518 -- but there's no other obvious place for it
519
520 findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)
521 findObjectLinkableMaybe mod locn
522    = do let obj_fn = ml_obj_file locn
523         maybe_obj_time <- modificationTimeIfExists obj_fn
524         case maybe_obj_time of
525           Nothing -> return Nothing
526           Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time)
527
528 -- Make an object linkable when we know the object file exists, and we know
529 -- its modification time.
530 findObjectLinkable :: Module -> FilePath -> ClockTime -> IO Linkable
531 findObjectLinkable mod obj_fn obj_time = do
532   let stub_fn = (dropExtension obj_fn ++ "_stub") <.> "o"
533   stub_exist <- doesFileExist stub_fn
534   if stub_exist
535         then return (LM obj_time mod [DotO obj_fn, DotO stub_fn])
536         else return (LM obj_time mod [DotO obj_fn])
537
538 -- -----------------------------------------------------------------------------
539 -- Error messages
540
541 cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc
542 cannotFindModule = cantFindErr (sLit "Could not find module")
543                                (sLit "Ambiguous module name")
544
545 cannotFindInterface  :: DynFlags -> ModuleName -> FindResult -> SDoc
546 cannotFindInterface = cantFindErr (sLit "Failed to load interface for")
547                                   (sLit "Ambiguous interface for")
548
549 cantFindErr :: LitString -> LitString -> DynFlags -> ModuleName -> FindResult
550             -> SDoc
551 cantFindErr _ multiple_found _ mod_name (FoundMultiple pkgs)
552   = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (
553        sep [ptext (sLit "it was found in multiple packages:"),
554                 hsep (map (text.packageIdString) pkgs)]
555     )
556 cantFindErr cannot_find _ dflags mod_name find_result
557   = hang (ptext cannot_find <+> quotes (ppr mod_name) <> colon)
558        2 more_info
559   where
560     more_info
561       = case find_result of
562             NoPackage pkg
563                 -> ptext (sLit "no package matching") <+> quotes (ppr pkg) <+>
564                    ptext (sLit "was found")
565
566             NotFound files mb_pkg mod_hiddens pkg_hiddens
567                 | Just pkg <- mb_pkg, pkg /= thisPackage dflags
568                 -> not_found_in_package pkg files
569
570                 | null files && null mod_hiddens && null pkg_hiddens
571                 -> ptext (sLit "it is not a module in the current program, or in any known package.")
572
573                 | otherwise
574                 -> vcat (map pkg_hidden pkg_hiddens) $$
575                    vcat (map mod_hidden mod_hiddens) $$ 
576                    tried_these files
577
578             NotFoundInPackage pkg
579                 -> ptext (sLit "it is not in package") <+> quotes (ppr pkg)
580
581             _ -> panic "cantFindErr"
582
583     build_tag = buildTag dflags
584
585     not_found_in_package pkg files
586        | build_tag /= ""
587        = let
588             build = if build_tag == "p" then "profiling"
589                                         else "\"" ++ build_tag ++ "\""
590          in
591          ptext (sLit "Perhaps you haven't installed the ") <> text build <>
592          ptext (sLit " libraries for package ") <> quotes (ppr pkg) <> char '?' $$
593          tried_these files
594
595        | otherwise
596        = ptext (sLit "There are files missing in the ") <> quotes (ppr pkg) <>
597          ptext (sLit " package,") $$
598          ptext (sLit "try running 'ghc-pkg check'.") $$
599          tried_these files
600
601     tried_these files
602         | null files = empty
603         | verbosity dflags < 3 =
604               ptext (sLit "Use -v to see a list of the files searched for.")
605         | otherwise =
606                hang (ptext (sLit "locations searched:")) 2 $ vcat (map text files)
607         
608     pkg_hidden pkg =
609         ptext (sLit "It is a member of the hidden package") <+> quotes (ppr pkg)
610         <> dot $$ cabal_pkg_hidden_hint pkg
611     cabal_pkg_hidden_hint pkg
612      | dopt Opt_BuildingCabalPackage dflags
613         = case simpleParse (packageIdString pkg) of
614           Just pid ->
615               ptext (sLit "Perhaps you need to add") <+>
616               quotes (text (display (pkgName pid))) <+>
617               ptext (sLit "to the build-depends in your .cabal file.")
618           Nothing -> empty
619      | otherwise = empty
620
621     mod_hidden pkg =
622         ptext (sLit "it is a hidden module in the package") <+> quotes (ppr pkg)
623 \end{code}