ghc/compiler/ghci/CompManager.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-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 )
  17 import Outputable       ( SDoc )
  18 import FiniteMap        ( emptyFM, filterFM )
  19 import Digraph          ( SCC(..), stronglyConnComp )
  20 import Panic            ( panic )
  21
  22 import CmStaticInfo     ( FLAGS, PCI, SI(..), mkSI )
  23 import CmFind           ( Finder, newFinder,
  24                           ModName, ml_modname, isPackageLoc )
  25 import CmSummarise      ( summarise, ModSummary(..),
  26                           mi_name, ms_get_imports )
  27 import CmCompile        ( PCS, emptyPCS, HST, HIT, CompResult(..) )
  28 import CmLink           ( PLS, emptyPLS, HValue, Linkable,
  29                           link, LinkResult(..),
  30                           filterModuleLinkables, modname_of_linkable,
  31                           is_package_linkable )
  32
  33
  34
  35 cmInit :: FLAGS
  36        -> PCI
  37        -> IO CmState
  38 cmInit flags pkginfo
  39    = emptyCmState flags pkginfo
  40
  41 cmGetExpr :: CmState
  42           -> ModHandle
  43           -> String
  44           -> IO (CmState, Either [SDoc] HValue)
  45 cmGetExpr cmstate modhdl expr
  46    = return (error "cmGetExpr:unimp")
  47
  48 cmRunExpr :: HValue -> IO ()
  49 cmRunExpr hval
  50    = return (error "cmRunExpr:unimp")
  51
  52 type ModHandle = String   -- ToDo: do better?
  53
  54
  55 -- Persistent state just for CM, excluding link & compile subsystems
  56 data PCMS
  57    = PCMS {
  58         hst :: HST,   -- home symbol table
  59         hit :: HIT,   -- home interface table
  60         ui  :: UI,    -- the unlinked images
  61         mg  :: MG     -- the module graph
  62      }
  63
  64 emptyPCMS :: PCMS
  65 emptyPCMS = PCMS { hst = emptyHST,
  66                    hit = emptyHIT,
  67                    ui  = emptyUI,
  68                    mg  = emptyMG }
  69
  70 emptyHIT :: HIT
  71 emptyHIT = emptyFM
  72
  73 emptyHST :: HST
  74 emptyHST = emptyFM
  75
  76
  77
  78 -- Persistent state for the entire system
  79 data CmState
  80    = CmState {
  81         pcms   :: PCMS,      -- CM's persistent state
  82         pcs    :: PCS,       -- compile's persistent state
  83         pls    :: PLS,       -- link's persistent state
  84         si     :: SI,        -- static info, never changes
  85         finder :: Finder     -- the module finder
  86      }
  87
  88 emptyCmState :: FLAGS -> PCI -> IO CmState
  89 emptyCmState flags pci
  90     = do let pcms = emptyPCMS
  91          pcs     <- emptyPCS
  92          pls     <- emptyPLS
  93          let si   = mkSI flags pci
  94          finder  <- newFinder pci
  95          return (CmState { pcms   = pcms,
  96                            pcs    = pcs,
  97                            pls    =   pls,
  98                            si     = si,
  99                            finder = finder })
 100
 101 -- CM internal types
 102 type UI = [Linkable]    -- the unlinked images (should be a set, really)
 103 emptyUI :: UI
 104 emptyUI = []
 105
 106
 107 type MG = [SCC ModSummary]  -- the module graph, topologically sorted
 108 emptyMG :: MG
 109 emptyMG = []
 110
 111 \end{code}
 112
 113 The real business of the compilation manager: given a system state and
 114 a module name, try and bring the module up to date, probably changing
 115 the system state at the same time.
 116
 117 \begin{code}
 118 cmLoadModule :: CmState
 119              -> ModName
 120              -> IO (CmState, Either [SDoc] ModHandle)
 121
 122 cmLoadModule cmstate1 modname
 123    = do -- version 1's are the original, before downsweep
 124
 125         let pci1  = pci  (si cmstate1)
 126         let pcms1 = pcms cmstate1
 127         let pls1  = pls  cmstate1
 128         let pcs1  = pcs  cmstate1
 129         let mg1   = mg  pcms1
 130         let hst1  = hst pcms1
 131         let hit1  = hit pcms1
 132         let ui1   = ui  pcms1
 133
 134         -- do the downsweep to reestablish the module graph
 135         -- then generate version 2's by removing from HIT,HST,UI any
 136         -- modules in the old MG which are not in the new one.
 137
 138         putStr "cmLoadModule: downsweep begins\n"
 139         mg2unsorted <- downsweep modname (finder cmstate1)
 140         putStrLn ( "after chasing:\n\n" ++ unlines (map show mg2unsorted))
 141
 142         let modnames1   = map name_of_summary (flattenMG mg1)
 143         let modnames2   = map name_of_summary mg2unsorted
 144         let mods_to_zap = filter (`notElem` modnames2) modnames1
 145
 146         let (hst2, hit2, ui2)
 147                = filterTopLevelEnvs (`notElem` mods_to_zap)
 148                                     (hst1, hit2, ui2)
 149
 150         let mg2 = topological_sort mg2unsorted
 151
 152         putStrLn ( "after tsort:\n\n"
 153                    ++ unlines (map show (flattenMG mg2)))
 154
 155         -- Now do the upsweep, calling compile for each module in
 156         -- turn.  Final result is version 3 of everything.
 157
 158         let threaded2 = ModThreaded pcs1 hst2 hit2
 159
 160         (threaded3, sccOKs, newLis, errs, warns)
 161            <- upsweep_sccs threaded2 [] [] [] [] mg2
 162
 163         let ui3 = add_to_ui ui2 newLis
 164         let (ModThreaded pcs3 hst3 hit3) = threaded3
 165
 166         -- Try and do linking in some form, depending on whether the
 167         -- upsweep was completely or only partially successful.
 168
 169         if null errs
 170
 171          then
 172            do let mods_to_relink = upwards_closure mg2
 173                                       (map modname_of_linkable newLis)
 174               let sccs_to_relink = group_uis ui3 mg2 mods_to_relink
 175               linkresult <- link pci1 sccs_to_relink pls1
 176               case linkresult of
 177                  LinkErrs _ _
 178                     -> panic "cmLoadModule: link failed (1)"
 179                  LinkOK pls3
 180                     -> do let pcms3
 181                                  = PCMS { hst=hst3, hit=hit3, ui=ui3, mg=mg2 }
 182                           let cmstate3
 183                                  = CmState { pcms=pcms3, pcs=pcs3, pls=pls3,
 184                                              si     = si cmstate1,
 185                                              finder = finder cmstate1
 186                                    }
 187                           return (cmstate3, Right modname)
 188
 189          else
 190            do let mods_to_relink = downwards_closure mg2
 191                                       (map name_of_summary (flattenMG sccOKs))
 192               let sccs_to_relink = group_uis ui3 mg2 mods_to_relink
 193               linkresult <- link pci1 sccs_to_relink pls1
 194               let (hst4, hit4, ui4)
 195                      = filterTopLevelEnvs (`notElem` mods_to_relink)
 196                                           (hst3,hit3,ui3)
 197               case linkresult of
 198                  LinkErrs _ _
 199                     -> panic "cmLoadModule: link failed (2)"
 200                  LinkOK pls4
 201                     -> do let pcms4
 202                                  = PCMS { hst=hst4, hit=hit4, ui=ui4, mg=mg2 }
 203                           let cmstate4
 204                                  = CmState { pcms=pcms4, pcs=pcs3, pls=pls4,
 205                                              si     = si cmstate1,
 206                                              finder = finder cmstate1
 207                                    }
 208                           return (cmstate4, Right modname)
 209
 210
 211 flattenMG :: [SCC ModSummary] -> [ModSummary]
 212 flattenMG = concatMap flatten
 213
 214 flatten (AcyclicSCC v) = [v]
 215 flatten (CyclicSCC vs) = vs
 216
 217 -- For each module in mods_to_group, extract the relevant linkable
 218 -- out of UI, and arrange these linkables in SCCs as defined by modGraph.
 219 -- All this is so that we can pass SCCified Linkable groups to the
 220 -- linker.  A constraint that should be recorded somewhere is that
 221 -- all sccs should either be all-interpreted or all-object, not a mixture.
 222 group_uis :: UI -> [SCC ModSummary] -> [ModName] -> [SCC Linkable]
 223 group_uis ui modGraph mods_to_group
 224    = map extract (cleanup (fishOut modGraph mods_to_group))
 225      where
 226         fishOut :: [SCC ModSummary] -> [ModName] -> [(Bool,[ModName])]
 227         fishOut [] unused
 228            | null unused = []
 229            | otherwise   = panic "group_uis: modnames not in modgraph"
 230         fishOut ((AcyclicSCC ms):sccs) unused
 231            = case split (== (name_of_summary ms)) unused of
 232                 (eq, not_eq) -> (False, eq) : fishOut sccs not_eq
 233         fishOut ((CyclicSCC mss):sccs) unused
 234            = case split (`elem` (map name_of_summary mss)) unused of
 235                 (eq, not_eq) -> (True, eq) : fishOut sccs not_eq
 236
 237         cleanup :: [(Bool,[ModName])] -> [SCC ModName]
 238         cleanup [] = []
 239         cleanup ((isRec,names):rest)
 240            | null names = cleanup rest
 241            | isRec      = CyclicSCC names : cleanup rest
 242            | not isRec  = case names of [name] -> AcyclicSCC name : cleanup rest
 243                                         other  -> panic "group_uis(cleanup)"
 244
 245         extract :: SCC ModName -> SCC Linkable
 246         extract (AcyclicSCC nm) = AcyclicSCC (getLi nm)
 247         extract (CyclicSCC nms) = CyclicSCC (map getLi nms)
 248
 249         getLi nm = case [li | li <- ui, not (is_package_linkable li),
 250                                         nm == modname_of_linkable li] of
 251                       [li]  -> li
 252                       other -> panic "group_uis:getLi"
 253
 254         split f xs = (filter f xs, filter (not.f) xs)
 255
 256
 257 -- Add the given (LM-form) Linkables to the UI, overwriting previous
 258 -- versions if they exist.
 259 add_to_ui :: UI -> [Linkable] -> UI
 260 add_to_ui ui lis
 261    = foldr add1 ui lis
 262      where
 263         add1 :: Linkable -> UI -> UI
 264         add1 li ui
 265            = li : filter (\li2 -> not (for_same_module li li2)) ui
 266
 267         for_same_module :: Linkable -> Linkable -> Bool
 268         for_same_module li1 li2
 269            = not (is_package_linkable li1)
 270              && not (is_package_linkable li2)
 271              && modname_of_linkable li1 == modname_of_linkable li2
 272
 273
 274 -- Compute upwards and downwards closures in the (home-) module graph.
 275 downwards_closure,
 276  upwards_closure :: [SCC ModSummary] -> [ModName] -> [ModName]
 277
 278 upwards_closure   = up_down_closure True
 279 downwards_closure = up_down_closure False
 280
 281 up_down_closure :: Bool -> [SCC ModSummary] -> [ModName] -> [ModName]
 282 up_down_closure up modGraph roots
 283    = let mgFlat = flattenMG modGraph
 284          nodes  = map name_of_summary mgFlat
 285
 286          fwdEdges, backEdges  :: [(ModName, [ModName])]
 287                    -- have an entry for each mod in mgFlat, and do not
 288                    -- mention edges leading out of the home package
 289          fwdEdges
 290             = map mkEdge mgFlat
 291          backEdges -- Only calculated if needed, which is just as well!
 292             = [(n, [m | (m, m_imports) <- fwdEdges, n `elem` m_imports])
 293                | (n, n_imports) <- fwdEdges]
 294
 295          iterate :: [(ModName,[ModName])] -> [ModName] -> [ModName]
 296          iterate graph set
 297             = let set2 = nub (concatMap dsts set)
 298                   dsts :: ModName -> [ModName]
 299                   dsts node = case lookup node graph of
 300                                  Just ds -> ds
 301                                  Nothing -> panic "up_down_closure"
 302               in
 303                   if length set == length set2 then set else iterate graph set2
 304
 305          mkEdge summ
 306             = (name_of_summary summ,
 307                -- ignore imports not from the home package
 308                filter (`elem` nodes) (deps_of_summary summ))
 309      in
 310          (if up then iterate backEdges else iterate fwdEdges) (nub roots)
 311
 312
 313 data ModThreaded  -- stuff threaded through individual module compilations
 314    = ModThreaded PCS HST HIT
 315
 316 -- Compile multiple SCCs, stopping as soon as an error appears
 317 upsweep_sccs :: ModThreaded           -- PCS & HST & HIT
 318              -> [SCC ModSummary]      -- accum: SCCs which succeeded
 319              -> [Linkable]            -- accum: new Linkables
 320              -> [SDoc]                -- accum: error messages
 321              -> [SDoc]                -- accum: warnings
 322              -> [SCC ModSummary]      -- SCCs to do (the worklist)
 323                                       -- ...... RETURNING ......
 324              -> IO (ModThreaded,
 325                     [SCC ModSummary], -- SCCs which succeeded
 326                     [Linkable],       -- new linkables
 327                     [SDoc],           -- error messages
 328                     [SDoc])           -- warnings
 329
 330 upsweep_sccs threaded sccOKs newLis errs warns []
 331    = -- No more SCCs to do.
 332      return (threaded, sccOKs, newLis, errs, warns)
 333
 334 upsweep_sccs threaded sccOKs newLis errs warns (scc:sccs)
 335    = -- Start work on a new SCC.
 336      do (threaded2, lisM, errsM, warnsM)
 337            <- upsweep_mods threaded (flatten scc)
 338         if    null errsM
 339          then -- all the modules in the scc were ok
 340               -- move on to the next SCC
 341               upsweep_sccs threaded2 (scc:sccOKs) (lisM++newLis)
 342                            errs (warnsM++warns) sccs
 343          else -- we got a compilation error; give up now
 344               return
 345                  (threaded2, sccOKs,
 346                  lisM++newLis, errsM++errs, warnsM++warns)
 347
 348 -- Compile multiple modules (one SCC), stopping as soon as an error appears
 349 upsweep_mods :: ModThreaded
 350              -> [ModSummary]
 351              -> IO (ModThreaded, [Linkable], [SDoc], [SDoc])
 352 upsweep_mods threaded []
 353    = return (threaded, [], [], [])
 354 upsweep_mods threaded (mod:mods)
 355    = do (threaded1, maybe_linkable, errsM, warnsM) <- upsweep_mod threaded mod
 356         if null errsM
 357          then -- No errors; get contribs from the rest
 358               do (threaded2, linkables, errsMM, warnsMM)
 359                     <- upsweep_mods threaded1 mods
 360                  return
 361                     (threaded2, maybeToList maybe_linkable ++ linkables,
 362                      errsM++errsMM, warnsM++warnsMM)
 363          else -- Errors; give up _now_
 364               return (threaded1, [], errsM, warnsM)
 365
 366 -- Compile a single module.
 367 upsweep_mod :: ModThreaded
 368             -> ModSummary
 369             -> IO (ModThreaded, Maybe Linkable, [SDoc], [SDoc])
 370 upsweep_mod = error "upsweep_mod"
 371
 372
 373
 374
 375 filterTopLevelEnvs :: (ModName -> Bool) -> (HST, HIT, UI) -> (HST, HIT, UI)
 376 filterTopLevelEnvs p (hst, hit, ui)
 377    = (filterFM (\k v -> p k) hst,
 378       filterFM (\k v -> p k) hit,
 379       filterModuleLinkables p ui
 380      )
 381
 382 name_of_summary :: ModSummary -> ModName
 383 name_of_summary = ml_modname . ms_loc
 384
 385 deps_of_summary :: ModSummary -> [ModName]
 386 deps_of_summary = map mi_name . ms_get_imports
 387
 388 topological_sort :: [ModSummary] -> [SCC ModSummary]
 389 topological_sort summaries
 390    = let
 391          toEdge :: ModSummary -> (ModSummary,ModName,[ModName])
 392          toEdge summ
 393              = (summ, name_of_summary summ, deps_of_summary summ)
 394
 395          mash_edge :: (ModSummary,ModName,[ModName]) -> (ModSummary,Int,[Int])
 396          mash_edge (summ, m, m_imports)
 397             = case lookup m key_map of
 398                  Nothing -> panic "reverse_topological_sort"
 399                  Just mk -> (summ, mk,
 400                                 -- ignore imports not from the home package
 401                                 catMaybes (map (flip lookup key_map) m_imports))
 402
 403          edges     = map toEdge summaries
 404          key_map   = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModName,Int)]
 405          scc_input = map mash_edge edges
 406          sccs      = stronglyConnComp scc_input
 407      in
 408          sccs
 409
 410 downsweep :: ModName          -- module to chase from
 411           -> Finder
 412           -> IO [ModSummary]
 413 downsweep rootNm finder
 414    = do rootLoc <- getSummary rootNm
 415         loop [rootLoc]
 416      where
 417         getSummary :: ModName -> IO ModSummary
 418         getSummary nm
 419            = do loc     <- finder nm
 420                 summary <- summarise loc
 421                 return summary
 422
 423         -- loop invariant: homeSummaries doesn't contain package modules
 424         loop :: [ModSummary] -> IO [ModSummary]
 425         loop homeSummaries
 426            = do let allImps   -- all imports
 427                        = (nub . map mi_name . concat . map ms_get_imports)
 428                          homeSummaries
 429                 let allHome   -- all modules currently in homeSummaries
 430                        = map (ml_modname.ms_loc) homeSummaries
 431                 let neededImps
 432                        = filter (`notElem` allHome) allImps
 433                 neededSummaries
 434                        <- mapM getSummary neededImps
 435                 let newHomeSummaries
 436                        = filter (not.isPackageLoc.ms_loc) neededSummaries
 437                 if null newHomeSummaries
 438                  then return homeSummaries
 439                  else loop (newHomeSummaries ++ homeSummaries)
 440
 441 \end{code}