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 )
20 import Panic ( panic )
22 import CmStaticInfo ( PCI(..), mkPCI, Package(..) )
23 import Finder ( Finder, newFinder,
24 ModName, ml_modname, isPackageLoc,
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(..),
32 filterModuleLinkables, modname_of_linkable,
34 import InterpSyn ( HValue )
37 cmInit :: String{-temp debugging hack-}
40 cmInit path raw_package_info
41 = emptyCmState path raw_package_info
46 -> IO (CmState, Either [SDoc] HValue)
47 cmGetExpr cmstate modhdl expr
48 = return (error "cmGetExpr:unimp")
50 cmRunExpr :: HValue -> IO ()
52 = return (error "cmRunExpr:unimp")
54 type ModHandle = String -- ToDo: do better?
57 -- Persistent state just for CM, excluding link & compile subsystems
58 data PersistentCMState
60 hst :: HomeSymbolTable, -- home symbol table
61 hit :: HomeInterfaceTable, -- home interface table
62 ui :: UnlinkedImages, -- the unlinked images
63 mg :: ModuleGraph -- the module graph
66 emptyPCMS :: PersistentCMState
67 emptyPCMS = PersistentCMState
69 hst = emptyHST, hit = emptyHIT,
70 ui = emptyUI, mg = emptyMG }
72 emptyHIT :: HomeInterfaceTable
74 emptyHST :: HomeSymbolTable
79 -- Persistent state for the entire system
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
89 emptyCmState :: String{-temp debugging hack-}
90 -> [Package] -> IO CmState
91 emptyCmState path_TMP_DEBUGGING_HACK raw_package_info
92 = do let pcms = emptyPCMS
95 pci <- mkPCI raw_package_info
96 finder <- newFinder path_TMP_DEBUGGING_HACK pci
97 return (CmState { pcms = pcms,
104 type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really)
105 emptyUI :: UnlinkedImage
108 type ModuleGraph = [SCC ModSummary] -- the module graph, topologically sorted
109 emptyMG :: ModuleGraph
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.
119 cmLoadModule :: CmState
121 -> IO (CmState, Either [SDoc] ModHandle)
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
132 -- these aren't numbered since they don't change
133 let pcii = pci cmstate1
134 let finderr = finder cmstate1
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.
140 putStr "cmLoadModule: downsweep begins\n"
141 mg2unsorted <- downsweep modname finderr
142 putStrLn (showSDoc (vcat (map ppr mg2unsorted)))
144 let modnames1 = map name_of_summary (flattenSCCs mg1)
145 let modnames2 = map name_of_summary mg2unsorted
146 let mods_to_zap = filter (`notElem` modnames2) modnames1
148 let (hst2, hit2, ui2)
149 = filterTopLevelEnvs (`notElem` mods_to_zap)
152 let mg2 = topological_sort mg2unsorted
154 putStrLn "after tsort:\n"
155 putStrLn (showSDoc (vcat (map ppr (flattenSCCs mg2))))
157 -- Now do the upsweep, calling compile for each module in
158 -- turn. Final result is version 3 of everything.
160 let threaded2 = ModThreaded pcs1 hst2 hit2
162 (threaded3, sccOKs, newLis, errs, warns)
163 <- upsweep_sccs finderr threaded2 [] [] [] [] mg2
165 let ui3 = add_to_ui ui2 newLis
166 let (ModThreaded pcs3 hst3 hit3) = threaded3
168 -- Try and do linking in some form, depending on whether the
169 -- upsweep was completely or only partially successful.
174 do let mods_to_relink = upwards_closure mg2
175 (map modname_of_linkable newLis)
176 let pkg_linkables = find_pkg_linkables_for pcii mg2 mods_to_relink
177 putStrLn ("needed package modules =\n"
178 ++ showSDoc (vcat (map ppr pkg_linkables)))
179 let sccs_to_relink = group_uis ui3 mg2 mods_to_relink
180 let all_to_relink = map AcyclicSCC pkg_linkables
182 linkresult <- link pcii all_to_relink pls1
185 -> panic "cmLoadModule: link failed (1)"
188 = PCMS { hst=hst3, hit=hit3, ui=ui3, mg=mg2 }
190 = CmState { pcms=pcms3, pcs=pcs3, pls=pls3,
191 pci=pcii, finder=finderr }
192 return (cmstate3, Right modname)
195 do let mods_to_relink = downwards_closure mg2
196 (map name_of_summary (flattenSCCs sccOKs))
197 let pkg_linkables = find_pkg_linkables_for pcii mg2 mods_to_relink
198 let sccs_to_relink = group_uis ui3 mg2 mods_to_relink
199 let all_to_relink = map AcyclicSCC pkg_linkables
201 linkresult <- link pcii all_to_relink pls1
202 let (hst4, hit4, ui4)
203 = filterTopLevelEnvs (`notElem` mods_to_relink)
207 -> panic "cmLoadModule: link failed (2)"
210 = PCMS { hst=hst4, hit=hit4, ui=ui4, mg=mg2 }
212 = CmState { pcms=pcms4, pcs=pcs3, pls=pls4,
213 pci=pcii, finder=finderr }
214 return (cmstate4, Right 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 :: PCI -> [SCC ModSummary] -> [ModName] -> [Linkable]
228 find_pkg_linkables_for pcii mg mods
229 = let mg_summaries = flattenSCCs mg
230 mg_names = map name_of_summary mg_summaries
232 if not (all (`elem` mg_names) mods)
233 then panic "find_packages_for"
237 [deps_of_summary summ
238 | summ <- mg_summaries, name_of_summary summ `elem` mods]
239 imports_not_in_home -- imports which must be from packages
240 = nub (filter (`notElem` mg_names) all_imports)
241 mod_tab :: [(ModName, PkgName, Path)]
242 mod_tab = module_table pcii
243 home_pkgs_needed -- the packages directly needed by the home modules
244 = nub [pkg_nm | (mod_nm, pkg_nm, path) <- mod_tab,
245 mod_nm `elem` imports_not_in_home]
247 -- Discover the package dependency graph, and use it to find the
248 -- transitive closure of all the needed packages
249 pkg_depend_graph :: [(PkgName,[PkgName])]
250 pkg_depend_graph = map (\raw -> (name raw, package_deps raw))
251 (raw_package_info pcii)
253 all_pkgs_needed = simple_transitive_closure
254 pkg_depend_graph home_pkgs_needed
256 -- Make a graph, in the style which Digraph.stronglyConnComp expects,
257 -- containing entries only for the needed packages.
260 [if srcP `elem` all_pkgs_needed
261 then [(srcP, srcP, dstsP)]
263 | (srcP, dstsP) <- pkg_depend_graph]
264 tsorted = flattenSCCs (stronglyConnComp needed_graph)
269 simple_transitive_closure :: Eq a => [(a,[a])] -> [a] -> [a]
270 simple_transitive_closure graph set
271 = let set2 = nub (concatMap dsts set ++ set)
272 dsts node = fromMaybe [] (lookup node graph)
274 if length set == length set2
276 else simple_transitive_closure graph set2
279 flattenSCCs :: [SCC a] -> [a]
280 flattenSCCs = concatMap flatten
282 flatten (AcyclicSCC v) = [v]
283 flatten (CyclicSCC vs) = vs
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 :: UI -> [SCC ModSummary] -> [ModName] -> [SCC Linkable]
291 group_uis ui modGraph mods_to_group
292 = map extract (cleanup (fishOut modGraph mods_to_group))
294 fishOut :: [SCC ModSummary] -> [ModName] -> [(Bool,[ModName])]
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,[ModName])] -> [SCC ModName]
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 ModName -> 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 :: UI -> [Linkable] -> UI
331 add1 :: Linkable -> UI -> UI
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] -> [ModName] -> [ModName]
346 upwards_closure = up_down_closure True
347 downwards_closure = up_down_closure False
349 up_down_closure :: Bool -> [SCC ModSummary] -> [ModName] -> [ModName]
350 up_down_closure up modGraph roots
351 = let mgFlat = flattenSCCs modGraph
352 nodes = map name_of_summary mgFlat
354 fwdEdges, backEdges :: [(ModName, [ModName])]
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)
372 data ModThreaded -- stuff threaded through individual module compilations
373 = ModThreaded PCS HST HIT
375 -- Compile multiple SCCs, stopping as soon as an error appears
376 upsweep_sccs :: Finder -- the finder
377 -> ModThreaded -- PCS & HST & HIT
378 -> [SCC ModSummary] -- accum: SCCs which succeeded
379 -> [Linkable] -- accum: new Linkables
380 -> [SDoc] -- accum: error messages
381 -> [SDoc] -- accum: warnings
382 -> [SCC ModSummary] -- SCCs to do (the worklist)
383 -- ...... RETURNING ......
385 [SCC ModSummary], -- SCCs which succeeded
386 [Linkable], -- new linkables
387 [SDoc], -- error messages
390 upsweep_sccs finder threaded sccOKs newLis errs warns []
391 = -- No more SCCs to do.
392 return (threaded, sccOKs, newLis, errs, warns)
394 upsweep_sccs finder threaded sccOKs newLis errs warns (scc:sccs)
395 = -- Start work on a new SCC.
396 do (threaded2, lisM, errsM, warnsM)
397 <- upsweep_mods finder threaded (flatten scc)
399 then -- all the modules in the scc were ok
400 -- move on to the next SCC
401 upsweep_sccs finder threaded2
402 (scc:sccOKs) (lisM++newLis)
403 errs (warnsM++warns) sccs
404 else -- we got a compilation error; give up now
407 lisM++newLis, errsM++errs, warnsM++warns)
409 -- Compile multiple modules (one SCC), stopping as soon as an error appears
410 upsweep_mods :: Finder
413 -> IO (ModThreaded, [Linkable], [SDoc], [SDoc])
414 upsweep_mods finder threaded []
415 = return (threaded, [], [], [])
416 upsweep_mods finder threaded (mod:mods)
417 = do (threaded1, maybe_linkable, errsM, warnsM)
418 <- upsweep_mod finder threaded mod
420 then -- No errors; get contribs from the rest
421 do (threaded2, linkables, errsMM, warnsMM)
422 <- upsweep_mods finder threaded1 mods
424 (threaded2, maybeToList maybe_linkable ++ linkables,
425 errsM++errsMM, warnsM++warnsMM)
426 else -- Errors; give up _now_
427 return (threaded1, [], errsM, warnsM)
429 -- Compile a single module.
430 upsweep_mod :: Finder
433 -> IO (ModThreaded, Maybe Linkable, [SDoc], [SDoc])
435 upsweep_mod finder threaded1 summary1
436 = do let mod_name = name_of_summary summary1
437 let (ModThreaded pcs1 hst1 hit1) = threaded1
438 let old_iface = lookupFM hit1 (name_of_summary summary1)
439 compresult <- cmCompile finder summary1 old_iface hst1 pcs1
443 -- Compilation "succeeded", but didn't return a new iface or
444 -- linkable, meaning that compilation wasn't needed, and the
445 -- new details were manufactured from the old iface.
446 CompOK details Nothing pcs2 warns
447 -> let hst2 = addToFM hst1 mod_name details
449 threaded2 = ModThreaded pcs2 hst2 hit2
450 in return (threaded2, Nothing, [], warns)
452 -- Compilation really did happen, and succeeded. A new
453 -- details, iface and linkable are returned.
454 CompOK details (Just (new_iface, new_linkable)) pcs2 warns
455 -> let hst2 = addToFM hst1 mod_name details
456 hit2 = addToFM hit1 mod_name new_iface
457 threaded2 = ModThreaded pcs2 hst2 hit2
458 in return (threaded2, Just new_linkable, [], warns)
460 -- Compilation failed. compile may still have updated
462 CompErrs pcs2 errs warns
463 -> let threaded2 = ModThreaded pcs2 hst1 hit1
464 in return (threaded2, Nothing, errs, warns)
466 filterTopLevelEnvs :: (ModName -> Bool) -> (HST, HIT, UI) -> (HST, HIT, UI)
467 filterTopLevelEnvs p (hst, hit, ui)
468 = (filterFM (\k v -> p k) hst,
469 filterFM (\k v -> p k) hit,
470 filterModuleLinkables p ui
473 topological_sort :: [ModSummary] -> [SCC ModSummary]
474 topological_sort summaries
476 toEdge :: ModSummary -> (ModSummary,ModName,[ModName])
478 = (summ, name_of_summary summ, deps_of_summary summ)
480 mash_edge :: (ModSummary,ModName,[ModName]) -> (ModSummary,Int,[Int])
481 mash_edge (summ, m, m_imports)
482 = case lookup m key_map of
483 Nothing -> panic "reverse_topological_sort"
484 Just mk -> (summ, mk,
485 -- ignore imports not from the home package
486 catMaybes (map (flip lookup key_map) m_imports))
488 edges = map toEdge summaries
489 key_map = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModName,Int)]
490 scc_input = map mash_edge edges
491 sccs = stronglyConnComp scc_input
495 downsweep :: ModName -- module to chase from
498 downsweep rootNm finder
499 = do rootLoc <- getSummary rootNm
502 getSummary :: ModName -> IO ModSummary
504 = do loc <- finder nm
505 summary <- summarise loc
508 -- loop invariant: homeSummaries doesn't contain package modules
509 loop :: [ModSummary] -> IO [ModSummary]
511 = do let allImps -- all imports
512 = (nub . map mi_name . concat . map ms_get_imports)
514 let allHome -- all modules currently in homeSummaries
515 = map (ml_modname.ms_loc) homeSummaries
517 = filter (`notElem` allHome) allImps
519 <- mapM getSummary neededImps
521 = filter (not.isPackageLoc.ms_loc) neededSummaries
522 if null newHomeSummaries
523 then return homeSummaries
524 else loop (newHomeSummaries ++ homeSummaries)