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 )
17 import Maybes ( maybeToBool )
19 import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM )
20 import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
22 import CmLink ( PersistentLinkerState, emptyPLS, Linkable(..),
24 filterModuleLinkables, modname_of_linkable,
25 is_package_linkable, findModuleLinkable )
28 import Interpreter ( HValue )
29 import Module ( ModuleName, moduleName, packageOfModule,
30 isModuleInThisPackage, PackageName, moduleEnvElts,
31 moduleNameUserString )
32 import CmStaticInfo ( Package(..), PackageConfigInfo, GhciMode )
35 import HscTypes ( HomeSymbolTable, HomeIfaceTable,
36 PersistentCompilerState, ModDetails(..) )
37 import Name ( lookupNameEnv )
39 import PrelNames ( mainName )
40 import HscMain ( initPersistentCompilerState )
41 import Finder ( findModule, emptyHomeDirCache )
42 import DriverUtil ( BarfKind(..) )
44 import Panic ( panic )
46 import Exception ( throwDyn )
53 cmInit :: PackageConfigInfo -> GhciMode -> IO CmState
54 cmInit raw_package_info gmode
55 = emptyCmState raw_package_info gmode
60 -> IO (CmState, Either [SDoc] HValue)
61 cmGetExpr cmstate modhdl expr
62 = return (panic "cmGetExpr:unimp")
64 cmRunExpr :: HValue -> IO ()
66 = return (panic "cmRunExpr:unimp")
69 -- Persistent state just for CM, excluding link & compile subsystems
70 data PersistentCMState
72 hst :: HomeSymbolTable, -- home symbol table
73 hit :: HomeIfaceTable, -- home interface table
74 ui :: UnlinkedImage, -- the unlinked images
75 mg :: ModuleGraph, -- the module graph
76 pci :: PackageConfigInfo, -- NEVER CHANGES
77 gmode :: GhciMode -- NEVER CHANGES
80 emptyPCMS :: PackageConfigInfo -> GhciMode -> PersistentCMState
82 = PersistentCMState { hst = emptyHST, hit = emptyHIT,
83 ui = emptyUI, mg = emptyMG,
84 pci = pci, gmode = gmode }
86 emptyHIT :: HomeIfaceTable
88 emptyHST :: HomeSymbolTable
93 -- Persistent state for the entire system
96 pcms :: PersistentCMState, -- CM's persistent state
97 pcs :: PersistentCompilerState, -- compile's persistent state
98 pls :: PersistentLinkerState -- link's persistent state
101 emptyCmState :: PackageConfigInfo -> GhciMode -> IO CmState
102 emptyCmState pci gmode
103 = do let pcms = emptyPCMS pci gmode
104 pcs <- initPersistentCompilerState
106 return (CmState { pcms = pcms,
111 type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really)
112 emptyUI :: UnlinkedImage
115 type ModuleGraph = [ModSummary] -- the module graph, topologically sorted
116 emptyMG :: ModuleGraph
121 The real business of the compilation manager: given a system state and
122 a module name, try and bring the module up to date, probably changing
123 the system state at the same time.
126 cmLoadModule :: CmState
128 -> IO (CmState, Maybe ModuleName)
130 cmLoadModule cmstate1 rootname
131 = do -- version 1's are the original, before downsweep
132 let pcms1 = pcms cmstate1
133 let pls1 = pls cmstate1
134 let pcs1 = pcs cmstate1
140 let pcii = pci pcms1 -- this never changes
141 let ghci_mode = gmode pcms1 -- ToDo: fix!
143 -- Do the downsweep to reestablish the module graph
144 -- then generate version 2's by removing from HIT,HST,UI any
145 -- modules in the old MG which are not in the new one.
147 -- Throw away the old home dir cache
150 hPutStr stderr "cmLoadModule: downsweep begins\n"
151 mg2unsorted <- downsweep [rootname]
153 let modnames1 = map name_of_summary mg1
154 let modnames2 = map name_of_summary mg2unsorted
155 let mods_to_zap = filter (`notElem` modnames2) modnames1
157 let (hst2, hit2, ui2)
158 = removeFromTopLevelEnvs mods_to_zap (hst1, hit1, ui1)
159 -- should be cycle free; ignores 'import source's
160 let mg2 = topological_sort False mg2unsorted
161 -- ... whereas this takes them into account. Only used for
162 -- backing out partially complete cycles following a failed
164 let mg2_with_srcimps = topological_sort True mg2unsorted
166 hPutStrLn stderr "after tsort:\n"
167 hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
169 -- Because we don't take into account source imports when doing
170 -- the topological sort, there shouldn't be any cycles in mg2.
171 -- If there is, we complain and give up -- the user needs to
172 -- break the cycle using a boot file.
174 -- Now do the upsweep, calling compile for each module in
175 -- turn. Final result is version 3 of everything.
177 let threaded2 = CmThreaded pcs1 hst2 hit2
179 (upsweep_complete_success, threaded3, modsDone, newLis)
180 <- upsweep_mods ui2 threaded2 mg2
182 let ui3 = add_to_ui ui2 newLis
183 let (CmThreaded pcs3 hst3 hit3) = threaded3
185 -- At this point, modsDone and newLis should have the same
186 -- length, so there is one new (or old) linkable for each
187 -- mod which was processed (passed to compile).
189 -- Try and do linking in some form, depending on whether the
190 -- upsweep was completely or only partially successful.
192 if upsweep_complete_success
195 -- Easy; just relink it all.
196 do hPutStrLn stderr "UPSWEEP COMPLETELY SUCCESSFUL"
198 <- link ghci_mode (any exports_main (moduleEnvElts hst3))
202 -> panic "cmLoadModule: link failed (1)"
204 -> do let pcms3 = PersistentCMState { hst=hst3, hit=hit3,
206 pci=pcii, gmode=ghci_mode }
208 = CmState { pcms=pcms3, pcs=pcs3, pls=pls3 }
209 return (cmstate3, Just rootname)
212 -- Tricky. We need to back out the effects of compiling any
213 -- half-done cycles, both so as to clean up the top level envs
214 -- and to avoid telling the interactive linker to link them.
215 do hPutStrLn stderr "UPSWEEP PARTIALLY SUCCESSFUL"
218 = map name_of_summary modsDone
219 let mods_to_zap_names
220 = findPartiallyCompletedCycles modsDone_names mg2_with_srcimps
221 let (hst4, hit4, ui4)
222 = removeFromTopLevelEnvs mods_to_zap_names (hst3,hit3,ui3)
224 = filter ((`notElem` mods_to_zap_names).name_of_summary) modsDone
225 let mods_to_keep_names
226 = map name_of_summary mods_to_keep
227 -- we could get the relevant linkables by filtering newLis, but
228 -- it seems easier to drag them out of the updated, cleaned-up UI
229 let linkables_to_link
230 = map (findModuleLinkable ui4) mods_to_keep_names
232 linkresult <- link ghci_mode False linkables_to_link pls1
235 -> panic "cmLoadModule: link failed (2)"
237 -> do let pcms4 = PersistentCMState { hst=hst4, hit=hit4,
238 ui=ui4, mg=mods_to_keep,
239 pci=pcii, gmode=ghci_mode }
241 = CmState { pcms=pcms4, pcs=pcs3, pls=pls4 }
243 -- choose rather arbitrarily who to return
244 if null mods_to_keep then Nothing
245 else Just (last mods_to_keep_names))
248 -- Return (names of) all those in modsDone who are part of a cycle
249 -- as defined by theGraph.
250 findPartiallyCompletedCycles :: [ModuleName] -> [SCC ModSummary] -> [ModuleName]
251 findPartiallyCompletedCycles modsDone theGraph
255 chew ((AcyclicSCC v):rest) = chew rest -- acyclic? not interesting.
256 chew ((CyclicSCC vs):rest)
257 = let names_in_this_cycle = nub (map name_of_summary vs)
259 = nub ([done | done <- modsDone,
260 done `elem` names_in_this_cycle])
261 chewed_rest = chew rest
263 if not (null mods_in_this_cycle)
264 && length mods_in_this_cycle < length names_in_this_cycle
265 then mods_in_this_cycle ++ chewed_rest
269 exports_main :: ModDetails -> Bool
271 = maybeToBool (lookupNameEnv (md_types md) mainName)
274 -- Add the given (LM-form) Linkables to the UI, overwriting previous
275 -- versions if they exist.
276 add_to_ui :: UnlinkedImage -> [Linkable] -> UnlinkedImage
280 add1 :: Linkable -> UnlinkedImage -> UnlinkedImage
282 = li : filter (\li2 -> not (for_same_module li li2)) ui
284 for_same_module :: Linkable -> Linkable -> Bool
285 for_same_module li1 li2
286 = not (is_package_linkable li1)
287 && not (is_package_linkable li2)
288 && modname_of_linkable li1 == modname_of_linkable li2
291 data CmThreaded -- stuff threaded through individual module compilations
292 = CmThreaded PersistentCompilerState HomeSymbolTable HomeIfaceTable
295 -- Compile multiple modules, stopping as soon as an error appears.
296 -- There better had not be any cyclic groups here -- we check for them.
297 upsweep_mods :: UnlinkedImage -- old linkables
298 -> CmThreaded -- PCS & HST & HIT
299 -> [SCC ModSummary] -- mods to do (the worklist)
300 -- ...... RETURNING ......
301 -> IO (Bool{-complete success?-},
303 [ModSummary], -- mods which succeeded
304 [Linkable]) -- new linkables
306 upsweep_mods oldUI threaded []
307 = return (True, threaded, [], [])
309 upsweep_mods oldUI threaded ((CyclicSCC ms):_)
310 = do hPutStrLn stderr ("ghc: module imports form a cycle for modules:\n\t" ++
311 unwords (map (moduleNameUserString.name_of_summary) ms))
312 return (False, threaded, [], [])
314 upsweep_mods oldUI threaded ((AcyclicSCC mod):mods)
315 = do (threaded1, maybe_linkable) <- upsweep_mod oldUI threaded mod
316 case maybe_linkable of
318 -> -- No errors; do the rest
319 do (restOK, threaded2, modOKs, linkables)
320 <- upsweep_mods oldUI threaded1 mods
321 return (restOK, threaded2, mod:modOKs, linkable:linkables)
322 Nothing -- we got a compilation error; give up now
323 -> return (False, threaded1, [], [])
326 -- Compile a single module. Always produce a Linkable for it if
327 -- successful. If no compilation happened, return the old Linkable.
328 upsweep_mod :: UnlinkedImage
331 -> IO (CmThreaded, Maybe Linkable)
333 upsweep_mod oldUI threaded1 summary1
334 = do let mod_name = name_of_summary summary1
335 let (CmThreaded pcs1 hst1 hit1) = threaded1
336 let old_iface = lookupUFM hit1 (name_of_summary summary1)
337 compresult <- compile summary1 old_iface hst1 hit1 pcs1
341 -- Compilation "succeeded", but didn't return a new iface or
342 -- linkable, meaning that compilation wasn't needed, and the
343 -- new details were manufactured from the old iface.
344 CompOK details Nothing pcs2
345 -> let hst2 = addToUFM hst1 mod_name details
347 threaded2 = CmThreaded pcs2 hst2 hit2
348 old_linkable = findModuleLinkable oldUI mod_name
349 in return (threaded2, Just old_linkable)
351 -- Compilation really did happen, and succeeded. A new
352 -- details, iface and linkable are returned.
353 CompOK details (Just (new_iface, new_linkable)) pcs2
354 -> let hst2 = addToUFM hst1 mod_name details
355 hit2 = addToUFM hit1 mod_name new_iface
356 threaded2 = CmThreaded pcs2 hst2 hit2
357 in return (threaded2, Just new_linkable)
359 -- Compilation failed. compile may still have updated
362 -> let threaded2 = CmThreaded pcs2 hst1 hit1
363 in return (threaded2, Nothing)
366 removeFromTopLevelEnvs :: [ModuleName]
367 -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
368 -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
369 removeFromTopLevelEnvs zap_these (hst, hit, ui)
370 = (delListFromUFM hst zap_these,
371 delListFromUFM hit zap_these,
372 filterModuleLinkables (`notElem` zap_these) ui
376 topological_sort :: Bool -> [ModSummary] -> [SCC ModSummary]
377 topological_sort include_source_imports summaries
379 toEdge :: ModSummary -> (ModSummary,ModuleName,[ModuleName])
381 = (summ, name_of_summary summ,
382 (if include_source_imports
383 then ms_srcimps summ else []) ++ ms_imps summ)
385 mash_edge :: (ModSummary,ModuleName,[ModuleName]) -> (ModSummary,Int,[Int])
386 mash_edge (summ, m, m_imports)
387 = case lookup m key_map of
388 Nothing -> panic "reverse_topological_sort"
389 Just mk -> (summ, mk,
390 -- ignore imports not from the home package
391 catMaybes (map (flip lookup key_map) m_imports))
393 edges = map toEdge summaries
394 key_map = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModuleName,Int)]
395 scc_input = map mash_edge edges
396 sccs = stronglyConnComp scc_input
401 -- Chase downwards from the specified root set, returning summaries
402 -- for all home modules encountered. Only follow source-import
404 downsweep :: [ModuleName] -> IO [ModSummary]
406 = do rootSummaries <- mapM getSummary rootNm
407 loop (filter (isModuleInThisPackage.ms_mod) rootSummaries)
409 getSummary :: ModuleName -> IO ModSummary
411 | trace ("getSummary: "++ showSDoc (ppr nm)) True
412 = do found <- findModule nm
414 Just (mod, location) -> summarise mod location
415 Nothing -> throwDyn (OtherError
416 ("no signs of life for module `"
417 ++ showSDoc (ppr nm) ++ "'"))
419 -- loop invariant: homeSummaries doesn't contain package modules
420 loop :: [ModSummary] -> IO [ModSummary]
422 = do let allImps :: [ModuleName]
423 allImps = (nub . concatMap ms_imps) homeSummaries
424 let allHome -- all modules currently in homeSummaries
425 = map (moduleName.ms_mod) homeSummaries
427 = filter (`notElem` allHome) allImps
429 <- mapM getSummary neededImps
431 = filter (isModuleInThisPackage.ms_mod) neededSummaries
432 if null newHomeSummaries
433 then return homeSummaries
434 else loop (newHomeSummaries ++ homeSummaries)
437 summarise :: Module -> ModuleLocation -> IO ModSummary
438 summarise mod location
439 | isModuleInThisPackage mod
440 = do let hs_fn = unJust (ml_hs_file location) "summarise"
441 hspp_fn <- preprocess hs_fn
442 modsrc <- readFile hspp_fn
443 let (srcimps,imps) = getImports modsrc
446 -- <- case ml_hs_file location of
447 -- Nothing -> return Nothing
448 -- Just src_fn -> getModificationTime src_fn >>= Just
450 return (ModSummary mod location{ml_hspp_file=Just hspp_fn}
452 {-maybe_timestamp-} )
454 = return (ModSummary mod location [] [])