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