From: sewardj Date: Thu, 2 Nov 2000 13:58:45 +0000 (+0000) Subject: [project @ 2000-11-02 13:58:44 by sewardj] X-Git-Tag: Approximately_9120_patches~3444 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=c1d8b21c963eec0cee6151b98c35e1fb372ee163;p=ghc-hetmet.git [project @ 2000-11-02 13:58:44 by sewardj] Most, but not all changes needed to get CompManager to compile. --- diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index 5c2b423..b12ba5d 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -21,7 +21,7 @@ in a different DLL, by setting the DLL flag. \begin{code} module Module ( - Module, moduleName + Module, moduleName, packageOfModule, -- abstract, instance of Eq, Ord, Outputable , ModuleName , isModuleInThisPackage, mkModuleInThisPackage, @@ -255,7 +255,7 @@ moduleString :: Module -> EncodedString moduleString (Module (ModuleName fs) _) = _UNPK_ fs moduleName :: Module -> ModuleName -moduleName (Module mod _) = mod +moduleName (Module mod pkg_info) = mod moduleUserString :: Module -> UserString moduleUserString (Module mod _) = moduleNameUserString mod @@ -264,6 +264,10 @@ isModuleInThisPackage :: Module -> Bool isModuleInThisPackage (Module nm ThisPackage) = True isModuleInThisPackage _ = False +packageOfModule :: Module -> Maybe PackageName +packageOfModule (Module nm (AnotherPackage pn)) = Just pn +packageOfModule _ = Nothing + printModulePrefix :: Module -> Bool -- When printing, say M.x printModulePrefix (Module nm ThisPackage) = False diff --git a/ghc/compiler/ghci/CmSummarise.lhs b/ghc/compiler/ghci/CmSummarise.lhs index eff75bc..eb75ca4 100644 --- a/ghc/compiler/ghci/CmSummarise.lhs +++ b/ghc/compiler/ghci/CmSummarise.lhs @@ -13,10 +13,9 @@ where #include "HsVersions.h" import List ( nub ) -import Char ( ord, isAlphaNum ) +import Char ( isAlphaNum ) import Util ( unJust ) import HscTypes ( ModuleLocation(..) ) -import FastTypes import Module import Outputable @@ -36,7 +35,6 @@ data ModSummary = ModSummary { ms_mod :: Module, -- name, package ms_location :: ModuleLocation, -- location - ms_ppsource :: (Maybe (FilePath, Fingerprint)), -- preprocessed and sig if .hs ms_imports :: (Maybe [ModImport]) -- imports if .hs or .hi } @@ -44,15 +42,9 @@ instance Outputable ModSummary where ppr ms = sep [text "ModSummary {", nest 3 (sep [text "ms_mod =" <+> ppr (ms_mod ms), - text "ms_ppsource =" <+> fooble (ms_ppsource ms), text "ms_imports=" <+> ppr (ms_imports ms)]), char '}' ] - where - fooble Nothing = text "Nothing" - fooble (Just (cppd_source_name,fp)) - = text "(fp =" <+> int fp <> text "," - <+> text (show cppd_source_name) <> text ")" data ModImport = MINormal ModuleName | MISource ModuleName @@ -80,28 +72,13 @@ type Fingerprint = Int summarise :: Module -> ModuleLocation -> IO ModSummary summarise mod location - = if isModuleInThisPackage mod - then do - let source_fn = unJust (ml_hspp_file location) "summarise" - modsrc <- readFile source_fn - let imps = getImports modsrc - fp = fingerprint modsrc - return (ModSummary mod location (Just (source_fn,fp)) (Just imps)) - else - return (ModSummary mod location Nothing Nothing) - -fingerprint :: String -> Int -fingerprint s - = dofp s (_ILIT 3) (_ILIT 3) - where - -- Copied from hash() in Hugs' storage.c. - dofp :: String -> FastInt -> FastInt -> Int - dofp [] m fp = iBox fp - dofp (c:cs) m fp = dofp cs (m +# _ILIT 1) - (iabs (fp +# m *# iUnbox (ord c))) - - iabs :: FastInt -> FastInt - iabs n = if n <# _ILIT 0 then (_ILIT 0) -# n else n + | isModuleInThisPackage mod + = do let hspp_fn = unJust (ml_hspp_file location) "summarise" + modsrc <- readFile hspp_fn + let imps = getImports modsrc + return (ModSummary mod location (Just imps)) + | otherwise + = return (ModSummary mod location Nothing) \end{code} Collect up the imports from a Haskell source module. This is @@ -141,21 +118,21 @@ clean s where -- running through text we want to keep keep [] = [] - keep ('"':cs) = dquote cs + keep ('"':cs) = dquote cs -- " -- try to eliminate single quotes when they're part of -- an identifier... keep (c:'\'':cs) | isAlphaNum c || c == '_' = keep (dropWhile (=='\'') cs) keep ('\'':cs) = squote cs keep ('-':'-':cs) = linecomment cs keep ('{':'-':'#':' ':cs) = "{-# " ++ keep cs - keep ('{':'-':cs) = runcomment cs + keep ('{':'-':cs) = runcomment cs -- -} keep (c:cs) = c : keep cs -- in a double-quoted string dquote [] = [] - dquote ('\\':'\"':cs) = dquote cs + dquote ('\\':'\"':cs) = dquote cs -- " dquote ('\\':'\\':cs) = dquote cs - dquote ('\"':cs) = keep cs + dquote ('\"':cs) = keep cs -- " dquote (c:cs) = dquote cs -- in a single-quoted string diff --git a/ghc/compiler/ghci/CompManager.lhs b/ghc/compiler/ghci/CompManager.lhs index d68a7a0..dfc863a 100644 --- a/ghc/compiler/ghci/CompManager.lhs +++ b/ghc/compiler/ghci/CompManager.lhs @@ -4,13 +4,6 @@ \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 @@ -23,40 +16,44 @@ import List ( nub ) import Maybe ( catMaybes, maybeToList, fromMaybe ) import Outputable import FiniteMap ( emptyFM, filterFM, lookupFM, addToFM ) -import Digraph ( SCC(..), stronglyConnComp ) +import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs ) import Panic ( panic ) -import CmStaticInfo ( PCI(..), mkPCI, Package(..) ) -import Finder ( Finder, newFinder, - ModName, ml_modname, isPackageLoc, - PkgName, Path ) -import CmSummarise ( summarise, ModSummary(..), - mi_name, ms_get_imports, - name_of_summary, deps_of_summary ) ---import CmCompile ( PCS, emptyPCS, HST, HIT, CompResult(..), cmCompile ) -import CmLink ( PLS, emptyPLS, Linkable(..), +import CmLink ( PersistentLinkerState, emptyPLS, Linkable(..), link, LinkResult(..), filterModuleLinkables, modname_of_linkable, is_package_linkable ) import InterpSyn ( HValue ) +import CmSummarise ( summarise, ModSummary(..), + name_of_summary, deps_of_summary, + mimp_name, ms_get_imports ) +import Module ( ModuleName, moduleName, packageOfModule, + isModuleInThisPackage, PackageName ) +import CmStaticInfo ( Package(..), PackageConfigInfo ) +import DriverPipeline ( compile, CompResult(..) ) +import HscTypes ( HomeSymbolTable, HomeIfaceTable, + PersistentCompilerState ) +import HscMain ( initPersistentCompilerState ) +import Finder ( findModule, emptyHomeDirCache ) +\end{code} -cmInit :: String{-temp debugging hack-} - -> [Package] - -> IO CmState -cmInit path raw_package_info - = emptyCmState path raw_package_info + +\begin{code} +cmInit :: PackageConfigInfo -> IO CmState +cmInit raw_package_info + = emptyCmState raw_package_info cmGetExpr :: CmState -> ModHandle -> String -> IO (CmState, Either [SDoc] HValue) cmGetExpr cmstate modhdl expr - = return (error "cmGetExpr:unimp") + = return (panic "cmGetExpr:unimp") cmRunExpr :: HValue -> IO () cmRunExpr hval - = return (error "cmRunExpr:unimp") + = return (panic "cmRunExpr:unimp") type ModHandle = String -- ToDo: do better? @@ -65,16 +62,16 @@ type ModHandle = String -- ToDo: do better? data PersistentCMState = PersistentCMState { hst :: HomeSymbolTable, -- home symbol table - hit :: HomeIfaceTable, -- home interface table - ui :: UnlinkedImages, -- the unlinked images - mg :: ModuleGraph -- the module graph + hit :: HomeIfaceTable, -- home interface table + ui :: UnlinkedImage, -- the unlinked images + mg :: ModuleGraph, -- the module graph + pci :: PackageConfigInfo -- NEVER CHANGES } -emptyPCMS :: PersistentCMState -emptyPCMS = PersistentCMState - { hmm = emptyHMM, - hst = emptyHST, hit = emptyHIT, - ui = emptyUI, mg = emptyMG } +emptyPCMS :: PackageConfigInfo -> PersistentCMState +emptyPCMS pci + = PersistentCMState { hst = emptyHST, hit = emptyHIT, + ui = emptyUI, mg = emptyMG, pci = pci } emptyHIT :: HomeIfaceTable emptyHIT = emptyFM @@ -88,24 +85,17 @@ data CmState = CmState { 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 + pls :: PersistentLinkerState -- link's persistent state } -emptyCmState :: String{-temp debugging hack-} - -> [Package] -> IO CmState -emptyCmState path_TMP_DEBUGGING_HACK raw_package_info - = do let pcms = emptyPCMS - pcs <- emptyPCS +emptyCmState :: PackageConfigInfo -> IO CmState +emptyCmState pci + = do let pcms = emptyPCMS pci + pcs <- initPersistentCompilerState pls <- emptyPLS - pci <- mkPCI raw_package_info - finder <- newFinder path_TMP_DEBUGGING_HACK pci return (CmState { pcms = pcms, pcs = pcs, - pls = pls, - pci = pci, - finder = finder }) + pls = pls }) -- CM internal types type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really) @@ -124,7 +114,7 @@ the system state at the same time. \begin{code} cmLoadModule :: CmState - -> ModName + -> ModuleName -> IO (CmState, Either [SDoc] ModHandle) cmLoadModule cmstate1 modname @@ -136,18 +126,16 @@ cmLoadModule cmstate1 modname 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?! + -- Throw away the old home dir cache + emptyHomeDirCache putStr "cmLoadModule: downsweep begins\n" - mg2unsorted <- downsweep modname finderr + mg2unsorted <- downsweep modname putStrLn (showSDoc (vcat (map ppr mg2unsorted))) let modnames1 = map name_of_summary (flattenSCCs mg1) @@ -168,8 +156,8 @@ cmLoadModule cmstate1 modname let threaded2 = ModThreaded pcs1 hst2 hit2 - (threaded3, sccOKs, newLis, errs, warns) - <- upsweep_sccs finderr threaded2 [] [] [] [] mg2 + (upsweepOK, threaded3, sccOKs, newLis) + <- upsweep_sccs threaded2 [] [] mg2 let ui3 = add_to_ui ui2 newLis let (ModThreaded pcs3 hst3 hit3) = threaded3 @@ -177,37 +165,39 @@ cmLoadModule cmstate1 modname -- Try and do linking in some form, depending on whether the -- upsweep was completely or only partially successful. - if null errs + if upsweepOK 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 + pkg_linkables <- find_pkg_linkables_for (pci (pcms cmstate1)) + 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 let all_to_relink = map AcyclicSCC pkg_linkables ++ sccs_to_relink - linkresult <- link pcii all_to_relink pls1 + linkresult <- link all_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 } + = PersistentCMState + { hst=hst3, hit=hit3, ui=ui3, mg=mg2 } let cmstate3 - = CmState { pcms=pcms3, pcs=pcs3, pls=pls3, - pci=pcii, finder=finderr } - return (cmstate3, Right modname) + = CmState { pcms=pcms3, pcs=pcs3, pls=pls3 } + return (cmstate3, Just modname) else do let mods_to_relink = downwards_closure mg2 (map name_of_summary (flattenSCCs sccOKs)) - let pkg_linkables = find_pkg_linkables_for pcii mg2 mods_to_relink + pkg_linkables <- find_pkg_linkables_for (pci (pcms cmstate1)) + mg2 mods_to_relink let sccs_to_relink = group_uis ui3 mg2 mods_to_relink let all_to_relink = map AcyclicSCC pkg_linkables ++ sccs_to_relink - linkresult <- link pcii all_to_relink pls1 + linkresult <- link all_to_relink pls1 let (hst4, hit4, ui4) = filterTopLevelEnvs (`notElem` mods_to_relink) (hst3,hit3,ui3) @@ -216,11 +206,12 @@ cmLoadModule cmstate1 modname -> panic "cmLoadModule: link failed (2)" LinkOK pls4 -> do let pcms4 - = PCMS { hst=hst4, hit=hit4, ui=ui4, mg=mg2 } + = PersistentCMState + { hst=hst4, hit=hit4, ui=ui4, mg=mg2 } let cmstate4 - = CmState { pcms=pcms4, pcs=pcs3, pls=pls4, - pci=pcii, finder=finderr } - return (cmstate4, Right modname) + = CmState { pcms=pcms4, pcs=pcs3, pls=pls4 } + return (cmstate4, Just 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 @@ -233,46 +224,52 @@ cmLoadModule cmstate1 modname -- 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 :: PackageConfigInfo -> [SCC ModSummary] -> [ModuleName] + -> IO [Linkable] find_pkg_linkables_for pcii mg mods = let mg_summaries = flattenSCCs mg mg_names = map name_of_summary mg_summaries in + -- Assert that the modules for which we seek the required packages + -- are all in the module graph, i.e. are all home modules. if not (all (`elem` mg_names) mods) - then panic "find_packages_for" + then panic "find_pkg_linkables_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 + do let all_imports + = concat + [deps_of_summary summ + | summ <- mg_summaries, name_of_summary summ `elem` mods] + let imports_not_in_home -- imports which must be from packages + = nub (filter (`notElem` mg_names) all_imports) + + -- Figure out the packages directly imported by the home modules + maybe_locs_n_mods <- sequence (mapM findModule imports_not_in_home) + let home_pkgs_needed + = nub (concatMap get_pkg maybe_locs_n_mods) + where get_pkg Nothing = [] + get_pkg (Just (mod, loc)) + = case packageOfModule mod of + Just p -> [p]; _ -> [] + + -- Discover the package dependency graph, and use it to find the + -- transitive closure of all the needed packages + let pkg_depend_graph :: [(PackageName,[PackageName])] + pkg_depend_graph = map (\pkg -> (name pkg, package_deps pkg)) pcii + + let 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. + let needed_graph + = concat + [if srcP `elem` all_pkgs_needed + then [(srcP, srcP, dstsP)] + else [] + | (srcP, dstsP) <- pkg_depend_graph] + tsorted = flattenSCCs (stronglyConnComp needed_graph) + + return (map LP tsorted) simple_transitive_closure :: Eq a => [(a,[a])] -> [a] -> [a] @@ -286,15 +283,15 @@ simple_transitive_closure graph set -- For each module in mods_to_group, extract the relevant linkable --- out of UI, and arrange these linkables in SCCs as defined by modGraph. +-- out of "ui", and arrange these linkables in SCCs as defined by modGraph. -- All this is so that we can pass SCCified Linkable groups to the -- linker. A constraint that should be recorded somewhere is that -- all sccs should either be all-interpreted or all-object, not a mixture. -group_uis :: UI -> [SCC ModSummary] -> [ModName] -> [SCC Linkable] +group_uis :: UnlinkedImage -> [SCC ModSummary] -> [ModuleName] -> [SCC Linkable] group_uis ui modGraph mods_to_group = map extract (cleanup (fishOut modGraph mods_to_group)) where - fishOut :: [SCC ModSummary] -> [ModName] -> [(Bool,[ModName])] + fishOut :: [SCC ModSummary] -> [ModuleName] -> [(Bool,[ModuleName])] fishOut [] unused | null unused = [] | otherwise = panic "group_uis: modnames not in modgraph" @@ -305,7 +302,7 @@ group_uis ui modGraph mods_to_group = case split (`elem` (map name_of_summary mss)) unused of (eq, not_eq) -> (True, eq) : fishOut sccs not_eq - cleanup :: [(Bool,[ModName])] -> [SCC ModName] + cleanup :: [(Bool,[ModuleName])] -> [SCC ModuleName] cleanup [] = [] cleanup ((isRec,names):rest) | null names = cleanup rest @@ -313,7 +310,7 @@ group_uis ui modGraph mods_to_group | not isRec = case names of [name] -> AcyclicSCC name : cleanup rest other -> panic "group_uis(cleanup)" - extract :: SCC ModName -> SCC Linkable + extract :: SCC ModuleName -> SCC Linkable extract (AcyclicSCC nm) = AcyclicSCC (getLi nm) extract (CyclicSCC nms) = CyclicSCC (map getLi nms) @@ -327,11 +324,11 @@ group_uis ui modGraph mods_to_group -- Add the given (LM-form) Linkables to the UI, overwriting previous -- versions if they exist. -add_to_ui :: UI -> [Linkable] -> UI +add_to_ui :: UnlinkedImage -> [Linkable] -> UnlinkedImage add_to_ui ui lis = foldr add1 ui lis where - add1 :: Linkable -> UI -> UI + add1 :: Linkable -> UnlinkedImage -> UnlinkedImage add1 li ui = li : filter (\li2 -> not (for_same_module li li2)) ui @@ -344,17 +341,17 @@ add_to_ui ui lis -- Compute upwards and downwards closures in the (home-) module graph. downwards_closure, - upwards_closure :: [SCC ModSummary] -> [ModName] -> [ModName] + upwards_closure :: [SCC ModSummary] -> [ModuleName] -> [ModuleName] upwards_closure = up_down_closure True downwards_closure = up_down_closure False -up_down_closure :: Bool -> [SCC ModSummary] -> [ModName] -> [ModName] +up_down_closure :: Bool -> [SCC ModSummary] -> [ModuleName] -> [ModuleName] up_down_closure up modGraph roots = let mgFlat = flattenSCCs modGraph nodes = map name_of_summary mgFlat - fwdEdges, backEdges :: [(ModName, [ModName])] + fwdEdges, backEdges :: [(ModuleName, [ModuleName])] -- have an entry for each mod in mgFlat, and do not -- mention edges leading out of the home package fwdEdges @@ -372,101 +369,97 @@ up_down_closure up modGraph roots (if up then backEdges else fwdEdges) (nub roots) + data ModThreaded -- stuff threaded through individual module compilations - = ModThreaded PCS HST HIT + = ModThreaded PersistentCompilerState HomeSymbolTable HomeIfaceTable -- Compile multiple SCCs, stopping as soon as an error appears -upsweep_sccs :: Finder -- the finder - -> ModThreaded -- PCS & HST & HIT +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, + -> IO (Bool{-success?-}, + ModThreaded, [SCC ModSummary], -- SCCs which succeeded - [Linkable], -- new linkables - [SDoc], -- error messages - [SDoc]) -- warnings + [Linkable]) -- new linkables -upsweep_sccs finder threaded sccOKs newLis errs warns [] +upsweep_sccs threaded sccOKs newLis [] = -- No more SCCs to do. - return (threaded, sccOKs, newLis, errs, warns) + return (True, threaded, sccOKs, newLis) -upsweep_sccs finder threaded sccOKs newLis errs warns (scc:sccs) +upsweep_sccs threaded sccOKs newLis (scc:sccs) = -- Start work on a new SCC. - do (threaded2, lisM, errsM, warnsM) - <- upsweep_mods finder threaded (flatten scc) - if null errsM + do (sccOK, threaded2, lisSCC) + <- upsweep_scc threaded (flattenSCC scc) + if sccOK then -- all the modules in the scc were ok -- move on to the next SCC - upsweep_sccs finder threaded2 - (scc:sccOKs) (lisM++newLis) - errs (warnsM++warns) sccs + upsweep_sccs threaded2 + (scc:sccOKs) (lisSCC++newLis) sccs else -- we got a compilation error; give up now - return - (threaded2, sccOKs, - lisM++newLis, errsM++errs, warnsM++warns) + return + (False, threaded2, sccOKs, lisSCC++newLis) + -- Compile multiple modules (one SCC), stopping as soon as an error appears -upsweep_mods :: Finder - -> ModThreaded +upsweep_scc :: ModThreaded -> [ModSummary] - -> IO (ModThreaded, [Linkable], [SDoc], [SDoc]) -upsweep_mods finder threaded [] - = return (threaded, [], [], []) -upsweep_mods finder threaded (mod:mods) - = do (threaded1, maybe_linkable, errsM, warnsM) - <- upsweep_mod finder threaded mod - if null errsM + -> IO (Bool{-success?-}, ModThreaded, [Linkable]) +upsweep_scc threaded [] + = return (True, threaded, []) +upsweep_scc threaded (mod:mods) + = do (moduleOK, threaded1, maybe_linkable) + <- upsweep_mod threaded mod + if moduleOK then -- No errors; get contribs from the rest - do (threaded2, linkables, errsMM, warnsMM) - <- upsweep_mods finder threaded1 mods + do (restOK, threaded2, linkables) + <- upsweep_scc threaded1 mods return - (threaded2, maybeToList maybe_linkable ++ linkables, - errsM++errsMM, warnsM++warnsMM) + (restOK, maybeToList maybe_linkable ++ linkables) else -- Errors; give up _now_ - return (threaded1, [], errsM, warnsM) + return (False, threaded1, []) -- Compile a single module. -upsweep_mod :: Finder - -> ModThreaded +upsweep_mod :: ModThreaded -> ModSummary - -> IO (ModThreaded, Maybe Linkable, [SDoc], [SDoc]) + -> IO (Bool{-success?-}, ModThreaded, Maybe Linkable) -upsweep_mod finder threaded1 summary1 +upsweep_mod 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 + compresult <- compile 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 + CompOK details Nothing pcs2 -> let hst2 = addToFM hst1 mod_name details hit2 = hit1 threaded2 = ModThreaded pcs2 hst2 hit2 - in return (threaded2, Nothing, [], warns) + in return (True, threaded2, Nothing) -- Compilation really did happen, and succeeded. A new -- details, iface and linkable are returned. - CompOK details (Just (new_iface, new_linkable)) pcs2 warns + CompOK details (Just (new_iface, new_linkable)) pcs2 -> 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) + in return (True, threaded2, Just new_linkable) -- Compilation failed. compile may still have updated -- the PCS, tho. - CompErrs pcs2 errs warns + CompErrs pcs2 -> let threaded2 = ModThreaded pcs2 hst1 hit1 - in return (threaded2, Nothing, errs, warns) - -filterTopLevelEnvs :: (ModName -> Bool) -> (HST, HIT, UI) -> (HST, HIT, UI) + in return (False, threaded2, Nothing) + + +filterTopLevelEnvs :: (ModuleName -> Bool) + -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage) + -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage) filterTopLevelEnvs p (hst, hit, ui) = (filterFM (\k v -> p k) hst, filterFM (\k v -> p k) hit, @@ -476,11 +469,11 @@ filterTopLevelEnvs p (hst, hit, ui) topological_sort :: [ModSummary] -> [SCC ModSummary] topological_sort summaries = let - toEdge :: ModSummary -> (ModSummary,ModName,[ModName]) + toEdge :: ModSummary -> (ModSummary,ModuleName,[ModuleName]) toEdge summ = (summ, name_of_summary summ, deps_of_summary summ) - mash_edge :: (ModSummary,ModName,[ModName]) -> (ModSummary,Int,[Int]) + mash_edge :: (ModSummary,ModuleName,[ModuleName]) -> (ModSummary,Int,[Int]) mash_edge (summ, m, m_imports) = case lookup m key_map of Nothing -> panic "reverse_topological_sort" @@ -489,22 +482,21 @@ topological_sort summaries catMaybes (map (flip lookup key_map) m_imports)) edges = map toEdge summaries - key_map = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModName,Int)] + key_map = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModuleName,Int)] scc_input = map mash_edge edges sccs = stronglyConnComp scc_input in sccs -downsweep :: ModName -- module to chase from - -> Finder +downsweep :: ModuleName -- module to chase from -> IO [ModSummary] -downsweep rootNm finder +downsweep rootNm = do rootLoc <- getSummary rootNm loop [rootLoc] where - getSummary :: ModName -> IO ModSummary + getSummary :: ModuleName -> IO ModSummary getSummary nm - = do found <- finder nm + = do found <- findModule nm case found of Just (mod, location) -> summarise mod location Nothing -> panic ("CompManager: can't find module `" ++ @@ -513,19 +505,19 @@ downsweep rootNm finder -- loop invariant: homeSummaries doesn't contain package modules loop :: [ModSummary] -> IO [ModSummary] loop homeSummaries - = do let allImps -- all imports - = (nub . map mi_name . concat . map ms_get_imports) + = do let allImps :: [ModuleName] + allImps -- all imports + = (nub . map mimp_name . concat . map ms_get_imports) homeSummaries let allHome -- all modules currently in homeSummaries - = map (ml_modname.ms_loc) homeSummaries + = map (moduleName.ms_mod) homeSummaries let neededImps = filter (`notElem` allHome) allImps neededSummaries <- mapM getSummary neededImps let newHomeSummaries - = filter (not.isPackageLoc.ms_loc) neededSummaries + = filter (isModuleInThisPackage.ms_mod) neededSummaries if null newHomeSummaries then return homeSummaries else loop (newHomeSummaries ++ homeSummaries) -#endif \end{code} diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 555afc5..4f06e11 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPipeline.hs,v 1.14 2000/10/31 13:01:46 sewardj Exp $ +-- $Id: DriverPipeline.hs,v 1.15 2000/11/02 13:58:45 sewardj Exp $ -- -- GHC Driver -- @@ -14,10 +14,10 @@ module DriverPipeline ( genPipeline, runPipeline, -- interfaces for the compilation manager (interpreted/batch-mode) - preprocess, compile, + preprocess, compile, CompResult(..), -- batch-mode linking interface - doLink, + doLink ) where #include "HsVersions.h" diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index e985ac0..732047b 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -6,7 +6,8 @@ \begin{code} module Finder ( initFinder, -- :: PackageConfigInfo -> IO (), - findModule -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) + findModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) + emptyHomeDirCache -- :: IO () ) where #include "HsVersions.h" @@ -18,6 +19,7 @@ import DriverState import Module import FiniteMap import Util +import Panic ( panic ) import IOExts import Directory @@ -35,11 +37,12 @@ source, interface, and object files for a module live. \begin{code} -- v_PkgDirCache caches contents of package directories, never expunged -GLOBAL_VAR(v_PkgDirCache, error "no pkg cache!", FiniteMap String (PackageName, FilePath)) +GLOBAL_VAR(v_PkgDirCache, panic "no pkg cache!", + FiniteMap String (PackageName, FilePath)) -- v_HomeDirCache caches contents of home directories, -- expunged whenever we create a new finder. -GLOBAL_VAR(v_HomeDirCache, Nothing, Maybe (FiniteMap String FilePath)) +GLOBAL_VAR(v_HomeDirCache, Nothing, Maybe (FiniteMap String FilePath)) initFinder :: PackageConfigInfo -> IO () @@ -54,6 +57,10 @@ initFinder pkgs -- ; putStrLn (unlines (map show (fmToList pkg_dbg_info))) } +emptyHomeDirCache :: IO () +emptyHomeDirCache + = writeIORef v_HomeDirCache Nothing + findModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) findModule name = do { hPutStr stderr ("findModule: " ++ moduleNameUserString name ++ " ... ") @@ -69,7 +76,7 @@ findModule_wrk name = do { j <- maybeHomeModule name ; case j of Just home_module -> return (Just home_module) - Nothing -> maybePackageModule name + Nothing -> maybePackageModule name } maybeHomeModule :: ModuleName -> IO (Maybe (Module, ModuleLocation))