compiler/main/GhcMake.hs

   1 -- -----------------------------------------------------------------------------
   2 --
   3 -- (c) The University of Glasgow, 2011
   4 --
   5 --       This module implements multi-module compilation, and is used
   6 --       by --make and GHCi.
   7 --
   8 -- -----------------------------------------------------------------------------
   9
  10 module GhcMake(
  11   depanal,
  12   load, LoadHowMuch(..),
  13
  14   topSortModuleGraph,
  15
  16   noModError, cyclicModuleErr
  17   ) where
  18
  19 #include "HsVersions.h"
  20
  21 #ifdef GHCI
  22 import qualified Linker         ( unload )
  23 #endif
  24
  25 import DriverPipeline
  26 import DriverPhases
  27 import GhcMonad
  28 import Module
  29 import HscTypes
  30 import ErrUtils
  31 import DynFlags
  32 import HsSyn hiding ((<.>))
  33 import Finder
  34 import HeaderInfo
  35 import TcIface          ( typecheckIface )
  36 import TcRnMonad        ( initIfaceCheck )
  37 import RdrName          ( RdrName )
  38
  39 import Exception        ( evaluate, tryIO )
  40 import Panic
  41 import SysTools
  42 import BasicTypes
  43 import SrcLoc
  44 import Util
  45 import Digraph
  46 import Bag              ( listToBag )
  47 import Maybes           ( expectJust, mapCatMaybes )
  48 import StringBuffer
  49 import FastString
  50 import Outputable
  51 import UniqFM
  52
  53 import qualified Data.Map as Map
  54 import qualified FiniteMap as Map( insertListWith)
  55
  56 import System.Directory ( doesFileExist, getModificationTime )
  57 import System.IO        ( fixIO )
  58 import System.IO.Error  ( isDoesNotExistError )
  59 import System.Time      ( ClockTime )
  60 import System.FilePath
  61 import Control.Monad
  62 import Data.Maybe
  63 import Data.List
  64 import qualified Data.List as List
  65
  66 -- -----------------------------------------------------------------------------
  67 -- Loading the program
  68
  69 -- | Perform a dependency analysis starting from the current targets
  70 -- and update the session with the new module graph.
  71 --
  72 -- Dependency analysis entails parsing the @import@ directives and may
  73 -- therefore require running certain preprocessors.
  74 --
  75 -- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.
  76 -- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the
  77 -- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want to
  78 -- changes to the 'DynFlags' to take effect you need to call this function
  79 -- again.
  80 --
  81 depanal :: GhcMonad m =>
  82            [ModuleName]  -- ^ excluded modules
  83         -> Bool          -- ^ allow duplicate roots
  84         -> m ModuleGraph
  85 depanal excluded_mods allow_dup_roots = do
  86   hsc_env <- getSession
  87   let
  88          dflags  = hsc_dflags hsc_env
  89          targets = hsc_targets hsc_env
  90          old_graph = hsc_mod_graph hsc_env
  91
  92   liftIO $ showPass dflags "Chasing dependencies"
  93   liftIO $ debugTraceMsg dflags 2 (hcat [
  94              text "Chasing modules from: ",
  95              hcat (punctuate comma (map pprTarget targets))])
  96
  97   mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots
  98   modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }
  99   return mod_graph
 100
 101 -- | Describes which modules of the module graph need to be loaded.
 102 data LoadHowMuch
 103    = LoadAllTargets
 104      -- ^ Load all targets and its dependencies.
 105    | LoadUpTo ModuleName
 106      -- ^ Load only the given module and its dependencies.
 107    | LoadDependenciesOf ModuleName
 108      -- ^ Load only the dependencies of the given module, but not the module
 109      -- itself.
 110
 111 -- | Try to load the program.  See 'LoadHowMuch' for the different modes.
 112 --
 113 -- This function implements the core of GHC's @--make@ mode.  It preprocesses,
 114 -- compiles and loads the specified modules, avoiding re-compilation wherever
 115 -- possible.  Depending on the target (see 'DynFlags.hscTarget') compilating
 116 -- and loading may result in files being created on disk.
 117 --
 118 -- Calls the 'reportModuleCompilationResult' callback after each compiling
 119 -- each module, whether successful or not.
 120 --
 121 -- Throw a 'SourceError' if errors are encountered before the actual
 122 -- compilation starts (e.g., during dependency analysis).  All other errors
 123 -- are reported using the callback.
 124 --
 125 load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
 126 load how_much = do
 127    mod_graph <- depanal [] False
 128    load2 how_much mod_graph
 129
 130 load2 :: GhcMonad m => LoadHowMuch -> [ModSummary]
 131       -> m SuccessFlag
 132 load2 how_much mod_graph = do
 133         guessOutputFile
 134         hsc_env <- getSession
 135
 136         let hpt1      = hsc_HPT hsc_env
 137         let dflags    = hsc_dflags hsc_env
 138
 139         -- The "bad" boot modules are the ones for which we have
 140         -- B.hs-boot in the module graph, but no B.hs
 141         -- The downsweep should have ensured this does not happen
 142         -- (see msDeps)
 143         let all_home_mods = [ms_mod_name s
 144                             | s <- mod_graph, not (isBootSummary s)]
 145             bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,
 146                                         not (ms_mod_name s `elem` all_home_mods)]
 147         ASSERT( null bad_boot_mods ) return ()
 148
 149         -- check that the module given in HowMuch actually exists, otherwise
 150         -- topSortModuleGraph will bomb later.
 151         let checkHowMuch (LoadUpTo m)           = checkMod m
 152             checkHowMuch (LoadDependenciesOf m) = checkMod m
 153             checkHowMuch _ = id
 154
 155             checkMod m and_then
 156                 | m `elem` all_home_mods = and_then
 157                 | otherwise = do
 158                         liftIO $ errorMsg dflags (text "no such module:" <+>
 159                                          quotes (ppr m))
 160                         return Failed
 161
 162         checkHowMuch how_much $ do
 163
 164         -- mg2_with_srcimps drops the hi-boot nodes, returning a
 165         -- graph with cycles.  Among other things, it is used for
 166         -- backing out partially complete cycles following a failed
 167         -- upsweep, and for removing from hpt all the modules
 168         -- not in strict downwards closure, during calls to compile.
 169         let mg2_with_srcimps :: [SCC ModSummary]
 170             mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
 171
 172         -- If we can determine that any of the {-# SOURCE #-} imports
 173         -- are definitely unnecessary, then emit a warning.
 174         warnUnnecessarySourceImports mg2_with_srcimps
 175
 176         let
 177             -- check the stability property for each module.
 178             stable_mods@(stable_obj,stable_bco)
 179                 = checkStability hpt1 mg2_with_srcimps all_home_mods
 180
 181             -- prune bits of the HPT which are definitely redundant now,
 182             -- to save space.
 183             pruned_hpt = pruneHomePackageTable hpt1
 184                                 (flattenSCCs mg2_with_srcimps)
 185                                 stable_mods
 186
 187         _ <- liftIO $ evaluate pruned_hpt
 188
 189         -- before we unload anything, make sure we don't leave an old
 190         -- interactive context around pointing to dead bindings.  Also,
 191         -- write the pruned HPT to allow the old HPT to be GC'd.
 192         modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext,
 193                                        hsc_HPT = pruned_hpt }
 194
 195         liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
 196                                 text "Stable BCO:" <+> ppr stable_bco)
 197
 198         -- Unload any modules which are going to be re-linked this time around.
 199         let stable_linkables = [ linkable
 200                                | m <- stable_obj++stable_bco,
 201                                  Just hmi <- [lookupUFM pruned_hpt m],
 202                                  Just linkable <- [hm_linkable hmi] ]
 203         liftIO $ unload hsc_env stable_linkables
 204
 205         -- We could at this point detect cycles which aren't broken by
 206         -- a source-import, and complain immediately, but it seems better
 207         -- to let upsweep_mods do this, so at least some useful work gets
 208         -- done before the upsweep is abandoned.
 209         --hPutStrLn stderr "after tsort:\n"
 210         --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
 211
 212         -- Now do the upsweep, calling compile for each module in
 213         -- turn.  Final result is version 3 of everything.
 214
 215         -- Topologically sort the module graph, this time including hi-boot
 216         -- nodes, and possibly just including the portion of the graph
 217         -- reachable from the module specified in the 2nd argument to load.
 218         -- This graph should be cycle-free.
 219         -- If we're restricting the upsweep to a portion of the graph, we
 220         -- also want to retain everything that is still stable.
 221         let full_mg :: [SCC ModSummary]
 222             full_mg    = topSortModuleGraph False mod_graph Nothing
 223
 224             maybe_top_mod = case how_much of
 225                                 LoadUpTo m           -> Just m
 226                                 LoadDependenciesOf m -> Just m
 227                                 _                    -> Nothing
 228
 229             partial_mg0 :: [SCC ModSummary]
 230             partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
 231
 232             -- LoadDependenciesOf m: we want the upsweep to stop just
 233             -- short of the specified module (unless the specified module
 234             -- is stable).
 235             partial_mg
 236                 | LoadDependenciesOf _mod <- how_much
 237                 = ASSERT( case last partial_mg0 of
 238                             AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
 239                   List.init partial_mg0
 240                 | otherwise
 241                 = partial_mg0
 242
 243             stable_mg =
 244                 [ AcyclicSCC ms
 245                 | AcyclicSCC ms <- full_mg,
 246                   ms_mod_name ms `elem` stable_obj++stable_bco,
 247                   ms_mod_name ms `notElem` [ ms_mod_name ms' |
 248                                                 AcyclicSCC ms' <- partial_mg ] ]
 249
 250             mg = stable_mg ++ partial_mg
 251
 252         -- clean up between compilations
 253         let cleanup hsc_env = intermediateCleanTempFiles dflags
 254                                   (flattenSCCs mg2_with_srcimps)
 255                                   hsc_env
 256
 257         liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
 258                                    2 (ppr mg))
 259
 260         setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
 261         (upsweep_ok, modsUpswept)
 262            <- upsweep pruned_hpt stable_mods cleanup mg
 263
 264         -- Make modsDone be the summaries for each home module now
 265         -- available; this should equal the domain of hpt3.
 266         -- Get in in a roughly top .. bottom order (hence reverse).
 267
 268         let modsDone = reverse modsUpswept
 269
 270         -- Try and do linking in some form, depending on whether the
 271         -- upsweep was completely or only partially successful.
 272
 273         if succeeded upsweep_ok
 274
 275          then
 276            -- Easy; just relink it all.
 277            do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
 278
 279               -- Clean up after ourselves
 280               hsc_env1 <- getSession
 281               liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1
 282
 283               -- Issue a warning for the confusing case where the user
 284               -- said '-o foo' but we're not going to do any linking.
 285               -- We attempt linking if either (a) one of the modules is
 286               -- called Main, or (b) the user said -no-hs-main, indicating
 287               -- that main() is going to come from somewhere else.
 288               --
 289               let ofile = outputFile dflags
 290               let no_hs_main = dopt Opt_NoHsMain dflags
 291               let
 292                 main_mod = mainModIs dflags
 293                 a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
 294                 do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib
 295
 296               when (ghcLink dflags == LinkBinary
 297                     && isJust ofile && not do_linking) $
 298                 liftIO $ debugTraceMsg dflags 1 $
 299                     text ("Warning: output was redirected with -o, " ++
 300                           "but no output will be generated\n" ++
 301                           "because there is no " ++
 302                           moduleNameString (moduleName main_mod) ++ " module.")
 303
 304               -- link everything together
 305               linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
 306
 307               loadFinish Succeeded linkresult
 308
 309          else
 310            -- Tricky.  We need to back out the effects of compiling any
 311            -- half-done cycles, both so as to clean up the top level envs
 312            -- and to avoid telling the interactive linker to link them.
 313            do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
 314
 315               let modsDone_names
 316                      = map ms_mod modsDone
 317               let mods_to_zap_names
 318                      = findPartiallyCompletedCycles modsDone_names
 319                           mg2_with_srcimps
 320               let mods_to_keep
 321                      = filter ((`notElem` mods_to_zap_names).ms_mod)
 322                           modsDone
 323
 324               hsc_env1 <- getSession
 325               let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
 326                                               (hsc_HPT hsc_env1)
 327
 328               -- Clean up after ourselves
 329               liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1
 330
 331               -- there should be no Nothings where linkables should be, now
 332               ASSERT(all (isJust.hm_linkable)
 333                         (eltsUFM (hsc_HPT hsc_env))) do
 334
 335               -- Link everything together
 336               linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
 337
 338               modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 }
 339               loadFinish Failed linkresult
 340
 341 -- Finish up after a load.
 342
 343 -- If the link failed, unload everything and return.
 344 loadFinish :: GhcMonad m =>
 345               SuccessFlag -> SuccessFlag
 346            -> m SuccessFlag
 347 loadFinish _all_ok Failed
 348   = do hsc_env <- getSession
 349        liftIO $ unload hsc_env []
 350        modifySession discardProg
 351        return Failed
 352
 353 -- Empty the interactive context and set the module context to the topmost
 354 -- newly loaded module, or the Prelude if none were loaded.
 355 loadFinish all_ok Succeeded
 356   = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext }
 357        return all_ok
 358
 359
 360 -- Forget the current program, but retain the persistent info in HscEnv
 361 discardProg :: HscEnv -> HscEnv
 362 discardProg hsc_env
 363   = hsc_env { hsc_mod_graph = emptyMG,
 364               hsc_IC = emptyInteractiveContext,
 365               hsc_HPT = emptyHomePackageTable }
 366
 367 intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO ()
 368 intermediateCleanTempFiles dflags summaries hsc_env
 369  = cleanTempFilesExcept dflags except
 370   where
 371     except =
 372           -- Save preprocessed files. The preprocessed file *might* be
 373           -- the same as the source file, but that doesn't do any
 374           -- harm.
 375           map ms_hspp_file summaries ++
 376           -- Save object files for loaded modules.  The point of this
 377           -- is that we might have generated and compiled a stub C
 378           -- file, and in the case of GHCi the object file will be a
 379           -- temporary file which we must not remove because we need
 380           -- to load/link it later.
 381           hptObjs (hsc_HPT hsc_env)
 382
 383 -- | If there is no -o option, guess the name of target executable
 384 -- by using top-level source file name as a base.
 385 guessOutputFile :: GhcMonad m => m ()
 386 guessOutputFile = modifySession $ \env ->
 387     let dflags = hsc_dflags env
 388         mod_graph = hsc_mod_graph env
 389         mainModuleSrcPath :: Maybe String
 390         mainModuleSrcPath = do
 391             let isMain = (== mainModIs dflags) . ms_mod
 392             [ms] <- return (filter isMain mod_graph)
 393             ml_hs_file (ms_location ms)
 394         name = fmap dropExtension mainModuleSrcPath
 395
 396 #if defined(mingw32_HOST_OS)
 397         -- we must add the .exe extention unconditionally here, otherwise
 398         -- when name has an extension of its own, the .exe extension will
 399         -- not be added by DriverPipeline.exeFileName.  See #2248
 400         name_exe = fmap (<.> "exe") name
 401 #else
 402         name_exe = name
 403 #endif
 404     in
 405     case outputFile dflags of
 406         Just _ -> env
 407         Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
 408
 409 -- -----------------------------------------------------------------------------
 410
 411 -- | Prune the HomePackageTable
 412 --
 413 -- Before doing an upsweep, we can throw away:
 414 --
 415 --   - For non-stable modules:
 416 --      - all ModDetails, all linked code
 417 --   - all unlinked code that is out of date with respect to
 418 --     the source file
 419 --
 420 -- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
 421 -- space at the end of the upsweep, because the topmost ModDetails of the
 422 -- old HPT holds on to the entire type environment from the previous
 423 -- compilation.
 424
 425 pruneHomePackageTable
 426    :: HomePackageTable
 427    -> [ModSummary]
 428    -> ([ModuleName],[ModuleName])
 429    -> HomePackageTable
 430
 431 pruneHomePackageTable hpt summ (stable_obj, stable_bco)
 432   = mapUFM prune hpt
 433   where prune hmi
 434           | is_stable modl = hmi'
 435           | otherwise      = hmi'{ hm_details = emptyModDetails }
 436           where
 437            modl = moduleName (mi_module (hm_iface hmi))
 438            hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
 439                 = hmi{ hm_linkable = Nothing }
 440                 | otherwise
 441                 = hmi
 442                 where ms = expectJust "prune" (lookupUFM ms_map modl)
 443
 444         ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
 445
 446         is_stable m = m `elem` stable_obj || m `elem` stable_bco
 447
 448 -- -----------------------------------------------------------------------------
 449
 450 -- Return (names of) all those in modsDone who are part of a cycle
 451 -- as defined by theGraph.
 452 findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
 453 findPartiallyCompletedCycles modsDone theGraph
 454    = chew theGraph
 455      where
 456         chew [] = []
 457         chew ((AcyclicSCC _):rest) = chew rest    -- acyclic?  not interesting.
 458         chew ((CyclicSCC vs):rest)
 459            = let names_in_this_cycle = nub (map ms_mod vs)
 460                  mods_in_this_cycle
 461                     = nub ([done | done <- modsDone,
 462                                    done `elem` names_in_this_cycle])
 463                  chewed_rest = chew rest
 464              in
 465              if   notNull mods_in_this_cycle
 466                   && length mods_in_this_cycle < length names_in_this_cycle
 467              then mods_in_this_cycle ++ chewed_rest
 468              else chewed_rest
 469
 470
 471 -- ---------------------------------------------------------------------------
 472 -- Unloading
 473
 474 unload :: HscEnv -> [Linkable] -> IO ()
 475 unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
 476   = case ghcLink (hsc_dflags hsc_env) of
 477 #ifdef GHCI
 478         LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables
 479 #else
 480         LinkInMemory -> panic "unload: no interpreter"
 481                                 -- urgh.  avoid warnings:
 482                                 hsc_env stable_linkables
 483 #endif
 484         _other -> return ()
 485
 486 -- -----------------------------------------------------------------------------
 487
 488 {- |
 489
 490   Stability tells us which modules definitely do not need to be recompiled.
 491   There are two main reasons for having stability:
 492
 493    - avoid doing a complete upsweep of the module graph in GHCi when
 494      modules near the bottom of the tree have not changed.
 495
 496    - to tell GHCi when it can load object code: we can only load object code
 497      for a module when we also load object code fo  all of the imports of the
 498      module.  So we need to know that we will definitely not be recompiling
 499      any of these modules, and we can use the object code.
 500
 501   The stability check is as follows.  Both stableObject and
 502   stableBCO are used during the upsweep phase later.
 503
 504 @
 505   stable m = stableObject m || stableBCO m
 506
 507   stableObject m =
 508         all stableObject (imports m)
 509         && old linkable does not exist, or is == on-disk .o
 510         && date(on-disk .o) > date(.hs)
 511
 512   stableBCO m =
 513         all stable (imports m)
 514         && date(BCO) > date(.hs)
 515 @
 516
 517   These properties embody the following ideas:
 518
 519     - if a module is stable, then:
 520
 521         - if it has been compiled in a previous pass (present in HPT)
 522           then it does not need to be compiled or re-linked.
 523
 524         - if it has not been compiled in a previous pass,
 525           then we only need to read its .hi file from disk and
 526           link it to produce a 'ModDetails'.
 527
 528     - if a modules is not stable, we will definitely be at least
 529       re-linking, and possibly re-compiling it during the 'upsweep'.
 530       All non-stable modules can (and should) therefore be unlinked
 531       before the 'upsweep'.
 532
 533     - Note that objects are only considered stable if they only depend
 534       on other objects.  We can't link object code against byte code.
 535 -}
 536
 537 checkStability
 538         :: HomePackageTable             -- HPT from last compilation
 539         -> [SCC ModSummary]             -- current module graph (cyclic)
 540         -> [ModuleName]                 -- all home modules
 541         -> ([ModuleName],               -- stableObject
 542             [ModuleName])               -- stableBCO
 543
 544 checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
 545   where
 546    checkSCC (stable_obj, stable_bco) scc0
 547      | stableObjects = (scc_mods ++ stable_obj, stable_bco)
 548      | stableBCOs    = (stable_obj, scc_mods ++ stable_bco)
 549      | otherwise     = (stable_obj, stable_bco)
 550      where
 551         scc = flattenSCC scc0
 552         scc_mods = map ms_mod_name scc
 553         home_module m   = m `elem` all_home_mods && m `notElem` scc_mods
 554
 555         scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))
 556             -- all imports outside the current SCC, but in the home pkg
 557
 558         stable_obj_imps = map (`elem` stable_obj) scc_allimps
 559         stable_bco_imps = map (`elem` stable_bco) scc_allimps
 560
 561         stableObjects =
 562            and stable_obj_imps
 563            && all object_ok scc
 564
 565         stableBCOs =
 566            and (zipWith (||) stable_obj_imps stable_bco_imps)
 567            && all bco_ok scc
 568
 569         object_ok ms
 570           | Just t <- ms_obj_date ms  =  t >= ms_hs_date ms
 571                                          && same_as_prev t
 572           | otherwise = False
 573           where
 574              same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
 575                                 Just hmi  | Just l <- hm_linkable hmi
 576                                  -> isObjectLinkable l && t == linkableTime l
 577                                 _other  -> True
 578                 -- why '>=' rather than '>' above?  If the filesystem stores
 579                 -- times to the nearset second, we may occasionally find that
 580                 -- the object & source have the same modification time,
 581                 -- especially if the source was automatically generated
 582                 -- and compiled.  Using >= is slightly unsafe, but it matches
 583                 -- make's behaviour.
 584
 585         bco_ok ms
 586           = case lookupUFM hpt (ms_mod_name ms) of
 587                 Just hmi  | Just l <- hm_linkable hmi ->
 588                         not (isObjectLinkable l) &&
 589                         linkableTime l >= ms_hs_date ms
 590                 _other  -> False
 591
 592 -- -----------------------------------------------------------------------------
 593
 594 -- | The upsweep
 595 --
 596 -- This is where we compile each module in the module graph, in a pass
 597 -- from the bottom to the top of the graph.
 598 --
 599 -- There better had not be any cyclic groups here -- we check for them.
 600
 601 upsweep
 602     :: GhcMonad m
 603     => HomePackageTable         -- ^ HPT from last time round (pruned)
 604     -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
 605     -> (HscEnv -> IO ())           -- ^ How to clean up unwanted tmp files
 606     -> [SCC ModSummary]         -- ^ Mods to do (the worklist)
 607     -> m (SuccessFlag,
 608           [ModSummary])
 609        -- ^ Returns:
 610        --
 611        --  1. A flag whether the complete upsweep was successful.
 612        --  2. The 'HscEnv' in the monad has an updated HPT
 613        --  3. A list of modules which succeeded loading.
 614
 615 upsweep old_hpt stable_mods cleanup sccs = do
 616    (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)
 617    return (res, reverse done)
 618  where
 619
 620   upsweep' _old_hpt done
 621      [] _ _
 622    = return (Succeeded, done)
 623
 624   upsweep' _old_hpt done
 625      (CyclicSCC ms:_) _ _
 626    = do dflags <- getSessionDynFlags
 627         liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
 628         return (Failed, done)
 629
 630   upsweep' old_hpt done
 631      (AcyclicSCC mod:mods) mod_index nmods
 632    = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
 633         --           show (map (moduleUserString.moduleName.mi_module.hm_iface)
 634         --                     (moduleEnvElts (hsc_HPT hsc_env)))
 635         let logger _mod = defaultWarnErrLogger
 636
 637         hsc_env <- getSession
 638
 639         -- Remove unwanted tmp files between compilations
 640         liftIO (cleanup hsc_env)
 641
 642         mb_mod_info
 643             <- handleSourceError
 644                    (\err -> do logger mod (Just err); return Nothing) $ do
 645                  mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods
 646                                                   mod mod_index nmods
 647                  logger mod Nothing -- log warnings
 648                  return (Just mod_info)
 649
 650         case mb_mod_info of
 651           Nothing -> return (Failed, done)
 652           Just mod_info -> do
 653                 let this_mod = ms_mod_name mod
 654
 655                         -- Add new info to hsc_env
 656                     hpt1     = addToUFM (hsc_HPT hsc_env) this_mod mod_info
 657                     hsc_env1 = hsc_env { hsc_HPT = hpt1 }
 658
 659                         -- Space-saving: delete the old HPT entry
 660                         -- for mod BUT if mod is a hs-boot
 661                         -- node, don't delete it.  For the
 662                         -- interface, the HPT entry is probaby for the
 663                         -- main Haskell source file.  Deleting it
 664                         -- would force the real module to be recompiled
 665                         -- every time.
 666                     old_hpt1 | isBootSummary mod = old_hpt
 667                              | otherwise = delFromUFM old_hpt this_mod
 668
 669                     done' = mod:done
 670
 671                         -- fixup our HomePackageTable after we've finished compiling
 672                         -- a mutually-recursive loop.  See reTypecheckLoop, below.
 673                 hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'
 674                 setSession hsc_env2
 675
 676                 upsweep' old_hpt1 done' mods (mod_index+1) nmods
 677
 678 -- | Compile a single module.  Always produce a Linkable for it if
 679 -- successful.  If no compilation happened, return the old Linkable.
 680 upsweep_mod :: HscEnv
 681             -> HomePackageTable
 682             -> ([ModuleName],[ModuleName])
 683             -> ModSummary
 684             -> Int  -- index of module
 685             -> Int  -- total number of modules
 686             -> IO HomeModInfo
 687
 688 upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
 689    =    let
 690             this_mod_name = ms_mod_name summary
 691             this_mod    = ms_mod summary
 692             mb_obj_date = ms_obj_date summary
 693             obj_fn      = ml_obj_file (ms_location summary)
 694             hs_date     = ms_hs_date summary
 695
 696             is_stable_obj = this_mod_name `elem` stable_obj
 697             is_stable_bco = this_mod_name `elem` stable_bco
 698
 699             old_hmi = lookupUFM old_hpt this_mod_name
 700
 701             -- We're using the dflags for this module now, obtained by
 702             -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
 703             dflags = ms_hspp_opts summary
 704             prevailing_target = hscTarget (hsc_dflags hsc_env)
 705             local_target      = hscTarget dflags
 706
 707             -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
 708             -- we don't do anything dodgy: these should only work to change
 709             -- from -fvia-C to -fasm and vice-versa, otherwise we could
 710             -- end up trying to link object code to byte code.
 711             target = if prevailing_target /= local_target
 712                         && (not (isObjectTarget prevailing_target)
 713                             || not (isObjectTarget local_target))
 714                         then prevailing_target
 715                         else local_target
 716
 717             -- store the corrected hscTarget into the summary
 718             summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
 719
 720             -- The old interface is ok if
 721             --  a) we're compiling a source file, and the old HPT
 722             --     entry is for a source file
 723             --  b) we're compiling a hs-boot file
 724             -- Case (b) allows an hs-boot file to get the interface of its
 725             -- real source file on the second iteration of the compilation
 726             -- manager, but that does no harm.  Otherwise the hs-boot file
 727             -- will always be recompiled
 728
 729             mb_old_iface
 730                 = case old_hmi of
 731                      Nothing                              -> Nothing
 732                      Just hm_info | isBootSummary summary -> Just iface
 733                                   | not (mi_boot iface)   -> Just iface
 734                                   | otherwise             -> Nothing
 735                                    where
 736                                      iface = hm_iface hm_info
 737
 738             compile_it :: Maybe Linkable -> IO HomeModInfo
 739             compile_it  mb_linkable =
 740                   compile hsc_env summary' mod_index nmods
 741                           mb_old_iface mb_linkable
 742
 743             compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo
 744             compile_it_discard_iface mb_linkable =
 745                   compile hsc_env summary' mod_index nmods
 746                           Nothing mb_linkable
 747
 748             -- With the HscNothing target we create empty linkables to avoid
 749             -- recompilation.  We have to detect these to recompile anyway if
 750             -- the target changed since the last compile.
 751             is_fake_linkable
 752                | Just hmi <- old_hmi, Just l <- hm_linkable hmi =
 753                   null (linkableUnlinked l)
 754                | otherwise =
 755                    -- we have no linkable, so it cannot be fake
 756                    False
 757
 758             implies False _ = True
 759             implies True x  = x
 760
 761         in
 762         case () of
 763          _
 764                 -- Regardless of whether we're generating object code or
 765                 -- byte code, we can always use an existing object file
 766                 -- if it is *stable* (see checkStability).
 767           | is_stable_obj, Just hmi <- old_hmi -> do
 768                 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
 769                            (text "skipping stable obj mod:" <+> ppr this_mod_name)
 770                 return hmi
 771                 -- object is stable, and we have an entry in the
 772                 -- old HPT: nothing to do
 773
 774           | is_stable_obj, isNothing old_hmi -> do
 775                 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
 776                            (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
 777                 linkable <- liftIO $ findObjectLinkable this_mod obj_fn
 778                               (expectJust "upsweep1" mb_obj_date)
 779                 compile_it (Just linkable)
 780                 -- object is stable, but we need to load the interface
 781                 -- off disk to make a HMI.
 782
 783           | not (isObjectTarget target), is_stable_bco,
 784             (target /= HscNothing) `implies` not is_fake_linkable ->
 785                 ASSERT(isJust old_hmi) -- must be in the old_hpt
 786                 let Just hmi = old_hmi in do
 787                 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
 788                            (text "skipping stable BCO mod:" <+> ppr this_mod_name)
 789                 return hmi
 790                 -- BCO is stable: nothing to do
 791
 792           | not (isObjectTarget target),
 793             Just hmi <- old_hmi,
 794             Just l <- hm_linkable hmi,
 795             not (isObjectLinkable l),
 796             (target /= HscNothing) `implies` not is_fake_linkable,
 797             linkableTime l >= ms_hs_date summary -> do
 798                 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
 799                            (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
 800                 compile_it (Just l)
 801                 -- we have an old BCO that is up to date with respect
 802                 -- to the source: do a recompilation check as normal.
 803
 804           -- When generating object code, if there's an up-to-date
 805           -- object file on the disk, then we can use it.
 806           -- However, if the object file is new (compared to any
 807           -- linkable we had from a previous compilation), then we
 808           -- must discard any in-memory interface, because this
 809           -- means the user has compiled the source file
 810           -- separately and generated a new interface, that we must
 811           -- read from the disk.
 812           --
 813           | isObjectTarget target,
 814             Just obj_date <- mb_obj_date,
 815             obj_date >= hs_date -> do
 816                 case old_hmi of
 817                   Just hmi
 818                     | Just l <- hm_linkable hmi,
 819                       isObjectLinkable l && linkableTime l == obj_date -> do
 820                           liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
 821                                      (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
 822                           compile_it (Just l)
 823                   _otherwise -> do
 824                           liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
 825                                      (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
 826                           linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
 827                           compile_it_discard_iface (Just linkable)
 828
 829          _otherwise -> do
 830                 liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
 831                            (text "compiling mod:" <+> ppr this_mod_name)
 832                 compile_it Nothing
 833
 834
 835
 836 -- Filter modules in the HPT
 837 retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
 838 retainInTopLevelEnvs keep_these hpt
 839    = listToUFM   [ (mod, expectJust "retain" mb_mod_info)
 840                  | mod <- keep_these
 841                  , let mb_mod_info = lookupUFM hpt mod
 842                  , isJust mb_mod_info ]
 843
 844 -- ---------------------------------------------------------------------------
 845 -- Typecheck module loops
 846
 847 {-
 848 See bug #930.  This code fixes a long-standing bug in --make.  The
 849 problem is that when compiling the modules *inside* a loop, a data
 850 type that is only defined at the top of the loop looks opaque; but
 851 after the loop is done, the structure of the data type becomes
 852 apparent.
 853
 854 The difficulty is then that two different bits of code have
 855 different notions of what the data type looks like.
 856
 857 The idea is that after we compile a module which also has an .hs-boot
 858 file, we re-generate the ModDetails for each of the modules that
 859 depends on the .hs-boot file, so that everyone points to the proper
 860 TyCons, Ids etc. defined by the real module, not the boot module.
 861 Fortunately re-generating a ModDetails from a ModIface is easy: the
 862 function TcIface.typecheckIface does exactly that.
 863
 864 Picking the modules to re-typecheck is slightly tricky.  Starting from
 865 the module graph consisting of the modules that have already been
 866 compiled, we reverse the edges (so they point from the imported module
 867 to the importing module), and depth-first-search from the .hs-boot
 868 node.  This gives us all the modules that depend transitively on the
 869 .hs-boot module, and those are exactly the modules that we need to
 870 re-typecheck.
 871
 872 Following this fix, GHC can compile itself with --make -O2.
 873 -}
 874
 875 reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
 876 reTypecheckLoop hsc_env ms graph
 877   | not (isBootSummary ms) &&
 878     any (\m -> ms_mod m == this_mod && isBootSummary m) graph
 879   = do
 880         let mss = reachableBackwards (ms_mod_name ms) graph
 881             non_boot = filter (not.isBootSummary) mss
 882         debugTraceMsg (hsc_dflags hsc_env) 2 $
 883            text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)
 884         typecheckLoop hsc_env (map ms_mod_name non_boot)
 885   | otherwise
 886   = return hsc_env
 887  where
 888   this_mod = ms_mod ms
 889
 890 typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv
 891 typecheckLoop hsc_env mods = do
 892   new_hpt <-
 893     fixIO $ \new_hpt -> do
 894       let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
 895       mds <- initIfaceCheck new_hsc_env $
 896                 mapM (typecheckIface . hm_iface) hmis
 897       let new_hpt = addListToUFM old_hpt
 898                         (zip mods [ hmi{ hm_details = details }
 899                                   | (hmi,details) <- zip hmis mds ])
 900       return new_hpt
 901   return hsc_env{ hsc_HPT = new_hpt }
 902   where
 903     old_hpt = hsc_HPT hsc_env
 904     hmis    = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods
 905
 906 reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
 907 reachableBackwards mod summaries
 908   = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
 909   where -- the rest just sets up the graph:
 910         (graph, lookup_node) = moduleGraphNodes False summaries
 911         root  = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
 912
 913 -- ---------------------------------------------------------------------------
 914 -- Topological sort of the module graph
 915
 916 type SummaryNode = (ModSummary, Int, [Int])
 917
 918 topSortModuleGraph
 919           :: Bool
 920           -- ^ Drop hi-boot nodes? (see below)
 921           -> [ModSummary]
 922           -> Maybe ModuleName
 923              -- ^ Root module name.  If @Nothing@, use the full graph.
 924           -> [SCC ModSummary]
 925 -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
 926 -- The resulting list of strongly-connected-components is in topologically
 927 -- sorted order, starting with the module(s) at the bottom of the
 928 -- dependency graph (ie compile them first) and ending with the ones at
 929 -- the top.
 930 --
 931 -- Drop hi-boot nodes (first boolean arg)?
 932 --
 933 -- - @False@:   treat the hi-boot summaries as nodes of the graph,
 934 --              so the graph must be acyclic
 935 --
 936 -- - @True@:    eliminate the hi-boot nodes, and instead pretend
 937 --              the a source-import of Foo is an import of Foo
 938 --              The resulting graph has no hi-boot nodes, but can be cyclic
 939
 940 topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
 941   = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
 942   where
 943     (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
 944
 945     initial_graph = case mb_root_mod of
 946         Nothing -> graph
 947         Just root_mod ->
 948             -- restrict the graph to just those modules reachable from
 949             -- the specified module.  We do this by building a graph with
 950             -- the full set of nodes, and determining the reachable set from
 951             -- the specified node.
 952             let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
 953                      | otherwise = ghcError (ProgramError "module does not exist")
 954             in graphFromEdgedVertices (seq root (reachableG graph root))
 955
 956 summaryNodeKey :: SummaryNode -> Int
 957 summaryNodeKey (_, k, _) = k
 958
 959 summaryNodeSummary :: SummaryNode -> ModSummary
 960 summaryNodeSummary (s, _, _) = s
 961
 962 moduleGraphNodes :: Bool -> [ModSummary]
 963   -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
 964 moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
 965   where
 966     numbered_summaries = zip summaries [1..]
 967
 968     lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
 969     lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map
 970
 971     lookup_key :: HscSource -> ModuleName -> Maybe Int
 972     lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
 973
 974     node_map :: NodeMap SummaryNode
 975     node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node)
 976                             | node@(s, _, _) <- nodes ]
 977
 978     -- We use integers as the keys for the SCC algorithm
 979     nodes :: [SummaryNode]
 980     nodes = [ (s, key, out_keys)
 981             | (s, key) <- numbered_summaries
 982              -- Drop the hi-boot ones if told to do so
 983             , not (isBootSummary s && drop_hs_boot_nodes)
 984             , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
 985                              out_edge_keys HsSrcFile   (map unLoc (ms_home_imps s)) ++
 986                              (-- see [boot-edges] below
 987                               if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
 988                               then []
 989                               else case lookup_key HsBootFile (ms_mod_name s) of
 990                                     Nothing -> []
 991                                     Just k  -> [k]) ]
 992
 993     -- [boot-edges] if this is a .hs and there is an equivalent
 994     -- .hs-boot, add a link from the former to the latter.  This
 995     -- has the effect of detecting bogus cases where the .hs-boot
 996     -- depends on the .hs, by introducing a cycle.  Additionally,
 997     -- it ensures that we will always process the .hs-boot before
 998     -- the .hs, and so the HomePackageTable will always have the
 999     -- most up to date information.
1000
1001     -- Drop hs-boot nodes by using HsSrcFile as the key
1002     hs_boot_key | drop_hs_boot_nodes = HsSrcFile
1003                 | otherwise          = HsBootFile
1004
1005     out_edge_keys :: HscSource -> [ModuleName] -> [Int]
1006     out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
1007         -- If we want keep_hi_boot_nodes, then we do lookup_key with
1008         -- the IsBootInterface parameter True; else False
1009
1010
1011 type NodeKey   = (ModuleName, HscSource)  -- The nodes of the graph are
1012 type NodeMap a = Map.Map NodeKey a        -- keyed by (mod, src_file_type) pairs
1013
1014 msKey :: ModSummary -> NodeKey
1015 msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
1016
1017 mkNodeMap :: [ModSummary] -> NodeMap ModSummary
1018 mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
1019
1020 nodeMapElts :: NodeMap a -> [a]
1021 nodeMapElts = Map.elems
1022
1023 -- | If there are {-# SOURCE #-} imports between strongly connected
1024 -- components in the topological sort, then those imports can
1025 -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
1026 -- were necessary, then the edge would be part of a cycle.
1027 warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
1028 warnUnnecessarySourceImports sccs = do
1029   logWarnings (listToBag (concatMap (check.flattenSCC) sccs))
1030   where check ms =
1031            let mods_in_this_cycle = map ms_mod_name ms in
1032            [ warn i | m <- ms, i <- ms_home_srcimps m,
1033                       unLoc i `notElem`  mods_in_this_cycle ]
1034
1035         warn :: Located ModuleName -> WarnMsg
1036         warn (L loc mod) =
1037            mkPlainErrMsg loc
1038                 (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")
1039                  <+> quotes (ppr mod))
1040
1041 -----------------------------------------------------------------------------
1042 -- Downsweep (dependency analysis)
1043
1044 -- Chase downwards from the specified root set, returning summaries
1045 -- for all home modules encountered.  Only follow source-import
1046 -- links.
1047
1048 -- We pass in the previous collection of summaries, which is used as a
1049 -- cache to avoid recalculating a module summary if the source is
1050 -- unchanged.
1051 --
1052 -- The returned list of [ModSummary] nodes has one node for each home-package
1053 -- module, plus one for any hs-boot files.  The imports of these nodes
1054 -- are all there, including the imports of non-home-package modules.
1055
1056 downsweep :: HscEnv
1057           -> [ModSummary]       -- Old summaries
1058           -> [ModuleName]       -- Ignore dependencies on these; treat
1059                                 -- them as if they were package modules
1060           -> Bool               -- True <=> allow multiple targets to have
1061                                 --          the same module name; this is
1062                                 --          very useful for ghc -M
1063           -> IO [ModSummary]
1064                 -- The elts of [ModSummary] all have distinct
1065                 -- (Modules, IsBoot) identifiers, unless the Bool is true
1066                 -- in which case there can be repeats
1067 downsweep hsc_env old_summaries excl_mods allow_dup_roots
1068    = do
1069        rootSummaries <- mapM getRootSummary roots
1070        let root_map = mkRootMap rootSummaries
1071        checkDuplicates root_map
1072        summs <- loop (concatMap msDeps rootSummaries) root_map
1073        return summs
1074      where
1075         roots = hsc_targets hsc_env
1076
1077         old_summary_map :: NodeMap ModSummary
1078         old_summary_map = mkNodeMap old_summaries
1079
1080         getRootSummary :: Target -> IO ModSummary
1081         getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
1082            = do exists <- liftIO $ doesFileExist file
1083                 if exists
1084                     then summariseFile hsc_env old_summaries file mb_phase
1085                                        obj_allowed maybe_buf
1086                     else throwOneError $ mkPlainErrMsg noSrcSpan $
1087                            text "can't find file:" <+> text file
1088         getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
1089            = do maybe_summary <- summariseModule hsc_env old_summary_map False
1090                                            (L rootLoc modl) obj_allowed
1091                                            maybe_buf excl_mods
1092                 case maybe_summary of
1093                    Nothing -> packageModErr modl
1094                    Just s  -> return s
1095
1096         rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
1097
1098         -- In a root module, the filename is allowed to diverge from the module
1099         -- name, so we have to check that there aren't multiple root files
1100         -- defining the same module (otherwise the duplicates will be silently
1101         -- ignored, leading to confusing behaviour).
1102         checkDuplicates :: NodeMap [ModSummary] -> IO ()
1103         checkDuplicates root_map
1104            | allow_dup_roots = return ()
1105            | null dup_roots  = return ()
1106            | otherwise       = liftIO $ multiRootsErr (head dup_roots)
1107            where
1108              dup_roots :: [[ModSummary]]        -- Each at least of length 2
1109              dup_roots = filterOut isSingleton (nodeMapElts root_map)
1110
1111         loop :: [(Located ModuleName,IsBootInterface)]
1112                         -- Work list: process these modules
1113              -> NodeMap [ModSummary]
1114                         -- Visited set; the range is a list because
1115                         -- the roots can have the same module names
1116                         -- if allow_dup_roots is True
1117              -> IO [ModSummary]
1118                         -- The result includes the worklist, except
1119                         -- for those mentioned in the visited set
1120         loop [] done      = return (concat (nodeMapElts done))
1121         loop ((wanted_mod, is_boot) : ss) done
1122           | Just summs <- Map.lookup key done
1123           = if isSingleton summs then
1124                 loop ss done
1125             else
1126                 do { multiRootsErr summs; return [] }
1127           | otherwise
1128           = do mb_s <- summariseModule hsc_env old_summary_map
1129                                        is_boot wanted_mod True
1130                                        Nothing excl_mods
1131                case mb_s of
1132                    Nothing -> loop ss done
1133                    Just s  -> loop (msDeps s ++ ss) (Map.insert key [s] done)
1134           where
1135             key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
1136
1137 -- XXX Does the (++) here need to be flipped?
1138 mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
1139 mkRootMap summaries = Map.insertListWith (flip (++))
1140                                          [ (msKey s, [s]) | s <- summaries ]
1141                                          Map.empty
1142
1143 msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
1144 -- (msDeps s) returns the dependencies of the ModSummary s.
1145 -- A wrinkle is that for a {-# SOURCE #-} import we return
1146 --      *both* the hs-boot file
1147 --      *and* the source file
1148 -- as "dependencies".  That ensures that the list of all relevant
1149 -- modules always contains B.hs if it contains B.hs-boot.
1150 -- Remember, this pass isn't doing the topological sort.  It's
1151 -- just gathering the list of all relevant ModSummaries
1152 msDeps s =
1153     concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ]
1154          ++ [ (m,False) | m <- ms_home_imps s ]
1155
1156 home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
1157 home_imps imps = [ ideclName i |  L _ i <- imps, isLocal (ideclPkgQual i) ]
1158   where isLocal Nothing = True
1159         isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
1160         isLocal _ = False
1161
1162 ms_home_allimps :: ModSummary -> [ModuleName]
1163 ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
1164
1165 ms_home_srcimps :: ModSummary -> [Located ModuleName]
1166 ms_home_srcimps = home_imps . ms_srcimps
1167
1168 ms_home_imps :: ModSummary -> [Located ModuleName]
1169 ms_home_imps = home_imps . ms_imps
1170
1171 -----------------------------------------------------------------------------
1172 -- Summarising modules
1173
1174 -- We have two types of summarisation:
1175 --
1176 --    * Summarise a file.  This is used for the root module(s) passed to
1177 --      cmLoadModules.  The file is read, and used to determine the root
1178 --      module name.  The module name may differ from the filename.
1179 --
1180 --    * Summarise a module.  We are given a module name, and must provide
1181 --      a summary.  The finder is used to locate the file in which the module
1182 --      resides.
1183
1184 summariseFile
1185         :: HscEnv
1186         -> [ModSummary]                 -- old summaries
1187         -> FilePath                     -- source file name
1188         -> Maybe Phase                  -- start phase
1189         -> Bool                         -- object code allowed?
1190         -> Maybe (StringBuffer,ClockTime)
1191         -> IO ModSummary
1192
1193 summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
1194         -- we can use a cached summary if one is available and the
1195         -- source file hasn't changed,  But we have to look up the summary
1196         -- by source file, rather than module name as we do in summarise.
1197    | Just old_summary <- findSummaryBySourceFile old_summaries file
1198    = do
1199         let location = ms_location old_summary
1200
1201                 -- return the cached summary if the source didn't change
1202         src_timestamp <- case maybe_buf of
1203                            Just (_,t) -> return t
1204                            Nothing    -> liftIO $ getModificationTime file
1205                 -- The file exists; we checked in getRootSummary above.
1206                 -- If it gets removed subsequently, then this
1207                 -- getModificationTime may fail, but that's the right
1208                 -- behaviour.
1209
1210         if ms_hs_date old_summary == src_timestamp
1211            then do -- update the object-file timestamp
1212                   obj_timestamp <-
1213                     if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1214                         || obj_allowed -- bug #1205
1215                         then liftIO $ getObjTimestamp location False
1216                         else return Nothing
1217                   return old_summary{ ms_obj_date = obj_timestamp }
1218            else
1219                 new_summary
1220
1221    | otherwise
1222    = new_summary
1223   where
1224     new_summary = do
1225         let dflags = hsc_dflags hsc_env
1226
1227         (dflags', hspp_fn, buf)
1228             <- preprocessFile hsc_env file mb_phase maybe_buf
1229
1230         (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
1231
1232         -- Make a ModLocation for this file
1233         location <- liftIO $ mkHomeModLocation dflags mod_name file
1234
1235         -- Tell the Finder cache where it is, so that subsequent calls
1236         -- to findModule will find it, even if it's not on any search path
1237         mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
1238
1239         src_timestamp <- case maybe_buf of
1240                            Just (_,t) -> return t
1241                            Nothing    -> liftIO $ getModificationTime file
1242                         -- getMofificationTime may fail
1243
1244         -- when the user asks to load a source file by name, we only
1245         -- use an object file if -fobject-code is on.  See #1205.
1246         obj_timestamp <-
1247             if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1248                || obj_allowed -- bug #1205
1249                 then liftIO $ modificationTimeIfExists (ml_obj_file location)
1250                 else return Nothing
1251
1252         return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
1253                              ms_location = location,
1254                              ms_hspp_file = hspp_fn,
1255                              ms_hspp_opts = dflags',
1256                              ms_hspp_buf  = Just buf,
1257                              ms_srcimps = srcimps, ms_imps = the_imps,
1258                              ms_hs_date = src_timestamp,
1259                              ms_obj_date = obj_timestamp })
1260
1261 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
1262 findSummaryBySourceFile summaries file
1263   = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
1264                                  expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
1265         [] -> Nothing
1266         (x:_) -> Just x
1267
1268 -- Summarise a module, and pick up source and timestamp.
1269 summariseModule
1270           :: HscEnv
1271           -> NodeMap ModSummary -- Map of old summaries
1272           -> IsBootInterface    -- True <=> a {-# SOURCE #-} import
1273           -> Located ModuleName -- Imported module to be summarised
1274           -> Bool               -- object code allowed?
1275           -> Maybe (StringBuffer, ClockTime)
1276           -> [ModuleName]               -- Modules to exclude
1277           -> IO (Maybe ModSummary)      -- Its new summary
1278
1279 summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
1280                 obj_allowed maybe_buf excl_mods
1281   | wanted_mod `elem` excl_mods
1282   = return Nothing
1283
1284   | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map
1285   = do          -- Find its new timestamp; all the
1286                 -- ModSummaries in the old map have valid ml_hs_files
1287         let location = ms_location old_summary
1288             src_fn = expectJust "summariseModule" (ml_hs_file location)
1289
1290                 -- check the modification time on the source file, and
1291                 -- return the cached summary if it hasn't changed.  If the
1292                 -- file has disappeared, we need to call the Finder again.
1293         case maybe_buf of
1294            Just (_,t) -> check_timestamp old_summary location src_fn t
1295            Nothing    -> do
1296                 m <- tryIO (getModificationTime src_fn)
1297                 case m of
1298                    Right t -> check_timestamp old_summary location src_fn t
1299                    Left e | isDoesNotExistError e -> find_it
1300                           | otherwise             -> ioError e
1301
1302   | otherwise  = find_it
1303   where
1304     dflags = hsc_dflags hsc_env
1305
1306     hsc_src = if is_boot then HsBootFile else HsSrcFile
1307
1308     check_timestamp old_summary location src_fn src_timestamp
1309         | ms_hs_date old_summary == src_timestamp = do
1310                 -- update the object-file timestamp
1311                 obj_timestamp <-
1312                     if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1313                        || obj_allowed -- bug #1205
1314                        then getObjTimestamp location is_boot
1315                        else return Nothing
1316                 return (Just old_summary{ ms_obj_date = obj_timestamp })
1317         | otherwise =
1318                 -- source changed: re-summarise.
1319                 new_summary location (ms_mod old_summary) src_fn src_timestamp
1320
1321     find_it = do
1322         -- Don't use the Finder's cache this time.  If the module was
1323         -- previously a package module, it may have now appeared on the
1324         -- search path, so we want to consider it to be a home module.  If
1325         -- the module was previously a home module, it may have moved.
1326         uncacheModule hsc_env wanted_mod
1327         found <- findImportedModule hsc_env wanted_mod Nothing
1328         case found of
1329              Found location mod
1330                 | isJust (ml_hs_file location) ->
1331                         -- Home package
1332                          just_found location mod
1333                 | otherwise ->
1334                         -- Drop external-pkg
1335                         ASSERT(modulePackageId mod /= thisPackage dflags)
1336                         return Nothing
1337
1338              err -> noModError dflags loc wanted_mod err
1339                         -- Not found
1340
1341     just_found location mod = do
1342                 -- Adjust location to point to the hs-boot source file,
1343                 -- hi file, object file, when is_boot says so
1344         let location' | is_boot   = addBootSuffixLocn location
1345                       | otherwise = location
1346             src_fn = expectJust "summarise2" (ml_hs_file location')
1347
1348                 -- Check that it exists
1349                 -- It might have been deleted since the Finder last found it
1350         maybe_t <- modificationTimeIfExists src_fn
1351         case maybe_t of
1352           Nothing -> noHsFileErr loc src_fn
1353           Just t  -> new_summary location' mod src_fn t
1354
1355
1356     new_summary location mod src_fn src_timestamp
1357       = do
1358         -- Preprocess the source file and get its imports
1359         -- The dflags' contains the OPTIONS pragmas
1360         (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
1361         (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
1362
1363         when (mod_name /= wanted_mod) $
1364                 throwOneError $ mkPlainErrMsg mod_loc $
1365                               text "File name does not match module name:"
1366                               $$ text "Saw:" <+> quotes (ppr mod_name)
1367                               $$ text "Expected:" <+> quotes (ppr wanted_mod)
1368
1369                 -- Find the object timestamp, and return the summary
1370         obj_timestamp <-
1371            if isObjectTarget (hscTarget (hsc_dflags hsc_env))
1372               || obj_allowed -- bug #1205
1373               then getObjTimestamp location is_boot
1374               else return Nothing
1375
1376         return (Just (ModSummary { ms_mod       = mod,
1377                               ms_hsc_src   = hsc_src,
1378                               ms_location  = location,
1379                               ms_hspp_file = hspp_fn,
1380                               ms_hspp_opts = dflags',
1381                               ms_hspp_buf  = Just buf,
1382                               ms_srcimps   = srcimps,
1383                               ms_imps      = the_imps,
1384                               ms_hs_date   = src_timestamp,
1385                               ms_obj_date  = obj_timestamp }))
1386
1387
1388 getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime)
1389 getObjTimestamp location is_boot
1390   = if is_boot then return Nothing
1391                else modificationTimeIfExists (ml_obj_file location)
1392
1393
1394 preprocessFile :: HscEnv
1395                -> FilePath
1396                -> Maybe Phase -- ^ Starting phase
1397                -> Maybe (StringBuffer,ClockTime)
1398                -> IO (DynFlags, FilePath, StringBuffer)
1399 preprocessFile hsc_env src_fn mb_phase Nothing
1400   = do
1401         (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
1402         buf <- hGetStringBuffer hspp_fn
1403         return (dflags', hspp_fn, buf)
1404
1405 preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
1406   = do
1407         let dflags = hsc_dflags hsc_env
1408         let local_opts = getOptions dflags buf src_fn
1409
1410         (dflags', leftovers, warns)
1411             <- parseDynamicNoPackageFlags dflags local_opts
1412         checkProcessArgsResult leftovers
1413         handleFlagWarnings dflags' warns
1414
1415         let needs_preprocessing
1416                 | Just (Unlit _) <- mb_phase    = True
1417                 | Nothing <- mb_phase, Unlit _ <- startPhase src_fn  = True
1418                   -- note: local_opts is only required if there's no Unlit phase
1419                 | xopt Opt_Cpp dflags'          = True
1420                 | dopt Opt_Pp  dflags'          = True
1421                 | otherwise                     = False
1422
1423         when needs_preprocessing $
1424            ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
1425
1426         return (dflags', src_fn, buf)
1427
1428
1429 -----------------------------------------------------------------------------
1430 --                      Error messages
1431 -----------------------------------------------------------------------------
1432
1433 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
1434 -- ToDo: we don't have a proper line number for this error
1435 noModError dflags loc wanted_mod err
1436   = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
1437
1438 noHsFileErr :: SrcSpan -> String -> IO a
1439 noHsFileErr loc path
1440   = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
1441
1442 packageModErr :: ModuleName -> IO a
1443 packageModErr mod
1444   = throwOneError $ mkPlainErrMsg noSrcSpan $
1445         text "module" <+> quotes (ppr mod) <+> text "is a package module"
1446
1447 multiRootsErr :: [ModSummary] -> IO ()
1448 multiRootsErr [] = panic "multiRootsErr"
1449 multiRootsErr summs@(summ1:_)
1450   = throwOneError $ mkPlainErrMsg noSrcSpan $
1451         text "module" <+> quotes (ppr mod) <+>
1452         text "is defined in multiple files:" <+>
1453         sep (map text files)
1454   where
1455     mod = ms_mod summ1
1456     files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
1457
1458 cyclicModuleErr :: [ModSummary] -> SDoc
1459 -- From a strongly connected component we find
1460 -- a single cycle to report
1461 cyclicModuleErr ms
1462   = ASSERT( not (null ms) )
1463     hang (ptext (sLit "Module imports form a cycle:"))
1464        2 (show_path (shortest [] root_mod))
1465   where
1466     deps :: [(ModuleName, [ModuleName])]
1467     deps = [ (moduleName (ms_mod m), get_deps m) | m <- ms ]
1468
1469     get_deps :: ModSummary -> [ModuleName]
1470     get_deps m = filter (\k -> Map.member k dep_env) (map unLoc (ms_home_imps m))
1471
1472     dep_env :: Map.Map ModuleName [ModuleName]
1473     dep_env = Map.fromList deps
1474
1475     -- Find the module with fewest imports among the SCC modules
1476     -- This is just a heuristic to find some plausible root module
1477     root_mod  :: ModuleName
1478     root_mod = fst (minWith (length . snd) deps)
1479
1480     shortest :: [ModuleName] -> ModuleName -> [ModuleName]
1481     -- (shortest [v1,v2,..,vn] m) assumes that
1482     --   m     is imported by v1
1483     --   which is imported by v2
1484     --   ...
1485     --   which is imported by vn
1486     -- It retuns an import chain [w1, w2, ..wm]
1487     -- where  w1 imports w2 imports .... imports wm imports w1
1488     shortest visited m
1489       | m `elem` visited
1490       = m : reverse (takeWhile (/= m) visited)
1491       | otherwise
1492       = minWith length (map (shortest (m:visited)) deps)
1493       where
1494         Just deps = Map.lookup m dep_env
1495
1496     show_path []         = panic "show_path"
1497     show_path [m]        = ptext (sLit "module") <+> quotes (ppr m)
1498                            <+> ptext (sLit "imports itself")
1499     show_path (m1:m2:ms) = ptext (sLit "module") <+> quotes (ppr m1)
1500                            <+> sep ( nest 6 (ptext (sLit "imports") <+> quotes (ppr m2))
1501                                    : go ms)
1502        where
1503          go []     =  [ptext (sLit "which imports") <+> quotes (ppr m1)]
1504          go (m:ms) = (ptext (sLit "which imports") <+> quotes (ppr m)) : go ms
1505
1506 minWith :: Ord b => (a -> b) -> [a] -> a
1507 minWith get_key xs = ASSERT( not (null xs) )
1508                      head (sortWith get_key xs)