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