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 FiniteMap ( emptyFM, filterFM, lookupFM, addToFM )
19 import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
20 import Panic ( panic )
22 import CmLink ( PersistentLinkerState, emptyPLS, Linkable(..),
24 filterModuleLinkables, modname_of_linkable,
26 import InterpSyn ( 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")
58 type ModHandle = String -- ToDo: do better?
61 -- Persistent state just for CM, excluding link & compile subsystems
62 data PersistentCMState
64 hst :: HomeSymbolTable, -- home symbol table
65 hit :: HomeIfaceTable, -- home interface table
66 ui :: UnlinkedImage, -- the unlinked images
67 mg :: ModuleGraph, -- the module graph
68 pci :: PackageConfigInfo -- NEVER CHANGES
71 emptyPCMS :: PackageConfigInfo -> PersistentCMState
73 = PersistentCMState { hst = emptyHST, hit = emptyHIT,
74 ui = emptyUI, mg = emptyMG, pci = pci }
76 emptyHIT :: HomeIfaceTable
78 emptyHST :: HomeSymbolTable
83 -- Persistent state for the entire system
86 pcms :: PersistentCMState, -- CM's persistent state
87 pcs :: PersistentCompilerState, -- compile's persistent state
88 pls :: PersistentLinkerState -- link's persistent state
91 emptyCmState :: PackageConfigInfo -> IO CmState
93 = do let pcms = emptyPCMS pci
94 pcs <- initPersistentCompilerState
96 return (CmState { pcms = pcms,
101 type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really)
102 emptyUI :: UnlinkedImage
105 type ModuleGraph = [SCC ModSummary] -- the module graph, topologically sorted
106 emptyMG :: ModuleGraph
111 The real business of the compilation manager: given a system state and
112 a module name, try and bring the module up to date, probably changing
113 the system state at the same time.
116 cmLoadModule :: CmState
118 -> IO (CmState, Either [SDoc] ModHandle)
120 cmLoadModule cmstate1 modname
121 = do -- version 1's are the original, before downsweep
122 let pcms1 = pcms cmstate1
123 let pls1 = pls cmstate1
124 let pcs1 = pcs cmstate1
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 = filterTopLevelEnvs (`notElem` mods_to_zap)
149 let mg2 = topological_sort mg2unsorted
151 putStrLn "after tsort:\n"
152 putStrLn (showSDoc (vcat (map ppr (flattenSCCs mg2))))
154 -- Now do the upsweep, calling compile for each module in
155 -- turn. Final result is version 3 of everything.
157 let threaded2 = ModThreaded pcs1 hst2 hit2
159 (upsweepOK, threaded3, sccOKs, newLis)
160 <- upsweep_sccs threaded2 [] [] mg2
162 let ui3 = add_to_ui ui2 newLis
163 let (ModThreaded pcs3 hst3 hit3) = threaded3
165 -- Try and do linking in some form, depending on whether the
166 -- upsweep was completely or only partially successful.
171 do let mods_to_relink = upwards_closure mg2
172 (map modname_of_linkable newLis)
173 pkg_linkables <- find_pkg_linkables_for (pci (pcms cmstate1))
175 putStrLn ("needed package modules =\n"
176 ++ showSDoc (vcat (map ppr pkg_linkables)))
177 let sccs_to_relink = group_uis ui3 mg2 mods_to_relink
178 let all_to_relink = map AcyclicSCC pkg_linkables
180 linkresult <- link all_to_relink pls1
183 -> panic "cmLoadModule: link failed (1)"
187 { hst=hst3, hit=hit3, ui=ui3, mg=mg2 }
189 = CmState { pcms=pcms3, pcs=pcs3, pls=pls3 }
190 return (cmstate3, Just modname)
193 do let mods_to_relink = downwards_closure mg2
194 (map name_of_summary (flattenSCCs sccOKs))
195 pkg_linkables <- find_pkg_linkables_for (pci (pcms cmstate1))
197 let sccs_to_relink = group_uis ui3 mg2 mods_to_relink
198 let all_to_relink = map AcyclicSCC pkg_linkables
200 linkresult <- link all_to_relink pls1
201 let (hst4, hit4, ui4)
202 = filterTopLevelEnvs (`notElem` mods_to_relink)
206 -> panic "cmLoadModule: link failed (2)"
210 { hst=hst4, hit=hit4, ui=ui4, mg=mg2 }
212 = CmState { pcms=pcms4, pcs=pcs3, pls=pls4 }
213 return (cmstate4, Just modname)
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".
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 :: PackageConfigInfo -> [SCC ModSummary] -> [ModuleName]
229 find_pkg_linkables_for pcii mg mods
230 = let mg_summaries = flattenSCCs mg
231 mg_names = map name_of_summary mg_summaries
233 -- Assert that the modules for which we seek the required packages
234 -- are all in the module graph, i.e. are all home modules.
235 if not (all (`elem` mg_names) mods)
236 then panic "find_pkg_linkables_for"
240 [deps_of_summary summ
241 | summ <- mg_summaries, name_of_summary summ `elem` mods]
242 let imports_not_in_home -- imports which must be from packages
243 = nub (filter (`notElem` mg_names) all_imports)
245 -- Figure out the packages directly imported by the home modules
246 maybe_locs_n_mods <- sequence (mapM findModule imports_not_in_home)
248 = nub (concatMap get_pkg maybe_locs_n_mods)
249 where get_pkg Nothing = []
250 get_pkg (Just (mod, loc))
251 = case packageOfModule mod of
252 Just p -> [p]; _ -> []
254 -- Discover the package dependency graph, and use it to find the
255 -- transitive closure of all the needed packages
256 let pkg_depend_graph :: [(PackageName,[PackageName])]
257 pkg_depend_graph = map (\pkg -> (name pkg, package_deps pkg)) pcii
259 let all_pkgs_needed = simple_transitive_closure
260 pkg_depend_graph home_pkgs_needed
262 -- Make a graph, in the style which Digraph.stronglyConnComp expects,
263 -- containing entries only for the needed packages.
266 [if srcP `elem` all_pkgs_needed
267 then [(srcP, srcP, dstsP)]
269 | (srcP, dstsP) <- pkg_depend_graph]
270 tsorted = flattenSCCs (stronglyConnComp needed_graph)
272 return (map LP tsorted)
275 simple_transitive_closure :: Eq a => [(a,[a])] -> [a] -> [a]
276 simple_transitive_closure graph set
277 = let set2 = nub (concatMap dsts set ++ set)
278 dsts node = fromMaybe [] (lookup node graph)
280 if length set == length set2
282 else simple_transitive_closure graph set2
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 :: UnlinkedImage -> [SCC ModSummary] -> [ModuleName] -> [SCC Linkable]
291 group_uis ui modGraph mods_to_group
292 = map extract (cleanup (fishOut modGraph mods_to_group))
294 fishOut :: [SCC ModSummary] -> [ModuleName] -> [(Bool,[ModuleName])]
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
305 cleanup :: [(Bool,[ModuleName])] -> [SCC ModuleName]
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)"
313 extract :: SCC ModuleName -> SCC Linkable
314 extract (AcyclicSCC nm) = AcyclicSCC (getLi nm)
315 extract (CyclicSCC nms) = CyclicSCC (map getLi nms)
317 getLi nm = case [li | li <- ui, not (is_package_linkable li),
318 nm == modname_of_linkable li] of
320 other -> panic "group_uis:getLi"
322 split f xs = (filter f xs, filter (not.f) xs)
325 -- Add the given (LM-form) Linkables to the UI, overwriting previous
326 -- versions if they exist.
327 add_to_ui :: UnlinkedImage -> [Linkable] -> UnlinkedImage
331 add1 :: Linkable -> UnlinkedImage -> UnlinkedImage
333 = li : filter (\li2 -> not (for_same_module li li2)) ui
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
342 -- Compute upwards and downwards closures in the (home-) module graph.
344 upwards_closure :: [SCC ModSummary] -> [ModuleName] -> [ModuleName]
346 upwards_closure = up_down_closure True
347 downwards_closure = up_down_closure False
349 up_down_closure :: Bool -> [SCC ModSummary] -> [ModuleName] -> [ModuleName]
350 up_down_closure up modGraph roots
351 = let mgFlat = flattenSCCs modGraph
352 nodes = map name_of_summary mgFlat
354 fwdEdges, backEdges :: [(ModuleName, [ModuleName])]
355 -- have an entry for each mod in mgFlat, and do not
356 -- mention edges leading out of the home package
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]
364 = (name_of_summary summ,
365 -- ignore imports not from the home package
366 filter (`elem` nodes) (deps_of_summary summ))
368 simple_transitive_closure
369 (if up then backEdges else fwdEdges) (nub roots)
373 data ModThreaded -- stuff threaded through individual module compilations
374 = ModThreaded PersistentCompilerState HomeSymbolTable HomeIfaceTable
376 -- Compile multiple SCCs, stopping as soon as an error appears
377 upsweep_sccs :: ModThreaded -- PCS & HST & HIT
378 -> [SCC ModSummary] -- accum: SCCs which succeeded
379 -> [Linkable] -- accum: new Linkables
380 -> [SCC ModSummary] -- SCCs to do (the worklist)
381 -- ...... RETURNING ......
382 -> IO (Bool{-success?-},
384 [SCC ModSummary], -- SCCs which succeeded
385 [Linkable]) -- new linkables
387 upsweep_sccs threaded sccOKs newLis []
388 = -- No more SCCs to do.
389 return (True, threaded, sccOKs, newLis)
391 upsweep_sccs threaded sccOKs newLis (scc:sccs)
392 = -- Start work on a new SCC.
393 do (sccOK, threaded2, lisSCC)
394 <- upsweep_scc threaded (flattenSCC scc)
396 then -- all the modules in the scc were ok
397 -- move on to the next SCC
398 upsweep_sccs threaded2
399 (scc:sccOKs) (lisSCC++newLis) sccs
400 else -- we got a compilation error; give up now
402 (False, threaded2, sccOKs, lisSCC++newLis)
405 -- Compile multiple modules (one SCC), stopping as soon as an error appears
406 upsweep_scc :: ModThreaded
408 -> IO (Bool{-success?-}, ModThreaded, [Linkable])
409 upsweep_scc threaded []
410 = return (True, threaded, [])
411 upsweep_scc threaded (mod:mods)
412 = do (moduleOK, threaded1, maybe_linkable)
413 <- upsweep_mod threaded mod
415 then -- No errors; get contribs from the rest
416 do (restOK, threaded2, linkables)
417 <- upsweep_scc threaded1 mods
419 (restOK, maybeToList maybe_linkable ++ linkables)
420 else -- Errors; give up _now_
421 return (False, threaded1, [])
423 -- Compile a single module.
424 upsweep_mod :: ModThreaded
426 -> IO (Bool{-success?-}, ModThreaded, Maybe Linkable)
428 upsweep_mod threaded1 summary1
429 = do let mod_name = name_of_summary summary1
430 let (ModThreaded pcs1 hst1 hit1) = threaded1
431 let old_iface = lookupFM hit1 (name_of_summary summary1)
432 compresult <- compile summary1 old_iface hst1 pcs1
436 -- Compilation "succeeded", but didn't return a new iface or
437 -- linkable, meaning that compilation wasn't needed, and the
438 -- new details were manufactured from the old iface.
439 CompOK details Nothing pcs2
440 -> let hst2 = addToFM hst1 mod_name details
442 threaded2 = ModThreaded pcs2 hst2 hit2
443 in return (True, threaded2, Nothing)
445 -- Compilation really did happen, and succeeded. A new
446 -- details, iface and linkable are returned.
447 CompOK details (Just (new_iface, new_linkable)) pcs2
448 -> let hst2 = addToFM hst1 mod_name details
449 hit2 = addToFM hit1 mod_name new_iface
450 threaded2 = ModThreaded pcs2 hst2 hit2
451 in return (True, threaded2, Just new_linkable)
453 -- Compilation failed. compile may still have updated
456 -> let threaded2 = ModThreaded pcs2 hst1 hit1
457 in return (False, threaded2, Nothing)
460 filterTopLevelEnvs :: (ModuleName -> Bool)
461 -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
462 -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
463 filterTopLevelEnvs p (hst, hit, ui)
464 = (filterFM (\k v -> p k) hst,
465 filterFM (\k v -> p k) hit,
466 filterModuleLinkables p ui
469 topological_sort :: [ModSummary] -> [SCC ModSummary]
470 topological_sort summaries
472 toEdge :: ModSummary -> (ModSummary,ModuleName,[ModuleName])
474 = (summ, name_of_summary summ, deps_of_summary summ)
476 mash_edge :: (ModSummary,ModuleName,[ModuleName]) -> (ModSummary,Int,[Int])
477 mash_edge (summ, m, m_imports)
478 = case lookup m key_map of
479 Nothing -> panic "reverse_topological_sort"
480 Just mk -> (summ, mk,
481 -- ignore imports not from the home package
482 catMaybes (map (flip lookup key_map) m_imports))
484 edges = map toEdge summaries
485 key_map = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModuleName,Int)]
486 scc_input = map mash_edge edges
487 sccs = stronglyConnComp scc_input
491 downsweep :: ModuleName -- module to chase from
494 = do rootLoc <- getSummary rootNm
497 getSummary :: ModuleName -> IO ModSummary
499 = do found <- findModule nm
501 Just (mod, location) -> summarise mod location
502 Nothing -> panic ("CompManager: can't find module `" ++
503 showSDoc (ppr nm) ++ "'")
505 -- loop invariant: homeSummaries doesn't contain package modules
506 loop :: [ModSummary] -> IO [ModSummary]
508 = do let allImps :: [ModuleName]
509 allImps -- all imports
510 = (nub . map mimp_name . concat . map ms_get_imports)
512 let allHome -- all modules currently in homeSummaries
513 = map (moduleName.ms_mod) homeSummaries
515 = filter (`notElem` allHome) allImps
517 <- mapM getSummary neededImps
519 = filter (isModuleInThisPackage.ms_mod) neededSummaries
520 if null newHomeSummaries
521 then return homeSummaries
522 else loop (newHomeSummaries ++ homeSummaries)