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 Outputable
  18 import UniqFM           ( emptyUFM, lookupUFM, addToUFM, delListFromUFM )
  19 import Digraph          ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
  20 import Panic            ( panic )
  21
  22 import CmLink           ( PersistentLinkerState, emptyPLS, Linkable(..),
  23                           link, LinkResult(..),
  24                           filterModuleLinkables, modname_of_linkable,
  25                           is_package_linkable )
  26 import InterpSyn        ( HValue )
  27 import CmSummarise      ( summarise, ModSummary(..),
  28                           name_of_summary, deps_of_summary,
  29                           mimp_name, ms_get_imports )
  30 import Module           ( ModuleName, moduleName, packageOfModule,
  31                           isModuleInThisPackage, PackageName )
  32 import CmStaticInfo     ( Package(..), PackageConfigInfo )
  33 import DriverPipeline   ( compile, CompResult(..) )
  34 import HscTypes         ( HomeSymbolTable, HomeIfaceTable,
  35                           PersistentCompilerState )
  36 import HscMain          ( initPersistentCompilerState )
  37 import Finder           ( findModule, emptyHomeDirCache )
  38 \end{code}
  39
  40
  41
  42 \begin{code}
  43 cmInit :: PackageConfigInfo -> IO CmState
  44 cmInit raw_package_info
  45    = emptyCmState raw_package_info
  46
  47 cmGetExpr :: CmState
  48           -> ModuleName
  49           -> String
  50           -> IO (CmState, Either [SDoc] HValue)
  51 cmGetExpr cmstate modhdl expr
  52    = return (panic "cmGetExpr:unimp")
  53
  54 cmRunExpr :: HValue -> IO ()
  55 cmRunExpr hval
  56    = return (panic "cmRunExpr:unimp")
  57
  58
  59 -- Persistent state just for CM, excluding link & compile subsystems
  60 data PersistentCMState
  61    = PersistentCMState {
  62         hst :: HomeSymbolTable,    -- home symbol table
  63         hit :: HomeIfaceTable,     -- home interface table
  64         ui  :: UnlinkedImage,      -- the unlinked images
  65         mg  :: ModuleGraph,        -- the module graph
  66         pci :: PackageConfigInfo   -- NEVER CHANGES
  67      }
  68
  69 emptyPCMS :: PackageConfigInfo -> PersistentCMState
  70 emptyPCMS pci
  71   = PersistentCMState { hst = emptyHST, hit = emptyHIT,
  72                         ui  = emptyUI,  mg  = emptyMG, pci = pci }
  73
  74 emptyHIT :: HomeIfaceTable
  75 emptyHIT = emptyUFM
  76 emptyHST :: HomeSymbolTable
  77 emptyHST = emptyUFM
  78
  79
  80
  81 -- Persistent state for the entire system
  82 data CmState
  83    = CmState {
  84         pcms   :: PersistentCMState,       -- CM's persistent state
  85         pcs    :: PersistentCompilerState, -- compile's persistent state
  86         pls    :: PersistentLinkerState    -- link's persistent state
  87      }
  88
  89 emptyCmState :: PackageConfigInfo -> IO CmState
  90 emptyCmState pci
  91     = do let pcms = emptyPCMS pci
  92          pcs     <- initPersistentCompilerState
  93          pls     <- emptyPLS
  94          return (CmState { pcms   = pcms,
  95                            pcs    = pcs,
  96                            pls    = pls })
  97
  98 -- CM internal types
  99 type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really)
 100 emptyUI :: UnlinkedImage
 101 emptyUI = []
 102
 103 type ModuleGraph = [SCC ModSummary]  -- the module graph, topologically sorted
 104 emptyMG :: ModuleGraph
 105 emptyMG = []
 106
 107 \end{code}
 108
 109 The real business of the compilation manager: given a system state and
 110 a module name, try and bring the module up to date, probably changing
 111 the system state at the same time.
 112
 113 \begin{code}
 114 cmLoadModule :: CmState
 115              -> ModuleName
 116              -> IO (CmState, Maybe ModuleName)
 117
 118 cmLoadModule cmstate1 modname
 119    = do -- version 1's are the original, before downsweep
 120         let pcms1   = pcms   cmstate1
 121         let pls1    = pls    cmstate1
 122         let pcs1    = pcs    cmstate1
 123         let mg1     = mg     pcms1
 124         let hst1    = hst    pcms1
 125         let hit1    = hit    pcms1
 126         let ui1     = ui     pcms1
 127
 128         let pcii    = pci    pcms1      -- this never changes
 129
 130         -- do the downsweep to reestablish the module graph
 131         -- then generate version 2's by removing from HIT,HST,UI any
 132         -- modules in the old MG which are not in the new one.
 133
 134         -- Throw away the old home dir cache
 135         emptyHomeDirCache
 136
 137         putStr "cmLoadModule: downsweep begins\n"
 138         mg2unsorted <- downsweep modname
 139         putStrLn (showSDoc (vcat (map ppr mg2unsorted)))
 140
 141         let modnames1   = map name_of_summary (flattenSCCs mg1)
 142         let modnames2   = map name_of_summary mg2unsorted
 143         let mods_to_zap = filter (`notElem` modnames2) modnames1
 144
 145         let (hst2, hit2, ui2)
 146                = removeFromTopLevelEnvs mods_to_zap (hst1, hit1, ui1)
 147
 148         let mg2 = topological_sort mg2unsorted
 149
 150         putStrLn "after tsort:\n"
 151         putStrLn (showSDoc (vcat (map ppr (flattenSCCs mg2))))
 152
 153         -- Now do the upsweep, calling compile for each module in
 154         -- turn.  Final result is version 3 of everything.
 155
 156         let threaded2 = ModThreaded pcs1 hst2 hit2
 157
 158         (upsweepOK, threaded3, sccOKs, newLis)
 159            <- upsweep_sccs threaded2 [] [] mg2
 160
 161         let ui3 = add_to_ui ui2 newLis
 162         let (ModThreaded pcs3 hst3 hit3) = threaded3
 163
 164         -- Try and do linking in some form, depending on whether the
 165         -- upsweep was completely or only partially successful.
 166
 167         if upsweepOK
 168
 169          then
 170            do let mods_to_relink = upwards_closure mg2
 171                                       (map modname_of_linkable newLis)
 172               pkg_linkables <- find_pkg_linkables_for pcii
 173                                                       mg2 mods_to_relink
 174               putStrLn ("needed package modules =\n"
 175                         ++ showSDoc (vcat (map ppr pkg_linkables)))
 176               let sccs_to_relink = group_uis ui3 mg2 mods_to_relink
 177               let all_to_relink  = map AcyclicSCC pkg_linkables
 178                                    ++ sccs_to_relink
 179               linkresult <- link pcii all_to_relink pls1
 180               case linkresult of
 181                  LinkErrs _ _
 182                     -> panic "cmLoadModule: link failed (1)"
 183                  LinkOK pls3
 184                     -> do let pcms3 = PersistentCMState { hst=hst3, hit=hit3,
 185                                                           ui=ui3, mg=mg2, pci=pcii }
 186                           let cmstate3
 187                                  = CmState { pcms=pcms3, pcs=pcs3, pls=pls3 }
 188                           return (cmstate3, Just modname)
 189
 190          else
 191            do let mods_to_relink = downwards_closure mg2
 192                                       (map name_of_summary (flattenSCCs sccOKs))
 193               pkg_linkables <- find_pkg_linkables_for pcii
 194                                                       mg2 mods_to_relink
 195               let sccs_to_relink = group_uis ui3 mg2 mods_to_relink
 196               let all_to_relink  = map AcyclicSCC pkg_linkables
 197                                    ++ sccs_to_relink
 198               linkresult <- link pcii all_to_relink pls1
 199               let (hst4, hit4, ui4)
 200                      = removeFromTopLevelEnvs mods_to_relink (hst3,hit3,ui3)
 201               case linkresult of
 202                  LinkErrs _ _
 203                     -> panic "cmLoadModule: link failed (2)"
 204                  LinkOK pls4
 205                     -> do let pcms4 = PersistentCMState { hst=hst4, hit=hit4,
 206                                                           ui=ui4, mg=mg2, pci=pcii }
 207                           let cmstate4
 208                                  = CmState { pcms=pcms4, pcs=pcs3, pls=pls4 }
 209                           return (cmstate4, Just modname)
 210
 211
 212 -- Given a (home) module graph and a bunch of names of (home) modules
 213 -- within that graph, return the names of any packages needed by the
 214 -- named modules.  Do this by looking at their imports.  Assumes, and
 215 -- checks, that all of "mods" are mentioned in "mg".
 216 --
 217 -- Then, having found the packages directly needed by "mods",
 218 -- (1) round up, by looking in "pci", all packages they directly or
 219 -- indirectly depend on, and (2) put these packages in topological
 220 -- order, since that's important for some linkers.  Since cycles in
 221 -- the package dependency graph aren't allowed, we can just return
 222 -- the list of (package) linkables, rather than a list of SCCs.
 223 find_pkg_linkables_for :: PackageConfigInfo -> [SCC ModSummary] -> [ModuleName]
 224                        -> IO [Linkable]
 225 find_pkg_linkables_for pcii mg mods
 226    = let mg_summaries = flattenSCCs mg
 227          mg_names     = map name_of_summary mg_summaries
 228      in
 229      -- Assert that the modules for which we seek the required packages
 230      -- are all in the module graph, i.e. are all home modules.
 231      if   not (all (`elem` mg_names) mods)
 232      then panic "find_pkg_linkables_for"
 233      else
 234      do let all_imports
 235                = concat
 236                     [deps_of_summary summ
 237                     | summ <- mg_summaries, name_of_summary summ `elem` mods]
 238         let imports_not_in_home  -- imports which must be from packages
 239                = nub (filter (`notElem` mg_names) all_imports)
 240
 241         -- Figure out the packages directly imported by the home modules
 242         maybe_locs_n_mods <- mapM findModule imports_not_in_home
 243         let home_pkgs_needed
 244                = nub (concatMap get_pkg maybe_locs_n_mods)
 245                  where get_pkg Nothing = []
 246                        get_pkg (Just (mod, loc))
 247                           = case packageOfModule mod of
 248                                Just p -> [p]; _ -> []
 249
 250         -- Discover the package dependency graph, and use it to find the
 251         -- transitive closure of all the needed packages
 252         let pkg_depend_graph :: [(PackageName,[PackageName])]
 253             pkg_depend_graph = map (\pkg -> (_PK_ (name pkg), map _PK_ (package_deps pkg))) pcii
 254
 255         let all_pkgs_needed = simple_transitive_closure
 256                                  pkg_depend_graph home_pkgs_needed
 257
 258         -- Make a graph, in the style which Digraph.stronglyConnComp expects,
 259         -- containing entries only for the needed packages.
 260         let needed_graph
 261                = concat
 262                    [if srcP `elem` all_pkgs_needed
 263                      then [(srcP, srcP, dstsP)]
 264                      else []
 265                     | (srcP, dstsP) <- pkg_depend_graph]
 266             tsorted = flattenSCCs (stronglyConnComp needed_graph)
 267
 268         return (map LP tsorted)
 269
 270
 271 simple_transitive_closure :: Eq a => [(a,[a])] -> [a] -> [a]
 272 simple_transitive_closure graph set
 273    = let set2      = nub (concatMap dsts set ++ set)
 274          dsts node = fromMaybe [] (lookup node graph)
 275      in
 276          if   length set == length set2
 277          then set
 278          else simple_transitive_closure graph set2
 279
 280
 281 -- For each module in mods_to_group, extract the relevant linkable
 282 -- out of "ui", and arrange these linkables in SCCs as defined by modGraph.
 283 -- All this is so that we can pass SCCified Linkable groups to the
 284 -- linker.  A constraint that should be recorded somewhere is that
 285 -- all sccs should either be all-interpreted or all-object, not a mixture.
 286 group_uis :: UnlinkedImage -> [SCC ModSummary] -> [ModuleName] -> [SCC Linkable]
 287 group_uis ui modGraph mods_to_group
 288    = map extract (cleanup (fishOut modGraph mods_to_group))
 289      where
 290         fishOut :: [SCC ModSummary] -> [ModuleName] -> [(Bool,[ModuleName])]
 291         fishOut [] unused
 292            | null unused = []
 293            | otherwise   = panic "group_uis: modnames not in modgraph"
 294         fishOut ((AcyclicSCC ms):sccs) unused
 295            = case split (== (name_of_summary ms)) unused of
 296                 (eq, not_eq) -> (False, eq) : fishOut sccs not_eq
 297         fishOut ((CyclicSCC mss):sccs) unused
 298            = case split (`elem` (map name_of_summary mss)) unused of
 299                 (eq, not_eq) -> (True, eq) : fishOut sccs not_eq
 300
 301         cleanup :: [(Bool,[ModuleName])] -> [SCC ModuleName]
 302         cleanup [] = []
 303         cleanup ((isRec,names):rest)
 304            | null names = cleanup rest
 305            | isRec      = CyclicSCC names : cleanup rest
 306            | not isRec  = case names of [name] -> AcyclicSCC name : cleanup rest
 307                                         other  -> panic "group_uis(cleanup)"
 308
 309         extract :: SCC ModuleName -> SCC Linkable
 310         extract (AcyclicSCC nm) = AcyclicSCC (getLi nm)
 311         extract (CyclicSCC nms) = CyclicSCC (map getLi nms)
 312
 313         getLi nm = case [li | li <- ui, not (is_package_linkable li),
 314                                         nm == modname_of_linkable li] of
 315                       [li]  -> li
 316                       other -> panic "group_uis:getLi"
 317
 318         split f xs = (filter f xs, filter (not.f) xs)
 319
 320
 321 -- Add the given (LM-form) Linkables to the UI, overwriting previous
 322 -- versions if they exist.
 323 add_to_ui :: UnlinkedImage -> [Linkable] -> UnlinkedImage
 324 add_to_ui ui lis
 325    = foldr add1 ui lis
 326      where
 327         add1 :: Linkable -> UnlinkedImage -> UnlinkedImage
 328         add1 li ui
 329            = li : filter (\li2 -> not (for_same_module li li2)) ui
 330
 331         for_same_module :: Linkable -> Linkable -> Bool
 332         for_same_module li1 li2
 333            = not (is_package_linkable li1)
 334              && not (is_package_linkable li2)
 335              && modname_of_linkable li1 == modname_of_linkable li2
 336
 337
 338 -- Compute upwards and downwards closures in the (home-) module graph.
 339 downwards_closure,
 340  upwards_closure :: [SCC ModSummary] -> [ModuleName] -> [ModuleName]
 341
 342 upwards_closure   = up_down_closure True
 343 downwards_closure = up_down_closure False
 344
 345 up_down_closure :: Bool -> [SCC ModSummary] -> [ModuleName] -> [ModuleName]
 346 up_down_closure up modGraph roots
 347    = let mgFlat = flattenSCCs modGraph
 348          nodes  = map name_of_summary mgFlat
 349
 350          fwdEdges, backEdges  :: [(ModuleName, [ModuleName])]
 351                    -- have an entry for each mod in mgFlat, and do not
 352                    -- mention edges leading out of the home package
 353          fwdEdges
 354             = map mkEdge mgFlat
 355          backEdges -- Only calculated if needed, which is just as well!
 356             = [(n, [m | (m, m_imports) <- fwdEdges, n `elem` m_imports])
 357                | (n, n_imports) <- fwdEdges]
 358
 359          mkEdge summ
 360             = (name_of_summary summ,
 361                -- ignore imports not from the home package
 362                filter (`elem` nodes) (deps_of_summary summ))
 363      in
 364          simple_transitive_closure
 365             (if up then backEdges else fwdEdges) (nub roots)
 366
 367
 368
 369 data ModThreaded  -- stuff threaded through individual module compilations
 370    = ModThreaded PersistentCompilerState HomeSymbolTable HomeIfaceTable
 371
 372 -- Compile multiple SCCs, stopping as soon as an error appears
 373 upsweep_sccs :: ModThreaded           -- PCS & HST & HIT
 374              -> [SCC ModSummary]      -- accum: SCCs which succeeded
 375              -> [Linkable]            -- accum: new Linkables
 376              -> [SCC ModSummary]      -- SCCs to do (the worklist)
 377                                       -- ...... RETURNING ......
 378              -> IO (Bool{-success?-},
 379                     ModThreaded,
 380                     [SCC ModSummary], -- SCCs which succeeded
 381                     [Linkable])       -- new linkables
 382
 383 upsweep_sccs threaded sccOKs newLis []
 384    = -- No more SCCs to do.
 385      return (True, threaded, sccOKs, newLis)
 386
 387 upsweep_sccs threaded sccOKs newLis (scc:sccs)
 388    = -- Start work on a new SCC.
 389      do (sccOK, threaded2, lisSCC)
 390            <- upsweep_scc threaded (flattenSCC scc)
 391         if    sccOK
 392          then -- all the modules in the scc were ok
 393               -- move on to the next SCC
 394               upsweep_sccs threaded2
 395                            (scc:sccOKs) (lisSCC++newLis) sccs
 396          else -- we got a compilation error; give up now
 397               return
 398                  (False, threaded2, sccOKs, lisSCC++newLis)
 399
 400
 401 -- Compile multiple modules (one SCC), stopping as soon as an error appears
 402 upsweep_scc :: ModThreaded
 403              -> [ModSummary]
 404              -> IO (Bool{-success?-}, ModThreaded, [Linkable])
 405 upsweep_scc threaded []
 406    = return (True, threaded, [])
 407 upsweep_scc threaded (mod:mods)
 408    = do (moduleOK, threaded1, maybe_linkable)
 409            <- upsweep_mod threaded mod
 410         if moduleOK
 411          then -- No errors; get contribs from the rest
 412               do (restOK, threaded2, linkables)
 413                     <- upsweep_scc threaded1 mods
 414                  return
 415                     (restOK, threaded2, maybeToList maybe_linkable ++ linkables)
 416          else -- Errors; give up _now_
 417               return (False, threaded1, [])
 418
 419 -- Compile a single module.
 420 upsweep_mod :: ModThreaded
 421             -> ModSummary
 422             -> IO (Bool{-success?-}, ModThreaded, Maybe Linkable)
 423
 424 upsweep_mod threaded1 summary1
 425    = do let mod_name = name_of_summary summary1
 426         let (ModThreaded pcs1 hst1 hit1) = threaded1
 427         let old_iface = lookupUFM hit1 (name_of_summary summary1)
 428         compresult <- compile summary1 old_iface hst1 hit1 pcs1
 429
 430         case compresult of
 431
 432            -- Compilation "succeeded", but didn't return a new iface or
 433            -- linkable, meaning that compilation wasn't needed, and the
 434            -- new details were manufactured from the old iface.
 435            CompOK details Nothing pcs2
 436               -> let hst2      = addToUFM hst1 mod_name details
 437                      hit2      = hit1
 438                      threaded2 = ModThreaded pcs2 hst2 hit2
 439                  in  return (True, threaded2, Nothing)
 440
 441            -- Compilation really did happen, and succeeded.  A new
 442            -- details, iface and linkable are returned.
 443            CompOK details (Just (new_iface, new_linkable)) pcs2
 444               -> let hst2      = addToUFM hst1 mod_name details
 445                      hit2      = addToUFM hit1 mod_name new_iface
 446                      threaded2 = ModThreaded pcs2 hst2 hit2
 447                  in  return (True, threaded2, Just new_linkable)
 448
 449            -- Compilation failed.  compile may still have updated
 450            -- the PCS, tho.
 451            CompErrs pcs2
 452               -> let threaded2 = ModThreaded pcs2 hst1 hit1
 453                  in  return (False, threaded2, Nothing)
 454
 455
 456 removeFromTopLevelEnvs :: [ModuleName]
 457                        -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
 458                        -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
 459 removeFromTopLevelEnvs zap_these (hst, hit, ui)
 460    = (delListFromUFM hst zap_these,
 461       delListFromUFM hit zap_these,
 462       filterModuleLinkables (`notElem` zap_these) ui
 463      )
 464
 465 topological_sort :: [ModSummary] -> [SCC ModSummary]
 466 topological_sort summaries
 467    = let
 468          toEdge :: ModSummary -> (ModSummary,ModuleName,[ModuleName])
 469          toEdge summ
 470              = (summ, name_of_summary summ, deps_of_summary summ)
 471
 472          mash_edge :: (ModSummary,ModuleName,[ModuleName]) -> (ModSummary,Int,[Int])
 473          mash_edge (summ, m, m_imports)
 474             = case lookup m key_map of
 475                  Nothing -> panic "reverse_topological_sort"
 476                  Just mk -> (summ, mk,
 477                                 -- ignore imports not from the home package
 478                                 catMaybes (map (flip lookup key_map) m_imports))
 479
 480          edges     = map toEdge summaries
 481          key_map   = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModuleName,Int)]
 482          scc_input = map mash_edge edges
 483          sccs      = stronglyConnComp scc_input
 484      in
 485          sccs
 486
 487 downsweep :: ModuleName          -- module to chase from
 488           -> IO [ModSummary]
 489 downsweep rootNm
 490    = do rootLoc <- getSummary rootNm
 491         loop [rootLoc]
 492      where
 493         getSummary :: ModuleName -> IO ModSummary
 494         getSummary nm
 495            = do found <- findModule nm
 496                 case found of
 497                    Just (mod, location) -> summarise mod location
 498                    Nothing -> panic ("CompManager: can't find module `" ++
 499                                         showSDoc (ppr nm) ++ "'")
 500
 501         -- loop invariant: homeSummaries doesn't contain package modules
 502         loop :: [ModSummary] -> IO [ModSummary]
 503         loop homeSummaries
 504            = do let allImps :: [ModuleName]
 505                     allImps   -- all imports
 506                        = (nub . map mimp_name . concat . map ms_get_imports)
 507                          homeSummaries
 508                 let allHome   -- all modules currently in homeSummaries
 509                        = map (moduleName.ms_mod) homeSummaries
 510                 let neededImps
 511                        = filter (`notElem` allHome) allImps
 512                 neededSummaries
 513                        <- mapM getSummary neededImps
 514                 let newHomeSummaries
 515                        = filter (isModuleInThisPackage.ms_mod) neededSummaries
 516                 if null newHomeSummaries
 517                  then return homeSummaries
 518                  else loop (newHomeSummaries ++ homeSummaries)
 519 \end{code}