2 % (c) The University of Glasgow, 2000
4 \section[CompManager]{The Compilation Manager}
7 module CompManager ( cmInit, cmLoadModule,
9 CmState, emptyCmState -- abstract
13 #include "HsVersions.h"
16 import Maybe ( catMaybes, maybeToList, fromMaybe )
18 import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM )
19 import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
20 import Panic ( panic )
22 import CmLink ( PersistentLinkerState, emptyPLS, Linkable(..),
24 filterModuleLinkables, modname_of_linkable,
26 import Interpreter ( HValue )
27 import CmSummarise ( summarise, ModSummary(..),
28 name_of_summary, deps_of_summary,
29 mimp_name, ms_get_imports )
30 import Module ( ModuleName, moduleName, packageOfModule,
31 isModuleInThisPackage, PackageName )
32 import CmStaticInfo ( Package(..), PackageConfigInfo )
33 import DriverPipeline ( compile, CompResult(..) )
34 import HscTypes ( HomeSymbolTable, HomeIfaceTable,
35 PersistentCompilerState )
36 import HscMain ( initPersistentCompilerState )
37 import Finder ( findModule, emptyHomeDirCache )
43 cmInit :: PackageConfigInfo -> IO CmState
44 cmInit raw_package_info
45 = emptyCmState raw_package_info
50 -> IO (CmState, Either [SDoc] HValue)
51 cmGetExpr cmstate modhdl expr
52 = return (panic "cmGetExpr:unimp")
54 cmRunExpr :: HValue -> IO ()
56 = return (panic "cmRunExpr:unimp")
59 -- Persistent state just for CM, excluding link & compile subsystems
60 data PersistentCMState
62 hst :: HomeSymbolTable, -- home symbol table
63 hit :: HomeIfaceTable, -- home interface table
64 ui :: UnlinkedImage, -- the unlinked images
65 mg :: ModuleGraph, -- the module graph
66 pci :: PackageConfigInfo -- NEVER CHANGES
69 emptyPCMS :: PackageConfigInfo -> PersistentCMState
71 = PersistentCMState { hst = emptyHST, hit = emptyHIT,
72 ui = emptyUI, mg = emptyMG, pci = pci }
74 emptyHIT :: HomeIfaceTable
76 emptyHST :: HomeSymbolTable
81 -- Persistent state for the entire system
84 pcms :: PersistentCMState, -- CM's persistent state
85 pcs :: PersistentCompilerState, -- compile's persistent state
86 pls :: PersistentLinkerState -- link's persistent state
89 emptyCmState :: PackageConfigInfo -> IO CmState
91 = do let pcms = emptyPCMS pci
92 pcs <- initPersistentCompilerState
94 return (CmState { pcms = pcms,
99 type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really)
100 emptyUI :: UnlinkedImage
103 type ModuleGraph = [SCC ModSummary] -- the module graph, topologically sorted
104 emptyMG :: ModuleGraph
109 The real business of the compilation manager: given a system state and
110 a module name, try and bring the module up to date, probably changing
111 the system state at the same time.
114 cmLoadModule :: CmState
116 -> IO (CmState, Maybe ModuleName)
118 cmLoadModule cmstate1 modname
119 = do -- version 1's are the original, before downsweep
120 let pcms1 = pcms cmstate1
121 let pls1 = pls cmstate1
122 let pcs1 = pcs cmstate1
128 let pcii = pci pcms1 -- this never changes
130 -- do the downsweep to reestablish the module graph
131 -- then generate version 2's by removing from HIT,HST,UI any
132 -- modules in the old MG which are not in the new one.
134 -- Throw away the old home dir cache
137 putStr "cmLoadModule: downsweep begins\n"
138 mg2unsorted <- downsweep modname
139 putStrLn (showSDoc (vcat (map ppr mg2unsorted)))
141 let modnames1 = map name_of_summary (flattenSCCs mg1)
142 let modnames2 = map name_of_summary mg2unsorted
143 let mods_to_zap = filter (`notElem` modnames2) modnames1
145 let (hst2, hit2, ui2)
146 = removeFromTopLevelEnvs mods_to_zap (hst1, hit1, ui1)
148 let mg2 = topological_sort mg2unsorted
150 putStrLn "after tsort:\n"
151 putStrLn (showSDoc (vcat (map ppr (flattenSCCs mg2))))
153 -- Now do the upsweep, calling compile for each module in
154 -- turn. Final result is version 3 of everything.
156 let threaded2 = ModThreaded pcs1 hst2 hit2
158 (upsweepOK, threaded3, sccOKs, newLis)
159 <- upsweep_sccs threaded2 [] [] mg2
161 let ui3 = add_to_ui ui2 newLis
162 let (ModThreaded pcs3 hst3 hit3) = threaded3
164 -- Try and do linking in some form, depending on whether the
165 -- upsweep was completely or only partially successful.
170 do let mods_to_relink = upwards_closure mg2
171 (map modname_of_linkable newLis)
172 pkg_linkables <- find_pkg_linkables_for pcii
174 putStrLn ("needed package modules =\n"
175 ++ showSDoc (vcat (map ppr pkg_linkables)))
176 let sccs_to_relink = group_uis ui3 mg2 mods_to_relink
177 let all_to_relink = map AcyclicSCC pkg_linkables
179 linkresult <- link pcii all_to_relink pls1
182 -> panic "cmLoadModule: link failed (1)"
184 -> do let pcms3 = PersistentCMState { hst=hst3, hit=hit3,
185 ui=ui3, mg=mg2, pci=pcii }
187 = CmState { pcms=pcms3, pcs=pcs3, pls=pls3 }
188 return (cmstate3, Just modname)
191 do let mods_to_relink = downwards_closure mg2
192 (map name_of_summary (flattenSCCs sccOKs))
193 pkg_linkables <- find_pkg_linkables_for pcii
195 let sccs_to_relink = group_uis ui3 mg2 mods_to_relink
196 let all_to_relink = map AcyclicSCC pkg_linkables
198 linkresult <- link pcii all_to_relink pls1
199 let (hst4, hit4, ui4)
200 = removeFromTopLevelEnvs mods_to_relink (hst3,hit3,ui3)
203 -> panic "cmLoadModule: link failed (2)"
205 -> do let pcms4 = PersistentCMState { hst=hst4, hit=hit4,
206 ui=ui4, mg=mg2, pci=pcii }
208 = CmState { pcms=pcms4, pcs=pcs3, pls=pls4 }
209 return (cmstate4, Just modname)
212 -- Given a (home) module graph and a bunch of names of (home) modules
213 -- within that graph, return the names of any packages needed by the
214 -- named modules. Do this by looking at their imports. Assumes, and
215 -- checks, that all of "mods" are mentioned in "mg".
217 -- Then, having found the packages directly needed by "mods",
218 -- (1) round up, by looking in "pci", all packages they directly or
219 -- indirectly depend on, and (2) put these packages in topological
220 -- order, since that's important for some linkers. Since cycles in
221 -- the package dependency graph aren't allowed, we can just return
222 -- the list of (package) linkables, rather than a list of SCCs.
223 find_pkg_linkables_for :: PackageConfigInfo -> [SCC ModSummary] -> [ModuleName]
225 find_pkg_linkables_for pcii mg mods
226 = let mg_summaries = flattenSCCs mg
227 mg_names = map name_of_summary mg_summaries
229 -- Assert that the modules for which we seek the required packages
230 -- are all in the module graph, i.e. are all home modules.
231 if not (all (`elem` mg_names) mods)
232 then panic "find_pkg_linkables_for"
236 [deps_of_summary summ
237 | summ <- mg_summaries, name_of_summary summ `elem` mods]
238 let imports_not_in_home -- imports which must be from packages
239 = nub (filter (`notElem` mg_names) all_imports)
241 -- Figure out the packages directly imported by the home modules
242 maybe_locs_n_mods <- mapM findModule imports_not_in_home
244 = nub (concatMap get_pkg maybe_locs_n_mods)
245 where get_pkg Nothing = []
246 get_pkg (Just (mod, loc))
247 = case packageOfModule mod of
248 Just p -> [p]; _ -> []
250 -- Discover the package dependency graph, and use it to find the
251 -- transitive closure of all the needed packages
252 let pkg_depend_graph :: [(PackageName,[PackageName])]
253 pkg_depend_graph = map (\pkg -> (_PK_ (name pkg), map _PK_ (package_deps pkg))) pcii
255 let all_pkgs_needed = simple_transitive_closure
256 pkg_depend_graph home_pkgs_needed
258 -- Make a graph, in the style which Digraph.stronglyConnComp expects,
259 -- containing entries only for the needed packages.
262 [if srcP `elem` all_pkgs_needed
263 then [(srcP, srcP, dstsP)]
265 | (srcP, dstsP) <- pkg_depend_graph]
266 tsorted = flattenSCCs (stronglyConnComp needed_graph)
268 return (map LP tsorted)
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)
276 if length set == length set2
278 else simple_transitive_closure graph set2
281 -- For each module in mods_to_group, extract the relevant linkable
282 -- out of "ui", and arrange these linkables in SCCs as defined by modGraph.
283 -- All this is so that we can pass SCCified Linkable groups to the
284 -- linker. A constraint that should be recorded somewhere is that
285 -- all sccs should either be all-interpreted or all-object, not a mixture.
286 group_uis :: UnlinkedImage -> [SCC ModSummary] -> [ModuleName] -> [SCC Linkable]
287 group_uis ui modGraph mods_to_group
288 = map extract (cleanup (fishOut modGraph mods_to_group))
290 fishOut :: [SCC ModSummary] -> [ModuleName] -> [(Bool,[ModuleName])]
293 | otherwise = panic "group_uis: modnames not in modgraph"
294 fishOut ((AcyclicSCC ms):sccs) unused
295 = case split (== (name_of_summary ms)) unused of
296 (eq, not_eq) -> (False, eq) : fishOut sccs not_eq
297 fishOut ((CyclicSCC mss):sccs) unused
298 = case split (`elem` (map name_of_summary mss)) unused of
299 (eq, not_eq) -> (True, eq) : fishOut sccs not_eq
301 cleanup :: [(Bool,[ModuleName])] -> [SCC ModuleName]
303 cleanup ((isRec,names):rest)
304 | null names = cleanup rest
305 | isRec = CyclicSCC names : cleanup rest
306 | not isRec = case names of [name] -> AcyclicSCC name : cleanup rest
307 other -> panic "group_uis(cleanup)"
309 extract :: SCC ModuleName -> SCC Linkable
310 extract (AcyclicSCC nm) = AcyclicSCC (getLi nm)
311 extract (CyclicSCC nms) = CyclicSCC (map getLi nms)
313 getLi nm = case [li | li <- ui, not (is_package_linkable li),
314 nm == modname_of_linkable li] of
316 other -> panic "group_uis:getLi"
318 split f xs = (filter f xs, filter (not.f) xs)
321 -- Add the given (LM-form) Linkables to the UI, overwriting previous
322 -- versions if they exist.
323 add_to_ui :: UnlinkedImage -> [Linkable] -> UnlinkedImage
327 add1 :: Linkable -> UnlinkedImage -> UnlinkedImage
329 = li : filter (\li2 -> not (for_same_module li li2)) ui
331 for_same_module :: Linkable -> Linkable -> Bool
332 for_same_module li1 li2
333 = not (is_package_linkable li1)
334 && not (is_package_linkable li2)
335 && modname_of_linkable li1 == modname_of_linkable li2
338 -- Compute upwards and downwards closures in the (home-) module graph.
340 upwards_closure :: [SCC ModSummary] -> [ModuleName] -> [ModuleName]
342 upwards_closure = up_down_closure True
343 downwards_closure = up_down_closure False
345 up_down_closure :: Bool -> [SCC ModSummary] -> [ModuleName] -> [ModuleName]
346 up_down_closure up modGraph roots
347 = let mgFlat = flattenSCCs modGraph
348 nodes = map name_of_summary mgFlat
350 fwdEdges, backEdges :: [(ModuleName, [ModuleName])]
351 -- have an entry for each mod in mgFlat, and do not
352 -- mention edges leading out of the home package
355 backEdges -- Only calculated if needed, which is just as well!
356 = [(n, [m | (m, m_imports) <- fwdEdges, n `elem` m_imports])
357 | (n, n_imports) <- fwdEdges]
360 = (name_of_summary summ,
361 -- ignore imports not from the home package
362 filter (`elem` nodes) (deps_of_summary summ))
364 simple_transitive_closure
365 (if up then backEdges else fwdEdges) (nub roots)
369 data ModThreaded -- stuff threaded through individual module compilations
370 = ModThreaded PersistentCompilerState HomeSymbolTable HomeIfaceTable
372 -- Compile multiple SCCs, stopping as soon as an error appears
373 upsweep_sccs :: ModThreaded -- PCS & HST & HIT
374 -> [SCC ModSummary] -- accum: SCCs which succeeded
375 -> [Linkable] -- accum: new Linkables
376 -> [SCC ModSummary] -- SCCs to do (the worklist)
377 -- ...... RETURNING ......
378 -> IO (Bool{-success?-},
380 [SCC ModSummary], -- SCCs which succeeded
381 [Linkable]) -- new linkables
383 upsweep_sccs threaded sccOKs newLis []
384 = -- No more SCCs to do.
385 return (True, threaded, sccOKs, newLis)
387 upsweep_sccs threaded sccOKs newLis (scc:sccs)
388 = -- Start work on a new SCC.
389 do (sccOK, threaded2, lisSCC)
390 <- upsweep_scc threaded (flattenSCC scc)
392 then -- all the modules in the scc were ok
393 -- move on to the next SCC
394 upsweep_sccs threaded2
395 (scc:sccOKs) (lisSCC++newLis) sccs
396 else -- we got a compilation error; give up now
398 (False, threaded2, sccOKs, lisSCC++newLis)
401 -- Compile multiple modules (one SCC), stopping as soon as an error appears
402 upsweep_scc :: ModThreaded
404 -> IO (Bool{-success?-}, ModThreaded, [Linkable])
405 upsweep_scc threaded []
406 = return (True, threaded, [])
407 upsweep_scc threaded (mod:mods)
408 = do (moduleOK, threaded1, maybe_linkable)
409 <- upsweep_mod threaded mod
411 then -- No errors; get contribs from the rest
412 do (restOK, threaded2, linkables)
413 <- upsweep_scc threaded1 mods
415 (restOK, threaded2, maybeToList maybe_linkable ++ linkables)
416 else -- Errors; give up _now_
417 return (False, threaded1, [])
419 -- Compile a single module.
420 upsweep_mod :: ModThreaded
422 -> IO (Bool{-success?-}, ModThreaded, Maybe Linkable)
424 upsweep_mod threaded1 summary1
425 = do let mod_name = name_of_summary summary1
426 let (ModThreaded pcs1 hst1 hit1) = threaded1
427 let old_iface = lookupUFM hit1 (name_of_summary summary1)
428 compresult <- compile summary1 old_iface hst1 hit1 pcs1
432 -- Compilation "succeeded", but didn't return a new iface or
433 -- linkable, meaning that compilation wasn't needed, and the
434 -- new details were manufactured from the old iface.
435 CompOK details Nothing pcs2
436 -> let hst2 = addToUFM hst1 mod_name details
438 threaded2 = ModThreaded pcs2 hst2 hit2
439 in return (True, threaded2, Nothing)
441 -- Compilation really did happen, and succeeded. A new
442 -- details, iface and linkable are returned.
443 CompOK details (Just (new_iface, new_linkable)) pcs2
444 -> let hst2 = addToUFM hst1 mod_name details
445 hit2 = addToUFM hit1 mod_name new_iface
446 threaded2 = ModThreaded pcs2 hst2 hit2
447 in return (True, threaded2, Just new_linkable)
449 -- Compilation failed. compile may still have updated
452 -> let threaded2 = ModThreaded pcs2 hst1 hit1
453 in return (False, threaded2, Nothing)
456 removeFromTopLevelEnvs :: [ModuleName]
457 -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
458 -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
459 removeFromTopLevelEnvs zap_these (hst, hit, ui)
460 = (delListFromUFM hst zap_these,
461 delListFromUFM hit zap_these,
462 filterModuleLinkables (`notElem` zap_these) ui
465 topological_sort :: [ModSummary] -> [SCC ModSummary]
466 topological_sort summaries
468 toEdge :: ModSummary -> (ModSummary,ModuleName,[ModuleName])
470 = (summ, name_of_summary summ, deps_of_summary summ)
472 mash_edge :: (ModSummary,ModuleName,[ModuleName]) -> (ModSummary,Int,[Int])
473 mash_edge (summ, m, m_imports)
474 = case lookup m key_map of
475 Nothing -> panic "reverse_topological_sort"
476 Just mk -> (summ, mk,
477 -- ignore imports not from the home package
478 catMaybes (map (flip lookup key_map) m_imports))
480 edges = map toEdge summaries
481 key_map = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModuleName,Int)]
482 scc_input = map mash_edge edges
483 sccs = stronglyConnComp scc_input
487 downsweep :: ModuleName -- module to chase from
490 = do rootLoc <- getSummary rootNm
493 getSummary :: ModuleName -> IO ModSummary
495 = do found <- findModule nm
497 Just (mod, location) -> summarise mod location
498 Nothing -> panic ("CompManager: can't find module `" ++
499 showSDoc (ppr nm) ++ "'")
501 -- loop invariant: homeSummaries doesn't contain package modules
502 loop :: [ModSummary] -> IO [ModSummary]
504 = do let allImps :: [ModuleName]
505 allImps -- all imports
506 = (nub . map mimp_name . concat . map ms_get_imports)
508 let allHome -- all modules currently in homeSummaries
509 = map (moduleName.ms_mod) homeSummaries
511 = filter (`notElem` allHome) allImps
513 <- mapM getSummary neededImps
515 = filter (isModuleInThisPackage.ms_mod) neededSummaries
516 if null newHomeSummaries
517 then return homeSummaries
518 else loop (newHomeSummaries ++ homeSummaries)