ghc/compiler/compMan/CompManager.lhs

   1 %
   2 % (c) The University of Glasgow, 2000
   3 %
   4 \section[CompManager]{The Compilation Manager}
   5
   6 \begin{code}
   7 module CompManager (
   8     cmInit,       -- :: GhciMode -> IO CmState
   9
  10     cmLoadModule, -- :: CmState -> FilePath -> IO (CmState, [String])
  11
  12     cmUnload,     -- :: CmState -> IO CmState
  13
  14     cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String)
  15
  16     cmSetContext, -- :: CmState -> String -> IO CmState
  17
  18     cmGetContext, -- :: CmState -> IO String
  19
  20 #ifdef GHCI
  21     cmRunStmt,    --  :: CmState -> DynFlags -> String -> IO (CmState, [Name])
  22
  23     cmTypeOfExpr, --  :: CmState -> DynFlags -> String
  24                   --  -> IO (CmState, Maybe String)
  25
  26     cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String)
  27
  28     cmCompileExpr,-- :: CmState -> DynFlags -> String
  29                   -- -> IO (CmState, Maybe HValue)#endif
  30 #endif
  31     CmState, emptyCmState  -- abstract
  32   )
  33 where
  34
  35 #include "HsVersions.h"
  36
  37 import CmLink
  38 import CmTypes
  39 import HscTypes
  40 import RnEnv            ( unQualInScope )
  41 import Id               ( idType, idName )
  42 import Name             ( Name, lookupNameEnv, extendNameEnvList,
  43                           NamedThing(..) )
  44 import RdrName          ( emptyRdrEnv )
  45 import Module           ( Module, ModuleName, moduleName, isHomeModule,
  46                           mkModuleName, moduleNameUserString, moduleUserString )
  47 import CmStaticInfo     ( GhciMode(..) )
  48 import DriverPipeline
  49 import GetImports
  50 import Type             ( tidyType )
  51 import VarEnv           ( emptyTidyEnv )
  52 import HscTypes
  53 import HscMain          ( initPersistentCompilerState )
  54 import Finder
  55 import UniqFM           ( lookupUFM, addToUFM, delListFromUFM,
  56                           UniqFM, listToUFM )
  57 import Unique           ( Uniquable )
  58 import Digraph          ( SCC(..), stronglyConnComp, flattenSCC )
  59 import DriverFlags      ( getDynFlags )
  60 import DriverPhases
  61 import DriverUtil       ( splitFilename3 )
  62 import ErrUtils         ( showPass )
  63 import Util
  64 import DriverUtil
  65 import TmpFiles
  66 import Outputable
  67 import Panic
  68 import CmdLineOpts      ( DynFlags(..) )
  69 import IOExts
  70
  71 #ifdef GHCI
  72 import Interpreter      ( HValue )
  73 import HscMain          ( hscStmt )
  74 import PrelGHC          ( unsafeCoerce# )
  75 #endif
  76
  77 -- lang
  78 import Exception        ( throwDyn )
  79
  80 -- std
  81 import Time             ( ClockTime )
  82 import Directory        ( getModificationTime, doesFileExist )
  83 import IO
  84 import Monad
  85 import List             ( nub )
  86 import Maybe            ( catMaybes, fromMaybe, isJust, fromJust )
  87 \end{code}
  88
  89
  90 \begin{code}
  91 -- Persistent state for the entire system
  92 data CmState
  93    = CmState {
  94         hst   :: HomeSymbolTable,    -- home symbol table
  95         hit   :: HomeIfaceTable,     -- home interface table
  96         ui    :: UnlinkedImage,      -- the unlinked images
  97         mg    :: ModuleGraph,        -- the module graph
  98         gmode :: GhciMode,           -- NEVER CHANGES
  99         ic    :: InteractiveContext, -- command-line binding info
 100
 101         pcs    :: PersistentCompilerState, -- compile's persistent state
 102         pls    :: PersistentLinkerState    -- link's persistent state
 103      }
 104
 105 emptyCmState :: GhciMode -> Module -> IO CmState
 106 emptyCmState gmode mod
 107     = do pcs     <- initPersistentCompilerState
 108          pls     <- emptyPLS
 109          return (CmState { hst    = emptySymbolTable,
 110                            hit    = emptyIfaceTable,
 111                            ui     = emptyUI,
 112                            mg     = emptyMG,
 113                            gmode  = gmode,
 114                            ic     = emptyInteractiveContext mod,
 115                            pcs    = pcs,
 116                            pls    = pls })
 117
 118 emptyInteractiveContext mod
 119   = InteractiveContext { ic_module = mod,
 120                          ic_rn_env = emptyRdrEnv,
 121                          ic_type_env = emptyTypeEnv }
 122
 123 defaultCurrentModuleName = mkModuleName "Prelude"
 124 GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module)
 125
 126 -- CM internal types
 127 type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really)
 128 emptyUI :: UnlinkedImage
 129 emptyUI = []
 130
 131 type ModuleGraph = [ModSummary]  -- the module graph, topologically sorted
 132 emptyMG :: ModuleGraph
 133 emptyMG = []
 134
 135 -----------------------------------------------------------------------------
 136 -- Produce an initial CmState.
 137
 138 cmInit :: GhciMode -> IO CmState
 139 cmInit mode = do
 140    prel <- moduleNameToModule defaultCurrentModuleName
 141    writeIORef defaultCurrentModule prel
 142    emptyCmState mode prel
 143
 144 -----------------------------------------------------------------------------
 145 -- Setting the context doesn't throw away any bindings; the bindings
 146 -- we've built up in the InteractiveContext simply move to the new
 147 -- module.  They always shadow anything in scope in the current context.
 148
 149 cmSetContext :: CmState -> String -> IO CmState
 150 cmSetContext cmstate str
 151    = do let mn = mkModuleName str
 152             modules_loaded = [ (name_of_summary s, ms_mod s)  | s <- mg cmstate ]
 153
 154         m <- case lookup mn modules_loaded of
 155                 Just m  -> return m
 156                 Nothing -> do
 157                    mod <- moduleNameToModule mn
 158                    if isHomeModule mod
 159                         then throwDyn (OtherError (showSDoc
 160                                 (quotes (ppr (moduleName mod))
 161                                   <+> text "is not currently loaded")))
 162                         else return mod
 163
 164         return cmstate{ ic = (ic cmstate){ic_module=m} }
 165
 166 cmGetContext :: CmState -> IO String
 167 cmGetContext cmstate = return (moduleUserString (ic_module (ic cmstate)))
 168
 169 moduleNameToModule :: ModuleName -> IO Module
 170 moduleNameToModule mn
 171  = do maybe_stuff <- findModule mn
 172       case maybe_stuff of
 173         Nothing -> throwDyn (OtherError ("can't find module `"
 174                                     ++ moduleNameUserString mn ++ "'"))
 175         Just (m,_) -> return m
 176
 177 -----------------------------------------------------------------------------
 178 -- cmRunStmt:  Run a statement/expr.
 179
 180 #ifdef GHCI
 181 cmRunStmt :: CmState -> DynFlags -> String
 182         -> IO (CmState,                 -- new state
 183                [Name])                  -- names bound by this evaluation
 184 cmRunStmt cmstate dflags expr
 185    = do
 186         let InteractiveContext {
 187                 ic_rn_env = rn_env,
 188                 ic_type_env = type_env,
 189                 ic_module   = this_mod } = icontext
 190
 191         (new_pcs, maybe_stuff)
 192             <- hscStmt dflags hst hit pcs icontext expr
 193
 194         case maybe_stuff of
 195            Nothing -> return (cmstate{ pcs=new_pcs }, [])
 196            Just (ids, bcos) -> do
 197
 198                 -- update the interactive context
 199                 let
 200                     new_rn_env   = extendLocalRdrEnv rn_env (map idName ids)
 201
 202                         -- Extend the renamer-env from bound_ids, not
 203                         -- bound_names, because the latter may contain
 204                         -- [it] when the former is empty
 205                     new_type_env = extendNameEnvList type_env
 206                                         [ (getName id, AnId id) | id <- ids]
 207
 208                     new_ic = icontext { ic_rn_env   = new_rn_env,
 209                                         ic_type_env = new_type_env }
 210
 211                 -- link it
 212                 hval <- linkExpr pls bcos
 213
 214                 -- run it!
 215                 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
 216                 hvals <- thing_to_run
 217
 218                 -- get the newly bound things, and bind them
 219                 let names = map idName ids
 220                 new_pls <- updateClosureEnv pls (zip names hvals)
 221
 222                 return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names)
 223    where
 224        CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
 225 #endif
 226
 227 -----------------------------------------------------------------------------
 228 -- cmTypeOfExpr: returns a string representing the type of an expression
 229
 230 #ifdef GHCI
 231 cmTypeOfExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe String)
 232 cmTypeOfExpr cmstate dflags expr
 233   = do (new_cmstate, names)
 234            <- cmRunStmt cmstate dflags ("let __cmTypeOfExpr=" ++ expr)
 235        case names of
 236          [name] -> do maybe_tystr <- cmTypeOfName new_cmstate name
 237                       return (new_cmstate, maybe_tystr)
 238          _other -> pprPanic "cmTypeOfExpr" (ppr names)
 239 #endif
 240
 241 -----------------------------------------------------------------------------
 242 -- cmTypeOfName: returns a string representing the type of a name.
 243
 244 #ifdef GHCI
 245 cmTypeOfName :: CmState -> Name -> IO (Maybe String)
 246 cmTypeOfName CmState{ hit=hit, pcs=pcs, ic=ic } name
 247  = case lookupNameEnv (ic_type_env ic) name of
 248         Nothing -> return Nothing
 249         Just (AnId id) ->
 250            let pit = pcs_PIT pcs
 251                modname = moduleName (ic_module ic)
 252                ty = tidyType emptyTidyEnv (idType id)
 253                str = case lookupIfaceByModName hit pit modname of
 254                         Nothing    -> showSDoc (ppr ty)
 255                         Just iface -> showSDocForUser unqual (ppr ty)
 256                            where unqual = unQualInScope (mi_globals iface)
 257            in return (Just str)
 258
 259         _ -> panic "cmTypeOfName"
 260 #endif
 261
 262 -----------------------------------------------------------------------------
 263 -- cmCompileExpr: compile an expression and deliver an HValue
 264
 265 #ifdef GHCI
 266 cmCompileExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe HValue)
 267 cmCompileExpr cmstate dflags expr
 268    = do
 269         let InteractiveContext {
 270                 ic_rn_env = rn_env,
 271                 ic_type_env = type_env,
 272                 ic_module   = this_mod } = icontext
 273
 274         (new_pcs, maybe_stuff)
 275             <- hscStmt dflags hst hit pcs icontext
 276                   ("let __cmCompileExpr="++expr)
 277
 278         case maybe_stuff of
 279            Nothing -> return (cmstate{ pcs=new_pcs }, Nothing)
 280            Just (ids, bcos) -> do
 281
 282                 -- link it
 283                 hval <- linkExpr pls bcos
 284
 285                 -- run it!
 286                 let thing_to_run = unsafeCoerce# hval :: IO [HValue]
 287                 hvals <- thing_to_run
 288
 289                 case (ids,hvals) of
 290                   ([id],[hv]) -> return (cmstate{ pcs=new_pcs }, Just hv)
 291                   _ -> panic "cmCompileExpr"
 292
 293    where
 294        CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate
 295 #endif
 296
 297 -----------------------------------------------------------------------------
 298 -- cmInfo: return "info" about an expression.  The info might be:
 299 --
 300 --      * its type, for an expression,
 301 --      * the class definition, for a class
 302 --      * the datatype definition, for a tycon (or synonym)
 303 --      * the export list, for a module
 304 --
 305 -- Can be used to find the type of the last expression compiled, by looking
 306 -- for "it".
 307
 308 cmInfo :: CmState -> String -> IO (Maybe String)
 309 cmInfo cmstate str
 310  = do error "cmInfo not implemented yet"
 311
 312 -----------------------------------------------------------------------------
 313 -- Unload the compilation manager's state: everything it knows about the
 314 -- current collection of modules in the Home package.
 315
 316 cmUnload :: CmState -> IO CmState
 317 cmUnload state
 318  = do -- Throw away the old home dir cache
 319       emptyHomeDirCache
 320       -- Throw away the HIT and the HST
 321       return state{ hst=new_hst, hit=new_hit, ui=emptyUI }
 322    where
 323      CmState{ hst=hst, hit=hit } = state
 324      (new_hst, new_hit) = retainInTopLevelEnvs [] (hst,hit)
 325
 326 -----------------------------------------------------------------------------
 327 -- The real business of the compilation manager: given a system state and
 328 -- a module name, try and bring the module up to date, probably changing
 329 -- the system state at the same time.
 330
 331 cmLoadModule :: CmState
 332              -> FilePath
 333              -> IO (CmState,            -- new state
 334                     Bool,               -- was successful
 335                     [String])           -- list of modules loaded
 336
 337 cmLoadModule cmstate1 rootname
 338    = do -- version 1's are the original, before downsweep
 339         let pls1      = pls    cmstate1
 340         let pcs1      = pcs    cmstate1
 341         let hst1      = hst    cmstate1
 342         let hit1      = hit    cmstate1
 343         -- similarly, ui1 is the (complete) set of linkables from
 344         -- the previous pass, if any.
 345         let ui1       = ui     cmstate1
 346         let mg1       = mg     cmstate1
 347         let ic1       = ic     cmstate1
 348
 349         let ghci_mode = gmode cmstate1 -- this never changes
 350
 351         -- Do the downsweep to reestablish the module graph
 352         -- then generate version 2's by retaining in HIT,HST,UI a
 353         -- stable set S of modules, as defined below.
 354
 355         dflags <- getDynFlags
 356         let verb = verbosity dflags
 357
 358         showPass dflags "Chasing dependencies"
 359         when (verb >= 1 && ghci_mode == Batch) $
 360            hPutStrLn stderr (progName ++ ": chasing modules from: " ++ rootname)
 361
 362         (mg2unsorted, a_root_is_Main) <- downsweep [rootname] mg1
 363         let mg2unsorted_names = map name_of_summary mg2unsorted
 364
 365         -- reachable_from follows source as well as normal imports
 366         let reachable_from :: ModuleName -> [ModuleName]
 367             reachable_from = downwards_closure_of_module mg2unsorted
 368
 369         -- should be cycle free; ignores 'import source's
 370         let mg2 = topological_sort False mg2unsorted
 371         -- ... whereas this takes them into account.  Used for
 372         -- backing out partially complete cycles following a failed
 373         -- upsweep, and for removing from hst/hit all the modules
 374         -- not in strict downwards closure, during calls to compile.
 375         let mg2_with_srcimps = topological_sort True mg2unsorted
 376
 377         -- Sort out which linkables we wish to keep in the unlinked image.
 378         -- See getValidLinkables below for details.
 379         valid_linkables <- getValidLinkables ui1 mg2unsorted_names
 380                                 mg2_with_srcimps
 381
 382         -- Figure out a stable set of modules which can be retained
 383         -- the top level envs, to avoid upsweeping them.  Goes to a
 384         -- bit of trouble to avoid upsweeping module cycles.
 385         --
 386         -- Construct a set S of stable modules like this:
 387         -- Travel upwards, over the sccified graph.  For each scc
 388         -- of modules ms, add ms to S only if:
 389         -- 1.  All home imports of ms are either in ms or S
 390         -- 2.  A valid linkable exists for each module in ms
 391
 392         stable_mods
 393            <- preUpsweep valid_linkables ui1 mg2unsorted_names
 394                  [] mg2_with_srcimps
 395
 396         let stable_summaries
 397                = concatMap (findInSummaries mg2unsorted) stable_mods
 398
 399             stable_linkables
 400                = filter (\m -> linkableModName m `elem` stable_mods)
 401                     valid_linkables
 402
 403         when (verb >= 2) $
 404            putStrLn (showSDoc (text "Stable modules:"
 405                                <+> sep (map (text.moduleNameUserString) stable_mods)))
 406
 407         -- unload any modules which aren't going to be re-linked this
 408         -- time around.
 409         pls2 <- unload ghci_mode dflags stable_linkables pls1
 410
 411         -- We could at this point detect cycles which aren't broken by
 412         -- a source-import, and complain immediately, but it seems better
 413         -- to let upsweep_mods do this, so at least some useful work gets
 414         -- done before the upsweep is abandoned.
 415         let upsweep_these
 416                = filter (\scc -> any (`notElem` stable_mods)
 417                                      (map name_of_summary (flattenSCC scc)))
 418                         mg2
 419
 420         --hPutStrLn stderr "after tsort:\n"
 421         --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
 422
 423         -- Because we don't take into account source imports when doing
 424         -- the topological sort, there shouldn't be any cycles in mg2.
 425         -- If there is, we complain and give up -- the user needs to
 426         -- break the cycle using a boot file.
 427
 428         -- Now do the upsweep, calling compile for each module in
 429         -- turn.  Final result is version 3 of everything.
 430
 431         let threaded2 = CmThreaded pcs1 hst1 hit1
 432
 433         (upsweep_complete_success, threaded3, modsUpswept, newLis)
 434            <- upsweep_mods ghci_mode dflags valid_linkables reachable_from
 435                            threaded2 upsweep_these
 436
 437         let ui3 = add_to_ui valid_linkables newLis
 438         let (CmThreaded pcs3 hst3 hit3) = threaded3
 439
 440         -- At this point, modsUpswept and newLis should have the same
 441         -- length, so there is one new (or old) linkable for each
 442         -- mod which was processed (passed to compile).
 443
 444         -- Make modsDone be the summaries for each home module now
 445         -- available; this should equal the domains of hst3 and hit3.
 446         -- (NOT STRICTLY TRUE if an interactive session was started
 447         --  with some object on disk ???)
 448         -- Get in in a roughly top .. bottom order (hence reverse).
 449
 450         let modsDone = reverse modsUpswept ++ stable_summaries
 451
 452         -- Try and do linking in some form, depending on whether the
 453         -- upsweep was completely or only partially successful.
 454
 455         if upsweep_complete_success
 456
 457          then
 458            -- Easy; just relink it all.
 459            do when (verb >= 2) $
 460                  hPutStrLn stderr "Upsweep completely successful."
 461
 462               -- clean up after ourselves
 463               cleanTempFilesExcept verb (ppFilesFromSummaries modsDone)
 464
 465               -- link everything together
 466               linkresult <- link ghci_mode dflags a_root_is_Main ui3 pls2
 467
 468               cmLoadFinish True linkresult
 469                         hst3 hit3 ui3 modsDone ghci_mode pcs3
 470
 471          else
 472            -- Tricky.  We need to back out the effects of compiling any
 473            -- half-done cycles, both so as to clean up the top level envs
 474            -- and to avoid telling the interactive linker to link them.
 475            do when (verb >= 2) $
 476                 hPutStrLn stderr "Upsweep partially successful."
 477
 478               let modsDone_names
 479                      = map name_of_summary modsDone
 480               let mods_to_zap_names
 481                      = findPartiallyCompletedCycles modsDone_names
 482                           mg2_with_srcimps
 483               let (hst4, hit4, ui4)
 484                      = removeFromTopLevelEnvs mods_to_zap_names (hst3,hit3,ui3)
 485
 486               let mods_to_keep
 487                      = filter ((`notElem` mods_to_zap_names).name_of_summary)
 488                           modsDone
 489
 490               -- clean up after ourselves
 491               cleanTempFilesExcept verb (ppFilesFromSummaries mods_to_keep)
 492
 493               -- link everything together
 494               linkresult <- link ghci_mode dflags False ui4 pls2
 495
 496               cmLoadFinish False linkresult
 497                     hst4 hit4 ui4 mods_to_keep ghci_mode pcs3
 498
 499
 500 -- Finish up after a cmLoad.
 501 --
 502 -- Empty the interactive context and set the module context to the topmost
 503 -- newly loaded module, or the Prelude if none were loaded.
 504 cmLoadFinish ok linkresult hst hit ui mods ghci_mode pcs
 505   = do case linkresult of {
 506           LinkErrs _ _ -> panic "cmLoadModule: link failed (2)";
 507           LinkOK pls   -> do
 508
 509        def_mod <- readIORef defaultCurrentModule
 510        let current_mod = case mods of
 511                                 []    -> def_mod
 512                                 (x:_) -> ms_mod x
 513
 514            new_ic = emptyInteractiveContext current_mod
 515
 516            new_cmstate = CmState{ hst=hst, hit=hit,
 517                                   ui=ui, mg=mods,
 518                                   gmode=ghci_mode, pcs=pcs,
 519                                   pls=pls,
 520                                   ic = new_ic }
 521            mods_loaded = map (moduleNameUserString.name_of_summary) mods
 522
 523        return (new_cmstate, ok, mods_loaded)
 524     }
 525
 526 ppFilesFromSummaries summaries
 527   = [ fn | Just fn <- map (ml_hspp_file . ms_location) summaries ]
 528
 529 -----------------------------------------------------------------------------
 530 -- getValidLinkables
 531
 532 -- For each module (or SCC of modules), we take:
 533 --
 534 --      - the old in-core linkable, if available
 535 --      - an on-disk linkable, if available
 536 --
 537 -- and we take the youngest of these, provided it is younger than the
 538 -- source file.  We ignore the on-disk linkables unless all of the
 539 -- dependents of this SCC also have on-disk linkables.
 540 --
 541 -- If a module has a valid linkable, then it may be STABLE (see below),
 542 -- and it is classified as SOURCE UNCHANGED for the purposes of calling
 543 -- compile.
 544 --
 545 -- ToDo: this pass could be merged with the preUpsweep.
 546
 547 getValidLinkables
 548         :: [Linkable]           -- old linkables
 549         -> [ModuleName]         -- all home modules
 550         -> [SCC ModSummary]     -- all modules in the program, dependency order
 551         -> IO [Linkable]        -- still-valid linkables
 552
 553 getValidLinkables old_linkables all_home_mods module_graph
 554   = foldM (getValidLinkablesSCC old_linkables all_home_mods) [] module_graph
 555
 556 getValidLinkablesSCC old_linkables all_home_mods new_linkables scc0
 557    = let
 558           scc             = flattenSCC scc0
 559           scc_names       = map name_of_summary scc
 560           home_module m   = m `elem` all_home_mods && m `notElem` scc_names
 561           scc_allhomeimps = nub (filter home_module (concatMap ms_allimps scc))
 562
 563           has_object m = case findModuleLinkable_maybe new_linkables m of
 564                             Nothing -> False
 565                             Just l  -> isObjectLinkable l
 566
 567           objects_allowed = all has_object scc_allhomeimps
 568      in do
 569
 570      these_linkables
 571         <- foldM (getValidLinkable old_linkables objects_allowed) [] scc
 572
 573         -- since an scc can contain only all objects or no objects at all,
 574         -- we have to check whether we got all objects or not, and re-do
 575         -- the linkable check if not.
 576      adjusted_linkables
 577         <- if objects_allowed && not (all isObjectLinkable these_linkables)
 578               then foldM (getValidLinkable old_linkables False) [] scc
 579               else return these_linkables
 580
 581      return (adjusted_linkables ++ new_linkables)
 582
 583
 584 getValidLinkable :: [Linkable] -> Bool -> [Linkable] -> ModSummary
 585         -> IO [Linkable]
 586 getValidLinkable old_linkables objects_allowed new_linkables summary
 587    = do
 588         let mod_name = name_of_summary summary
 589
 590         maybe_disk_linkable
 591            <- if (not objects_allowed)
 592                 then return Nothing
 593                 else case ml_obj_file (ms_location summary) of
 594                         Just obj_fn -> maybe_getFileLinkable mod_name obj_fn
 595                         Nothing -> return Nothing
 596
 597          -- find an old in-core linkable if we have one. (forget about
 598          -- on-disk linkables for now, we'll check again whether there's
 599          -- one here below, just in case a new one has popped up recently).
 600         let old_linkable = findModuleLinkable_maybe old_linkables mod_name
 601             maybe_old_linkable =
 602                 case old_linkable of
 603                     Just (LM _ _ ls) | all isInterpretable ls -> old_linkable
 604                     _ -> Nothing
 605
 606         -- The most recent of the old UI linkable or whatever we could
 607         -- find on disk is returned as the linkable if compile
 608         -- doesn't think we need to recompile.
 609         let linkable_list
 610                = case (maybe_old_linkable, maybe_disk_linkable) of
 611                     (Nothing, Nothing) -> []
 612                     (Nothing, Just di) -> [di]
 613                     (Just ui, Nothing) -> [ui]
 614                     (Just ui, Just di)
 615                        | linkableTime ui >= linkableTime di -> [ui]
 616                        | otherwise                          -> [di]
 617
 618         -- only linkables newer than the source code are valid
 619         let maybe_src_date = ms_hs_date summary
 620
 621             valid_linkable_list
 622               = case maybe_src_date of
 623                   Nothing -> panic "valid_linkable_list"
 624                   Just src_date
 625                      -> filter (\li -> linkableTime li > src_date) linkable_list
 626
 627         return (valid_linkable_list ++ new_linkables)
 628
 629
 630 maybe_getFileLinkable :: ModuleName -> FilePath -> IO (Maybe Linkable)
 631 maybe_getFileLinkable mod_name obj_fn
 632    = do obj_exist <- doesFileExist obj_fn
 633         if not obj_exist
 634          then return Nothing
 635          else
 636          do let stub_fn = case splitFilename3 obj_fn of
 637                              (dir, base, ext) -> dir ++ "/" ++ base ++ ".stub_o"
 638             stub_exist <- doesFileExist stub_fn
 639             obj_time <- getModificationTime obj_fn
 640             if stub_exist
 641              then return (Just (LM obj_time mod_name [DotO obj_fn, DotO stub_fn]))
 642              else return (Just (LM obj_time mod_name [DotO obj_fn]))
 643
 644
 645 -----------------------------------------------------------------------------
 646 -- Do a pre-upsweep without use of "compile", to establish a
 647 -- (downward-closed) set of stable modules for which we won't call compile.
 648
 649 preUpsweep :: [Linkable]        -- new valid linkables
 650            -> [Linkable]        -- old linkables
 651            -> [ModuleName]      -- names of all mods encountered in downsweep
 652            -> [ModuleName]      -- accumulating stable modules
 653            -> [SCC ModSummary]  -- scc-ified mod graph, including src imps
 654            -> IO [ModuleName]   -- stable modules
 655
 656 preUpsweep valid_lis old_lis all_home_mods stable []
 657    = return stable
 658 preUpsweep valid_lis old_lis all_home_mods stable (scc0:sccs)
 659    = do let scc = flattenSCC scc0
 660             scc_allhomeimps :: [ModuleName]
 661             scc_allhomeimps
 662                = nub (filter (`elem` all_home_mods) (concatMap ms_allimps scc))
 663             all_imports_in_scc_or_stable
 664                = all in_stable_or_scc scc_allhomeimps
 665             scc_names
 666                = map name_of_summary scc
 667             in_stable_or_scc m
 668                = m `elem` scc_names || m `elem` stable
 669
 670             -- now we check for valid linkables: each module in the SCC must
 671             -- have a valid linkable (see getValidLinkables above), and the
 672             -- newest linkable must be the same as the previous linkable for
 673             -- this module (if one exists).
 674             has_valid_linkable new_summary
 675               = case findModuleLinkable_maybe valid_lis modname of
 676                    Nothing -> False
 677                    Just l  -> case findModuleLinkable_maybe old_lis modname of
 678                                 Nothing -> True
 679                                 Just m  -> linkableTime l == linkableTime m
 680                where modname = name_of_summary new_summary
 681
 682             scc_is_stable = all_imports_in_scc_or_stable
 683                           && all has_valid_linkable scc
 684
 685         if scc_is_stable
 686          then preUpsweep valid_lis old_lis all_home_mods
 687                 (scc_names++stable) sccs
 688          else preUpsweep valid_lis old_lis all_home_mods
 689                 stable sccs
 690
 691    where
 692
 693
 694 -- Helper for preUpsweep.  Assuming that new_summary's imports are all
 695 -- stable (in the sense of preUpsweep), determine if new_summary is itself
 696 -- stable, and, if so, in batch mode, return its linkable.
 697 findInSummaries :: [ModSummary] -> ModuleName -> [ModSummary]
 698 findInSummaries old_summaries mod_name
 699    = [s | s <- old_summaries, name_of_summary s == mod_name]
 700
 701 findModInSummaries :: [ModSummary] -> Module -> Maybe ModSummary
 702 findModInSummaries old_summaries mod
 703    = case [s | s <- old_summaries, ms_mod s == mod] of
 704          [] -> Nothing
 705          (s:_) -> Just s
 706
 707 -- Return (names of) all those in modsDone who are part of a cycle
 708 -- as defined by theGraph.
 709 findPartiallyCompletedCycles :: [ModuleName] -> [SCC ModSummary] -> [ModuleName]
 710 findPartiallyCompletedCycles modsDone theGraph
 711    = chew theGraph
 712      where
 713         chew [] = []
 714         chew ((AcyclicSCC v):rest) = chew rest    -- acyclic?  not interesting.
 715         chew ((CyclicSCC vs):rest)
 716            = let names_in_this_cycle = nub (map name_of_summary vs)
 717                  mods_in_this_cycle
 718                     = nub ([done | done <- modsDone,
 719                                    done `elem` names_in_this_cycle])
 720                  chewed_rest = chew rest
 721              in
 722              if   not (null mods_in_this_cycle)
 723                   && length mods_in_this_cycle < length names_in_this_cycle
 724              then mods_in_this_cycle ++ chewed_rest
 725              else chewed_rest
 726
 727
 728 -- Add the given (LM-form) Linkables to the UI, overwriting previous
 729 -- versions if they exist.
 730 add_to_ui :: UnlinkedImage -> [Linkable] -> UnlinkedImage
 731 add_to_ui ui lis
 732    = filter (not_in lis) ui ++ lis
 733      where
 734         not_in :: [Linkable] -> Linkable -> Bool
 735         not_in lis li
 736            = all (\l -> linkableModName l /= mod) lis
 737            where mod = linkableModName li
 738
 739
 740 data CmThreaded  -- stuff threaded through individual module compilations
 741    = CmThreaded PersistentCompilerState HomeSymbolTable HomeIfaceTable
 742
 743
 744 -- Compile multiple modules, stopping as soon as an error appears.
 745 -- There better had not be any cyclic groups here -- we check for them.
 746 upsweep_mods :: GhciMode
 747              -> DynFlags
 748              -> UnlinkedImage         -- valid linkables
 749              -> (ModuleName -> [ModuleName])  -- to construct downward closures
 750              -> CmThreaded            -- PCS & HST & HIT
 751              -> [SCC ModSummary]      -- mods to do (the worklist)
 752                                       -- ...... RETURNING ......
 753              -> IO (Bool{-complete success?-},
 754                     CmThreaded,
 755                     [ModSummary],     -- mods which succeeded
 756                     [Linkable])       -- new linkables
 757
 758 upsweep_mods ghci_mode dflags oldUI reachable_from threaded
 759      []
 760    = return (True, threaded, [], [])
 761
 762 upsweep_mods ghci_mode dflags oldUI reachable_from threaded
 763      ((CyclicSCC ms):_)
 764    = do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++
 765                           unwords (map (moduleNameUserString.name_of_summary) ms))
 766         return (False, threaded, [], [])
 767
 768 upsweep_mods ghci_mode dflags oldUI reachable_from threaded
 769      ((AcyclicSCC mod):mods)
 770    = do --case threaded of
 771         --   CmThreaded pcsz hstz hitz
 772         --      -> putStrLn ("UPSWEEP_MOD: hit = " ++ show (map (moduleNameUserString.moduleName.mi_module) (eltsUFM hitz)))
 773
 774         (threaded1, maybe_linkable)
 775            <- upsweep_mod ghci_mode dflags oldUI threaded mod
 776                           (reachable_from (name_of_summary mod))
 777         case maybe_linkable of
 778            Just linkable
 779               -> -- No errors; do the rest
 780                  do (restOK, threaded2, modOKs, linkables)
 781                        <- upsweep_mods ghci_mode dflags oldUI reachable_from
 782                                        threaded1 mods
 783                     return (restOK, threaded2, mod:modOKs, linkable:linkables)
 784            Nothing -- we got a compilation error; give up now
 785               -> return (False, threaded1, [], [])
 786
 787
 788 -- Compile a single module.  Always produce a Linkable for it if
 789 -- successful.  If no compilation happened, return the old Linkable.
 790 upsweep_mod :: GhciMode
 791             -> DynFlags
 792             -> UnlinkedImage
 793             -> CmThreaded
 794             -> ModSummary
 795             -> [ModuleName]
 796             -> IO (CmThreaded, Maybe Linkable)
 797
 798 upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_from_here
 799    = do
 800         let mod_name = name_of_summary summary1
 801         let verb = verbosity dflags
 802
 803         let (CmThreaded pcs1 hst1 hit1) = threaded1
 804         let old_iface = lookupUFM hit1 mod_name
 805
 806         let maybe_old_linkable = findModuleLinkable_maybe oldUI mod_name
 807
 808             source_unchanged = isJust maybe_old_linkable
 809
 810             (hst1_strictDC, hit1_strictDC)
 811                = retainInTopLevelEnvs
 812                     (filter (/= (name_of_summary summary1)) reachable_from_here)
 813                     (hst1,hit1)
 814
 815             old_linkable
 816                = unJust "upsweep_mod:old_linkable" maybe_old_linkable
 817
 818         compresult <- compile ghci_mode summary1 source_unchanged
 819                          old_iface hst1_strictDC hit1_strictDC pcs1
 820
 821         case compresult of
 822
 823            -- Compilation "succeeded", but didn't return a new
 824            -- linkable, meaning that compilation wasn't needed, and the
 825            -- new details were manufactured from the old iface.
 826            CompOK pcs2 new_details new_iface Nothing
 827               -> do let hst2         = addToUFM hst1 mod_name new_details
 828                         hit2         = addToUFM hit1 mod_name new_iface
 829                         threaded2    = CmThreaded pcs2 hst2 hit2
 830
 831                     if ghci_mode == Interactive && verb >= 1 then
 832                       -- if we're using an object file, tell the user
 833                       case old_linkable of
 834                         (LM _ _ objs@(DotO _:_))
 835                            -> do hPutStrLn stderr (showSDoc (space <>
 836                                    parens (hsep (text "using":
 837                                         punctuate comma
 838                                           [ text o | DotO o <- objs ]))))
 839                         _ -> return ()
 840                       else
 841                         return ()
 842
 843                     return (threaded2, Just old_linkable)
 844
 845            -- Compilation really did happen, and succeeded.  A new
 846            -- details, iface and linkable are returned.
 847            CompOK pcs2 new_details new_iface (Just new_linkable)
 848               -> do let hst2      = addToUFM hst1 mod_name new_details
 849                         hit2      = addToUFM hit1 mod_name new_iface
 850                         threaded2 = CmThreaded pcs2 hst2 hit2
 851
 852                     return (threaded2, Just new_linkable)
 853
 854            -- Compilation failed.  compile may still have updated
 855            -- the PCS, tho.
 856            CompErrs pcs2
 857               -> do let threaded2 = CmThreaded pcs2 hst1 hit1
 858                     return (threaded2, Nothing)
 859
 860 -- Remove unwanted modules from the top level envs (HST, HIT, UI).
 861 removeFromTopLevelEnvs :: [ModuleName]
 862                        -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
 863                        -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
 864 removeFromTopLevelEnvs zap_these (hst, hit, ui)
 865    = (delListFromUFM hst zap_these,
 866       delListFromUFM hit zap_these,
 867       filterModuleLinkables (`notElem` zap_these) ui
 868      )
 869
 870 retainInTopLevelEnvs :: [ModuleName]
 871                         -> (HomeSymbolTable, HomeIfaceTable)
 872                         -> (HomeSymbolTable, HomeIfaceTable)
 873 retainInTopLevelEnvs keep_these (hst, hit)
 874    = (retainInUFM hst keep_these,
 875       retainInUFM hit keep_these
 876      )
 877      where
 878         retainInUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
 879         retainInUFM ufm keys_to_keep
 880            = listToUFM (concatMap (maybeLookupUFM ufm) keys_to_keep)
 881         maybeLookupUFM ufm u
 882            = case lookupUFM ufm u of Nothing -> []; Just val -> [(u, val)]
 883
 884 -- Needed to clean up HIT and HST so that we don't get duplicates in inst env
 885 downwards_closure_of_module :: [ModSummary] -> ModuleName -> [ModuleName]
 886 downwards_closure_of_module summaries root
 887    = let toEdge :: ModSummary -> (ModuleName,[ModuleName])
 888          toEdge summ = (name_of_summary summ, ms_allimps summ)
 889          res = simple_transitive_closure (map toEdge summaries) [root]
 890      in
 891          --trace (showSDoc (text "DC of mod" <+> ppr root
 892          --                 <+> text "=" <+> ppr res)) (
 893          res
 894          --)
 895
 896 -- Calculate transitive closures from a set of roots given an adjacency list
 897 simple_transitive_closure :: Eq a => [(a,[a])] -> [a] -> [a]
 898 simple_transitive_closure graph set
 899    = let set2      = nub (concatMap dsts set ++ set)
 900          dsts node = fromMaybe [] (lookup node graph)
 901      in
 902          if   length set == length set2
 903          then set
 904          else simple_transitive_closure graph set2
 905
 906
 907 -- Calculate SCCs of the module graph, with or without taking into
 908 -- account source imports.
 909 topological_sort :: Bool -> [ModSummary] -> [SCC ModSummary]
 910 topological_sort include_source_imports summaries
 911    = let
 912          toEdge :: ModSummary -> (ModSummary,ModuleName,[ModuleName])
 913          toEdge summ
 914              = (summ, name_of_summary summ,
 915                       (if include_source_imports
 916                        then ms_srcimps summ else []) ++ ms_imps summ)
 917
 918          mash_edge :: (ModSummary,ModuleName,[ModuleName]) -> (ModSummary,Int,[Int])
 919          mash_edge (summ, m, m_imports)
 920             = case lookup m key_map of
 921                  Nothing -> panic "reverse_topological_sort"
 922                  Just mk -> (summ, mk,
 923                                 -- ignore imports not from the home package
 924                                 catMaybes (map (flip lookup key_map) m_imports))
 925
 926          edges     = map toEdge summaries
 927          key_map   = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModuleName,Int)]
 928          scc_input = map mash_edge edges
 929          sccs      = stronglyConnComp scc_input
 930      in
 931          sccs
 932
 933
 934 -- Chase downwards from the specified root set, returning summaries
 935 -- for all home modules encountered.  Only follow source-import
 936 -- links.  Also returns a Bool to indicate whether any of the roots
 937 -- are module Main.
 938 downsweep :: [FilePath] -> [ModSummary] -> IO ([ModSummary], Bool)
 939 downsweep rootNm old_summaries
 940    = do rootSummaries <- mapM getRootSummary rootNm
 941         let a_root_is_Main
 942                = any ((=="Main").moduleNameUserString.name_of_summary)
 943                      rootSummaries
 944         all_summaries
 945            <- loop (concat (map ms_imps rootSummaries))
 946                 (filter (isHomeModule.ms_mod) rootSummaries)
 947         return (all_summaries, a_root_is_Main)
 948      where
 949         getRootSummary :: FilePath -> IO ModSummary
 950         getRootSummary file
 951            | haskellish_file file
 952            = do exists <- doesFileExist file
 953                 if exists then summariseFile file else do
 954                 throwDyn (OtherError ("can't find file `" ++ file ++ "'"))
 955            | otherwise
 956            = do exists <- doesFileExist hs_file
 957                 if exists then summariseFile hs_file else do
 958                 exists <- doesFileExist lhs_file
 959                 if exists then summariseFile lhs_file else do
 960                 getSummary (mkModuleName file)
 961            where
 962                  hs_file = file ++ ".hs"
 963                  lhs_file = file ++ ".lhs"
 964
 965         getSummary :: ModuleName -> IO ModSummary
 966         getSummary nm
 967            = do found <- findModule nm
 968                 case found of
 969                    Just (mod, location) -> do
 970                         let old_summary = findModInSummaries old_summaries mod
 971                         new_summary <- summarise mod location old_summary
 972                         case new_summary of
 973                            Nothing -> return (fromJust old_summary)
 974                            Just s  -> return s
 975
 976                    Nothing -> throwDyn (OtherError
 977                                    ("can't find module `"
 978                                      ++ showSDoc (ppr nm) ++ "'"))
 979
 980         -- loop invariant: home_summaries doesn't contain package modules
 981         loop :: [ModuleName] -> [ModSummary] -> IO [ModSummary]
 982         loop [] home_summaries = return home_summaries
 983         loop imps home_summaries
 984            = do -- all modules currently in homeSummaries
 985                 let all_home = map (moduleName.ms_mod) home_summaries
 986
 987                 -- imports for modules we don't already have
 988                 let needed_imps = nub (filter (`notElem` all_home) imps)
 989
 990                 -- summarise them
 991                 needed_summaries <- mapM getSummary needed_imps
 992
 993                 -- get just the "home" modules
 994                 let new_home_summaries
 995                        = filter (isHomeModule.ms_mod) needed_summaries
 996
 997                 -- loop, checking the new imports
 998                 let new_imps = concat (map ms_imps new_home_summaries)
 999                 loop new_imps (new_home_summaries ++ home_summaries)
1000
1001 -----------------------------------------------------------------------------
1002 -- Summarising modules
1003
1004 -- We have two types of summarisation:
1005 --
1006 --    * Summarise a file.  This is used for the root module passed to
1007 --      cmLoadModule.  The file is read, and used to determine the root
1008 --      module name.  The module name may differ from the filename.
1009 --
1010 --    * Summarise a module.  We are given a module name, and must provide
1011 --      a summary.  The finder is used to locate the file in which the module
1012 --      resides.
1013
1014 summariseFile :: FilePath -> IO ModSummary
1015 summariseFile file
1016    = do hspp_fn <- preprocess file
1017         modsrc <- readFile hspp_fn
1018
1019         let (srcimps,imps,mod_name) = getImports modsrc
1020             (path, basename, ext) = splitFilename3 file
1021
1022         Just (mod, location)
1023            <- mkHomeModuleLocn mod_name (path ++ '/':basename) file
1024
1025         maybe_src_timestamp
1026            <- case ml_hs_file location of
1027                  Nothing     -> return Nothing
1028                  Just src_fn -> maybe_getModificationTime src_fn
1029
1030         return (ModSummary mod
1031                            location{ml_hspp_file=Just hspp_fn}
1032                            srcimps imps
1033                            maybe_src_timestamp)
1034
1035 -- Summarise a module, and pick up source and timestamp.
1036 summarise :: Module -> ModuleLocation -> Maybe ModSummary
1037     -> IO (Maybe ModSummary)
1038 summarise mod location old_summary
1039    | isHomeModule mod
1040    = do let hs_fn = unJust "summarise" (ml_hs_file location)
1041
1042         maybe_src_timestamp
1043            <- case ml_hs_file location of
1044                  Nothing     -> return Nothing
1045                  Just src_fn -> maybe_getModificationTime src_fn
1046
1047         -- return the cached summary if the source didn't change
1048         case old_summary of {
1049            Just s | ms_hs_date s == maybe_src_timestamp -> return Nothing;
1050            _ -> do
1051
1052         hspp_fn <- preprocess hs_fn
1053         modsrc <- readFile hspp_fn
1054         let (srcimps,imps,mod_name) = getImports modsrc
1055
1056         maybe_src_timestamp
1057            <- case ml_hs_file location of
1058                  Nothing     -> return Nothing
1059                  Just src_fn -> maybe_getModificationTime src_fn
1060
1061         when (mod_name /= moduleName mod) $
1062                 throwDyn (OtherError
1063                    (showSDoc (text "file name does not match module name: "
1064                               <+> ppr (moduleName mod) <+> text "vs"
1065                               <+> ppr mod_name)))
1066
1067         return (Just (ModSummary mod location{ml_hspp_file=Just hspp_fn}
1068                                  srcimps imps
1069                                  maybe_src_timestamp))
1070         }
1071
1072    | otherwise
1073    = return (Just (ModSummary mod location [] [] Nothing))
1074
1075 maybe_getModificationTime :: FilePath -> IO (Maybe ClockTime)
1076 maybe_getModificationTime fn
1077    = (do time <- getModificationTime fn
1078          return (Just time))
1079      `catch`
1080      (\err -> return Nothing)
1081 \end{code}