\section[CompManager]{The Compilation Manager}
\begin{code}
+#if 1
+module CompManager ( )
+where
+the_answer = "42"
+
+#else
+
module CompManager ( cmInit, cmLoadModule,
cmGetExpr, cmRunExpr,
CmState, emptyCmState -- abstract
#include "HsVersions.h"
import List ( nub )
-import Maybe ( catMaybes, maybeToList )
-import Outputable ( SDoc )
-import FiniteMap ( emptyFM, filterFM )
+import Maybe ( catMaybes, maybeToList, fromMaybe )
+import Outputable
+import FiniteMap ( emptyFM, filterFM, lookupFM, addToFM )
import Digraph ( SCC(..), stronglyConnComp )
import Panic ( panic )
-import CmStaticInfo ( FLAGS, PCI, SI(..), mkSI )
-import CmFind ( Finder, newFinder,
- ModName, ml_modname, isPackageLoc )
+import CmStaticInfo ( PCI(..), mkPCI, Package(..) )
+import Finder ( Finder, newFinder,
+ ModName, ml_modname, isPackageLoc,
+ PkgName, Path )
import CmSummarise ( summarise, ModSummary(..),
- mi_name, ms_get_imports )
-import CmCompile ( PCS, emptyPCS, HST, HIT, CompResult(..) )
-import CmLink ( PLS, emptyPLS, Linkable,
+ mi_name, ms_get_imports,
+ name_of_summary, deps_of_summary )
+--import CmCompile ( PCS, emptyPCS, HST, HIT, CompResult(..), cmCompile )
+import CmLink ( PLS, emptyPLS, Linkable(..),
link, LinkResult(..),
filterModuleLinkables, modname_of_linkable,
is_package_linkable )
import InterpSyn ( HValue )
-cmInit :: FLAGS
- -> PCI
+
+cmInit :: String{-temp debugging hack-}
+ -> [Package]
-> IO CmState
-cmInit flags pkginfo
- = emptyCmState flags pkginfo
+cmInit path raw_package_info
+ = emptyCmState path raw_package_info
cmGetExpr :: CmState
-> ModHandle
-- Persistent state just for CM, excluding link & compile subsystems
-data PCMS
- = PCMS {
- hst :: HST, -- home symbol table
- hit :: HIT, -- home interface table
- ui :: UI, -- the unlinked images
- mg :: MG -- the module graph
+data PersistentCMState
+ = PersistentCMState {
+ hst :: HomeSymbolTable, -- home symbol table
+ hit :: HomeIfaceTable, -- home interface table
+ ui :: UnlinkedImages, -- the unlinked images
+ mg :: ModuleGraph -- the module graph
}
-emptyPCMS :: PCMS
-emptyPCMS = PCMS { hst = emptyHST,
- hit = emptyHIT,
- ui = emptyUI,
- mg = emptyMG }
+emptyPCMS :: PersistentCMState
+emptyPCMS = PersistentCMState
+ { hmm = emptyHMM,
+ hst = emptyHST, hit = emptyHIT,
+ ui = emptyUI, mg = emptyMG }
-emptyHIT :: HIT
+emptyHIT :: HomeIfaceTable
emptyHIT = emptyFM
-
-emptyHST :: HST
+emptyHST :: HomeSymbolTable
emptyHST = emptyFM
-- Persistent state for the entire system
data CmState
= CmState {
- pcms :: PCMS, -- CM's persistent state
- pcs :: PCS, -- compile's persistent state
- pls :: PLS, -- link's persistent state
- si :: SI, -- static info, never changes
- finder :: Finder -- the module finder
+ pcms :: PersistentCMState, -- CM's persistent state
+ pcs :: PersistentCompilerState, -- compile's persistent state
+ pls :: PersistentLinkerState, -- link's persistent state
+ pci :: PackageConfigInfo, -- package config info, never changes
+ finder :: Finder -- the module finder
}
-emptyCmState :: FLAGS -> PCI -> IO CmState
-emptyCmState flags pci
+emptyCmState :: String{-temp debugging hack-}
+ -> [Package] -> IO CmState
+emptyCmState path_TMP_DEBUGGING_HACK raw_package_info
= do let pcms = emptyPCMS
pcs <- emptyPCS
pls <- emptyPLS
- let si = mkSI flags pci
- finder <- newFinder pci
+ pci <- mkPCI raw_package_info
+ finder <- newFinder path_TMP_DEBUGGING_HACK pci
return (CmState { pcms = pcms,
pcs = pcs,
- pls = pls,
- si = si,
+ pls = pls,
+ pci = pci,
finder = finder })
-- CM internal types
-type UI = [Linkable] -- the unlinked images (should be a set, really)
-emptyUI :: UI
+type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really)
+emptyUI :: UnlinkedImage
emptyUI = []
-
-type MG = [SCC ModSummary] -- the module graph, topologically sorted
-emptyMG :: MG
+type ModuleGraph = [SCC ModSummary] -- the module graph, topologically sorted
+emptyMG :: ModuleGraph
emptyMG = []
\end{code}
cmLoadModule cmstate1 modname
= do -- version 1's are the original, before downsweep
-
- let pci1 = pci (si cmstate1)
- let pcms1 = pcms cmstate1
- let pls1 = pls cmstate1
- let pcs1 = pcs cmstate1
- let mg1 = mg pcms1
- let hst1 = hst pcms1
- let hit1 = hit pcms1
- let ui1 = ui pcms1
+ let pcms1 = pcms cmstate1
+ let pls1 = pls cmstate1
+ let pcs1 = pcs cmstate1
+ let mg1 = mg pcms1
+ let hst1 = hst pcms1
+ let hit1 = hit pcms1
+ let ui1 = ui pcms1
+ -- these aren't numbered since they don't change
+ let pcii = pci cmstate1
+ let finderr = finder cmstate1
-- do the downsweep to reestablish the module graph
-- then generate version 2's by removing from HIT,HST,UI any
-- modules in the old MG which are not in the new one.
+ -- TODO: call newFinder to reestablish home module cache?!
+
putStr "cmLoadModule: downsweep begins\n"
- mg2unsorted <- downsweep modname (finder cmstate1)
- putStrLn ( "after chasing:\n\n" ++ unlines (map show mg2unsorted))
+ mg2unsorted <- downsweep modname finderr
+ putStrLn (showSDoc (vcat (map ppr mg2unsorted)))
- let modnames1 = map name_of_summary (flattenMG mg1)
+ let modnames1 = map name_of_summary (flattenSCCs mg1)
let modnames2 = map name_of_summary mg2unsorted
let mods_to_zap = filter (`notElem` modnames2) modnames1
let (hst2, hit2, ui2)
= filterTopLevelEnvs (`notElem` mods_to_zap)
- (hst1, hit2, ui2)
+ (hst1, hit1, ui1)
let mg2 = topological_sort mg2unsorted
- putStrLn ( "after tsort:\n\n"
- ++ unlines (map show (flattenMG mg2)))
+ putStrLn "after tsort:\n"
+ putStrLn (showSDoc (vcat (map ppr (flattenSCCs mg2))))
-- Now do the upsweep, calling compile for each module in
-- turn. Final result is version 3 of everything.
let threaded2 = ModThreaded pcs1 hst2 hit2
(threaded3, sccOKs, newLis, errs, warns)
- <- upsweep_sccs threaded2 [] [] [] [] mg2
+ <- upsweep_sccs finderr threaded2 [] [] [] [] mg2
let ui3 = add_to_ui ui2 newLis
let (ModThreaded pcs3 hst3 hit3) = threaded3
then
do let mods_to_relink = upwards_closure mg2
(map modname_of_linkable newLis)
+ let pkg_linkables = find_pkg_linkables_for pcii mg2 mods_to_relink
+ putStrLn ("needed package modules =\n"
+ ++ showSDoc (vcat (map ppr pkg_linkables)))
let sccs_to_relink = group_uis ui3 mg2 mods_to_relink
- linkresult <- link pci1 sccs_to_relink pls1
+ let all_to_relink = map AcyclicSCC pkg_linkables
+ ++ sccs_to_relink
+ linkresult <- link pcii all_to_relink pls1
case linkresult of
LinkErrs _ _
-> panic "cmLoadModule: link failed (1)"
= PCMS { hst=hst3, hit=hit3, ui=ui3, mg=mg2 }
let cmstate3
= CmState { pcms=pcms3, pcs=pcs3, pls=pls3,
- si = si cmstate1,
- finder = finder cmstate1
- }
+ pci=pcii, finder=finderr }
return (cmstate3, Right modname)
else
do let mods_to_relink = downwards_closure mg2
- (map name_of_summary (flattenMG sccOKs))
+ (map name_of_summary (flattenSCCs sccOKs))
+ let pkg_linkables = find_pkg_linkables_for pcii mg2 mods_to_relink
let sccs_to_relink = group_uis ui3 mg2 mods_to_relink
- linkresult <- link pci1 sccs_to_relink pls1
+ let all_to_relink = map AcyclicSCC pkg_linkables
+ ++ sccs_to_relink
+ linkresult <- link pcii all_to_relink pls1
let (hst4, hit4, ui4)
= filterTopLevelEnvs (`notElem` mods_to_relink)
(hst3,hit3,ui3)
= PCMS { hst=hst4, hit=hit4, ui=ui4, mg=mg2 }
let cmstate4
= CmState { pcms=pcms4, pcs=pcs3, pls=pls4,
- si = si cmstate1,
- finder = finder cmstate1
- }
+ pci=pcii, finder=finderr }
return (cmstate4, Right modname)
+-- Given a (home) module graph and a bunch of names of (home) modules
+-- within that graph, return the names of any packages needed by the
+-- named modules. Do this by looking at their imports. Assumes, and
+-- checks, that all of "mods" are mentioned in "mg".
+--
+-- Then, having found the packages directly needed by "mods",
+-- (1) round up, by looking in "pci", all packages they directly or
+-- indirectly depend on, and (2) put these packages in topological
+-- order, since that's important for some linkers. Since cycles in
+-- the package dependency graph aren't allowed, we can just return
+-- the list of (package) linkables, rather than a list of SCCs.
+find_pkg_linkables_for :: PCI -> [SCC ModSummary] -> [ModName] -> [Linkable]
+find_pkg_linkables_for pcii mg mods
+ = let mg_summaries = flattenSCCs mg
+ mg_names = map name_of_summary mg_summaries
+ in
+ if not (all (`elem` mg_names) mods)
+ then panic "find_packages_for"
+ else
+ let all_imports
+ = concat
+ [deps_of_summary summ
+ | summ <- mg_summaries, name_of_summary summ `elem` mods]
+ imports_not_in_home -- imports which must be from packages
+ = nub (filter (`notElem` mg_names) all_imports)
+ mod_tab :: [(ModName, PkgName, Path)]
+ mod_tab = module_table pcii
+ home_pkgs_needed -- the packages directly needed by the home modules
+ = nub [pkg_nm | (mod_nm, pkg_nm, path) <- mod_tab,
+ mod_nm `elem` imports_not_in_home]
+
+ -- Discover the package dependency graph, and use it to find the
+ -- transitive closure of all the needed packages
+ pkg_depend_graph :: [(PkgName,[PkgName])]
+ pkg_depend_graph = map (\raw -> (name raw, package_deps raw))
+ (raw_package_info pcii)
+
+ all_pkgs_needed = simple_transitive_closure
+ pkg_depend_graph home_pkgs_needed
+
+ -- Make a graph, in the style which Digraph.stronglyConnComp expects,
+ -- containing entries only for the needed packages.
+ needed_graph
+ = concat
+ [if srcP `elem` all_pkgs_needed
+ then [(srcP, srcP, dstsP)]
+ else []
+ | (srcP, dstsP) <- pkg_depend_graph]
+ tsorted = flattenSCCs (stronglyConnComp needed_graph)
+ in
+ map LP tsorted
-flattenMG :: [SCC ModSummary] -> [ModSummary]
-flattenMG = concatMap flatten
+
+simple_transitive_closure :: Eq a => [(a,[a])] -> [a] -> [a]
+simple_transitive_closure graph set
+ = let set2 = nub (concatMap dsts set ++ set)
+ dsts node = fromMaybe [] (lookup node graph)
+ in
+ if length set == length set2
+ then set
+ else simple_transitive_closure graph set2
+
+
+flattenSCCs :: [SCC a] -> [a]
+flattenSCCs = concatMap flatten
flatten (AcyclicSCC v) = [v]
flatten (CyclicSCC vs) = vs
-- Add the given (LM-form) Linkables to the UI, overwriting previous
-- versions if they exist.
add_to_ui :: UI -> [Linkable] -> UI
-add_to_ui ui lis
+add_to_ui ui lis
= foldr add1 ui lis
where
add1 :: Linkable -> UI -> UI
up_down_closure :: Bool -> [SCC ModSummary] -> [ModName] -> [ModName]
up_down_closure up modGraph roots
- = let mgFlat = flattenMG modGraph
+ = let mgFlat = flattenSCCs modGraph
nodes = map name_of_summary mgFlat
fwdEdges, backEdges :: [(ModName, [ModName])]
= [(n, [m | (m, m_imports) <- fwdEdges, n `elem` m_imports])
| (n, n_imports) <- fwdEdges]
- iterate :: [(ModName,[ModName])] -> [ModName] -> [ModName]
- iterate graph set
- = let set2 = nub (concatMap dsts set)
- dsts :: ModName -> [ModName]
- dsts node = case lookup node graph of
- Just ds -> ds
- Nothing -> panic "up_down_closure"
- in
- if length set == length set2 then set else iterate graph set2
-
mkEdge summ
= (name_of_summary summ,
-- ignore imports not from the home package
filter (`elem` nodes) (deps_of_summary summ))
in
- (if up then iterate backEdges else iterate fwdEdges) (nub roots)
+ simple_transitive_closure
+ (if up then backEdges else fwdEdges) (nub roots)
data ModThreaded -- stuff threaded through individual module compilations
= ModThreaded PCS HST HIT
-- Compile multiple SCCs, stopping as soon as an error appears
-upsweep_sccs :: ModThreaded -- PCS & HST & HIT
+upsweep_sccs :: Finder -- the finder
+ -> ModThreaded -- PCS & HST & HIT
-> [SCC ModSummary] -- accum: SCCs which succeeded
-> [Linkable] -- accum: new Linkables
-> [SDoc] -- accum: error messages
[SDoc], -- error messages
[SDoc]) -- warnings
-upsweep_sccs threaded sccOKs newLis errs warns []
+upsweep_sccs finder threaded sccOKs newLis errs warns []
= -- No more SCCs to do.
return (threaded, sccOKs, newLis, errs, warns)
-upsweep_sccs threaded sccOKs newLis errs warns (scc:sccs)
+upsweep_sccs finder threaded sccOKs newLis errs warns (scc:sccs)
= -- Start work on a new SCC.
do (threaded2, lisM, errsM, warnsM)
- <- upsweep_mods threaded (flatten scc)
+ <- upsweep_mods finder threaded (flatten scc)
if null errsM
then -- all the modules in the scc were ok
-- move on to the next SCC
- upsweep_sccs threaded2 (scc:sccOKs) (lisM++newLis)
+ upsweep_sccs finder threaded2
+ (scc:sccOKs) (lisM++newLis)
errs (warnsM++warns) sccs
else -- we got a compilation error; give up now
return
lisM++newLis, errsM++errs, warnsM++warns)
-- Compile multiple modules (one SCC), stopping as soon as an error appears
-upsweep_mods :: ModThreaded
+upsweep_mods :: Finder
+ -> ModThreaded
-> [ModSummary]
-> IO (ModThreaded, [Linkable], [SDoc], [SDoc])
-upsweep_mods threaded []
+upsweep_mods finder threaded []
= return (threaded, [], [], [])
-upsweep_mods threaded (mod:mods)
- = do (threaded1, maybe_linkable, errsM, warnsM) <- upsweep_mod threaded mod
+upsweep_mods finder threaded (mod:mods)
+ = do (threaded1, maybe_linkable, errsM, warnsM)
+ <- upsweep_mod finder threaded mod
if null errsM
then -- No errors; get contribs from the rest
do (threaded2, linkables, errsMM, warnsMM)
- <- upsweep_mods threaded1 mods
+ <- upsweep_mods finder threaded1 mods
return
(threaded2, maybeToList maybe_linkable ++ linkables,
errsM++errsMM, warnsM++warnsMM)
return (threaded1, [], errsM, warnsM)
-- Compile a single module.
-upsweep_mod :: ModThreaded
+upsweep_mod :: Finder
+ -> ModThreaded
-> ModSummary
-> IO (ModThreaded, Maybe Linkable, [SDoc], [SDoc])
-upsweep_mod = error "upsweep_mod"
-
-
+upsweep_mod finder threaded1 summary1
+ = do let mod_name = name_of_summary summary1
+ let (ModThreaded pcs1 hst1 hit1) = threaded1
+ let old_iface = lookupFM hit1 (name_of_summary summary1)
+ compresult <- cmCompile finder summary1 old_iface hst1 pcs1
+
+ case compresult of
+
+ -- Compilation "succeeded", but didn't return a new iface or
+ -- linkable, meaning that compilation wasn't needed, and the
+ -- new details were manufactured from the old iface.
+ CompOK details Nothing pcs2 warns
+ -> let hst2 = addToFM hst1 mod_name details
+ hit2 = hit1
+ threaded2 = ModThreaded pcs2 hst2 hit2
+ in return (threaded2, Nothing, [], warns)
+
+ -- Compilation really did happen, and succeeded. A new
+ -- details, iface and linkable are returned.
+ CompOK details (Just (new_iface, new_linkable)) pcs2 warns
+ -> let hst2 = addToFM hst1 mod_name details
+ hit2 = addToFM hit1 mod_name new_iface
+ threaded2 = ModThreaded pcs2 hst2 hit2
+ in return (threaded2, Just new_linkable, [], warns)
+
+ -- Compilation failed. compile may still have updated
+ -- the PCS, tho.
+ CompErrs pcs2 errs warns
+ -> let threaded2 = ModThreaded pcs2 hst1 hit1
+ in return (threaded2, Nothing, errs, warns)
filterTopLevelEnvs :: (ModName -> Bool) -> (HST, HIT, UI) -> (HST, HIT, UI)
filterTopLevelEnvs p (hst, hit, ui)
filterModuleLinkables p ui
)
-name_of_summary :: ModSummary -> ModName
-name_of_summary = ml_modname . ms_loc
-
-deps_of_summary :: ModSummary -> [ModName]
-deps_of_summary = map mi_name . ms_get_imports
-
topological_sort :: [ModSummary] -> [SCC ModSummary]
topological_sort summaries
= let
where
getSummary :: ModName -> IO ModSummary
getSummary nm
- = do loc <- finder nm
- summary <- summarise loc
- return summary
+ = do found <- finder nm
+ case found of
+ Just (mod, location) -> summarise mod location
+ Nothing -> panic ("CompManager: can't find module `" ++
+ showSDoc (ppr nm) ++ "'")
-- loop invariant: homeSummaries doesn't contain package modules
loop :: [ModSummary] -> IO [ModSummary]
if null newHomeSummaries
then return homeSummaries
else loop (newHomeSummaries ++ homeSummaries)
-
+#endif
\end{code}
projects / ghc-hetmet.git / blobdiff