GhcMake.hs 93.8 KB
Newer Older
1
{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-}
2 3 4 5
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
-- NB: we specifically ignore deprecations. GHC 7.6 marks the .QSem module as
-- deprecated, although it became un-deprecated later. As a result, using 7.6
-- as your bootstrap compiler throws annoying warnings.
6

Simon Marlow's avatar
Simon Marlow committed
7 8 9 10
-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 2011
--
dterei's avatar
dterei committed
11 12
-- This module implements multi-module compilation, and is used
-- by --make and GHCi.
Simon Marlow's avatar
Simon Marlow committed
13 14
--
-- -----------------------------------------------------------------------------
15 16
module GhcMake(
        depanal,
Edward Z. Yang's avatar
Edward Z. Yang committed
17
        load, load', LoadHowMuch(..),
Simon Marlow's avatar
Simon Marlow committed
18

19
        topSortModuleGraph,
Simon Marlow's avatar
Simon Marlow committed
20

21 22
        ms_home_srcimps, ms_home_imps,

Edward Z. Yang's avatar
Edward Z. Yang committed
23 24 25 26 27 28
        IsBoot(..),
        summariseModule,
        hscSourceToIsBoot,
        findExtraSigImports,
        implicitRequirements,

dterei's avatar
dterei committed
29 30
        noModError, cyclicModuleErr
    ) where
Simon Marlow's avatar
Simon Marlow committed
31 32 33

#include "HsVersions.h"

dterei's avatar
dterei committed
34
import qualified Linker         ( unload )
Simon Marlow's avatar
Simon Marlow committed
35 36

import DriverPhases
dterei's avatar
dterei committed
37
import DriverPipeline
Simon Marlow's avatar
Simon Marlow committed
38
import DynFlags
dterei's avatar
dterei committed
39
import ErrUtils
Simon Marlow's avatar
Simon Marlow committed
40
import Finder
dterei's avatar
dterei committed
41
import GhcMonad
Simon Marlow's avatar
Simon Marlow committed
42
import HeaderInfo
dterei's avatar
dterei committed
43 44
import HscTypes
import Module
dterei's avatar
dterei committed
45 46
import TcIface          ( typecheckIface )
import TcRnMonad        ( initIfaceCheck )
Edward Z. Yang's avatar
Edward Z. Yang committed
47
import HscMain
Simon Marlow's avatar
Simon Marlow committed
48

dterei's avatar
dterei committed
49
import Bag              ( listToBag )
Simon Marlow's avatar
Simon Marlow committed
50 51
import BasicTypes
import Digraph
parcs's avatar
parcs committed
52
import Exception        ( tryIO, gbracket, gfinally )
Simon Marlow's avatar
Simon Marlow committed
53
import FastString
Icelandjack's avatar
Icelandjack committed
54
import Maybes           ( expectJust )
55
import Name
56
import MonadUtils       ( allM, MonadIO )
Simon Marlow's avatar
Simon Marlow committed
57
import Outputable
dterei's avatar
dterei committed
58 59 60 61
import Panic
import SrcLoc
import StringBuffer
import SysTools
Simon Marlow's avatar
Simon Marlow committed
62
import UniqFM
Edward Z. Yang's avatar
Edward Z. Yang committed
63 64 65 66
import UniqDSet
import TcBackpack
import Packages
import UniqSet
dterei's avatar
dterei committed
67
import Util
68
import qualified GHC.LanguageExtensions as LangExt
69
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
70

71
import Data.Either ( rights, partitionEithers )
Simon Marlow's avatar
Simon Marlow committed
72
import qualified Data.Map as Map
73 74
import Data.Map (Map)
import qualified Data.Set as Set
dterei's avatar
dterei committed
75
import qualified FiniteMap as Map ( insertListWith )
Simon Marlow's avatar
Simon Marlow committed
76

parcs's avatar
parcs committed
77
import Control.Concurrent ( forkIOWithUnmask, killThread )
78
import qualified GHC.Conc as CC
parcs's avatar
parcs committed
79 80 81
import Control.Concurrent.MVar
import Control.Concurrent.QSem
import Control.Exception
Simon Marlow's avatar
Simon Marlow committed
82
import Control.Monad
83
import Data.IORef
Simon Marlow's avatar
Simon Marlow committed
84 85
import Data.List
import qualified Data.List as List
dterei's avatar
dterei committed
86
import Data.Maybe
parcs's avatar
parcs committed
87
import Data.Ord ( comparing )
88
import Data.Time
dterei's avatar
dterei committed
89 90 91 92
import System.Directory
import System.FilePath
import System.IO        ( fixIO )
import System.IO.Error  ( isDoesNotExistError )
Simon Marlow's avatar
Simon Marlow committed
93

parcs's avatar
parcs committed
94 95
import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )

96 97 98 99 100
label_self :: String -> IO ()
label_self thread_name = do
    self_tid <- CC.myThreadId
    CC.labelThread self_tid thread_name

Simon Marlow's avatar
Simon Marlow committed
101 102 103 104 105 106 107 108 109 110 111
-- -----------------------------------------------------------------------------
-- Loading the program

-- | Perform a dependency analysis starting from the current targets
-- and update the session with the new module graph.
--
-- Dependency analysis entails parsing the @import@ directives and may
-- therefore require running certain preprocessors.
--
-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.
-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the
thomie's avatar
thomie committed
112
-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want
Simon Marlow's avatar
Simon Marlow committed
113 114 115 116 117 118 119 120 121 122
-- changes to the 'DynFlags' to take effect you need to call this function
-- again.
--
depanal :: GhcMonad m =>
           [ModuleName]  -- ^ excluded modules
        -> Bool          -- ^ allow duplicate roots
        -> m ModuleGraph
depanal excluded_mods allow_dup_roots = do
  hsc_env <- getSession
  let
dterei's avatar
dterei committed
123 124 125
         dflags  = hsc_dflags hsc_env
         targets = hsc_targets hsc_env
         old_graph = hsc_mod_graph hsc_env
126

127 128 129 130 131 132 133 134
  withTiming (pure dflags) (text "Chasing dependencies") (const ()) $ do
    liftIO $ debugTraceMsg dflags 2 (hcat [
              text "Chasing modules from: ",
              hcat (punctuate comma (map pprTarget targets))])

    mod_graphE <- liftIO $ downsweep hsc_env old_graph
                                     excluded_mods allow_dup_roots
    mod_graph <- reportImportErrors mod_graphE
Yuras's avatar
Yuras committed
135 136 137

    warnMissingHomeModules hsc_env mod_graph

138
    setSession hsc_env { hsc_mod_graph = mod_graph }
139
    return mod_graph
Simon Marlow's avatar
Simon Marlow committed
140

Yuras's avatar
Yuras committed
141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173
-- Note [Missing home modules]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Sometimes user doesn't want GHC to pick up modules, not explicitly listed
-- in a command line. For example, cabal may want to enable this warning
-- when building a library, so that GHC warns user about modules, not listed
-- neither in `exposed-modules`, nor in `other-modules`.
--
-- Here "home module" means a module, that doesn't come from an other package.
--
-- For example, if GHC is invoked with modules "A" and "B" as targets,
-- but "A" imports some other module "C", then GHC will issue a warning
-- about module "C" not being listed in a command line.
--
-- The warning in enabled by `-Wmissing-home-modules`. See Trac #13129
warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m ()
warnMissingHomeModules hsc_env mod_graph =
    when (wopt Opt_WarnMissingHomeModules dflags && not (null missing)) $
        logWarnings (listToBag [warn])
    where
    dflags = hsc_dflags hsc_env
    missing = filter (`notElem` targets) imports
    imports = map (moduleName . ms_mod) mod_graph
    targets = map (targetid_to_name . targetId) (hsc_targets hsc_env)

    msg = text "Modules are not listed in command line: "
        <> sep (map ppr missing)
    warn = makeIntoWarning
      (Reason Opt_WarnMissingHomeModules)
      (mkPlainErrMsg dflags noSrcSpan msg)

    targetid_to_name (TargetModule name) = name
    targetid_to_name (TargetFile file _) =
      -- We can get a file even if module name in specified in command line
174
      -- because it can be converted in guessTarget. So let's convert it back.
Yuras's avatar
Yuras committed
175 176
      mkModuleName (fst $ splitExtension file)

Simon Marlow's avatar
Simon Marlow committed
177 178 179 180 181 182 183 184 185 186 187 188 189 190
-- | Describes which modules of the module graph need to be loaded.
data LoadHowMuch
   = LoadAllTargets
     -- ^ Load all targets and its dependencies.
   | LoadUpTo ModuleName
     -- ^ Load only the given module and its dependencies.
   | LoadDependenciesOf ModuleName
     -- ^ Load only the dependencies of the given module, but not the module
     -- itself.

-- | Try to load the program.  See 'LoadHowMuch' for the different modes.
--
-- This function implements the core of GHC's @--make@ mode.  It preprocesses,
-- compiles and loads the specified modules, avoiding re-compilation wherever
Ben Gamari's avatar
Ben Gamari committed
191
-- possible.  Depending on the target (see 'DynFlags.hscTarget') compiling
Simon Marlow's avatar
Simon Marlow committed
192 193
-- and loading may result in files being created on disk.
--
194 195
-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether
-- successful or not.
Simon Marlow's avatar
Simon Marlow committed
196 197 198
--
-- Throw a 'SourceError' if errors are encountered before the actual
-- compilation starts (e.g., during dependency analysis).  All other errors
199
-- are reported using the 'defaultWarnErrLogger'.
Simon Marlow's avatar
Simon Marlow committed
200 201 202
--
load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
load how_much = do
dterei's avatar
dterei committed
203
    mod_graph <- depanal [] False
Edward Z. Yang's avatar
Edward Z. Yang committed
204 205 206 207 208 209 210 211
    load' how_much (Just batchMsg) mod_graph

-- | Generalized version of 'load' which also supports a custom
-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
-- produced by calling 'depanal'.
load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag
load' how_much mHscMessage mod_graph = do
    modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }
dterei's avatar
dterei committed
212 213 214 215 216 217 218 219 220 221
    guessOutputFile
    hsc_env <- getSession

    let hpt1   = hsc_HPT hsc_env
    let dflags = hsc_dflags hsc_env

    -- The "bad" boot modules are the ones for which we have
    -- B.hs-boot in the module graph, but no B.hs
    -- The downsweep should have ensured this does not happen
    -- (see msDeps)
222
    let all_home_mods = [ms_mod_name s
dterei's avatar
dterei committed
223
                        | s <- mod_graph, not (isBootSummary s)]
Edward Z. Yang's avatar
Edward Z. Yang committed
224 225 226 227 228 229
    -- TODO: Figure out what the correct form of this assert is. It's violated
    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot
    -- files without corresponding hs files.
    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,
    --                              not (ms_mod_name s `elem` all_home_mods)]
    -- ASSERT( null bad_boot_mods ) return ()
dterei's avatar
dterei committed
230 231 232 233 234 235 236 237 238

    -- check that the module given in HowMuch actually exists, otherwise
    -- topSortModuleGraph will bomb later.
    let checkHowMuch (LoadUpTo m)           = checkMod m
        checkHowMuch (LoadDependenciesOf m) = checkMod m
        checkHowMuch _ = id

        checkMod m and_then
            | m `elem` all_home_mods = and_then
239
            | otherwise = do
dterei's avatar
dterei committed
240 241 242 243 244 245
                    liftIO $ errorMsg dflags (text "no such module:" <+>
                                     quotes (ppr m))
                    return Failed

    checkHowMuch how_much $ do

246
    -- mg2_with_srcimps drops the hi-boot nodes, returning a
dterei's avatar
dterei committed
247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264
    -- graph with cycles.  Among other things, it is used for
    -- backing out partially complete cycles following a failed
    -- upsweep, and for removing from hpt all the modules
    -- not in strict downwards closure, during calls to compile.
    let mg2_with_srcimps :: [SCC ModSummary]
        mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing

    -- If we can determine that any of the {-# SOURCE #-} imports
    -- are definitely unnecessary, then emit a warning.
    warnUnnecessarySourceImports mg2_with_srcimps

    let
        -- check the stability property for each module.
        stable_mods@(stable_obj,stable_bco)
            = checkStability hpt1 mg2_with_srcimps all_home_mods

        -- prune bits of the HPT which are definitely redundant now,
        -- to save space.
265
        pruned_hpt = pruneHomePackageTable hpt1
dterei's avatar
dterei committed
266 267 268 269 270 271 272 273
                            (flattenSCCs mg2_with_srcimps)
                            stable_mods

    _ <- liftIO $ evaluate pruned_hpt

    -- before we unload anything, make sure we don't leave an old
    -- interactive context around pointing to dead bindings.  Also,
    -- write the pruned HPT to allow the old HPT to be GC'd.
274
    setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt }
dterei's avatar
dterei committed
275 276 277 278 279 280 281

    liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
                            text "Stable BCO:" <+> ppr stable_bco)

    -- Unload any modules which are going to be re-linked this time around.
    let stable_linkables = [ linkable
                           | m <- stable_obj++stable_bco,
niteria's avatar
niteria committed
282
                             Just hmi <- [lookupHpt pruned_hpt m],
dterei's avatar
dterei committed
283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317
                             Just linkable <- [hm_linkable hmi] ]
    liftIO $ unload hsc_env stable_linkables

    -- We could at this point detect cycles which aren't broken by
    -- a source-import, and complain immediately, but it seems better
    -- to let upsweep_mods do this, so at least some useful work gets
    -- done before the upsweep is abandoned.
    --hPutStrLn stderr "after tsort:\n"
    --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))

    -- Now do the upsweep, calling compile for each module in
    -- turn.  Final result is version 3 of everything.

    -- Topologically sort the module graph, this time including hi-boot
    -- nodes, and possibly just including the portion of the graph
    -- reachable from the module specified in the 2nd argument to load.
    -- This graph should be cycle-free.
    -- If we're restricting the upsweep to a portion of the graph, we
    -- also want to retain everything that is still stable.
    let full_mg :: [SCC ModSummary]
        full_mg    = topSortModuleGraph False mod_graph Nothing

        maybe_top_mod = case how_much of
                            LoadUpTo m           -> Just m
                            LoadDependenciesOf m -> Just m
                            _                    -> Nothing

        partial_mg0 :: [SCC ModSummary]
        partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod

        -- LoadDependenciesOf m: we want the upsweep to stop just
        -- short of the specified module (unless the specified module
        -- is stable).
        partial_mg
            | LoadDependenciesOf _mod <- how_much
318
            = ASSERT( case last partial_mg0 of
dterei's avatar
dterei committed
319 320 321 322 323
                        AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
              List.init partial_mg0
            | otherwise
            = partial_mg0

324
        stable_mg =
dterei's avatar
dterei committed
325 326
            [ AcyclicSCC ms
            | AcyclicSCC ms <- full_mg,
327
              ms_mod_name ms `elem` stable_obj++stable_bco ]
328

329 330 331 332 333 334 335 336 337 338
        -- the modules from partial_mg that are not also stable
        -- NB. also keep cycles, we need to emit an error message later
        unstable_mg = filter not_stable partial_mg
          where not_stable (CyclicSCC _) = True
                not_stable (AcyclicSCC ms)
                   = ms_mod_name ms `notElem` stable_obj++stable_bco

        -- Load all the stable modules first, before attempting to load
        -- an unstable module (#7231).
        mg = stable_mg ++ unstable_mg
dterei's avatar
dterei committed
339 340

    -- clean up between compilations
parcs's avatar
parcs committed
341
    let cleanup hsc_env = intermediateCleanTempFiles (hsc_dflags hsc_env)
dterei's avatar
dterei committed
342 343 344 345 346 347
                              (flattenSCCs mg2_with_srcimps)
                              hsc_env

    liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
                               2 (ppr mg))

348
    n_jobs <- case parMakeCount dflags of
parcs's avatar
parcs committed
349 350 351 352 353
                    Nothing -> liftIO getNumProcessors
                    Just n  -> return n
    let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs
                   | otherwise  = upsweep

dterei's avatar
dterei committed
354 355
    setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
    (upsweep_ok, modsUpswept)
Edward Z. Yang's avatar
Edward Z. Yang committed
356
       <- upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg
dterei's avatar
dterei committed
357 358 359 360 361 362 363 364 365 366 367 368

    -- Make modsDone be the summaries for each home module now
    -- available; this should equal the domain of hpt3.
    -- Get in in a roughly top .. bottom order (hence reverse).

    let modsDone = reverse modsUpswept

    -- Try and do linking in some form, depending on whether the
    -- upsweep was completely or only partially successful.

    if succeeded upsweep_ok

369
     then
dterei's avatar
dterei committed
370 371 372 373 374 375 376 377 378 379 380 381 382 383
       -- Easy; just relink it all.
       do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")

          -- Clean up after ourselves
          hsc_env1 <- getSession
          liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1

          -- Issue a warning for the confusing case where the user
          -- said '-o foo' but we're not going to do any linking.
          -- We attempt linking if either (a) one of the modules is
          -- called Main, or (b) the user said -no-hs-main, indicating
          -- that main() is going to come from somewhere else.
          --
          let ofile = outputFile dflags
ian@well-typed.com's avatar
ian@well-typed.com committed
384
          let no_hs_main = gopt Opt_NoHsMain dflags
385
          let
dterei's avatar
dterei committed
386 387
            main_mod = mainModIs dflags
            a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
388
            do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib
dterei's avatar
dterei committed
389 390 391 392

          -- link everything together
          linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)

393 394 395 396 397 398 399 400 401 402 403
          if ghcLink dflags == LinkBinary && isJust ofile && not do_linking
             then do
                liftIO $ errorMsg dflags $ text
                   ("output was redirected with -o, " ++
                    "but no output will be generated\n" ++
                    "because there is no " ++
                    moduleNameString (moduleName main_mod) ++ " module.")
                -- This should be an error, not a warning (#10895).
                loadFinish Failed linkresult
             else
                loadFinish Succeeded linkresult
dterei's avatar
dterei committed
404

405
     else
dterei's avatar
dterei committed
406 407 408 409 410 411 412
       -- Tricky.  We need to back out the effects of compiling any
       -- half-done cycles, both so as to clean up the top level envs
       -- and to avoid telling the interactive linker to link them.
       do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")

          let modsDone_names
                 = map ms_mod modsDone
413 414
          let mods_to_zap_names
                 = findPartiallyCompletedCycles modsDone_names
dterei's avatar
dterei committed
415 416
                      mg2_with_srcimps
          let mods_to_keep
417
                 = filter ((`notElem` mods_to_zap_names).ms_mod)
dterei's avatar
dterei committed
418 419 420
                      modsDone

          hsc_env1 <- getSession
421
          let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
dterei's avatar
dterei committed
422 423 424 425 426 427
                                          (hsc_HPT hsc_env1)

          -- Clean up after ourselves
          liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1

          -- there should be no Nothings where linkables should be, now
428 429
          let just_linkables =
                    isNoLink (ghcLink dflags)
niteria's avatar
niteria committed
430 431 432
                 || allHpt (isJust.hm_linkable)
                        (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)
                                hpt4)
433
          ASSERT( just_linkables ) do
434

dterei's avatar
dterei committed
435 436
          -- Link everything together
          linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
Simon Marlow's avatar
Simon Marlow committed
437

dterei's avatar
dterei committed
438 439
          modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 }
          loadFinish Failed linkresult
Simon Marlow's avatar
Simon Marlow committed
440 441


dterei's avatar
dterei committed
442 443
-- | Finish up after a load.
loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag
Simon Marlow's avatar
Simon Marlow committed
444 445 446 447 448 449 450 451 452 453 454

-- If the link failed, unload everything and return.
loadFinish _all_ok Failed
  = do hsc_env <- getSession
       liftIO $ unload hsc_env []
       modifySession discardProg
       return Failed

-- Empty the interactive context and set the module context to the topmost
-- newly loaded module, or the Prelude if none were loaded.
loadFinish all_ok Succeeded
455
  = do modifySession discardIC
Simon Marlow's avatar
Simon Marlow committed
456 457 458
       return all_ok


dterei's avatar
dterei committed
459
-- | Forget the current program, but retain the persistent info in HscEnv
Simon Marlow's avatar
Simon Marlow committed
460 461
discardProg :: HscEnv -> HscEnv
discardProg hsc_env
462 463 464
  = discardIC $ hsc_env { hsc_mod_graph = emptyMG
                        , hsc_HPT = emptyHomePackageTable }

465 466 467
-- | Discard the contents of the InteractiveContext, but keep the DynFlags.
-- It will also keep ic_int_print and ic_monad if their names are from
-- external packages.
468 469
discardIC :: HscEnv -> HscEnv
discardIC hsc_env
470 471
  = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print
                                , ic_monad = new_ic_monad } }
472
  where
473 474 475
  -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic
  !new_ic_int_print = keep_external_name ic_int_print
  !new_ic_monad = keep_external_name ic_monad
476 477
  dflags = ic_dflags old_ic
  old_ic = hsc_IC hsc_env
478
  empty_ic = emptyInteractiveContext dflags
479 480
  keep_external_name ic_name
    | nameIsFromExternalPackage this_pkg old_name = old_name
481
    | otherwise = ic_name empty_ic
482 483 484
    where
    this_pkg = thisPackage dflags
    old_name = ic_name old_ic
Simon Marlow's avatar
Simon Marlow committed
485

486 487
intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO ()
intermediateCleanTempFiles dflags summaries hsc_env
488 489
 = do notIntermediate <- readIORef (filesToNotIntermediateClean dflags)
      cleanTempFilesExcept dflags (notIntermediate ++ except)
490 491 492 493 494 495 496 497 498 499 500 501
  where
    except =
          -- Save preprocessed files. The preprocessed file *might* be
          -- the same as the source file, but that doesn't do any
          -- harm.
          map ms_hspp_file summaries ++
          -- Save object files for loaded modules.  The point of this
          -- is that we might have generated and compiled a stub C
          -- file, and in the case of GHCi the object file will be a
          -- temporary file which we must not remove because we need
          -- to load/link it later.
          hptObjs (hsc_HPT hsc_env)
Simon Marlow's avatar
Simon Marlow committed
502 503 504 505 506 507

-- | If there is no -o option, guess the name of target executable
-- by using top-level source file name as a base.
guessOutputFile :: GhcMonad m => m ()
guessOutputFile = modifySession $ \env ->
    let dflags = hsc_dflags env
508 509
        -- Force mod_graph to avoid leaking env
        !mod_graph = hsc_mod_graph env
Simon Marlow's avatar
Simon Marlow committed
510 511 512 513 514 515 516
        mainModuleSrcPath :: Maybe String
        mainModuleSrcPath = do
            let isMain = (== mainModIs dflags) . ms_mod
            [ms] <- return (filter isMain mod_graph)
            ml_hs_file (ms_location ms)
        name = fmap dropExtension mainModuleSrcPath

517
        name_exe = do
Simon Marlow's avatar
Simon Marlow committed
518
#if defined(mingw32_HOST_OS)
Gabor Greif's avatar
Gabor Greif committed
519
          -- we must add the .exe extension unconditionally here, otherwise
520 521 522
          -- when name has an extension of its own, the .exe extension will
          -- not be added by DriverPipeline.exeFileName.  See #2248
          name' <- fmap (<.> "exe") name
Simon Marlow's avatar
Simon Marlow committed
523
#else
524
          name' <- name
Simon Marlow's avatar
Simon Marlow committed
525
#endif
526 527 528 529 530 531 532
          mainModuleSrcPath' <- mainModuleSrcPath
          -- #9930: don't clobber input files (unless they ask for it)
          if name' == mainModuleSrcPath'
            then throwGhcException . UsageError $
                 "default output name would overwrite the input file; " ++
                 "must specify -o explicitly"
            else Just name'
Simon Marlow's avatar
Simon Marlow committed
533 534 535 536 537 538
    in
    case outputFile dflags of
        Just _ -> env
        Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }

-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
539
--
Simon Marlow's avatar
Simon Marlow committed
540 541 542 543 544
-- | Prune the HomePackageTable
--
-- Before doing an upsweep, we can throw away:
--
--   - For non-stable modules:
dterei's avatar
dterei committed
545
--      - all ModDetails, all linked code
Simon Marlow's avatar
Simon Marlow committed
546 547 548 549 550 551 552
--   - all unlinked code that is out of date with respect to
--     the source file
--
-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
-- space at the end of the upsweep, because the topmost ModDetails of the
-- old HPT holds on to the entire type environment from the previous
-- compilation.
dterei's avatar
dterei committed
553 554 555 556
pruneHomePackageTable :: HomePackageTable
                      -> [ModSummary]
                      -> ([ModuleName],[ModuleName])
                      -> HomePackageTable
Simon Marlow's avatar
Simon Marlow committed
557
pruneHomePackageTable hpt summ (stable_obj, stable_bco)
niteria's avatar
niteria committed
558
  = mapHpt prune hpt
Simon Marlow's avatar
Simon Marlow committed
559
  where prune hmi
dterei's avatar
dterei committed
560 561 562 563 564 565 566 567 568
          | is_stable modl = hmi'
          | otherwise      = hmi'{ hm_details = emptyModDetails }
          where
           modl = moduleName (mi_module (hm_iface hmi))
           hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
                = hmi{ hm_linkable = Nothing }
                | otherwise
                = hmi
                where ms = expectJust "prune" (lookupUFM ms_map modl)
Simon Marlow's avatar
Simon Marlow committed
569 570 571

        ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]

dterei's avatar
dterei committed
572
        is_stable m = m `elem` stable_obj || m `elem` stable_bco
Simon Marlow's avatar
Simon Marlow committed
573 574

-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
575 576 577
--
-- | Return (names of) all those in modsDone who are part of a cycle as defined
-- by theGraph.
Simon Marlow's avatar
Simon Marlow committed
578 579 580 581 582 583 584 585
findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
findPartiallyCompletedCycles modsDone theGraph
   = chew theGraph
     where
        chew [] = []
        chew ((AcyclicSCC _):rest) = chew rest    -- acyclic?  not interesting.
        chew ((CyclicSCC vs):rest)
           = let names_in_this_cycle = nub (map ms_mod vs)
586 587
                 mods_in_this_cycle
                    = nub ([done | done <- modsDone,
Simon Marlow's avatar
Simon Marlow committed
588 589
                                   done `elem` names_in_this_cycle])
                 chewed_rest = chew rest
590
             in
Simon Marlow's avatar
Simon Marlow committed
591 592 593 594 595 596 597
             if   notNull mods_in_this_cycle
                  && length mods_in_this_cycle < length names_in_this_cycle
             then mods_in_this_cycle ++ chewed_rest
             else chewed_rest


-- ---------------------------------------------------------------------------
dterei's avatar
dterei committed
598 599
--
-- | Unloading
Simon Marlow's avatar
Simon Marlow committed
600
unload :: HscEnv -> [Linkable] -> IO ()
dterei's avatar
dterei committed
601
unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
Simon Marlow's avatar
Simon Marlow committed
602
  = case ghcLink (hsc_dflags hsc_env) of
603
        LinkInMemory -> Linker.unload hsc_env stable_linkables
dterei's avatar
dterei committed
604
        _other -> return ()
Simon Marlow's avatar
Simon Marlow committed
605 606 607 608 609 610

-- -----------------------------------------------------------------------------
{- |

  Stability tells us which modules definitely do not need to be recompiled.
  There are two main reasons for having stability:
611

Simon Marlow's avatar
Simon Marlow committed
612 613 614 615 616 617 618 619 620 621 622 623 624 625
   - avoid doing a complete upsweep of the module graph in GHCi when
     modules near the bottom of the tree have not changed.

   - to tell GHCi when it can load object code: we can only load object code
     for a module when we also load object code fo  all of the imports of the
     module.  So we need to know that we will definitely not be recompiling
     any of these modules, and we can use the object code.

  The stability check is as follows.  Both stableObject and
  stableBCO are used during the upsweep phase later.

@
  stable m = stableObject m || stableBCO m

626
  stableObject m =
dterei's avatar
dterei committed
627 628 629
        all stableObject (imports m)
        && old linkable does not exist, or is == on-disk .o
        && date(on-disk .o) > date(.hs)
Simon Marlow's avatar
Simon Marlow committed
630 631

  stableBCO m =
dterei's avatar
dterei committed
632 633
        all stable (imports m)
        && date(BCO) > date(.hs)
Simon Marlow's avatar
Simon Marlow committed
634 635 636 637 638 639
@

  These properties embody the following ideas:

    - if a module is stable, then:

dterei's avatar
dterei committed
640 641
        - if it has been compiled in a previous pass (present in HPT)
          then it does not need to be compiled or re-linked.
Simon Marlow's avatar
Simon Marlow committed
642 643

        - if it has not been compiled in a previous pass,
dterei's avatar
dterei committed
644 645
          then we only need to read its .hi file from disk and
          link it to produce a 'ModDetails'.
Simon Marlow's avatar
Simon Marlow committed
646 647 648 649 650 651 652 653

    - if a modules is not stable, we will definitely be at least
      re-linking, and possibly re-compiling it during the 'upsweep'.
      All non-stable modules can (and should) therefore be unlinked
      before the 'upsweep'.

    - Note that objects are only considered stable if they only depend
      on other objects.  We can't link object code against byte code.
654 655 656 657 658

    - Note that even if an object is stable, we may end up recompiling
      if the interface is out of date because an *external* interface
      has changed.  The current code in GhcMake handles this case
      fairly poorly, so be careful.
Simon Marlow's avatar
Simon Marlow committed
659 660
-}
checkStability
dterei's avatar
dterei committed
661 662 663 664 665
        :: HomePackageTable   -- HPT from last compilation
        -> [SCC ModSummary]   -- current module graph (cyclic)
        -> [ModuleName]       -- all home modules
        -> ([ModuleName],     -- stableObject
            [ModuleName])     -- stableBCO
Simon Marlow's avatar
Simon Marlow committed
666 667 668 669 670 671 672 673

checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
  where
   checkSCC (stable_obj, stable_bco) scc0
     | stableObjects = (scc_mods ++ stable_obj, stable_bco)
     | stableBCOs    = (stable_obj, scc_mods ++ stable_bco)
     | otherwise     = (stable_obj, stable_bco)
     where
dterei's avatar
dterei committed
674 675 676
        scc = flattenSCC scc0
        scc_mods = map ms_mod_name scc
        home_module m   = m `elem` all_home_mods && m `notElem` scc_mods
Simon Marlow's avatar
Simon Marlow committed
677 678

        scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))
dterei's avatar
dterei committed
679
            -- all imports outside the current SCC, but in the home pkg
680

dterei's avatar
dterei committed
681 682 683
        stable_obj_imps = map (`elem` stable_obj) scc_allimps
        stable_bco_imps = map (`elem` stable_bco) scc_allimps

684
        stableObjects =
dterei's avatar
dterei committed
685 686 687
           and stable_obj_imps
           && all object_ok scc

688
        stableBCOs =
dterei's avatar
dterei committed
689 690 691 692
           and (zipWith (||) stable_obj_imps stable_bco_imps)
           && all bco_ok scc

        object_ok ms
ian@well-typed.com's avatar
ian@well-typed.com committed
693
          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False
694
          | Just t <- ms_obj_date ms  =  t >= ms_hs_date ms
dterei's avatar
dterei committed
695 696 697
                                         && same_as_prev t
          | otherwise = False
          where
niteria's avatar
niteria committed
698
             same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of
dterei's avatar
dterei committed
699 700 701 702 703
                                Just hmi  | Just l <- hm_linkable hmi
                                 -> isObjectLinkable l && t == linkableTime l
                                _other  -> True
                -- why '>=' rather than '>' above?  If the filesystem stores
                -- times to the nearset second, we may occasionally find that
704
                -- the object & source have the same modification time,
dterei's avatar
dterei committed
705 706 707
                -- especially if the source was automatically generated
                -- and compiled.  Using >= is slightly unsafe, but it matches
                -- make's behaviour.
Simon Marlow's avatar
comment  
Simon Marlow committed
708 709 710
                --
                -- But see #5527, where someone ran into this and it caused
                -- a problem.
Simon Marlow's avatar
Simon Marlow committed
711

dterei's avatar
dterei committed
712
        bco_ok ms
ian@well-typed.com's avatar
ian@well-typed.com committed
713
          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False
niteria's avatar
niteria committed
714
          | otherwise = case lookupHpt hpt (ms_mod_name ms) of
dterei's avatar
dterei committed
715
                Just hmi  | Just l <- hm_linkable hmi ->
716
                        not (isObjectLinkable l) &&
dterei's avatar
dterei committed
717 718
                        linkableTime l >= ms_hs_date ms
                _other  -> False
Simon Marlow's avatar
Simon Marlow committed
719

parcs's avatar
parcs committed
720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746
{- Parallel Upsweep
 -
 - The parallel upsweep attempts to concurrently compile the modules in the
 - compilation graph using multiple Haskell threads.
 -
 - The Algorithm
 -
 - A Haskell thread is spawned for each module in the module graph, waiting for
 - its direct dependencies to finish building before it itself begins to build.
 -
 - Each module is associated with an initially empty MVar that stores the
 - result of that particular module's compile. If the compile succeeded, then
 - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that
 - module, and the module's HMI is deleted from the old HPT (synchronized by an
 - IORef) to save space.
 -
 - Instead of immediately outputting messages to the standard handles, all
 - compilation output is deferred to a per-module TQueue. A QSem is used to
 - limit the number of workers that are compiling simultaneously.
 -
 - Meanwhile, the main thread sequentially loops over all the modules in the
 - module graph, outputting the messages stored in each module's TQueue.
-}

-- | Each module is given a unique 'LogQueue' to redirect compilation messages
-- to. A 'Nothing' value contains the result of compilation, and denotes the
-- end of the message queue.
747
data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)])
parcs's avatar
parcs committed
748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768
                         !(MVar ())

-- | The graph of modules to compile and their corresponding result 'MVar' and
-- 'LogQueue'.
type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)]

-- | Build a 'CompilationGraph' out of a list of strongly-connected modules,
-- also returning the first, if any, encountered module cycle.
buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])
buildCompGraph [] = return ([], Nothing)
buildCompGraph (scc:sccs) = case scc of
    AcyclicSCC ms -> do
        mvar <- newEmptyMVar
        log_queue <- do
            ref <- newIORef []
            sem <- newEmptyMVar
            return (LogQueue ref sem)
        (rest,cycle) <- buildCompGraph sccs
        return ((ms,mvar,log_queue):rest, cycle)
    CyclicSCC mss -> return ([], Just mss)

769
-- A Module and whether it is a boot module.
770 771 772 773 774 775 776 777 778 779 780 781 782
type BuildModule = (Module, IsBoot)

-- | 'Bool' indicating if a module is a boot module or not.  We need to treat
-- boot modules specially when building compilation graphs, since they break
-- cycles.  Regular source files and signature files are treated equivalently.
data IsBoot = IsBoot | NotBoot
    deriving (Ord, Eq, Show, Read)

-- | Tests if an 'HscSource' is a boot file, primarily for constructing
-- elements of 'BuildModule'.
hscSourceToIsBoot :: HscSource -> IsBoot
hscSourceToIsBoot HsBootFile = IsBoot
hscSourceToIsBoot _ = NotBoot
783 784

mkBuildModule :: ModSummary -> BuildModule
785
mkBuildModule ms = (ms_mod ms, if isBootSummary ms then IsBoot else NotBoot)
786

parcs's avatar
parcs committed
787 788 789 790 791 792 793
-- | The entry point to the parallel upsweep.
--
-- See also the simpler, sequential 'upsweep'.
parUpsweep
    :: GhcMonad m
    => Int
    -- ^ The number of workers we wish to run in parallel
Edward Z. Yang's avatar
Edward Z. Yang committed
794
    -> Maybe Messager
parcs's avatar
parcs committed
795 796 797 798 799 800
    -> HomePackageTable
    -> ([ModuleName],[ModuleName])
    -> (HscEnv -> IO ())
    -> [SCC ModSummary]
    -> m (SuccessFlag,
          [ModSummary])
Edward Z. Yang's avatar
Edward Z. Yang committed
801
parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
parcs's avatar
parcs committed
802 803 804
    hsc_env <- getSession
    let dflags = hsc_dflags hsc_env

Edward Z. Yang's avatar
Edward Z. Yang committed
805 806 807
    when (not (null (unitIdsToCheck dflags))) $
      throwGhcException (ProgramError "Backpack typechecking not supported with -j")

parcs's avatar
parcs committed
808 809 810 811 812 813 814
    -- The bits of shared state we'll be using:

    -- The global HscEnv is updated with the module's HMI when a module
    -- successfully compiles.
    hsc_env_var <- liftIO $ newMVar hsc_env

    -- The old HPT is used for recompilation checking in upsweep_mod. When a
Gabor Greif's avatar
Gabor Greif committed
815
    -- module successfully gets compiled, its HMI is pruned from the old HPT.
parcs's avatar
parcs committed
816 817 818 819 820 821 822 823
    old_hpt_var <- liftIO $ newIORef old_hpt

    -- What we use to limit parallelism with.
    par_sem <- liftIO $ newQSem n_jobs


    let updNumCapabilities = liftIO $ do
            n_capabilities <- getNumCapabilities
824 825 826 827 828 829
            n_cpus <- getNumProcessors
            -- Setting number of capabilities more than
            -- CPU count usually leads to high userspace
            -- lock contention. Trac #9221
            let n_caps = min n_jobs n_cpus
            unless (n_capabilities /= 1) $ setNumCapabilities n_caps
parcs's avatar
parcs committed
830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848
            return n_capabilities
    -- Reset the number of capabilities once the upsweep ends.
    let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n

    gbracket updNumCapabilities resetNumCapabilities $ \_ -> do

    -- Sync the global session with the latest HscEnv once the upsweep ends.
    let finallySyncSession io = io `gfinally` do
            hsc_env <- liftIO $ readMVar hsc_env_var
            setSession hsc_env

    finallySyncSession $ do

    -- Build the compilation graph out of the list of SCCs. Module cycles are
    -- handled at the very end, after some useful work gets done. Note that
    -- this list is topologically sorted (by virtue of 'sccs' being sorted so).
    (comp_graph,cycle) <- liftIO $ buildCompGraph sccs
    let comp_graph_w_idx = zip comp_graph [1..]

849 850 851 852 853 854 855 856 857 858 859
    -- The list of all loops in the compilation graph.
    -- NB: For convenience, the last module of each loop (aka the module that
    -- finishes the loop) is prepended to the beginning of the loop.
    let comp_graph_loops = go (map fstOf3 (reverse comp_graph))
          where
            go [] = []
            go (ms:mss) | Just loop <- getModLoop ms (ms:mss)
                        = map mkBuildModule (ms:loop) : go mss
                        | otherwise
                        = go mss

parcs's avatar
parcs committed
860 861
    -- Build a Map out of the compilation graph with which we can efficiently
    -- look up the result MVar associated with a particular home module.
862 863 864 865 866
    let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)
        home_mod_map =
            Map.fromList [ (mkBuildModule ms, (mvar, idx))
                         | ((ms,mvar,_),idx) <- comp_graph_w_idx ]

parcs's avatar
parcs committed
867

868
    liftIO $ label_self "main --make thread"
parcs's avatar
parcs committed
869 870 871 872
    -- For each module in the module graph, spawn a worker thread that will
    -- compile this module.
    let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->
            forkIOWithUnmask $ \unmask -> do
873 874 875 876 877 878 879
                liftIO $ label_self $ unwords
                    [ "worker --make thread"
                    , "for module"
                    , show (moduleNameString (ms_mod_name mod))
                    , "number"
                    , show mod_idx
                    ]
parcs's avatar
parcs committed
880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895
                -- Replace the default log_action with one that writes each
                -- message to the module's log_queue. The main thread will
                -- deal with synchronously printing these messages.
                --
                -- Use a local filesToClean var so that we can clean up
                -- intermediate files in a timely fashion (as soon as
                -- compilation for that module is finished) without having to
                -- worry about accidentally deleting a simultaneous compile's
                -- important files.
                lcl_files_to_clean <- newIORef []
                let lcl_dflags = dflags { log_action = parLogAction log_queue
                                        , filesToClean = lcl_files_to_clean }

                -- Unmask asynchronous exceptions and perform the thread-local
                -- work to compile the module (see parUpsweep_one).
                m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $
896
                        parUpsweep_one mod home_mod_map comp_graph_loops
Edward Z. Yang's avatar
Edward Z. Yang committed
897
                                       lcl_dflags mHscMessage cleanup
898
                                       par_sem hsc_env_var old_hpt_var
parcs's avatar
parcs committed
899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956
                                       stable_mods mod_idx (length sccs)

                res <- case m_res of
                    Right flag -> return flag
                    Left exc -> do
                        -- Don't print ThreadKilled exceptions: they are used
                        -- to kill the worker thread in the event of a user
                        -- interrupt, and the user doesn't have to be informed
                        -- about that.
                        when (fromException exc /= Just ThreadKilled)
                             (errorMsg lcl_dflags (text (show exc)))
                        return Failed

                -- Populate the result MVar.
                putMVar mvar res

                -- Write the end marker to the message queue, telling the main
                -- thread that it can stop waiting for messages from this
                -- particular compile.
                writeLogQueue log_queue Nothing

                -- Add the remaining files that weren't cleaned up to the
                -- global filesToClean ref, for cleanup later.
                files_kept <- readIORef (filesToClean lcl_dflags)
                addFilesToClean dflags files_kept


        -- Kill all the workers, masking interrupts (since killThread is
        -- interruptible). XXX: This is not ideal.
        ; killWorkers = uninterruptibleMask_ . mapM_ killThread }


    -- Spawn the workers, making sure to kill them later. Collect the results
    -- of each compile.
    results <- liftIO $ bracket spawnWorkers killWorkers $ \_ ->
        -- Loop over each module in the compilation graph in order, printing
        -- each message from its log_queue.
        forM comp_graph $ \(mod,mvar,log_queue) -> do
            printLogs dflags log_queue
            result <- readMVar mvar
            if succeeded result then return (Just mod) else return Nothing


    -- Collect and return the ModSummaries of all the successful compiles.
    -- NB: Reverse this list to maintain output parity with the sequential upsweep.
    let ok_results = reverse (catMaybes results)

    -- Handle any cycle in the original compilation graph and return the result
    -- of the upsweep.
    case cycle of
        Just mss -> do
            liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss)
            return (Failed,ok_results)
        Nothing  -> do
            let success_flag = successIf (all isJust results)
            return (success_flag,ok_results)

  where
957
    writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO ()
parcs's avatar
parcs committed
958
    writeLogQueue (LogQueue ref sem) msg = do
959
        atomicModifyIORef' ref $ \msgs -> (msg:msgs,())
parcs's avatar
parcs committed
960 961 962 963 964 965
        _ <- tryPutMVar sem ()
        return ()

    -- The log_action callback that is used to synchronize messages from a
    -- worker thread.
    parLogAction :: LogQueue -> LogAction
966 967
    parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do
        writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg))
parcs's avatar
parcs committed
968 969 970 971 972 973 974

    -- Print each message from the log_queue using the log_action from the
    -- session's DynFlags.
    printLogs :: DynFlags -> LogQueue -> IO ()
    printLogs !dflags (LogQueue ref sem) = read_msgs
      where read_msgs = do
                takeMVar sem
975
                msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)
parcs's avatar
parcs committed
976 977 978 979
                print_loop msgs

            print_loop [] = read_msgs
            print_loop (x:xs) = case x of
980 981
                Just (reason,severity,srcSpan,style,msg) -> do
                    log_action dflags dflags reason severity srcSpan style msg
parcs's avatar
parcs committed
982 983 984 985 986 987 988 989
                    print_loop xs
                -- Exit the loop once we encounter the end marker.
                Nothing -> return ()

-- The interruptible subset of the worker threads' work.
parUpsweep_one
    :: ModSummary
    -- ^ The module we wish to compile
990
    -> Map BuildModule (MVar SuccessFlag, Int)
parcs's avatar
parcs committed
991
    -- ^ The map of home modules and their result MVar
992 993
    -> [[BuildModule]]
    -- ^ The list of all module loops within the compilation graph.
parcs's avatar
parcs committed
994 995
    -> DynFlags
    -- ^ The thread-local DynFlags
Edward Z. Yang's avatar
Edward Z. Yang committed
996 997
    -> Maybe Messager
    -- ^ The messager
parcs's avatar
parcs committed
998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013
    -> (HscEnv -> IO ())
    -- ^ The callback for cleaning up intermediate files
    -> QSem
    -- ^ The semaphore for limiting the number of simultaneous compiles
    -> MVar HscEnv
    -- ^ The MVar that synchronizes updates to the global HscEnv
    -> IORef HomePackageTable
    -- ^ The old HPT
    -> ([ModuleName],[ModuleName])
    -- ^ Lists of stable objects and BCOs
    -> Int
    -- ^ The index of this module
    -> Int
    -- ^ The total number of modules
    -> IO SuccessFlag
    -- ^ The result of this compile
Edward Z. Yang's avatar
Edward Z. Yang committed
1014
parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem
1015 1016 1017 1018
               hsc_env_var old_hpt_var stable_mods mod_index num_mods = do

    let this_build_mod = mkBuildModule mod

parcs's avatar
parcs committed
1019
    let home_imps     = map unLoc $ ms_home_imps mod
1020 1021 1022 1023
    let home_src_imps = map unLoc $ ms_home_srcimps mod

    -- All the textual imports of this module.
    let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $
1024 1025
                            zip home_imps     (repeat NotBoot) ++
                            zip home_src_imps (repeat IsBoot)
1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092

    -- Dealing with module loops
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~
    --
    -- Not only do we have to deal with explicit textual dependencies, we also
    -- have to deal with implicit dependencies introduced by import cycles that
    -- are broken by an hs-boot file. We have to ensure that:
    --
    -- 1. A module that breaks a loop must depend on all the modules in the
    --    loop (transitively or otherwise). This is normally always fulfilled
    --    by the module's textual dependencies except in degenerate loops,
    --    e.g.:
    --
    --    A.hs imports B.hs-boot
    --    B.hs doesn't import A.hs
    --    C.hs imports A.hs, B.hs
    --
    --    In this scenario, getModLoop will detect the module loop [A,B] but
    --    the loop finisher B doesn't depend on A. So we have to explicitly add
    --    A in as a dependency of B when we are compiling B.
    --
    -- 2. A module that depends on a module in an external loop can't proceed
    --    until the entire loop is re-typechecked.
    --
    -- These two invariants have to be maintained to correctly build a
    -- compilation graph with one or more loops.


    -- The loop that this module will finish. After this module successfully
    -- compiles, this loop is going to get re-typechecked.
    let finish_loop = listToMaybe
            [ tail loop | loop <- comp_graph_loops
                        , head loop == this_build_mod ]

    -- If this module finishes a loop then it must depend on all the other
    -- modules in that loop because the entire module loop is going to be
    -- re-typechecked once this module gets compiled. These extra dependencies
    -- are this module's "internal" loop dependencies, because this module is
    -- inside the loop in question.
    let int_loop_deps = Set.fromList $
            case finish_loop of
                Nothing   -> []
                Just loop -> filter (/= this_build_mod) loop

    -- If this module depends on a module within a loop then it must wait for
    -- that loop to get re-typechecked, i.e. it must wait on the module that
    -- finishes that loop. These extra dependencies are this module's
    -- "external" loop dependencies, because this module is outside of the
    -- loop(s) in question.
    let ext_loop_deps = Set.fromList
            [ head loop | loop <- comp_graph_loops
                        , any (`Set.member` textual_deps) loop
                        , this_build_mod `notElem` loop ]


    let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps]

    -- All of the module's home-module dependencies.
    let home_deps_with_idx =
            [ home_dep | dep <- Set.toList all_deps
                       , Just home_dep <- [Map.lookup dep home_mod_map] ]

    -- Sort the list of dependencies in reverse-topological order. This way, by
    -- the time we get woken up by the result of an earlier dependency,
    -- subsequent dependencies are more likely to have finished. This step
    -- effectively reduces the number of MVars that each thread blocks on.
    let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx
parcs's avatar
parcs committed
1093 1094

    -- Wait for the all the module's dependencies to finish building.
1095
    deps_ok <- allM (fmap succeeded . readMVar) home_deps
parcs's avatar
parcs committed
1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116

    -- We can't build this module if any of its dependencies failed to build.
    if not deps_ok
      then return Failed
      else do
        -- Any hsc_env at this point is OK to use since we only really require
        -- that the HPT contains the HMIs of our dependencies.
        hsc_env <- readMVar hsc_env_var
        old_hpt <- readIORef old_hpt_var

        let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err)

        -- Limit the number of parallel compiles.
        let withSem sem = bracket_ (waitQSem sem) (signalQSem sem)
        mb_mod_info <- withSem par_sem $
            handleSourceError (\err -> do logger err; return Nothing) $ do
                -- Have the ModSummary and HscEnv point to our local log_action
                -- and filesToClean var.
                let lcl_mod = localize_mod mod
                let lcl_hsc_env = localize_hsc_env hsc_env

1117
                -- Re-typecheck the loop
1118 1119
                -- This is necessary to make sure the knot is tied when
                -- we close a recursive module loop, see bug #12035.
1120 1121 1122 1123 1124 1125 1126 1127
                type_env_var <- liftIO $ newIORef emptyNameEnv
                let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var =
                                    Just (ms_mod lcl_mod, type_env_var) }
                lcl_hsc_env'' <- case finish_loop of
                    Nothing   -> return lcl_hsc_env'
                    Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $
                                 map (moduleName . fst) loop

parcs's avatar
parcs committed
1128
                -- Compile the module.
Edward Z. Yang's avatar
Edward Z. Yang committed
1129
                mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods
1130
                                        lcl_mod mod_index num_mods
parcs's avatar
parcs committed
1131 1132 1133 1134 1135 1136 1137 1138 1139
                return (Just mod_info)

        case mb_mod_info of
            Nothing -> return Failed
            Just mod_info -> do
                let this_mod = ms_mod_name mod

                -- Prune the old HPT unless this is an hs-boot module.
                unless (isBootSummary mod) $
1140
                    atomicModifyIORef' old_hpt_var $ \old_hpt ->
niteria's avatar
niteria committed
1141
                        (delFromHpt old_hpt this_mod, ())
parcs's avatar
parcs committed
1142

1143
                -- Update and fetch the global HscEnv.
parcs's avatar
parcs committed
1144
                lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do
niteria's avatar
niteria committed
1145 1146 1147
                    let hsc_env' = hsc_env
                                     { hsc_HPT = addToHpt (hsc_HPT hsc_env)
                                                           this_mod mod_info }
1148 1149 1150 1151
                    -- If this module is a loop finisher, now is the time to
                    -- re-typecheck the loop.
                    hsc_env'' <- case finish_loop of
                        Nothing   -> return hsc_env'
1152
                        Just loop -> typecheckLoop lcl_dflags hsc_env' $
1153
                                     map (moduleName . fst) loop
parcs's avatar
parcs committed
1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170
                    return (hsc_env'', localize_hsc_env hsc_env'')

                -- Clean up any intermediate files.
                cleanup lcl_hsc_env'
                return Succeeded

  where
    localize_mod mod
        = mod { ms_hspp_opts = (ms_hspp_opts mod)
                 { log_action = log_action lcl_dflags
                 , filesToClean = filesToClean lcl_dflags } }

    localize_hsc_env hsc_env
        = hsc_env { hsc_dflags = (hsc_dflags hsc_env)
                     { log_action = log_action lcl_dflags
                     , filesToClean = filesToClean lcl_dflags } }

Simon Marlow's avatar
Simon Marlow committed
1171
-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
1172
--
Simon Marlow's avatar
Simon Marlow committed
1173 1174 1175 1176 1177 1178 1179 1180
-- | The upsweep
--
-- This is where we compile each module in the module graph, in a pass
-- from the bottom to the top of the graph.
--
-- There better had not be any cyclic groups here -- we check for them.
upsweep
    :: GhcMonad m
Edward Z. Yang's avatar
Edward Z. Yang committed
1181 1182
    => Maybe Messager
    -> HomePackageTable            -- ^ HPT from last time round (pruned)
Simon Marlow's avatar
Simon Marlow committed
1183
    -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
1184
    -> (HscEnv -> IO ())           -- ^ How to clean up unwanted tmp files
dterei's avatar
dterei committed
1185
    -> [SCC ModSummary]            -- ^ Mods to do (the worklist)
Simon Marlow's avatar
Simon Marlow committed
1186 1187 1188 1189 1190 1191 1192 1193
    -> m (SuccessFlag,
          [ModSummary])
       -- ^ Returns:
       --
       --  1. A flag whether the complete upsweep was successful.
       --  2. The 'HscEnv' in the monad has an updated HPT
       --  3. A list of modules which succeeded loading.

Edward Z. Yang's avatar
Edward Z. Yang committed
1194 1195
upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
   dflags <- getSessionDynFlags
Simon Marlow's avatar
Simon Marlow committed
1196
   (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)
Edward Z. Yang's avatar
Edward Z. Yang committed
1197
                           (unitIdsToCheck dflags) done_holes
Simon Marlow's avatar
Simon Marlow committed
1198 1199
   return (res, reverse done)
 where
Edward Z. Yang's avatar
Edward Z. Yang committed
1200
  done_holes = emptyUniqSet
Simon Marlow's avatar
Simon Marlow committed
1201 1202

  upsweep' _old_hpt done
Edward Z. Yang's avatar
Edward Z. Yang committed
1203 1204 1205 1206
     [] _ _ uids_to_check _
   = do hsc_env <- getSession
        liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) uids_to_check
        return (Succeeded, done)
Simon Marlow's avatar
Simon Marlow committed
1207 1208

  upsweep' _old_hpt done
Edward Z. Yang's avatar
Edward Z. Yang committed
1209
     (CyclicSCC ms:_) _ _ _ _
Simon Marlow's avatar
Simon Marlow committed
1210 1211 1212 1213 1214
   = do dflags <- getSessionDynFlags
        liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
        return (Failed, done)

  upsweep' old_hpt done
Edward Z. Yang's avatar
Edward Z. Yang committed
1215
     (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes
1216 1217
   = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
        --           show (map (moduleUserString.moduleName.mi_module.hm_iface)
dterei's avatar
dterei committed
1218
        --                     (moduleEnvElts (hsc_HPT hsc_env)))
Simon Marlow's avatar
Simon Marlow committed
1219 1220 1221
        let logger _mod = defaultWarnErrLogger

        hsc_env <- getSession
1222

Edward Z. Yang's avatar
Edward Z. Yang committed
1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234
        -- TODO: Cache this, so that we don't repeatedly re-check
        -- our imports when you run --make.
        let (ready_uids, uids_to_check')
                = partition (\uid -> isEmptyUniqDSet
                    (unitIdFreeHoles uid `uniqDSetMinusUniqSet` done_holes))
                     uids_to_check
            done_holes'
                | ms_hsc_src mod == HsigFile
                = addOneToUniqSet done_holes (ms_mod_name mod)
                | otherwise = done_holes
        liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnitId hsc_env) ready_uids

1235 1236 1237
        -- Remove unwanted tmp files between compilations
        liftIO (cleanup hsc_env)

1238 1239 1240 1241 1242 1243 1244 1245 1246
        -- Get ready to tie the knot
        type_env_var <- liftIO $ newIORef emptyNameEnv
        let hsc_env1 = hsc_env { hsc_type_env_var =
                                    Just (ms_mod mod, type_env_var) }
        setSession hsc_env1

        -- Lazily reload the HPT modules participating in the loop.
        -- See Note [Tying the knot]--if we don't throw out the old HPT
        -- and reinitalize the knot-tying process, anything that was forced
1247 1248
        -- while we were previously typechecking won't get updated, this
        -- was bug #12035.
1249 1250 1251
        hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done
        setSession hsc_env2

Simon Marlow's avatar
Simon Marlow committed
1252 1253 1254
        mb_mod_info
            <- handleSourceError
                   (\err -> do logger mod (Just err); return Nothing) $ do
Edward Z. Yang's avatar
Edward Z. Yang committed