2 % (c) The University of Glasgow, 2000
4 \section[CompManager]{The Compilation Manager}
7 module CompManager ( cmInit, cmLoadModule,
9 CmState, emptyCmState, -- abstract
14 #include "HsVersions.h"
17 import Maybe ( catMaybes, maybeToList, fromMaybe )
18 import Maybes ( maybeToBool )
20 import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM )
21 import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs )
26 import Interpreter ( HValue )
27 import Module ( ModuleName, moduleName, packageOfModule,
28 isModuleInThisPackage, PackageName, moduleEnvElts,
29 moduleNameUserString )
30 import CmStaticInfo ( Package(..), PackageConfigInfo, GhciMode(..) )
33 import HscTypes ( HomeSymbolTable, HomeIfaceTable,
34 PersistentCompilerState, ModDetails(..) )
35 import Name ( lookupNameEnv )
38 import PrelNames ( mainName )
39 import HscMain ( initPersistentCompilerState )
40 import Finder ( findModule, emptyHomeDirCache )
41 import DriverUtil ( BarfKind(..) )
43 import Panic ( panic )
45 import Exception ( throwDyn )
47 import Time ( ClockTime )
48 import Directory ( getModificationTime, doesFileExist )
55 cmInit :: PackageConfigInfo -> GhciMode -> IO CmState
56 cmInit raw_package_info gmode
57 = emptyCmState raw_package_info gmode
62 -> IO (CmState, Either [SDoc] HValue)
63 cmGetExpr cmstate modhdl expr
64 = return (panic "cmGetExpr:unimp")
66 cmRunExpr :: HValue -> IO ()
68 = return (panic "cmRunExpr:unimp")
71 -- Persistent state just for CM, excluding link & compile subsystems
72 data PersistentCMState
74 hst :: HomeSymbolTable, -- home symbol table
75 hit :: HomeIfaceTable, -- home interface table
76 ui :: UnlinkedImage, -- the unlinked images
77 mg :: ModuleGraph, -- the module graph
78 pci :: PackageConfigInfo, -- NEVER CHANGES
79 gmode :: GhciMode -- NEVER CHANGES
82 emptyPCMS :: PackageConfigInfo -> GhciMode -> PersistentCMState
84 = PersistentCMState { hst = emptyHST, hit = emptyHIT,
85 ui = emptyUI, mg = emptyMG,
86 pci = pci, gmode = gmode }
88 emptyHIT :: HomeIfaceTable
90 emptyHST :: HomeSymbolTable
95 -- Persistent state for the entire system
98 pcms :: PersistentCMState, -- CM's persistent state
99 pcs :: PersistentCompilerState, -- compile's persistent state
100 pls :: PersistentLinkerState -- link's persistent state
103 emptyCmState :: PackageConfigInfo -> GhciMode -> IO CmState
104 emptyCmState pci gmode
105 = do let pcms = emptyPCMS pci gmode
106 pcs <- initPersistentCompilerState
108 return (CmState { pcms = pcms,
113 type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really)
114 emptyUI :: UnlinkedImage
117 type ModuleGraph = [ModSummary] -- the module graph, topologically sorted
118 emptyMG :: ModuleGraph
123 The real business of the compilation manager: given a system state and
124 a module name, try and bring the module up to date, probably changing
125 the system state at the same time.
128 cmLoadModule :: CmState
130 -> IO (CmState, Maybe ModuleName)
132 cmLoadModule cmstate1 rootname
133 = do -- version 1's are the original, before downsweep
134 let pcms1 = pcms cmstate1
135 let pls1 = pls cmstate1
136 let pcs1 = pcs cmstate1
142 let pcii = pci pcms1 -- this never changes
143 let ghci_mode = gmode pcms1 -- ToDo: fix!
145 -- During upsweep, look at new summaries to see if source has
146 -- changed. Here's a function to pass down; it takes a new
148 let source_changed :: ModSummary -> Bool
149 source_changed = summary_indicates_source_changed mg1
151 -- Do the downsweep to reestablish the module graph
152 -- then generate version 2's by removing from HIT,HST,UI any
153 -- modules in the old MG which are not in the new one.
155 -- Throw away the old home dir cache
158 hPutStr stderr "cmLoadModule: downsweep begins\n"
159 mg2unsorted <- downsweep [rootname]
161 let modnames1 = map name_of_summary mg1
162 let modnames2 = map name_of_summary mg2unsorted
163 let mods_to_zap = filter (`notElem` modnames2) modnames1
165 let (hst2, hit2, ui2)
166 = removeFromTopLevelEnvs mods_to_zap (hst1, hit1, ui1)
167 -- should be cycle free; ignores 'import source's
168 let mg2 = topological_sort False mg2unsorted
169 -- ... whereas this takes them into account. Only used for
170 -- backing out partially complete cycles following a failed
172 let mg2_with_srcimps = topological_sort True mg2unsorted
174 hPutStrLn stderr "after tsort:\n"
175 hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
177 -- Because we don't take into account source imports when doing
178 -- the topological sort, there shouldn't be any cycles in mg2.
179 -- If there is, we complain and give up -- the user needs to
180 -- break the cycle using a boot file.
182 -- Now do the upsweep, calling compile for each module in
183 -- turn. Final result is version 3 of everything.
185 let threaded2 = CmThreaded pcs1 hst2 hit2
187 (upsweep_complete_success, threaded3, modsDone, newLis)
188 <- upsweep_mods ghci_mode ui2 source_changed threaded2 mg2
190 let ui3 = add_to_ui ui2 newLis
191 let (CmThreaded pcs3 hst3 hit3) = threaded3
193 -- At this point, modsDone and newLis should have the same
194 -- length, so there is one new (or old) linkable for each
195 -- mod which was processed (passed to compile).
197 -- Try and do linking in some form, depending on whether the
198 -- upsweep was completely or only partially successful.
200 if upsweep_complete_success
203 -- Easy; just relink it all.
204 do hPutStrLn stderr "UPSWEEP COMPLETELY SUCCESSFUL"
206 <- link ghci_mode (any exports_main (moduleEnvElts hst3))
210 -> panic "cmLoadModule: link failed (1)"
212 -> do let pcms3 = PersistentCMState { hst=hst3, hit=hit3,
214 pci=pcii, gmode=ghci_mode }
216 = CmState { pcms=pcms3, pcs=pcs3, pls=pls3 }
217 return (cmstate3, Just rootname)
220 -- Tricky. We need to back out the effects of compiling any
221 -- half-done cycles, both so as to clean up the top level envs
222 -- and to avoid telling the interactive linker to link them.
223 do hPutStrLn stderr "UPSWEEP PARTIALLY SUCCESSFUL"
226 = map name_of_summary modsDone
227 let mods_to_zap_names
228 = findPartiallyCompletedCycles modsDone_names mg2_with_srcimps
229 let (hst4, hit4, ui4)
230 = removeFromTopLevelEnvs mods_to_zap_names (hst3,hit3,ui3)
232 = filter ((`notElem` mods_to_zap_names).name_of_summary) modsDone
233 let mods_to_keep_names
234 = map name_of_summary mods_to_keep
235 -- we could get the relevant linkables by filtering newLis, but
236 -- it seems easier to drag them out of the updated, cleaned-up UI
237 let linkables_to_link
238 = map (findModuleLinkable ui4) mods_to_keep_names
240 linkresult <- link ghci_mode False linkables_to_link pls1
243 -> panic "cmLoadModule: link failed (2)"
245 -> do let pcms4 = PersistentCMState { hst=hst4, hit=hit4,
246 ui=ui4, mg=mods_to_keep,
247 pci=pcii, gmode=ghci_mode }
249 = CmState { pcms=pcms4, pcs=pcs3, pls=pls4 }
251 -- choose rather arbitrarily who to return
252 if null mods_to_keep then Nothing
253 else Just (last mods_to_keep_names))
256 -- Given a bunch of old summaries and a new summary, try and
257 -- find the corresponding old summary, and, if found, compare
258 -- its source timestamp with that of the new summary. If in
260 summary_indicates_source_changed :: [ModSummary] -> ModSummary -> Bool
261 summary_indicates_source_changed old_summaries new_summary
262 = case [old | old <- old_summaries,
263 name_of_summary old == name_of_summary new_summary] of
265 (_:_:_) -> panic "summary_indicates_newer_source"
267 [] -> -- can't find a corresponding old summary, so
268 -- compare source and iface dates in the new summary.
269 trace (showSDoc (text "SISC: no old summary, new ="
270 <+> pprSummaryTimes new_summary)) (
271 case (ms_hs_date new_summary, ms_hi_date new_summary) of
272 (Just hs_t, Just hi_t) -> hs_t > hi_t
276 [old] -> -- found old summary; compare source timestamps
277 trace (showSDoc (text "SISC: old ="
278 <+> pprSummaryTimes old
279 <+> pprSummaryTimes new_summary)) (
280 case (ms_hs_date old, ms_hs_date new_summary) of
281 (Just old_t, Just new_t) -> new_t > old_t
285 -- Return (names of) all those in modsDone who are part of a cycle
286 -- as defined by theGraph.
287 findPartiallyCompletedCycles :: [ModuleName] -> [SCC ModSummary] -> [ModuleName]
288 findPartiallyCompletedCycles modsDone theGraph
292 chew ((AcyclicSCC v):rest) = chew rest -- acyclic? not interesting.
293 chew ((CyclicSCC vs):rest)
294 = let names_in_this_cycle = nub (map name_of_summary vs)
296 = nub ([done | done <- modsDone,
297 done `elem` names_in_this_cycle])
298 chewed_rest = chew rest
300 if not (null mods_in_this_cycle)
301 && length mods_in_this_cycle < length names_in_this_cycle
302 then mods_in_this_cycle ++ chewed_rest
306 -- Does this ModDetails export Main.main?
307 exports_main :: ModDetails -> Bool
309 = maybeToBool (lookupNameEnv (md_types md) mainName)
312 -- Add the given (LM-form) Linkables to the UI, overwriting previous
313 -- versions if they exist.
314 add_to_ui :: UnlinkedImage -> [Linkable] -> UnlinkedImage
318 add1 :: Linkable -> UnlinkedImage -> UnlinkedImage
320 = li : filter (\li2 -> not (for_same_module li li2)) ui
322 for_same_module :: Linkable -> Linkable -> Bool
323 for_same_module li1 li2
324 = not (is_package_linkable li1)
325 && not (is_package_linkable li2)
326 && modname_of_linkable li1 == modname_of_linkable li2
329 data CmThreaded -- stuff threaded through individual module compilations
330 = CmThreaded PersistentCompilerState HomeSymbolTable HomeIfaceTable
333 -- Compile multiple modules, stopping as soon as an error appears.
334 -- There better had not be any cyclic groups here -- we check for them.
335 upsweep_mods :: GhciMode
336 -> UnlinkedImage -- old linkables
337 -> (ModSummary -> Bool) -- has source changed?
338 -> CmThreaded -- PCS & HST & HIT
339 -> [SCC ModSummary] -- mods to do (the worklist)
340 -- ...... RETURNING ......
341 -> IO (Bool{-complete success?-},
343 [ModSummary], -- mods which succeeded
344 [Linkable]) -- new linkables
346 upsweep_mods ghci_mode oldUI source_changed threaded []
347 = return (True, threaded, [], [])
349 upsweep_mods ghci_mode oldUI source_changed threaded ((CyclicSCC ms):_)
350 = do hPutStrLn stderr ("ghc: module imports form a cycle for modules:\n\t" ++
351 unwords (map (moduleNameUserString.name_of_summary) ms))
352 return (False, threaded, [], [])
354 upsweep_mods ghci_mode oldUI source_changed threaded ((AcyclicSCC mod):mods)
355 = do (threaded1, maybe_linkable)
356 <- upsweep_mod ghci_mode oldUI threaded mod (source_changed mod)
357 case maybe_linkable of
359 -> -- No errors; do the rest
360 do (restOK, threaded2, modOKs, linkables)
361 <- upsweep_mods ghci_mode oldUI source_changed threaded1 mods
362 return (restOK, threaded2, mod:modOKs, linkable:linkables)
363 Nothing -- we got a compilation error; give up now
364 -> return (False, threaded1, [], [])
367 -- Compile a single module. Always produce a Linkable for it if
368 -- successful. If no compilation happened, return the old Linkable.
369 upsweep_mod :: GhciMode
374 -> IO (CmThreaded, Maybe Linkable)
376 upsweep_mod ghci_mode oldUI threaded1 summary1 source_might_have_changed
377 = do let mod_name = name_of_summary summary1
378 let (CmThreaded pcs1 hst1 hit1) = threaded1
379 let old_iface = lookupUFM hit1 (name_of_summary summary1)
381 -- We *have* to compile it if we're in batch mode and we can't see
382 -- a previous linkable for it on disk.
383 compilation_mandatory
384 <- if ghci_mode /= Batch then return False
385 else case ml_obj_file (ms_location summary1) of
386 Nothing -> do --putStrLn "cmcm: object?!"
388 Just obj_fn -> do --putStrLn ("cmcm: old obj " ++ obj_fn)
389 b <- doesFileExist obj_fn
392 let compilation_might_be_needed
393 = source_might_have_changed || compilation_mandatory
395 = not compilation_might_be_needed
397 compresult <- compile ghci_mode summary1 source_unchanged
398 old_iface hst1 hit1 pcs1
400 putStrLn ( "UPSWEEP_MOD: smhc = " ++ show source_might_have_changed
401 ++ ", cman = " ++ show compilation_mandatory)
405 -- Compilation "succeeded", but didn't return a new iface or
406 -- linkable, meaning that compilation wasn't needed, and the
407 -- new details were manufactured from the old iface.
408 CompOK details Nothing pcs2
409 -> let hst2 = addToUFM hst1 mod_name details
411 threaded2 = CmThreaded pcs2 hst2 hit2
413 | ghci_mode == Interactive
414 = findModuleLinkable oldUI mod_name
417 [DotO (unJust (ml_obj_file (ms_location summary1))
419 in return (threaded2, Just old_linkable)
421 -- Compilation really did happen, and succeeded. A new
422 -- details, iface and linkable are returned.
423 CompOK details (Just (new_iface, new_linkable)) pcs2
424 -> let hst2 = addToUFM hst1 mod_name details
425 hit2 = addToUFM hit1 mod_name new_iface
426 threaded2 = CmThreaded pcs2 hst2 hit2
427 in return (threaded2, Just new_linkable)
429 -- Compilation failed. compile may still have updated
432 -> let threaded2 = CmThreaded pcs2 hst1 hit1
433 in return (threaded2, Nothing)
436 -- Remove unwanted modules from the top level envs (HST, HIT, UI).
437 removeFromTopLevelEnvs :: [ModuleName]
438 -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
439 -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage)
440 removeFromTopLevelEnvs zap_these (hst, hit, ui)
441 = (delListFromUFM hst zap_these,
442 delListFromUFM hit zap_these,
443 filterModuleLinkables (`notElem` zap_these) ui
447 topological_sort :: Bool -> [ModSummary] -> [SCC ModSummary]
448 topological_sort include_source_imports summaries
450 toEdge :: ModSummary -> (ModSummary,ModuleName,[ModuleName])
452 = (summ, name_of_summary summ,
453 (if include_source_imports
454 then ms_srcimps summ else []) ++ ms_imps summ)
456 mash_edge :: (ModSummary,ModuleName,[ModuleName]) -> (ModSummary,Int,[Int])
457 mash_edge (summ, m, m_imports)
458 = case lookup m key_map of
459 Nothing -> panic "reverse_topological_sort"
460 Just mk -> (summ, mk,
461 -- ignore imports not from the home package
462 catMaybes (map (flip lookup key_map) m_imports))
464 edges = map toEdge summaries
465 key_map = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModuleName,Int)]
466 scc_input = map mash_edge edges
467 sccs = stronglyConnComp scc_input
472 -- Chase downwards from the specified root set, returning summaries
473 -- for all home modules encountered. Only follow source-import
475 downsweep :: [ModuleName] -> IO [ModSummary]
477 = do rootSummaries <- mapM getSummary rootNm
478 loop (filter (isModuleInThisPackage.ms_mod) rootSummaries)
480 getSummary :: ModuleName -> IO ModSummary
482 | trace ("getSummary: "++ showSDoc (ppr nm)) True
483 = do found <- findModule nm
485 Just (mod, location) -> summarise mod location
486 Nothing -> throwDyn (OtherError
487 ("no signs of life for module `"
488 ++ showSDoc (ppr nm) ++ "'"))
490 -- loop invariant: homeSummaries doesn't contain package modules
491 loop :: [ModSummary] -> IO [ModSummary]
493 = do let allImps :: [ModuleName]
494 allImps = (nub . concatMap ms_imps) homeSummaries
495 let allHome -- all modules currently in homeSummaries
496 = map (moduleName.ms_mod) homeSummaries
498 = filter (`notElem` allHome) allImps
500 <- mapM getSummary neededImps
502 = filter (isModuleInThisPackage.ms_mod) neededSummaries
503 if null newHomeSummaries
504 then return homeSummaries
505 else loop (newHomeSummaries ++ homeSummaries)
508 -- Summarise a module, and pick and source and interface timestamps.
509 summarise :: Module -> ModuleLocation -> IO ModSummary
510 summarise mod location
511 | isModuleInThisPackage mod
512 = do let hs_fn = unJust (ml_hs_file location) "summarise"
513 hspp_fn <- preprocess hs_fn
514 modsrc <- readFile hspp_fn
515 let (srcimps,imps) = getImports modsrc
518 <- case ml_hs_file location of
519 Nothing -> return Nothing
520 Just src_fn -> maybe_getModificationTime src_fn
521 maybe_iface_timestamp
522 <- case ml_hi_file location of
523 Nothing -> return Nothing
524 Just if_fn -> maybe_getModificationTime if_fn
526 return (ModSummary mod location{ml_hspp_file=Just hspp_fn}
528 maybe_src_timestamp maybe_iface_timestamp)
530 = return (ModSummary mod location [] [] Nothing Nothing)
533 maybe_getModificationTime :: FilePath -> IO (Maybe ClockTime)
534 maybe_getModificationTime fn
535 = (do time <- getModificationTime fn
538 (\err -> return Nothing)
540 cmLookupSymbol :: RdrName -> CmState -> Maybe HValue
541 cmLookupSymbol nm CmState{ pls = pls } = lookupClosure nm pls