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 ( cmInit, cmLoadModule,
   8                      cmGetExpr, cmRunExpr,
   9                      CmState, emptyCmState  -- abstract
  10                    )
  11 where
  12
  13 #include "HsVersions.h"
  14
  15 import List             ( nub )
  16 import Maybe            ( catMaybes, maybeToList, fromMaybe )
  17 import Maybes           ( maybeToBool )
  18 import Outputable
  19 import UniqFM           ( emptyUFM, lookupUFM, addToUFM, delListFromUFM )
  20 import Digraph          ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
  21
  22 import CmLink           ( PersistentLinkerState, emptyPLS, Linkable(..),
  23                           link, LinkResult(..),
  24                           filterModuleLinkables, modname_of_linkable,
  25                           is_package_linkable, findModuleLinkable )
  26 import CmTypes
  27 import HscTypes
  28 import Interpreter      ( HValue )
  29 import Module           ( ModuleName, moduleName, packageOfModule,
  30                           isModuleInThisPackage, PackageName, moduleEnvElts,
  31                           moduleNameUserString )
  32 import CmStaticInfo     ( Package(..), PackageConfigInfo, GhciMode )
  33 import DriverPipeline
  34 import GetImports
  35 import HscTypes         ( HomeSymbolTable, HomeIfaceTable,
  36                           PersistentCompilerState, ModDetails(..) )
  37 import Name             ( lookupNameEnv )
  38 import Module
  39 import PrelNames        ( mainName )
  40 import HscMain          ( initPersistentCompilerState )
  41 import Finder           ( findModule, emptyHomeDirCache )
  42 import DriverUtil       ( BarfKind(..) )
  43 import Util
  44 import Panic            ( panic )
  45
  46 import Exception        ( throwDyn )
  47 import IO
  48 import Time             ( ClockTime )
  49 import Directory        ( getModificationTime )
  50
  51 \end{code}
  52
  53
  54
  55 \begin{code}
  56 cmInit :: PackageConfigInfo -> GhciMode -> IO CmState
  57 cmInit raw_package_info gmode
  58    = emptyCmState raw_package_info gmode
  59
  60 cmGetExpr :: CmState
  61           -> ModuleName
  62           -> String
  63           -> IO (CmState, Either [SDoc] HValue)
  64 cmGetExpr cmstate modhdl expr
  65    = return (panic "cmGetExpr:unimp")
  66
  67 cmRunExpr :: HValue -> IO ()
  68 cmRunExpr hval
  69    = return (panic "cmRunExpr:unimp")
  70
  71
  72 -- Persistent state just for CM, excluding link & compile subsystems
  73 data PersistentCMState
  74    = PersistentCMState {
  75         hst   :: HomeSymbolTable,    -- home symbol table
  76         hit   :: HomeIfaceTable,     -- home interface table
  77         ui    :: UnlinkedImage,      -- the unlinked images
  78         mg    :: ModuleGraph,        -- the module graph
  79         pci   :: PackageConfigInfo,  -- NEVER CHANGES
  80         gmode :: GhciMode            -- NEVER CHANGES
  81      }
  82
  83 emptyPCMS :: PackageConfigInfo -> GhciMode -> PersistentCMState
  84 emptyPCMS pci gmode
  85   = PersistentCMState { hst = emptyHST, hit = emptyHIT,
  86                         ui  = emptyUI,  mg  = emptyMG,
  87                         pci = pci, gmode = gmode }
  88
  89 emptyHIT :: HomeIfaceTable
  90 emptyHIT = emptyUFM
  91 emptyHST :: HomeSymbolTable
  92 emptyHST = emptyUFM
  93
  94
  95
  96 -- Persistent state for the entire system
  97 data CmState
  98    = CmState {
  99         pcms   :: PersistentCMState,       -- CM's persistent state
 100         pcs    :: PersistentCompilerState, -- compile's persistent state
 101         pls    :: PersistentLinkerState    -- link's persistent state
 102      }
 103
 104 emptyCmState :: PackageConfigInfo -> GhciMode -> IO CmState
 105 emptyCmState pci gmode
 106     = do let pcms = emptyPCMS pci gmode
 107          pcs     <- initPersistentCompilerState
 108          pls     <- emptyPLS
 109          return (CmState { pcms   = pcms,
 110                            pcs    = pcs,
 111                            pls    = pls })
 112
 113 -- CM internal types
 114 type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really)
 115 emptyUI :: UnlinkedImage
 116 emptyUI = []
 117
 118 type ModuleGraph = [ModSummary]  -- the module graph, topologically sorted
 119 emptyMG :: ModuleGraph
 120 emptyMG = []
 121
 122 \end{code}
 123
 124 The real business of the compilation manager: given a system state and
 125 a module name, try and bring the module up to date, probably changing
 126 the system state at the same time.
 127
 128 \begin{code}
 129 cmLoadModule :: CmState
 130              -> ModuleName
 131              -> IO (CmState, Maybe ModuleName)
 132
 133 cmLoadModule cmstate1 rootname
 134    = do -- version 1's are the original, before downsweep
 135         let pcms1     = pcms   cmstate1
 136         let pls1      = pls    cmstate1
 137         let pcs1      = pcs    cmstate1
 138         let mg1       = mg     pcms1
 139         let hst1      = hst    pcms1
 140         let hit1      = hit    pcms1
 141         let ui1       = ui     pcms1
 142
 143         let pcii      = pci   pcms1 -- this never changes
 144         let ghci_mode = gmode pcms1 -- ToDo: fix!
 145
 146         -- During upsweep, look at new summaries to see if source has
 147         -- changed.  Here's a function to pass down; it takes a new
 148         -- summary.
 149         let source_changed :: ModSummary -> Bool
 150             source_changed = summary_indicates_source_changed mg1
 151
 152         -- Do the downsweep to reestablish the module graph
 153         -- then generate version 2's by removing from HIT,HST,UI any
 154         -- modules in the old MG which are not in the new one.
 155
 156         -- Throw away the old home dir cache
 157         emptyHomeDirCache
 158
 159         hPutStr stderr "cmLoadModule: downsweep begins\n"
 160         mg2unsorted <- downsweep [rootname]
 161
 162         let modnames1   = map name_of_summary mg1
 163         let modnames2   = map name_of_summary mg2unsorted
 164         let mods_to_zap = filter (`notElem` modnames2) modnames1
 165
 166         let (hst2, hit2, ui2)
 167                = removeFromTopLevelEnvs mods_to_zap (hst1, hit1, ui1)
 168         -- should be cycle free; ignores 'import source's
 169         let mg2 = topological_sort False mg2unsorted
 170         -- ... whereas this takes them into account.  Only used for
 171         -- backing out partially complete cycles following a failed
 172         -- upsweep.
 173         let mg2_with_srcimps = topological_sort True mg2unsorted
 174
 175         hPutStrLn stderr "after tsort:\n"
 176         hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
 177
 178         -- Because we don't take into account source imports when doing
 179         -- the topological sort, there shouldn't be any cycles in mg2.
 180         -- If there is, we complain and give up -- the user needs to
 181         -- break the cycle using a boot file.
 182
 183         -- Now do the upsweep, calling compile for each module in
 184         -- turn.  Final result is version 3 of everything.
 185
 186         let threaded2 = CmThreaded pcs1 hst2 hit2
 187
 188         (upsweep_complete_success, threaded3, modsDone, newLis)
 189            <- upsweep_mods ghci_mode ui2 source_changed threaded2 mg2
 190
 191         let ui3 = add_to_ui ui2 newLis
 192         let (CmThreaded pcs3 hst3 hit3) = threaded3
 193
 194         -- At this point, modsDone and newLis should have the same
 195         -- length, so there is one new (or old) linkable for each
 196         -- mod which was processed (passed to compile).
 197
 198         -- Try and do linking in some form, depending on whether the
 199         -- upsweep was completely or only partially successful.
 200
 201         if upsweep_complete_success
 202
 203          then
 204            -- Easy; just relink it all.
 205            do hPutStrLn stderr "UPSWEEP COMPLETELY SUCCESSFUL"
 206               linkresult
 207                  <- link ghci_mode (any exports_main (moduleEnvElts hst3))
 208                          newLis pls1
 209               case linkresult of
 210                  LinkErrs _ _
 211                     -> panic "cmLoadModule: link failed (1)"
 212                  LinkOK pls3
 213                     -> do let pcms3 = PersistentCMState { hst=hst3, hit=hit3,
 214                                                           ui=ui3, mg=modsDone,
 215                                                           pci=pcii, gmode=ghci_mode }
 216                           let cmstate3
 217                                  = CmState { pcms=pcms3, pcs=pcs3, pls=pls3 }
 218                           return (cmstate3, Just rootname)
 219
 220          else
 221            -- Tricky.  We need to back out the effects of compiling any
 222            -- half-done cycles, both so as to clean up the top level envs
 223            -- and to avoid telling the interactive linker to link them.
 224            do hPutStrLn stderr "UPSWEEP PARTIALLY SUCCESSFUL"
 225
 226               let modsDone_names
 227                      = map name_of_summary modsDone
 228               let mods_to_zap_names
 229                      = findPartiallyCompletedCycles modsDone_names mg2_with_srcimps
 230               let (hst4, hit4, ui4)
 231                      = removeFromTopLevelEnvs mods_to_zap_names (hst3,hit3,ui3)
 232               let mods_to_keep
 233                      = filter ((`notElem` mods_to_zap_names).name_of_summary) modsDone
 234               let mods_to_keep_names
 235                      = map name_of_summary mods_to_keep
 236               -- we could get the relevant linkables by filtering newLis, but
 237               -- it seems easier to drag them out of the updated, cleaned-up UI
 238               let linkables_to_link
 239                      = map (findModuleLinkable ui4) mods_to_keep_names
 240
 241               linkresult <- link ghci_mode False linkables_to_link pls1
 242               case linkresult of
 243                  LinkErrs _ _
 244                     -> panic "cmLoadModule: link failed (2)"
 245                  LinkOK pls4
 246                     -> do let pcms4 = PersistentCMState { hst=hst4, hit=hit4,
 247                                                           ui=ui4, mg=mods_to_keep,
 248                                                           pci=pcii, gmode=ghci_mode }
 249                           let cmstate4
 250                                  = CmState { pcms=pcms4, pcs=pcs3, pls=pls4 }
 251                           return (cmstate4,
 252                                   -- choose rather arbitrarily who to return
 253                                   if null mods_to_keep then Nothing
 254                                      else Just (last mods_to_keep_names))
 255
 256
 257 -- Given a bunch of old summaries and a new summary, try and
 258 -- find the corresponding old summary, and, if found, compare
 259 -- its source timestamp with that of the new summary.  If in
 260 -- doubt say True.
 261 summary_indicates_source_changed :: [ModSummary] -> ModSummary -> Bool
 262 summary_indicates_source_changed old_summaries new_summary
 263    = case [old | old <- old_summaries,
 264                  name_of_summary old == name_of_summary new_summary] of
 265
 266         (_:_:_) -> panic "summary_indicates_newer_source"
 267
 268         []      -> -- can't find a corresponding old summary, so
 269                    -- compare source and iface dates in the new summary.
 270                    trace (showSDoc (text "SISC: no old summary, new ="
 271                                     <+> pprSummaryTimes new_summary)) (
 272                    case (ms_hs_date new_summary, ms_hi_date new_summary) of
 273                       (Just hs_t, Just hi_t) -> hs_t > hi_t
 274                       other                  -> True
 275                    )
 276
 277         [old]   -> -- found old summary; compare source timestamps
 278                    trace (showSDoc (text "SISC: old ="
 279                                     <+> pprSummaryTimes old
 280                                     <+> pprSummaryTimes new_summary)) (
 281                    case (ms_hs_date old, ms_hs_date new_summary) of
 282                       (Just old_t, Just new_t) -> new_t > old_t
 283                       other                    -> True
 284                    )
 285
 286 -- Return (names of) all those in modsDone who are part of a cycle
 287 -- as defined by theGraph.
 288 findPartiallyCompletedCycles :: [ModuleName] -> [SCC ModSummary] -> [ModuleName]
 289 findPartiallyCompletedCycles modsDone theGraph
 290    = chew theGraph
 291      where
 292         chew [] = []
 293         chew ((AcyclicSCC v):rest) = chew rest    -- acyclic?  not interesting.
 294         chew ((CyclicSCC vs):rest)
 295            = let names_in_this_cycle = nub (map name_of_summary vs)
 296                  mods_in_this_cycle
 297                     = nub ([done | done <- modsDone,
 298                                    done `elem` names_in_this_cycle])
 299                  chewed_rest = chew rest
 300              in
 301              if   not (null mods_in_this_cycle)
 302                   && length mods_in_this_cycle < length names_in_this_cycle
 303              then mods_in_this_cycle ++ chewed_rest
 304              else chewed_rest
 305
 306
 307 -- Does this ModDetails export Main.main?
 308 exports_main :: ModDetails -> Bool
 309 exports_main md
 310    = maybeToBool (lookupNameEnv (md_types md) mainName)
 311
 312
 313 -- Add the given (LM-form) Linkables to the UI, overwriting previous
 314 -- versions if they exist.
 315 add_to_ui :: UnlinkedImage -> [Linkable] -> UnlinkedImage
 316 add_to_ui ui lis
 317    = foldr add1 ui lis
 318      where
 319         add1 :: Linkable -> UnlinkedImage -> UnlinkedImage
 320         add1 li ui
 321            = li : filter (\li2 -> not (for_same_module li li2)) ui
 322
 323         for_same_module :: Linkable -> Linkable -> Bool
 324         for_same_module li1 li2
 325            = not (is_package_linkable li1)
 326              && not (is_package_linkable li2)
 327              && modname_of_linkable li1 == modname_of_linkable li2
 328
 329
 330 data CmThreaded  -- stuff threaded through individual module compilations
 331    = CmThreaded PersistentCompilerState HomeSymbolTable HomeIfaceTable
 332
 333
 334 -- Compile multiple modules, stopping as soon as an error appears.
 335 -- There better had not be any cyclic groups here -- we check for them.
 336 upsweep_mods :: GhciMode
 337              -> UnlinkedImage         -- old linkables
 338              -> (ModSummary -> Bool)  -- has source changed?
 339              -> CmThreaded            -- PCS & HST & HIT
 340              -> [SCC ModSummary]      -- mods to do (the worklist)
 341                                       -- ...... RETURNING ......
 342              -> IO (Bool{-complete success?-},
 343                     CmThreaded,
 344                     [ModSummary],     -- mods which succeeded
 345                     [Linkable])       -- new linkables
 346
 347 upsweep_mods ghci_mode oldUI source_changed threaded []
 348    = return (True, threaded, [], [])
 349
 350 upsweep_mods ghci_mode oldUI source_changed threaded ((CyclicSCC ms):_)
 351    = do hPutStrLn stderr ("ghc: module imports form a cycle for modules:\n\t" ++
 352                           unwords (map (moduleNameUserString.name_of_summary) ms))
 353         return (False, threaded, [], [])
 354
 355 upsweep_mods ghci_mode oldUI source_changed threaded ((AcyclicSCC mod):mods)
 356    = do (threaded1, maybe_linkable)
 357            <- upsweep_mod ghci_mode oldUI threaded mod (source_changed mod)
 358         case maybe_linkable of
 359            Just linkable
 360               -> -- No errors; do the rest
 361                  do (restOK, threaded2, modOKs, linkables)
 362                        <- upsweep_mods ghci_mode oldUI source_changed threaded1 mods
 363                     return (restOK, threaded2, mod:modOKs, linkable:linkables)
 364            Nothing -- we got a compilation error; give up now
 365               -> return (False, threaded1, [], [])
 366
 367
 368 -- Compile a single module.  Always produce a Linkable for it if
 369 -- successful.  If no compilation happened, return the old Linkable.
 370 upsweep_mod :: GhciMode
 371             -> UnlinkedImage
 372             -> CmThreaded
 373             -> ModSummary
 374             -> Bool
 375             -> IO (CmThreaded, Maybe Linkable)
 376
 377 upsweep_mod ghci_mode oldUI threaded1 summary1 source_might_have_changed
 378    = do let mod_name = name_of_summary summary1
 379         let (CmThreaded pcs1 hst1 hit1) = threaded1
 380         let old_iface = lookupUFM hit1 (name_of_summary summary1)
 381         compresult <- compile ghci_mode summary1 (not source_might_have_changed)
 382                               old_iface hst1 hit1 pcs1
 383
 384         case compresult of
 385
 386            -- Compilation "succeeded", but didn't return a new iface or
 387            -- linkable, meaning that compilation wasn't needed, and the
 388            -- new details were manufactured from the old iface.
 389            CompOK details Nothing pcs2
 390               -> let hst2         = addToUFM hst1 mod_name details
 391                      hit2         = hit1
 392                      threaded2    = CmThreaded pcs2 hst2 hit2
 393                      old_linkable = findModuleLinkable oldUI mod_name
 394                  in  return (threaded2, Just old_linkable)
 395
 396            -- Compilation really did happen, and succeeded.  A new
 397            -- details, iface and linkable are returned.
 398            CompOK details (Just (new_iface, new_linkable)) pcs2
 399               -> let hst2      = addToUFM hst1 mod_name details
 400                      hit2      = addToUFM hit1 mod_name new_iface
 401                      threaded2 = CmThreaded pcs2 hst2 hit2
 402                  in  return (threaded2, Just new_linkable)
 403
 404            -- Compilation failed.  compile may still have updated
 405            -- the PCS, tho.
 406            CompErrs pcs2
 407               -> let threaded2 = CmThreaded pcs2 hst1 hit1
 408                  in  return (threaded2, Nothing)
 409
 410
 411 -- Remove unwanted modules from the top level envs (HST, HIT, UI).
 412 removeFromTopLevelEnvs :: [ModuleName]
 413                        -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
 414                        -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
 415 removeFromTopLevelEnvs zap_these (hst, hit, ui)
 416    = (delListFromUFM hst zap_these,
 417       delListFromUFM hit zap_these,
 418       filterModuleLinkables (`notElem` zap_these) ui
 419      )
 420
 421
 422 topological_sort :: Bool -> [ModSummary] -> [SCC ModSummary]
 423 topological_sort include_source_imports summaries
 424    = let
 425          toEdge :: ModSummary -> (ModSummary,ModuleName,[ModuleName])
 426          toEdge summ
 427              = (summ, name_of_summary summ,
 428                       (if include_source_imports
 429                        then ms_srcimps summ else []) ++ ms_imps summ)
 430
 431          mash_edge :: (ModSummary,ModuleName,[ModuleName]) -> (ModSummary,Int,[Int])
 432          mash_edge (summ, m, m_imports)
 433             = case lookup m key_map of
 434                  Nothing -> panic "reverse_topological_sort"
 435                  Just mk -> (summ, mk,
 436                                 -- ignore imports not from the home package
 437                                 catMaybes (map (flip lookup key_map) m_imports))
 438
 439          edges     = map toEdge summaries
 440          key_map   = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModuleName,Int)]
 441          scc_input = map mash_edge edges
 442          sccs      = stronglyConnComp scc_input
 443      in
 444          sccs
 445
 446
 447 -- Chase downwards from the specified root set, returning summaries
 448 -- for all home modules encountered.  Only follow source-import
 449 -- links.
 450 downsweep :: [ModuleName] -> IO [ModSummary]
 451 downsweep rootNm
 452    = do rootSummaries <- mapM getSummary rootNm
 453         loop (filter (isModuleInThisPackage.ms_mod) rootSummaries)
 454      where
 455         getSummary :: ModuleName -> IO ModSummary
 456         getSummary nm
 457            | trace ("getSummary: "++ showSDoc (ppr nm)) True
 458            = do found <- findModule nm
 459                 case found of
 460                    Just (mod, location) -> summarise mod location
 461                    Nothing -> throwDyn (OtherError
 462                                    ("no signs of life for module `"
 463                                      ++ showSDoc (ppr nm) ++ "'"))
 464
 465         -- loop invariant: homeSummaries doesn't contain package modules
 466         loop :: [ModSummary] -> IO [ModSummary]
 467         loop homeSummaries
 468            = do let allImps :: [ModuleName]
 469                     allImps = (nub . concatMap ms_imps) homeSummaries
 470                 let allHome   -- all modules currently in homeSummaries
 471                        = map (moduleName.ms_mod) homeSummaries
 472                 let neededImps
 473                        = filter (`notElem` allHome) allImps
 474                 neededSummaries
 475                        <- mapM getSummary neededImps
 476                 let newHomeSummaries
 477                        = filter (isModuleInThisPackage.ms_mod) neededSummaries
 478                 if null newHomeSummaries
 479                  then return homeSummaries
 480                  else loop (newHomeSummaries ++ homeSummaries)
 481
 482
 483 -- Summarise a module, and pick and source and interface timestamps.
 484 summarise :: Module -> ModuleLocation -> IO ModSummary
 485 summarise mod location
 486    | isModuleInThisPackage mod
 487    = do let hs_fn = unJust (ml_hs_file location) "summarise"
 488         hspp_fn <- preprocess hs_fn
 489         modsrc <- readFile hspp_fn
 490         let (srcimps,imps) = getImports modsrc
 491
 492         maybe_src_timestamp
 493            <- case ml_hs_file location of
 494                  Nothing     -> return Nothing
 495                  Just src_fn -> maybe_getModificationTime src_fn
 496         maybe_iface_timestamp
 497            <- case ml_hi_file location of
 498                  Nothing     -> return Nothing
 499                  Just if_fn  -> maybe_getModificationTime if_fn
 500
 501         return (ModSummary mod location{ml_hspp_file=Just hspp_fn}
 502                                srcimps imps
 503                                maybe_src_timestamp maybe_iface_timestamp)
 504    | otherwise
 505    = return (ModSummary mod location [] [] Nothing Nothing)
 506
 507    where
 508       maybe_getModificationTime :: FilePath -> IO (Maybe ClockTime)
 509       maybe_getModificationTime fn
 510          = (do time <- getModificationTime fn
 511                return (Just time))
 512            `catch`
 513            (\err -> return Nothing)
 514 \end{code}