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