From bed2d482ce226b57d52995b354f696e70ce488d5 Mon Sep 17 00:00:00 2001 From: sewardj Date: Fri, 6 Oct 2000 13:07:32 +0000 Subject: [PATCH] [project @ 2000-10-06 13:07:32 by sewardj] Commit half-implemented CM, and supporting changes. --- ghc/compiler/ghci/CmCompile.lhs | 4 +- ghc/compiler/ghci/CmFind.lhs | 7 +- ghc/compiler/ghci/CmLink.lhs | 25 +++- ghc/compiler/ghci/CmStaticInfo.lhs | 6 +- ghc/compiler/ghci/CmSummarise.lhs | 6 +- ghc/compiler/ghci/CompManager.lhs | 235 +++++++++++++++++++++++++++++++++--- 6 files changed, 254 insertions(+), 29 deletions(-) diff --git a/ghc/compiler/ghci/CmCompile.lhs b/ghc/compiler/ghci/CmCompile.lhs index e1d238b..6382911 100644 --- a/ghc/compiler/ghci/CmCompile.lhs +++ b/ghc/compiler/ghci/CmCompile.lhs @@ -67,8 +67,8 @@ emptyPCS = return (MkPCS emptyPIT emptyPST emptyHoldingPen) -- These two are only here to avoid recursion between CmCompile and -- CompManager. They really ought to be in the latter. -type HST = FiniteMap Module ModDetails -type HIT = FiniteMap Module ModIFace +type HST = FiniteMap {-really:Module-} String{- == ModName-} ModDetails +type HIT = FiniteMap {-really:Module-} String{- == ModName-} ModIFace data PCS = MkPCS PIT -- Package interface table diff --git a/ghc/compiler/ghci/CmFind.lhs b/ghc/compiler/ghci/CmFind.lhs index c2c8069..5f15254 100644 --- a/ghc/compiler/ghci/CmFind.lhs +++ b/ghc/compiler/ghci/CmFind.lhs @@ -48,7 +48,6 @@ isPackageLoc _ = False mkFinder :: [(ModName,PkgName,Path)] -> [Path] -> Finder mkFinder pkg_ifaces home_dirs modnm = do found <- mkFinderX pkg_ifaces home_dirs modnm - putStrLn ("FINDER pkginfo\n" ++ unlines (map show pkg_ifaces) ++ "\n") putStrLn ("FINDER: request = " ++ modnm ++ "\n" ++ "FINDER: response = " ++ show found) return found @@ -107,13 +106,13 @@ homeModuleExists modname path maybeTime :: String -> IO (Maybe ClockTime) maybeTime f - = do putStrLn ("maybeTime: " ++ f) + = do -- putStrLn ("maybeTime: " ++ f) exists <- doesFileExist f if not exists - then do putStrLn " ... no" + then do -- putStrLn " ... no" return Nothing else do tm <- getModificationTime f - putStrLn (" ... " ++ show tm) + -- putStrLn (" ... " ++ show tm) return (Just tm) diff --git a/ghc/compiler/ghci/CmLink.lhs b/ghc/compiler/ghci/CmLink.lhs index 4bd231e..7c41862 100644 --- a/ghc/compiler/ghci/CmLink.lhs +++ b/ghc/compiler/ghci/CmLink.lhs @@ -4,7 +4,9 @@ \section[CmLink]{Linker for GHCI} \begin{code} -module CmLink ( Linkable(..), LinkResult(..), +module CmLink ( Linkable(..), + filterModuleLinkables, modname_of_linkable, + LinkResult(..), HValue, link, PLS{-abstractly!-}, emptyPLS ) @@ -17,7 +19,9 @@ import Module ( Module ) import Outputable ( SDoc ) import FiniteMap ( FiniteMap, emptyFM ) import RdrName ( RdrName ) +import Digraph ( SCC ) import Addr ( Addr ) +import Panic ( panic ) #include "HsVersions.h" @@ -33,7 +37,7 @@ data PLS data HValue = HValue -- fix this ... just temporary? -link :: PCI -> [[Linkable]] -> PLS -> IO LinkResult +link :: PCI -> [SCC Linkable] -> PLS -> IO LinkResult link pci linkabless pls = return (error "link:unimp") @@ -48,9 +52,24 @@ data Unlinked -- | Trees [StgTree RdrName] data Linkable - = LM Module [Unlinked] + = LM {-should be:Module-} String{- == ModName-} [Unlinked] | LP PkgName +modname_of_linkable (LM nm _) = nm +modname_of_linkable (LP _) = panic "modname_of_linkable: package" + +filterModuleLinkables :: (String{- ==ModName-} -> Bool) + -> [Linkable] + -> [Linkable] +filterModuleLinkables p [] = [] +filterModuleLinkables p (li:lis) + = case li of + LP _ -> retain + LM modnm _ -> if p modnm then retain else dump + where + dump = filterModuleLinkables p lis + retain = li : dump + emptyPLS :: IO PLS emptyPLS = return (MkPLS { source_symtab = emptyFM, object_symtab = emptyFM }) diff --git a/ghc/compiler/ghci/CmStaticInfo.lhs b/ghc/compiler/ghci/CmStaticInfo.lhs index 2bb52ba..329f0ba 100644 --- a/ghc/compiler/ghci/CmStaticInfo.lhs +++ b/ghc/compiler/ghci/CmStaticInfo.lhs @@ -5,7 +5,7 @@ \begin{code} module CmStaticInfo ( FLAGS, Package(..), PCI, - mkSI, SI -- abstract + mkSI, SI(..) ) where @@ -35,10 +35,10 @@ data Package deriving (Read, Show) -data SI = MkSI FLAGS PCI +data SI = SI { flags :: FLAGS, pci :: PCI } mkSI :: FLAGS -> PCI -> SI -mkSI = MkSI +mkSI flags pci = SI { flags = flags, pci = pci } \end{code} diff --git a/ghc/compiler/ghci/CmSummarise.lhs b/ghc/compiler/ghci/CmSummarise.lhs index 6d6b652..7ef80a9 100644 --- a/ghc/compiler/ghci/CmSummarise.lhs +++ b/ghc/compiler/ghci/CmSummarise.lhs @@ -5,7 +5,7 @@ \begin{code} module CmSummarise ( ModImport(..), mi_name, - ModSummary(..), summarise ) + ModSummary(..), summarise, ms_get_imports ) where #include "HsVersions.h" @@ -35,6 +35,10 @@ data ModImport mi_name (MINormal nm) = nm mi_name (MISource nm) = nm +ms_get_imports :: ModSummary -> [ModImport] +ms_get_imports summ + = case ms_imports summ of { Just is -> is; Nothing -> [] } + type Fingerprint = Int summarise :: ModLocation -> IO ModSummary diff --git a/ghc/compiler/ghci/CompManager.lhs b/ghc/compiler/ghci/CompManager.lhs index 2e0ca15..65dfb65 100644 --- a/ghc/compiler/ghci/CompManager.lhs +++ b/ghc/compiler/ghci/CompManager.lhs @@ -13,16 +13,21 @@ where #include "HsVersions.h" import List ( nub ) -import Maybe ( catMaybes ) +import Maybe ( catMaybes, maybeToList ) import Outputable ( SDoc ) -import FiniteMap ( emptyFM ) +import FiniteMap ( emptyFM, filterFM ) +import Digraph ( SCC(..), stronglyConnComp ) +import Panic ( panic ) -import CmStaticInfo ( FLAGS, PCI, SI, mkSI ) +import CmStaticInfo ( FLAGS, PCI, SI(..), mkSI ) import CmFind ( Finder, newFinder, ModName, ml_modname, isPackageLoc ) -import CmSummarise ( summarise, ModSummary(..), mi_name ) -import CmCompile ( PCS, emptyPCS, HST, HIT ) -import CmLink ( PLS, emptyPLS, HValue, Linkable ) +import CmSummarise ( summarise, ModSummary(..), + mi_name, ms_get_imports ) +import CmCompile ( PCS, emptyPCS, HST, HIT, CompResult(..) ) +import CmLink ( PLS, emptyPLS, HValue, Linkable, + link, LinkResult(..), + filterModuleLinkables, modname_of_linkable ) @@ -52,7 +57,7 @@ data PCMS hst :: HST, -- home symbol table hit :: HIT, -- home interface table ui :: UI, -- the unlinked images - mg :: MG -- the module graph + mg :: MG -- the module graph } emptyPCMS :: PCMS @@ -76,7 +81,7 @@ data CmState pcs :: PCS, -- compile's persistent state pls :: PLS, -- link's persistent state si :: SI, -- static info, never changes - finder :: Finder -- the module finder + finder :: Finder -- the module finder } emptyCmState :: FLAGS -> PCI -> IO CmState @@ -98,7 +103,7 @@ emptyUI :: UI emptyUI = [] -type MG = [[ModSummary]] -- the module graph +type MG = [SCC ModSummary] -- the module graph, topologically sorted emptyMG :: MG emptyMG = [] @@ -113,12 +118,210 @@ cmLoadModule :: CmState -> ModName -> IO (CmState, Either [SDoc] ModHandle) -cmLoadModule cmstate modname - = do putStr "cmLoadModule: downsweep begins\n" - let find = finder cmstate - mgNew <- downsweep modname find - putStrLn ( "after chasing:\n\n" ++ unlines (map show mgNew)) - return (error "cmLoadModule:unimp") +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 + + -- 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. + + putStr "cmLoadModule: downsweep begins\n" + mg2unsorted <- downsweep modname (finder cmstate1) + putStrLn ( "after chasing:\n\n" ++ unlines (map show mg2unsorted)) + + let modnames1 = map name_of_summary (flattenMG 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) + + let mg2 = topological_sort mg2unsorted + + putStrLn ( "after tsort:\n\n" + ++ unlines (map show (flattenMG 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 + + let ui3 = add_to_ui ui2 newLis + let (ModThreaded pcs3 hst3 hit3) = threaded3 + + -- Try and do linking in some form, depending on whether the + -- upsweep was completely or only partially successful. + + if null errs + + then + do let mods_to_relink = upwards_closure mg2 + (map modname_of_linkable newLis) + let sccs_to_relink = group_uis ui3 mg2 mods_to_relink + linkresult <- link pci1 sccs_to_relink pls1 + case linkresult of + LinkErrs _ _ + -> panic "cmLoadModule: link failed (1)" + LinkOK pls3 + -> do let pcms3 + = PCMS { hst=hst3, hit=hit3, ui=ui3, mg=mg2 } + let cmstate3 + = CmState { pcms=pcms3, pcs=pcs3, pls=pls3, + si = si cmstate1, + finder = finder cmstate1 + } + return (cmstate3, Right modname) + + else + do let mods_to_relink = downwards_closure mg2 + (map name_of_summary (flattenMG sccOKs)) + let sccs_to_relink = group_uis ui3 mg2 mods_to_relink + linkresult <- link pci1 sccs_to_relink pls1 + let (hst4, hit4, ui4) + = filterTopLevelEnvs (`notElem` mods_to_relink) + (hst3,hit3,ui3) + case linkresult of + LinkErrs _ _ + -> panic "cmLoadModule: link failed (2)" + LinkOK pls4 + -> do let pcms4 + = PCMS { hst=hst4, hit=hit4, ui=ui4, mg=mg2 } + let cmstate4 + = CmState { pcms=pcms4, pcs=pcs3, pls=pls4, + si = si cmstate1, + finder = finder cmstate1 + } + return (cmstate4, Right modname) + + +flattenMG :: [SCC ModSummary] -> [ModSummary] +flattenMG = concatMap flatten + +flatten (AcyclicSCC v) = [v] +flatten (CyclicSCC vs) = vs + +group_uis :: UI -> [SCC ModSummary] -> [ModName] -> [SCC Linkable] +group_uis ui modGraph mods_to_group + = error "group_uis" + +add_to_ui :: UI -> [Linkable] -> UI +add_to_ui = error "add_to_ui" + +downwards_closure, + upwards_closure :: [SCC ModSummary] -> [ModName] -> [ModName] + +upwards_closure = error "upwards_closure" +downwards_closure = error "downwards_closure" + +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 + -> [SCC ModSummary] -- accum: SCCs which succeeded + -> [Linkable] -- accum: new Linkables + -> [SDoc] -- accum: error messages + -> [SDoc] -- accum: warnings + -> [SCC ModSummary] -- SCCs to do (the worklist) + -- ...... RETURNING ...... + -> IO (ModThreaded, + [SCC ModSummary], -- SCCs which succeeded + [Linkable], -- new linkables + [SDoc], -- error messages + [SDoc]) -- warnings + +upsweep_sccs 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) + = -- Start work on a new SCC. + do (threaded2, lisM, errsM, warnsM) + <- upsweep_mods 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) + errs (warnsM++warns) sccs + else -- we got a compilation error; give up now + return + (threaded2, sccOKs, + lisM++newLis, errsM++errs, warnsM++warns) + +-- Compile multiple modules (one SCC), stopping as soon as an error appears +upsweep_mods :: ModThreaded + -> [ModSummary] + -> IO (ModThreaded, [Linkable], [SDoc], [SDoc]) +upsweep_mods threaded [] + = return (threaded, [], [], []) +upsweep_mods threaded (mod:mods) + = do (threaded1, maybe_linkable, errsM, warnsM) <- upsweep_mod threaded mod + if null errsM + then -- No errors; get contribs from the rest + do (threaded2, linkables, errsMM, warnsMM) + <- upsweep_mods threaded1 mods + return + (threaded2, maybeToList maybe_linkable ++ linkables, + errsM++errsMM, warnsM++warnsMM) + else -- Errors; give up _now_ + return (threaded1, [], errsM, warnsM) + +-- Compile a single module. +upsweep_mod :: ModThreaded + -> ModSummary + -> IO (ModThreaded, Maybe Linkable, [SDoc], [SDoc]) +upsweep_mod = error "upsweep_mod" + + + + +filterTopLevelEnvs :: (ModName -> Bool) -> (HST, HIT, UI) -> (HST, HIT, UI) +filterTopLevelEnvs p (hst, hit, ui) + = (filterFM (\k v -> p k) hst, + filterFM (\k v -> p k) hit, + 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 + toEdge :: ModSummary -> (ModSummary,ModName,[ModName]) + toEdge summ + = (summ, name_of_summary summ, deps_of_summary summ) + + mash_edge :: (ModSummary,ModName,[ModName]) -> (ModSummary,Int,[Int]) + mash_edge (summ, m, m_imports) + = case lookup m key_map of + Nothing -> panic "reverse_topological_sort" + Just mk -> (summ, mk, + -- ignore imports not from the home package + catMaybes (map (flip lookup key_map) m_imports)) + + edges = map toEdge summaries + key_map = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModName,Int)] + scc_input = map mash_edge edges + sccs = stronglyConnComp scc_input + in + sccs downsweep :: ModName -- module to chase from -> Finder @@ -137,7 +340,7 @@ downsweep rootNm finder loop :: [ModSummary] -> IO [ModSummary] loop homeSummaries = do let allImps -- all imports - = (nub . map mi_name . concat . catMaybes . map ms_imports) + = (nub . map mi_name . concat . map ms_get_imports) homeSummaries let allHome -- all modules currently in homeSummaries = map (ml_modname.ms_loc) homeSummaries -- 1.7.10.4