2 % (c) The AQUA Project, Glasgow University, 1993-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 )
17 import Outputable ( SDoc )
18 import FiniteMap ( emptyFM, filterFM )
19 import Digraph ( SCC(..), stronglyConnComp )
20 import Panic ( panic )
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,
30 filterModuleLinkables, modname_of_linkable,
39 = emptyCmState flags pkginfo
44 -> IO (CmState, Either [SDoc] HValue)
45 cmGetExpr cmstate modhdl expr
46 = return (error "cmGetExpr:unimp")
48 cmRunExpr :: HValue -> IO ()
50 = return (error "cmRunExpr:unimp")
52 type ModHandle = String -- ToDo: do better?
55 -- Persistent state just for CM, excluding link & compile subsystems
58 hst :: HST, -- home symbol table
59 hit :: HIT, -- home interface table
60 ui :: UI, -- the unlinked images
61 mg :: MG -- the module graph
65 emptyPCMS = PCMS { hst = emptyHST,
78 -- Persistent state for the entire system
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
88 emptyCmState :: FLAGS -> PCI -> IO CmState
89 emptyCmState flags pci
90 = do let pcms = emptyPCMS
93 let si = mkSI flags pci
94 finder <- newFinder pci
95 return (CmState { pcms = pcms,
102 type UI = [Linkable] -- the unlinked images (should be a set, really)
107 type MG = [SCC ModSummary] -- the module graph, topologically sorted
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.
118 cmLoadModule :: CmState
120 -> IO (CmState, Either [SDoc] ModHandle)
122 cmLoadModule cmstate1 modname
123 = do -- version 1's are the original, before downsweep
125 let pci1 = pci (si cmstate1)
126 let pcms1 = pcms cmstate1
127 let pls1 = pls cmstate1
128 let pcs1 = pcs cmstate1
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.
138 putStr "cmLoadModule: downsweep begins\n"
139 mg2unsorted <- downsweep modname (finder cmstate1)
140 putStrLn ( "after chasing:\n\n" ++ unlines (map show mg2unsorted))
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
146 let (hst2, hit2, ui2)
147 = filterTopLevelEnvs (`notElem` mods_to_zap)
150 let mg2 = topological_sort mg2unsorted
152 putStrLn ( "after tsort:\n\n"
153 ++ unlines (map show (flattenMG mg2)))
155 -- Now do the upsweep, calling compile for each module in
156 -- turn. Final result is version 3 of everything.
158 let threaded2 = ModThreaded pcs1 hst2 hit2
160 (threaded3, sccOKs, newLis, errs, warns)
161 <- upsweep_sccs threaded2 [] [] [] [] mg2
163 let ui3 = add_to_ui ui2 newLis
164 let (ModThreaded pcs3 hst3 hit3) = threaded3
166 -- Try and do linking in some form, depending on whether the
167 -- upsweep was completely or only partially successful.
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
178 -> panic "cmLoadModule: link failed (1)"
181 = PCMS { hst=hst3, hit=hit3, ui=ui3, mg=mg2 }
183 = CmState { pcms=pcms3, pcs=pcs3, pls=pls3,
185 finder = finder cmstate1
187 return (cmstate3, Right modname)
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)
199 -> panic "cmLoadModule: link failed (2)"
202 = PCMS { hst=hst4, hit=hit4, ui=ui4, mg=mg2 }
204 = CmState { pcms=pcms4, pcs=pcs3, pls=pls4,
206 finder = finder cmstate1
208 return (cmstate4, Right modname)
211 flattenMG :: [SCC ModSummary] -> [ModSummary]
212 flattenMG = concatMap flatten
214 flatten (AcyclicSCC v) = [v]
215 flatten (CyclicSCC vs) = vs
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))
226 fishOut :: [SCC ModSummary] -> [ModName] -> [(Bool,[ModName])]
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
237 cleanup :: [(Bool,[ModName])] -> [SCC ModName]
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)"
245 extract :: SCC ModName -> SCC Linkable
246 extract (AcyclicSCC nm) = AcyclicSCC (getLi nm)
247 extract (CyclicSCC nms) = CyclicSCC (map getLi nms)
249 getLi nm = case [li | li <- ui, not (is_package_linkable li),
250 nm == modname_of_linkable li] of
252 other -> panic "group_uis:getLi"
254 split f xs = (filter f xs, filter (not.f) xs)
257 -- Add the given (LM-form) Linkables to the UI, overwriting previous
258 -- versions if they exist.
259 add_to_ui :: UI -> [Linkable] -> UI
263 add1 :: Linkable -> UI -> UI
265 = li : filter (\li2 -> not (for_same_module li li2)) ui
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
274 -- Compute upwards and downwards closures in the (home-) module graph.
276 upwards_closure :: [SCC ModSummary] -> [ModName] -> [ModName]
278 upwards_closure = up_down_closure True
279 downwards_closure = up_down_closure False
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
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
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]
295 iterate :: [(ModName,[ModName])] -> [ModName] -> [ModName]
297 = let set2 = nub (concatMap dsts set)
298 dsts :: ModName -> [ModName]
299 dsts node = case lookup node graph of
301 Nothing -> panic "up_down_closure"
303 if length set == length set2 then set else iterate graph set2
306 = (name_of_summary summ,
307 -- ignore imports not from the home package
308 filter (`elem` nodes) (deps_of_summary summ))
310 (if up then iterate backEdges else iterate fwdEdges) (nub roots)
313 data ModThreaded -- stuff threaded through individual module compilations
314 = ModThreaded PCS HST HIT
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 ......
325 [SCC ModSummary], -- SCCs which succeeded
326 [Linkable], -- new linkables
327 [SDoc], -- error messages
330 upsweep_sccs threaded sccOKs newLis errs warns []
331 = -- No more SCCs to do.
332 return (threaded, sccOKs, newLis, errs, warns)
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)
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
346 lisM++newLis, errsM++errs, warnsM++warns)
348 -- Compile multiple modules (one SCC), stopping as soon as an error appears
349 upsweep_mods :: ModThreaded
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
357 then -- No errors; get contribs from the rest
358 do (threaded2, linkables, errsMM, warnsMM)
359 <- upsweep_mods threaded1 mods
361 (threaded2, maybeToList maybe_linkable ++ linkables,
362 errsM++errsMM, warnsM++warnsMM)
363 else -- Errors; give up _now_
364 return (threaded1, [], errsM, warnsM)
366 -- Compile a single module.
367 upsweep_mod :: ModThreaded
369 -> IO (ModThreaded, Maybe Linkable, [SDoc], [SDoc])
370 upsweep_mod = error "upsweep_mod"
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
382 name_of_summary :: ModSummary -> ModName
383 name_of_summary = ml_modname . ms_loc
385 deps_of_summary :: ModSummary -> [ModName]
386 deps_of_summary = map mi_name . ms_get_imports
388 topological_sort :: [ModSummary] -> [SCC ModSummary]
389 topological_sort summaries
391 toEdge :: ModSummary -> (ModSummary,ModName,[ModName])
393 = (summ, name_of_summary summ, deps_of_summary summ)
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))
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
410 downsweep :: ModName -- module to chase from
413 downsweep rootNm finder
414 = do rootLoc <- getSummary rootNm
417 getSummary :: ModName -> IO ModSummary
419 = do loc <- finder nm
420 summary <- summarise loc
423 -- loop invariant: homeSummaries doesn't contain package modules
424 loop :: [ModSummary] -> IO [ModSummary]
426 = do let allImps -- all imports
427 = (nub . map mi_name . concat . map ms_get_imports)
429 let allHome -- all modules currently in homeSummaries
430 = map (ml_modname.ms_loc) homeSummaries
432 = filter (`notElem` allHome) allImps
434 <- mapM getSummary neededImps
436 = filter (not.isPackageLoc.ms_loc) neededSummaries
437 if null newHomeSummaries
438 then return homeSummaries
439 else loop (newHomeSummaries ++ homeSummaries)