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 :: HomeIfaceTable, -- 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 :: HomeIfaceTable
  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         -- TODO: call newFinder to reestablish home module cache?!
 141
 142         putStr "cmLoadModule: downsweep begins\n"
 143         mg2unsorted <- downsweep modname finderr
 144         putStrLn (showSDoc (vcat (map ppr mg2unsorted)))
 145
 146         let modnames1   = map name_of_summary (flattenSCCs mg1)
 147         let modnames2   = map name_of_summary mg2unsorted
 148         let mods_to_zap = filter (`notElem` modnames2) modnames1
 149
 150         let (hst2, hit2, ui2)
 151                = filterTopLevelEnvs (`notElem` mods_to_zap)
 152                                     (hst1, hit1, ui1)
 153
 154         let mg2 = topological_sort mg2unsorted
 155
 156         putStrLn "after tsort:\n"
 157         putStrLn (showSDoc (vcat (map ppr (flattenSCCs mg2))))
 158
 159         -- Now do the upsweep, calling compile for each module in
 160         -- turn.  Final result is version 3 of everything.
 161
 162         let threaded2 = ModThreaded pcs1 hst2 hit2
 163
 164         (threaded3, sccOKs, newLis, errs, warns)
 165            <- upsweep_sccs finderr threaded2 [] [] [] [] mg2
 166
 167         let ui3 = add_to_ui ui2 newLis
 168         let (ModThreaded pcs3 hst3 hit3) = threaded3
 169
 170         -- Try and do linking in some form, depending on whether the
 171         -- upsweep was completely or only partially successful.
 172
 173         if null errs
 174
 175          then
 176            do let mods_to_relink = upwards_closure mg2
 177                                       (map modname_of_linkable newLis)
 178               let pkg_linkables = find_pkg_linkables_for pcii mg2 mods_to_relink
 179               putStrLn ("needed package modules =\n"
 180                         ++ showSDoc (vcat (map ppr pkg_linkables)))
 181               let sccs_to_relink = group_uis ui3 mg2 mods_to_relink
 182               let all_to_relink  = map AcyclicSCC pkg_linkables
 183                                    ++ sccs_to_relink
 184               linkresult <- link pcii all_to_relink pls1
 185               case linkresult of
 186                  LinkErrs _ _
 187                     -> panic "cmLoadModule: link failed (1)"
 188                  LinkOK pls3
 189                     -> do let pcms3
 190                                  = PCMS { hst=hst3, hit=hit3, ui=ui3, mg=mg2 }
 191                           let cmstate3
 192                                  = CmState { pcms=pcms3, pcs=pcs3, pls=pls3,
 193                                              pci=pcii, finder=finderr }
 194                           return (cmstate3, Right modname)
 195
 196          else
 197            do let mods_to_relink = downwards_closure mg2
 198                                       (map name_of_summary (flattenSCCs sccOKs))
 199               let pkg_linkables = find_pkg_linkables_for pcii mg2 mods_to_relink
 200               let sccs_to_relink = group_uis ui3 mg2 mods_to_relink
 201               let all_to_relink  = map AcyclicSCC pkg_linkables
 202                                    ++ sccs_to_relink
 203               linkresult <- link pcii all_to_relink pls1
 204               let (hst4, hit4, ui4)
 205                      = filterTopLevelEnvs (`notElem` mods_to_relink)
 206                                           (hst3,hit3,ui3)
 207               case linkresult of
 208                  LinkErrs _ _
 209                     -> panic "cmLoadModule: link failed (2)"
 210                  LinkOK pls4
 211                     -> do let pcms4
 212                                  = PCMS { hst=hst4, hit=hit4, ui=ui4, mg=mg2 }
 213                           let cmstate4
 214                                  = CmState { pcms=pcms4, pcs=pcs3, pls=pls4,
 215                                              pci=pcii, finder=finderr }
 216                           return (cmstate4, Right modname)
 217
 218 -- Given a (home) module graph and a bunch of names of (home) modules
 219 -- within that graph, return the names of any packages needed by the
 220 -- named modules.  Do this by looking at their imports.  Assumes, and
 221 -- checks, that all of "mods" are mentioned in "mg".
 222 --
 223 -- Then, having found the packages directly needed by "mods",
 224 -- (1) round up, by looking in "pci", all packages they directly or
 225 -- indirectly depend on, and (2) put these packages in topological
 226 -- order, since that's important for some linkers.  Since cycles in
 227 -- the package dependency graph aren't allowed, we can just return
 228 -- the list of (package) linkables, rather than a list of SCCs.
 229 find_pkg_linkables_for :: PCI -> [SCC ModSummary] -> [ModName] -> [Linkable]
 230 find_pkg_linkables_for pcii mg mods
 231    = let mg_summaries = flattenSCCs mg
 232          mg_names     = map name_of_summary mg_summaries
 233      in
 234      if   not (all (`elem` mg_names) mods)
 235      then panic "find_packages_for"
 236      else
 237      let all_imports
 238             = concat
 239                  [deps_of_summary summ
 240                  | summ <- mg_summaries, name_of_summary summ `elem` mods]
 241          imports_not_in_home  -- imports which must be from packages
 242             = nub (filter (`notElem` mg_names) all_imports)
 243          mod_tab :: [(ModName, PkgName, Path)]
 244          mod_tab = module_table pcii
 245          home_pkgs_needed -- the packages directly needed by the home modules
 246             = nub [pkg_nm | (mod_nm, pkg_nm, path) <- mod_tab,
 247                             mod_nm `elem` imports_not_in_home]
 248
 249          -- Discover the package dependency graph, and use it to find the
 250          -- transitive closure of all the needed packages
 251          pkg_depend_graph :: [(PkgName,[PkgName])]
 252          pkg_depend_graph = map (\raw -> (name raw, package_deps raw))
 253                                 (raw_package_info pcii)
 254
 255          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          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      in
 268          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 flattenSCCs :: [SCC a] -> [a]
 282 flattenSCCs = concatMap flatten
 283
 284 flatten (AcyclicSCC v) = [v]
 285 flatten (CyclicSCC vs) = vs
 286
 287 -- For each module in mods_to_group, extract the relevant linkable
 288 -- out of UI, and arrange these linkables in SCCs as defined by modGraph.
 289 -- All this is so that we can pass SCCified Linkable groups to the
 290 -- linker.  A constraint that should be recorded somewhere is that
 291 -- all sccs should either be all-interpreted or all-object, not a mixture.
 292 group_uis :: UI -> [SCC ModSummary] -> [ModName] -> [SCC Linkable]
 293 group_uis ui modGraph mods_to_group
 294    = map extract (cleanup (fishOut modGraph mods_to_group))
 295      where
 296         fishOut :: [SCC ModSummary] -> [ModName] -> [(Bool,[ModName])]
 297         fishOut [] unused
 298            | null unused = []
 299            | otherwise   = panic "group_uis: modnames not in modgraph"
 300         fishOut ((AcyclicSCC ms):sccs) unused
 301            = case split (== (name_of_summary ms)) unused of
 302                 (eq, not_eq) -> (False, eq) : fishOut sccs not_eq
 303         fishOut ((CyclicSCC mss):sccs) unused
 304            = case split (`elem` (map name_of_summary mss)) unused of
 305                 (eq, not_eq) -> (True, eq) : fishOut sccs not_eq
 306
 307         cleanup :: [(Bool,[ModName])] -> [SCC ModName]
 308         cleanup [] = []
 309         cleanup ((isRec,names):rest)
 310            | null names = cleanup rest
 311            | isRec      = CyclicSCC names : cleanup rest
 312            | not isRec  = case names of [name] -> AcyclicSCC name : cleanup rest
 313                                         other  -> panic "group_uis(cleanup)"
 314
 315         extract :: SCC ModName -> SCC Linkable
 316         extract (AcyclicSCC nm) = AcyclicSCC (getLi nm)
 317         extract (CyclicSCC nms) = CyclicSCC (map getLi nms)
 318
 319         getLi nm = case [li | li <- ui, not (is_package_linkable li),
 320                                         nm == modname_of_linkable li] of
 321                       [li]  -> li
 322                       other -> panic "group_uis:getLi"
 323
 324         split f xs = (filter f xs, filter (not.f) xs)
 325
 326
 327 -- Add the given (LM-form) Linkables to the UI, overwriting previous
 328 -- versions if they exist.
 329 add_to_ui :: UI -> [Linkable] -> UI
 330 add_to_ui ui lis
 331    = foldr add1 ui lis
 332      where
 333         add1 :: Linkable -> UI -> UI
 334         add1 li ui
 335            = li : filter (\li2 -> not (for_same_module li li2)) ui
 336
 337         for_same_module :: Linkable -> Linkable -> Bool
 338         for_same_module li1 li2
 339            = not (is_package_linkable li1)
 340              && not (is_package_linkable li2)
 341              && modname_of_linkable li1 == modname_of_linkable li2
 342
 343
 344 -- Compute upwards and downwards closures in the (home-) module graph.
 345 downwards_closure,
 346  upwards_closure :: [SCC ModSummary] -> [ModName] -> [ModName]
 347
 348 upwards_closure   = up_down_closure True
 349 downwards_closure = up_down_closure False
 350
 351 up_down_closure :: Bool -> [SCC ModSummary] -> [ModName] -> [ModName]
 352 up_down_closure up modGraph roots
 353    = let mgFlat = flattenSCCs modGraph
 354          nodes  = map name_of_summary mgFlat
 355
 356          fwdEdges, backEdges  :: [(ModName, [ModName])]
 357                    -- have an entry for each mod in mgFlat, and do not
 358                    -- mention edges leading out of the home package
 359          fwdEdges
 360             = map mkEdge mgFlat
 361          backEdges -- Only calculated if needed, which is just as well!
 362             = [(n, [m | (m, m_imports) <- fwdEdges, n `elem` m_imports])
 363                | (n, n_imports) <- fwdEdges]
 364
 365          mkEdge summ
 366             = (name_of_summary summ,
 367                -- ignore imports not from the home package
 368                filter (`elem` nodes) (deps_of_summary summ))
 369      in
 370          simple_transitive_closure
 371             (if up then backEdges else fwdEdges) (nub roots)
 372
 373
 374 data ModThreaded  -- stuff threaded through individual module compilations
 375    = ModThreaded PCS HST HIT
 376
 377 -- Compile multiple SCCs, stopping as soon as an error appears
 378 upsweep_sccs :: Finder                -- the finder
 379              -> ModThreaded           -- PCS & HST & HIT
 380              -> [SCC ModSummary]      -- accum: SCCs which succeeded
 381              -> [Linkable]            -- accum: new Linkables
 382              -> [SDoc]                -- accum: error messages
 383              -> [SDoc]                -- accum: warnings
 384              -> [SCC ModSummary]      -- SCCs to do (the worklist)
 385                                       -- ...... RETURNING ......
 386              -> IO (ModThreaded,
 387                     [SCC ModSummary], -- SCCs which succeeded
 388                     [Linkable],       -- new linkables
 389                     [SDoc],           -- error messages
 390                     [SDoc])           -- warnings
 391
 392 upsweep_sccs finder threaded sccOKs newLis errs warns []
 393    = -- No more SCCs to do.
 394      return (threaded, sccOKs, newLis, errs, warns)
 395
 396 upsweep_sccs finder threaded sccOKs newLis errs warns (scc:sccs)
 397    = -- Start work on a new SCC.
 398      do (threaded2, lisM, errsM, warnsM)
 399            <- upsweep_mods finder threaded (flatten scc)
 400         if    null errsM
 401          then -- all the modules in the scc were ok
 402               -- move on to the next SCC
 403               upsweep_sccs finder threaded2
 404                            (scc:sccOKs) (lisM++newLis)
 405                            errs (warnsM++warns) sccs
 406          else -- we got a compilation error; give up now
 407               return
 408                  (threaded2, sccOKs,
 409                  lisM++newLis, errsM++errs, warnsM++warns)
 410
 411 -- Compile multiple modules (one SCC), stopping as soon as an error appears
 412 upsweep_mods :: Finder
 413              -> ModThreaded
 414              -> [ModSummary]
 415              -> IO (ModThreaded, [Linkable], [SDoc], [SDoc])
 416 upsweep_mods finder threaded []
 417    = return (threaded, [], [], [])
 418 upsweep_mods finder threaded (mod:mods)
 419    = do (threaded1, maybe_linkable, errsM, warnsM)
 420            <- upsweep_mod finder threaded mod
 421         if null errsM
 422          then -- No errors; get contribs from the rest
 423               do (threaded2, linkables, errsMM, warnsMM)
 424                     <- upsweep_mods finder threaded1 mods
 425                  return
 426                     (threaded2, maybeToList maybe_linkable ++ linkables,
 427                      errsM++errsMM, warnsM++warnsMM)
 428          else -- Errors; give up _now_
 429               return (threaded1, [], errsM, warnsM)
 430
 431 -- Compile a single module.
 432 upsweep_mod :: Finder
 433             -> ModThreaded
 434             -> ModSummary
 435             -> IO (ModThreaded, Maybe Linkable, [SDoc], [SDoc])
 436
 437 upsweep_mod finder threaded1 summary1
 438    = do let mod_name = name_of_summary summary1
 439         let (ModThreaded pcs1 hst1 hit1) = threaded1
 440         let old_iface = lookupFM hit1 (name_of_summary summary1)
 441         compresult <- cmCompile finder summary1 old_iface hst1 pcs1
 442
 443         case compresult of
 444
 445            -- Compilation "succeeded", but didn't return a new iface or
 446            -- linkable, meaning that compilation wasn't needed, and the
 447            -- new details were manufactured from the old iface.
 448            CompOK details Nothing pcs2 warns
 449               -> let hst2      = addToFM hst1 mod_name details
 450                      hit2      = hit1
 451                      threaded2 = ModThreaded pcs2 hst2 hit2
 452                  in  return (threaded2, Nothing, [], warns)
 453
 454            -- Compilation really did happen, and succeeded.  A new
 455            -- details, iface and linkable are returned.
 456            CompOK details (Just (new_iface, new_linkable)) pcs2 warns
 457               -> let hst2      = addToFM hst1 mod_name details
 458                      hit2      = addToFM hit1 mod_name new_iface
 459                      threaded2 = ModThreaded pcs2 hst2 hit2
 460                  in  return (threaded2, Just new_linkable, [], warns)
 461
 462            -- Compilation failed.  compile may still have updated
 463            -- the PCS, tho.
 464            CompErrs pcs2 errs warns
 465               -> let threaded2 = ModThreaded pcs2 hst1 hit1
 466                  in  return (threaded2, Nothing, errs, warns)
 467
 468 filterTopLevelEnvs :: (ModName -> Bool) -> (HST, HIT, UI) -> (HST, HIT, UI)
 469 filterTopLevelEnvs p (hst, hit, ui)
 470    = (filterFM (\k v -> p k) hst,
 471       filterFM (\k v -> p k) hit,
 472       filterModuleLinkables p ui
 473      )
 474
 475 topological_sort :: [ModSummary] -> [SCC ModSummary]
 476 topological_sort summaries
 477    = let
 478          toEdge :: ModSummary -> (ModSummary,ModName,[ModName])
 479          toEdge summ
 480              = (summ, name_of_summary summ, deps_of_summary summ)
 481
 482          mash_edge :: (ModSummary,ModName,[ModName]) -> (ModSummary,Int,[Int])
 483          mash_edge (summ, m, m_imports)
 484             = case lookup m key_map of
 485                  Nothing -> panic "reverse_topological_sort"
 486                  Just mk -> (summ, mk,
 487                                 -- ignore imports not from the home package
 488                                 catMaybes (map (flip lookup key_map) m_imports))
 489
 490          edges     = map toEdge summaries
 491          key_map   = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModName,Int)]
 492          scc_input = map mash_edge edges
 493          sccs      = stronglyConnComp scc_input
 494      in
 495          sccs
 496
 497 downsweep :: ModName          -- module to chase from
 498           -> Finder
 499           -> IO [ModSummary]
 500 downsweep rootNm finder
 501    = do rootLoc <- getSummary rootNm
 502         loop [rootLoc]
 503      where
 504         getSummary :: ModName -> IO ModSummary
 505         getSummary nm
 506            = do found <- finder nm
 507                 case found of
 508                    Just (mod, location) -> summarise mod location
 509                    Nothing -> panic ("CompManager: can't find module `" ++
 510                                         showSDoc (ppr nm) ++ "'")
 511
 512         -- loop invariant: homeSummaries doesn't contain package modules
 513         loop :: [ModSummary] -> IO [ModSummary]
 514         loop homeSummaries
 515            = do let allImps   -- all imports
 516                        = (nub . map mi_name . concat . map ms_get_imports)
 517                          homeSummaries
 518                 let allHome   -- all modules currently in homeSummaries
 519                        = map (ml_modname.ms_loc) homeSummaries
 520                 let neededImps
 521                        = filter (`notElem` allHome) allImps
 522                 neededSummaries
 523                        <- mapM getSummary neededImps
 524                 let newHomeSummaries
 525                        = filter (not.isPackageLoc.ms_loc) neededSummaries
 526                 if null newHomeSummaries
 527                  then return homeSummaries
 528                  else loop (newHomeSummaries ++ homeSummaries)
 529
 530 \end{code}