GhcMake.hs 92.3 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 34

#include "HsVersions.h"

#ifdef GHCI
dterei's avatar
dterei committed
35
import qualified Linker         ( unload )
Simon Marlow's avatar
Simon Marlow committed
36 37 38
#endif

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

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

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

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

parcs's avatar
parcs committed
96 97
import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )

98 99 100 101 102
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
103 104 105 106 107 108 109 110 111 112 113
-- -----------------------------------------------------------------------------
-- 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
114
-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want
Simon Marlow's avatar
Simon Marlow committed
115 116 117 118 119 120 121 122 123 124
-- 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
125 126 127
         dflags  = hsc_dflags hsc_env
         targets = hsc_targets hsc_env
         old_graph = hsc_mod_graph hsc_env
128

129 130 131 132 133 134 135 136
  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
137
    setSession hsc_env { hsc_mod_graph = mod_graph }
138
    return mod_graph
Simon Marlow's avatar
Simon Marlow committed
139 140 141 142 143 144 145 146 147 148 149 150 151 152 153

-- | 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
154
-- possible.  Depending on the target (see 'DynFlags.hscTarget') compiling
Simon Marlow's avatar
Simon Marlow committed
155 156
-- and loading may result in files being created on disk.
--
157 158
-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether
-- successful or not.
Simon Marlow's avatar
Simon Marlow committed
159 160 161
--
-- Throw a 'SourceError' if errors are encountered before the actual
-- compilation starts (e.g., during dependency analysis).  All other errors
162
-- are reported using the 'defaultWarnErrLogger'.
Simon Marlow's avatar
Simon Marlow committed
163 164 165
--
load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
load how_much = do
dterei's avatar
dterei committed
166
    mod_graph <- depanal [] False
Edward Z. Yang's avatar
Edward Z. Yang committed
167 168 169 170 171 172 173 174
    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
175 176 177 178 179 180 181 182 183 184
    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)
185
    let all_home_mods = [ms_mod_name s
dterei's avatar
dterei committed
186
                        | s <- mod_graph, not (isBootSummary s)]
Edward Z. Yang's avatar
Edward Z. Yang committed
187 188 189 190 191 192
    -- 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
193 194 195 196 197 198 199 200 201

    -- 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
202
            | otherwise = do
dterei's avatar
dterei committed
203 204 205 206 207 208
                    liftIO $ errorMsg dflags (text "no such module:" <+>
                                     quotes (ppr m))
                    return Failed

    checkHowMuch how_much $ do

209
    -- mg2_with_srcimps drops the hi-boot nodes, returning a
dterei's avatar
dterei committed
210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227
    -- 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.
228
        pruned_hpt = pruneHomePackageTable hpt1
dterei's avatar
dterei committed
229 230 231 232 233 234 235 236
                            (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.
237
    setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt }
dterei's avatar
dterei committed
238 239 240 241 242 243 244

    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
245
                             Just hmi <- [lookupHpt pruned_hpt m],
dterei's avatar
dterei committed
246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280
                             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
281
            = ASSERT( case last partial_mg0 of
dterei's avatar
dterei committed
282 283 284 285 286
                        AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
              List.init partial_mg0
            | otherwise
            = partial_mg0

287
        stable_mg =
dterei's avatar
dterei committed
288 289
            [ AcyclicSCC ms
            | AcyclicSCC ms <- full_mg,
290
              ms_mod_name ms `elem` stable_obj++stable_bco ]
291

292 293 294 295 296 297 298 299 300 301
        -- 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
302 303

    -- clean up between compilations
parcs's avatar
parcs committed
304
    let cleanup hsc_env = intermediateCleanTempFiles (hsc_dflags hsc_env)
dterei's avatar
dterei committed
305 306 307 308 309 310
                              (flattenSCCs mg2_with_srcimps)
                              hsc_env

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

311
    n_jobs <- case parMakeCount dflags of
parcs's avatar
parcs committed
312 313 314 315 316
                    Nothing -> liftIO getNumProcessors
                    Just n  -> return n
    let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs
                   | otherwise  = upsweep

dterei's avatar
dterei committed
317 318
    setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
    (upsweep_ok, modsUpswept)
Edward Z. Yang's avatar
Edward Z. Yang committed
319
       <- upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg
dterei's avatar
dterei committed
320 321 322 323 324 325 326 327 328 329 330 331

    -- 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

332
     then
dterei's avatar
dterei committed
333 334 335 336 337 338 339 340 341 342 343 344 345 346
       -- 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
347
          let no_hs_main = gopt Opt_NoHsMain dflags
348
          let
dterei's avatar
dterei committed
349 350
            main_mod = mainModIs dflags
            a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
351
            do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib
dterei's avatar
dterei committed
352 353 354 355

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

356 357 358 359 360 361 362 363 364 365 366
          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
367

368
     else
dterei's avatar
dterei committed
369 370 371 372 373 374 375
       -- 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
376 377
          let mods_to_zap_names
                 = findPartiallyCompletedCycles modsDone_names
dterei's avatar
dterei committed
378 379
                      mg2_with_srcimps
          let mods_to_keep
380
                 = filter ((`notElem` mods_to_zap_names).ms_mod)
dterei's avatar
dterei committed
381 382 383
                      modsDone

          hsc_env1 <- getSession
384
          let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
dterei's avatar
dterei committed
385 386 387 388 389 390
                                          (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
391 392
          let just_linkables =
                    isNoLink (ghcLink dflags)
niteria's avatar
niteria committed
393 394 395
                 || allHpt (isJust.hm_linkable)
                        (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)
                                hpt4)
396
          ASSERT( just_linkables ) do
397

dterei's avatar
dterei committed
398 399
          -- Link everything together
          linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
Simon Marlow's avatar
Simon Marlow committed
400

dterei's avatar
dterei committed
401 402
          modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 }
          loadFinish Failed linkresult
Simon Marlow's avatar
Simon Marlow committed
403 404


dterei's avatar
dterei committed
405 406
-- | Finish up after a load.
loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag
Simon Marlow's avatar
Simon Marlow committed
407 408 409 410 411 412 413 414 415 416 417

-- 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
418
  = do modifySession discardIC
Simon Marlow's avatar
Simon Marlow committed
419 420 421
       return all_ok


dterei's avatar
dterei committed
422
-- | Forget the current program, but retain the persistent info in HscEnv
Simon Marlow's avatar
Simon Marlow committed
423 424
discardProg :: HscEnv -> HscEnv
discardProg hsc_env
425 426 427
  = discardIC $ hsc_env { hsc_mod_graph = emptyMG
                        , hsc_HPT = emptyHomePackageTable }

428 429 430
-- | 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.
431 432
discardIC :: HscEnv -> HscEnv
discardIC hsc_env
433 434
  = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print
                                , ic_monad = new_ic_monad } }
435
  where
436 437 438
  -- 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
439 440
  dflags = ic_dflags old_ic
  old_ic = hsc_IC hsc_env
441
  empty_ic = emptyInteractiveContext dflags
442 443
  keep_external_name ic_name
    | nameIsFromExternalPackage this_pkg old_name = old_name
444
    | otherwise = ic_name empty_ic
445 446 447
    where
    this_pkg = thisPackage dflags
    old_name = ic_name old_ic
Simon Marlow's avatar
Simon Marlow committed
448

449 450
intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO ()
intermediateCleanTempFiles dflags summaries hsc_env
451 452
 = do notIntermediate <- readIORef (filesToNotIntermediateClean dflags)
      cleanTempFilesExcept dflags (notIntermediate ++ except)
453 454 455 456 457 458 459 460 461 462 463 464
  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
465 466 467 468 469 470

-- | 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
471 472
        -- Force mod_graph to avoid leaking env
        !mod_graph = hsc_mod_graph env
Simon Marlow's avatar
Simon Marlow committed
473 474 475 476 477 478 479
        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

480
        name_exe = do
Simon Marlow's avatar
Simon Marlow committed
481
#if defined(mingw32_HOST_OS)
482 483 484 485
          -- we must add the .exe extention unconditionally here, otherwise
          -- 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
486
#else
487
          name' <- name
Simon Marlow's avatar
Simon Marlow committed
488
#endif
489 490 491 492 493 494 495
          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
496 497 498 499 500 501
    in
    case outputFile dflags of
        Just _ -> env
        Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }

-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
502
--
Simon Marlow's avatar
Simon Marlow committed
503 504 505 506 507
-- | Prune the HomePackageTable
--
-- Before doing an upsweep, we can throw away:
--
--   - For non-stable modules:
dterei's avatar
dterei committed
508
--      - all ModDetails, all linked code
Simon Marlow's avatar
Simon Marlow committed
509 510 511 512 513 514 515
--   - 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
516 517 518 519
pruneHomePackageTable :: HomePackageTable
                      -> [ModSummary]
                      -> ([ModuleName],[ModuleName])
                      -> HomePackageTable
Simon Marlow's avatar
Simon Marlow committed
520
pruneHomePackageTable hpt summ (stable_obj, stable_bco)
niteria's avatar
niteria committed
521
  = mapHpt prune hpt
Simon Marlow's avatar
Simon Marlow committed
522
  where prune hmi
dterei's avatar
dterei committed
523 524 525 526 527 528 529 530 531
          | 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
532 533 534

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

dterei's avatar
dterei committed
535
        is_stable m = m `elem` stable_obj || m `elem` stable_bco
Simon Marlow's avatar
Simon Marlow committed
536 537

-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
538 539 540
--
-- | Return (names of) all those in modsDone who are part of a cycle as defined
-- by theGraph.
Simon Marlow's avatar
Simon Marlow committed
541 542 543 544 545 546 547 548
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)
549 550
                 mods_in_this_cycle
                    = nub ([done | done <- modsDone,
Simon Marlow's avatar
Simon Marlow committed
551 552
                                   done `elem` names_in_this_cycle])
                 chewed_rest = chew rest
553
             in
Simon Marlow's avatar
Simon Marlow committed
554 555 556 557 558 559 560
             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
561 562
--
-- | Unloading
Simon Marlow's avatar
Simon Marlow committed
563
unload :: HscEnv -> [Linkable] -> IO ()
dterei's avatar
dterei committed
564
unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
Simon Marlow's avatar
Simon Marlow committed
565 566
  = case ghcLink (hsc_dflags hsc_env) of
#ifdef GHCI
567
        LinkInMemory -> Linker.unload hsc_env stable_linkables
Simon Marlow's avatar
Simon Marlow committed
568
#else
dterei's avatar
dterei committed
569
        LinkInMemory -> panic "unload: no interpreter"
Simon Marlow's avatar
Simon Marlow committed
570 571 572
                                -- urgh.  avoid warnings:
                                hsc_env stable_linkables
#endif
dterei's avatar
dterei committed
573
        _other -> return ()
Simon Marlow's avatar
Simon Marlow committed
574 575 576 577 578 579

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

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

Simon Marlow's avatar
Simon Marlow committed
581 582 583 584 585 586 587 588 589 590 591 592 593 594
   - 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

595
  stableObject m =
dterei's avatar
dterei committed
596 597 598
        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
599 600

  stableBCO m =
dterei's avatar
dterei committed
601 602
        all stable (imports m)
        && date(BCO) > date(.hs)
Simon Marlow's avatar
Simon Marlow committed
603 604 605 606 607 608
@

  These properties embody the following ideas:

    - if a module is stable, then:

dterei's avatar
dterei committed
609 610
        - 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
611 612

        - if it has not been compiled in a previous pass,
dterei's avatar
dterei committed
613 614
          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
615 616 617 618 619 620 621 622

    - 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.
623 624 625 626 627

    - 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
628 629
-}
checkStability
dterei's avatar
dterei committed
630 631 632 633 634
        :: 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
635 636 637 638 639 640 641 642

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
643 644 645
        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
646 647

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

dterei's avatar
dterei committed
650 651 652
        stable_obj_imps = map (`elem` stable_obj) scc_allimps
        stable_bco_imps = map (`elem` stable_bco) scc_allimps

653
        stableObjects =
dterei's avatar
dterei committed
654 655 656
           and stable_obj_imps
           && all object_ok scc

657
        stableBCOs =
dterei's avatar
dterei committed
658 659 660 661
           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
662
          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False
663
          | Just t <- ms_obj_date ms  =  t >= ms_hs_date ms
dterei's avatar
dterei committed
664 665 666
                                         && same_as_prev t
          | otherwise = False
          where
niteria's avatar
niteria committed
667
             same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of
dterei's avatar
dterei committed
668 669 670 671 672
                                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
673
                -- the object & source have the same modification time,
dterei's avatar
dterei committed
674 675 676
                -- 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
677 678 679
                --
                -- But see #5527, where someone ran into this and it caused
                -- a problem.
Simon Marlow's avatar
Simon Marlow committed
680

dterei's avatar
dterei committed
681
        bco_ok ms
ian@well-typed.com's avatar
ian@well-typed.com committed
682
          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False
niteria's avatar
niteria committed
683
          | otherwise = case lookupHpt hpt (ms_mod_name ms) of
dterei's avatar
dterei committed
684
                Just hmi  | Just l <- hm_linkable hmi ->
685
                        not (isObjectLinkable l) &&
dterei's avatar
dterei committed
686 687
                        linkableTime l >= ms_hs_date ms
                _other  -> False
Simon Marlow's avatar
Simon Marlow committed
688

parcs's avatar
parcs committed
689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715
{- 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.
716
data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)])
parcs's avatar
parcs committed
717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737
                         !(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)

738
-- A Module and whether it is a boot module.
739 740 741 742 743 744 745 746 747 748 749 750 751
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
752 753

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

parcs's avatar
parcs committed
756 757 758 759 760 761 762
-- | 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
763
    -> Maybe Messager
parcs's avatar
parcs committed
764 765 766 767 768 769
    -> HomePackageTable
    -> ([ModuleName],[ModuleName])
    -> (HscEnv -> IO ())
    -> [SCC ModSummary]
    -> m (SuccessFlag,
          [ModSummary])
Edward Z. Yang's avatar
Edward Z. Yang committed
770
parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do
parcs's avatar
parcs committed
771 772 773
    hsc_env <- getSession
    let dflags = hsc_dflags hsc_env

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

parcs's avatar
parcs committed
777 778 779 780 781 782 783
    -- 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
784
    -- module successfully gets compiled, its HMI is pruned from the old HPT.
parcs's avatar
parcs committed
785 786 787 788 789 790 791 792
    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
793 794 795 796 797 798
            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
799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817
            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..]

818 819 820 821 822 823 824 825 826 827 828
    -- 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
829 830
    -- Build a Map out of the compilation graph with which we can efficiently
    -- look up the result MVar associated with a particular home module.
831 832 833 834 835
    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
836

837
    liftIO $ label_self "main --make thread"
parcs's avatar
parcs committed
838 839 840 841
    -- 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
842 843 844 845 846 847 848
                liftIO $ label_self $ unwords
                    [ "worker --make thread"
                    , "for module"
                    , show (moduleNameString (ms_mod_name mod))
                    , "number"
                    , show mod_idx
                    ]
parcs's avatar
parcs committed
849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864
                -- 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 $
865
                        parUpsweep_one mod home_mod_map comp_graph_loops
Edward Z. Yang's avatar
Edward Z. Yang committed
866
                                       lcl_dflags mHscMessage cleanup
867
                                       par_sem hsc_env_var old_hpt_var
parcs's avatar
parcs committed
868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 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
                                       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
926
    writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO ()
parcs's avatar
parcs committed
927
    writeLogQueue (LogQueue ref sem) msg = do
928
        atomicModifyIORef' ref $ \msgs -> (msg:msgs,())
parcs's avatar
parcs committed
929 930 931 932 933 934
        _ <- tryPutMVar sem ()
        return ()

    -- The log_action callback that is used to synchronize messages from a
    -- worker thread.
    parLogAction :: LogQueue -> LogAction
935 936
    parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do
        writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg))
parcs's avatar
parcs committed
937 938 939 940 941 942 943

    -- 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
944
                msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)
parcs's avatar
parcs committed
945 946 947 948
                print_loop msgs

            print_loop [] = read_msgs
            print_loop (x:xs) = case x of
949 950
                Just (reason,severity,srcSpan,style,msg) -> do
                    log_action dflags dflags reason severity srcSpan style msg
parcs's avatar
parcs committed
951 952 953 954 955 956 957 958
                    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
959
    -> Map BuildModule (MVar SuccessFlag, Int)
parcs's avatar
parcs committed
960
    -- ^ The map of home modules and their result MVar
961 962
    -> [[BuildModule]]
    -- ^ The list of all module loops within the compilation graph.
parcs's avatar
parcs committed
963 964
    -> DynFlags
    -- ^ The thread-local DynFlags
Edward Z. Yang's avatar
Edward Z. Yang committed
965 966
    -> Maybe Messager
    -- ^ The messager
parcs's avatar
parcs committed
967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982
    -> (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
983
parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem
984 985 986 987
               hsc_env_var old_hpt_var stable_mods mod_index num_mods = do

    let this_build_mod = mkBuildModule mod

parcs's avatar
parcs committed
988
    let home_imps     = map unLoc $ ms_home_imps mod
989 990 991 992
    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)) $
993 994
                            zip home_imps     (repeat NotBoot) ++
                            zip home_src_imps (repeat IsBoot)
995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 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

    -- 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
1062 1063

    -- Wait for the all the module's dependencies to finish building.
1064
    deps_ok <- allM (fmap succeeded . readMVar) home_deps
parcs's avatar
parcs committed
1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085

    -- 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

1086
                -- Re-typecheck the loop
1087 1088
                -- This is necessary to make sure the knot is tied when
                -- we close a recursive module loop, see bug #12035.
1089 1090 1091 1092 1093 1094 1095 1096
                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
1097
                -- Compile the module.
Edward Z. Yang's avatar
Edward Z. Yang committed
1098
                mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods
1099
                                        lcl_mod mod_index num_mods
parcs's avatar
parcs committed
1100 1101 1102 1103 1104 1105 1106 1107 1108
                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) $
1109
                    atomicModifyIORef' old_hpt_var $ \old_hpt ->
niteria's avatar
niteria committed
1110
                        (delFromHpt old_hpt this_mod, ())
parcs's avatar
parcs committed
1111

1112
                -- Update and fetch the global HscEnv.
parcs's avatar
parcs committed
1113
                lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do
niteria's avatar
niteria committed
1114 1115 1116
                    let hsc_env' = hsc_env
                                     { hsc_HPT = addToHpt (hsc_HPT hsc_env)
                                                           this_mod mod_info }
1117 1118 1119 1120
                    -- 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'
1121
                        Just loop -> typecheckLoop lcl_dflags hsc_env' $
1122
                                     map (moduleName . fst) loop
parcs's avatar
parcs committed
1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139
                    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
1140
-- -----------------------------------------------------------------------------
dterei's avatar
dterei committed
1141
--
Simon Marlow's avatar
Simon Marlow committed
1142 1143 1144 1145 1146 1147 1148 1149
-- | 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
1150 1151
    => Maybe Messager
    -> HomePackageTable            -- ^ HPT from last time round (pruned)
Simon Marlow's avatar
Simon Marlow committed
1152
    -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
1153
    -> (HscEnv -> IO ())           -- ^ How to clean up unwanted tmp files
dterei's avatar
dterei committed
1154
    -> [SCC ModSummary]            -- ^ Mods to do (the worklist)
Simon Marlow's avatar
Simon Marlow committed
1155 1156 1157 1158 1159 1160 1161 1162
    -> 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
1163 1164
upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
   dflags <- getSessionDynFlags
Simon Marlow's avatar
Simon Marlow committed
1165
   (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)
Edward Z. Yang's avatar
Edward Z. Yang committed
1166
                           (unitIdsToCheck dflags) done_holes
Simon Marlow's avatar
Simon Marlow committed
1167 1168
   return (res, reverse done)
 where
Edward Z. Yang's avatar
Edward Z. Yang committed
1169
  done_holes = emptyUniqSet
Simon Marlow's avatar
Simon Marlow committed
1170 1171

  upsweep' _old_hpt done
Edward Z. Yang's avatar
Edward Z. Yang committed
1172 1173 1174 1175
     [] _ _ 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
1176 1177

  upsweep' _old_hpt done
Edward Z. Yang's avatar
Edward Z. Yang committed
1178
     (CyclicSCC ms:_) _ _ _ _
Simon Marlow's avatar
Simon Marlow committed
1179 1180 1181 1182 1183
   = do dflags <- getSessionDynFlags
        liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
        return (Failed, done)

  upsweep' old_hpt done
Edward Z. Yang's avatar
Edward Z. Yang committed
1184
     (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes
1185 1186
   = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
        --           show (map (moduleUserString.moduleName.mi_module.hm_iface)
dterei's avatar
dterei committed
1187
        --                     (moduleEnvElts (hsc_HPT hsc_env)))
Simon Marlow's avatar
Simon Marlow committed
1188 1189 1190
        let logger _mod = defaultWarnErrLogger

        hsc_env <- getSession
1191

Edward Z. Yang's avatar
Edward Z. Yang committed
1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203
        -- 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))