From: sewardj Date: Tue, 10 Oct 2000 12:20:46 +0000 (+0000) Subject: [project @ 2000-10-10 12:20:46 by sewardj] X-Git-Tag: Approximately_9120_patches~3657 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=fbadd1f6659fc2878eb46ad8bd6c25a4b173c3a0;p=ghc-hetmet.git [project @ 2000-10-10 12:20:46 by sewardj] * Get more of the compilation manager working, using a dummy compiler and linker. * When linking, figure out the set of packages which need to be linked. * Redo package config plumbing to support the above. Some stuff has moved from CmFind to CmStaticInfo. * Get rid of FLAGS entirely. --- diff --git a/ghc/compiler/ghci/CmCompile.lhs b/ghc/compiler/ghci/CmCompile.lhs index cbfecf0..f02b959 100644 --- a/ghc/compiler/ghci/CmCompile.lhs +++ b/ghc/compiler/ghci/CmCompile.lhs @@ -16,11 +16,10 @@ where #include "HsVersions.h" -import CmLink ( Linkable ) +import CmLink ( Linkable(..) ) import Outputable ( SDoc ) import CmFind ( Finder ) -import CmSummarise ( ModSummary ) -import CmStaticInfo ( SI ) +import CmSummarise ( ModSummary, name_of_summary ) import FiniteMap ( FiniteMap, emptyFM ) import Module ( Module ) @@ -38,17 +37,24 @@ import RdrHsSyn ( RdrNameDeprecation, RdrNameRuleDecl, RdrNameFixitySig, \end{code} \begin{code} -cmCompile :: SI -- obvious - -> Finder -- to find modules +cmCompile :: Finder -- to find modules -> ModSummary -- summary, including source -> Maybe ModIFace -- old interface, if available -> HST -- for home module ModDetails -> PCS -- IN: persistent compiler state -> IO CompResult -cmCompile flags finder summary old_iface hst pcs - = return (error "cmCompile:unimp") - +cmCompile finder summary old_iface hst pcs + = do putStrLn ("cmCompile: compiling " ++ name_of_summary summary) + return (CompOK (error "cmCompile:modDetails") + (Just (error "cmCompile:modIFace", + --error "cmCompile:Linkable" + --LM (name_of_summary summary) [] + LM (name_of_summary summary) [] + )) + pcs + [] + ) data CompResult = CompOK ModDetails -- new details (HST additions) @@ -59,7 +65,8 @@ data CompResult [SDoc] -- warnings | CompErrs PCS -- updated PCS - [SDoc] -- warnings and errors + [SDoc] -- errors + [SDoc] -- warnings emptyPCS :: IO PCS emptyPCS = return (MkPCS emptyPIT emptyPST emptyHoldingPen) diff --git a/ghc/compiler/ghci/CmFind.lhs b/ghc/compiler/ghci/CmFind.lhs index c3d94eb..96f0aff 100644 --- a/ghc/compiler/ghci/CmFind.lhs +++ b/ghc/compiler/ghci/CmFind.lhs @@ -14,27 +14,31 @@ where import IO ( hPutStr, stderr ) import List ( maximumBy ) import Maybe ( catMaybes ) -import Char ( isUpper ) -import List ( nub ) import Time ( ClockTime ) -import Directory ( doesFileExist, getModificationTime, - getDirectoryContents) +import Directory ( doesFileExist, getModificationTime ) +import Outputable import Module ( Module ) -import CmStaticInfo ( PCI, Package(..) ) +import CmStaticInfo ( PCI(..), Package(..), Path, ModName, PkgName ) \end{code} \begin{code} -type Path = String -type ModName = String -type PkgName = String - data ModLocation = SourceOnly ModName Path -- .hs | ObjectCode ModName Path Path -- .o, .hi | InPackage ModName PkgName | NotFound - deriving Show + +instance Outputable ModLocation where + ppr (SourceOnly nm path_hs) + = hsep [text "SourceOnly", text (show nm), text (show path_hs)] + ppr (ObjectCode nm path_o path_hi) + = hsep [text "ObjectCode", text (show nm), + text (show path_o), text (show path_hi)] + ppr (InPackage nm pkgname) + = hsep [text "InPackage", text (show nm), text (show pkgname)] + + type Finder = ModName -> IO ModLocation @@ -49,7 +53,7 @@ mkFinder :: [(ModName,PkgName,Path)] -> [Path] -> Finder mkFinder pkg_ifaces home_dirs modnm = do found <- mkFinderX pkg_ifaces home_dirs modnm putStrLn ("FINDER: request = " ++ modnm ++ "\n" ++ - "FINDER: response = " ++ show found) + "FINDER: response = " ++ showSDoc (ppr found)) return found @@ -117,35 +121,9 @@ homeModuleExists modname path -newFinder :: PCI -> IO Finder -newFinder pci - -- PCI is a list of packages and their names - = do - -- the list of directories where package interfaces are - let p_i_dirs :: [(PkgName,Path)] - p_i_dirs = concatMap nm_and_paths pci - - -- interface names in each directory - ifacess <- mapM ifaces_in_dir p_i_dirs - let ifaces :: [(ModName,PkgName,Path)] - ifaces = concat ifacess - - -- ToDo: allow a range of home package directories - return (mkFinder ifaces ["."]) - where - nm_and_paths :: Package -> [(PkgName,Path)] - nm_and_paths package - = [(name package, path) | path <- nub (import_dirs package)] - - ifaces_in_dir :: (PkgName,Path) -> IO [(ModName,PkgName,Path)] - ifaces_in_dir (pkgname,path) - = getDirectoryContents path >>= \ entries -> - return [(zap_hi if_nm, pkgname, path) - | if_nm <- entries, looks_like_iface_name if_nm] - looks_like_iface_name e - = not (null e) && isUpper (head e) - && take 3 (reverse e) == "ih." - zap_hi - = reverse . drop 3 . reverse +newFinder :: String{-temp debugging hack-} + -> PCI -> IO Finder +newFinder path pci + = return (mkFinder (module_table pci) [path]) \end{code} diff --git a/ghc/compiler/ghci/CmLink.lhs b/ghc/compiler/ghci/CmLink.lhs index 1a41571..6445663 100644 --- a/ghc/compiler/ghci/CmLink.lhs +++ b/ghc/compiler/ghci/CmLink.lhs @@ -17,12 +17,12 @@ import Linker import CmStaticInfo ( PCI ) import CmFind ( Path, PkgName ) -import InterpSyn ( UnlinkedIBind, HValue ) +import InterpSyn ( UnlinkedIBind, HValue, binder ) import Module ( Module ) import Outputable ( SDoc ) import FiniteMap ( FiniteMap, emptyFM ) import RdrName ( RdrName ) -import Digraph ( SCC ) +import Digraph ( SCC(..) ) import Addr ( Addr ) import Outputable import Panic ( panic ) @@ -49,6 +49,13 @@ data Unlinked | DotDLL Path | Trees [UnlinkedIBind] -- bunch of interpretable bindings +instance Outputable Unlinked where + ppr (DotO path) = text "DotO" <+> text path + ppr (DotA path) = text "DotA" <+> text path + ppr (DotDLL path) = text "DotDLL" <+> text path + ppr (Trees binds) = text "Trees" <+> ppr (map binder binds) + + isObject (DotO _) = True isObject (DotA _) = True isObject (DotDLL _) = True @@ -61,6 +68,10 @@ data Linkable = LM {-should be:Module-} String{- == ModName-} [Unlinked] | LP PkgName +instance Outputable Linkable where + ppr (LM mod_nm unlinkeds) = text "LinkableM" <+> text mod_nm <+> ppr unlinkeds + ppr (LP package_nm) = text "LinkableP" <+> text package_nm + emptyPLS :: IO PLS emptyPLS = return (MkPLS { closure_env = emptyFM, itbl_env = emptyFM }) @@ -70,7 +81,18 @@ emptyPLS = return (MkPLS { closure_env = emptyFM, link :: PCI -> [SCC Linkable] -> PLS -> IO LinkResult #ifndef GHCI_NOTYET -link = panic "CmLink.link: not implemented" +--link = panic "CmLink.link: not implemented" +link pci groups pls1 + = do putStrLn "Hello from the Linker!" + putStrLn (showSDoc (vcat (map ppLinkableSCC groups))) + putStrLn "Bye-bye from the Linker!" + return (LinkOK pls1) + +ppLinkableSCC :: SCC Linkable -> SDoc +ppLinkableSCC (CyclicSCC xs) = ppr xs +ppLinkableSCC (AcyclicSCC x) = ppr [x] + + #else link pci [] pls = return (LinkOK pls) link pci (group:groups) pls = do diff --git a/ghc/compiler/ghci/CmStaticInfo.lhs b/ghc/compiler/ghci/CmStaticInfo.lhs index db73aa7..90fdb5b 100644 --- a/ghc/compiler/ghci/CmStaticInfo.lhs +++ b/ghc/compiler/ghci/CmStaticInfo.lhs @@ -4,18 +4,28 @@ \section[CmStaticInfo]{Session-static info for the Compilation Manager} \begin{code} -module CmStaticInfo ( FLAGS, Package(..), PCI, - mkSI, SI(..) - ) +module CmStaticInfo ( Path, ModName, PkgName, + Package(..), PCI(..), mkPCI ) where #include "HsVersions.h" +import List ( nub ) +import Char ( isUpper ) +import Directory ( getDirectoryContents ) \end{code} \begin{code} -type FLAGS = [String] -- or some such fiction -type PCI = [Package] +type Path = String +type ModName = String +type PkgName = String + +data PCI + = PCI { + raw_package_info :: [Package], -- contents of packages.conf + module_table :: [(ModName, PkgName, Path)] + -- maps each available module to pkg and path + } -- copied from the driver data Package @@ -32,13 +42,42 @@ data Package extra_cc_opts :: [String], extra_ld_opts :: [String] } - deriving (Read, Show) + deriving Read + +mkPCI :: [Package] -> IO PCI +mkPCI raw_package_info + = do mtab <- mk_module_table raw_package_info + return (PCI { raw_package_info = raw_package_info, + module_table = mtab }) +mk_module_table :: [Package] -> IO [(ModName,PkgName,Path)] +mk_module_table raw_info + = do + -- the list of directories where package interfaces are + let p_i_dirs :: [(PkgName,Path)] + p_i_dirs = concatMap nm_and_paths raw_info -data SI = SI { flags :: FLAGS, pci :: PCI } + -- interface names in each directory + ifacess <- mapM ifaces_in_dir p_i_dirs + let iface_table :: [(ModName,PkgName,Path)] + iface_table = concat ifacess -mkSI :: FLAGS -> PCI -> SI -mkSI flags pci = SI { flags = flags, pci = pci } + -- ToDo: allow a range of home package directories + return iface_table + where + nm_and_paths :: Package -> [(PkgName,Path)] + nm_and_paths package + = [(name package, path) | path <- nub (import_dirs package)] + ifaces_in_dir :: (PkgName,Path) -> IO [(ModName,PkgName,Path)] + ifaces_in_dir (pkgname,path) + = getDirectoryContents path >>= \ entries -> + return [(zap_hi if_nm, pkgname, path) + | if_nm <- entries, looks_like_iface_name if_nm] + looks_like_iface_name e + = not (null e) && isUpper (head e) + && take 3 (reverse e) == "ih." + zap_hi + = reverse . drop 3 . reverse \end{code} diff --git a/ghc/compiler/ghci/CmSummarise.lhs b/ghc/compiler/ghci/CmSummarise.lhs index 524090f..3fd4a20 100644 --- a/ghc/compiler/ghci/CmSummarise.lhs +++ b/ghc/compiler/ghci/CmSummarise.lhs @@ -5,7 +5,8 @@ \begin{code} module CmSummarise ( ModImport(..), mi_name, - ModSummary(..), summarise, ms_get_imports ) + ModSummary(..), summarise, ms_get_imports, + name_of_summary, deps_of_summary ) where #include "HsVersions.h" @@ -13,28 +14,59 @@ where import List ( nub ) import Char ( ord, isAlphaNum ) -import CmFind ( ModName, ModLocation(..) ) -import Outputable ( pprPanic, text ) +import CmFind ( ModName, ModLocation(..), ml_modname ) +import Outputable \end{code} \begin{code} +-- The ModLocation contains the original source filename of the module. +-- The ms_ppsource field contains another filename, which is intended to +-- be the cleaned-up source file after all preprocessing has happened to +-- it. The point is that the summariser will have to cpp/unlit/whatever +-- all files anyway, and there's no point in doing this twice -- just +-- park the result in a temp file, put the name of it in ms_ppsource, +-- and let @compile@ read from that file on the way back up. data ModSummary = ModSummary { - ms_loc :: ModLocation, -- location and kind - ms_source :: (Maybe (String, Fingerprint)), -- source and sig if .hs - ms_imports :: (Maybe [ModImport]) -- imports if .hs or .hi + ms_loc :: ModLocation, -- location and kind + ms_ppsource :: (Maybe (FilePath, Fingerprint)), -- preprocessed and sig if .hs + ms_imports :: (Maybe [ModImport]) -- imports if .hs or .hi } - deriving Show + +instance Outputable ModSummary where + ppr ms + = sep [text "ModSummary {", + nest 3 (sep [text "ms_loc =" <+> ppr (ms_loc 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 ModName | MISource ModName - deriving (Eq, Show) + deriving Eq + +instance Outputable ModImport where + ppr (MINormal nm) = text nm + ppr (MISource nm) = text "{-# SOURCE #-}" <+> text nm + mi_name (MINormal nm) = nm mi_name (MISource nm) = nm +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 + ms_get_imports :: ModSummary -> [ModImport] ms_get_imports summ = case ms_imports summ of { Just is -> is; Nothing -> [] } @@ -51,25 +83,26 @@ summarise loc -> readFile path >>= \ modsrc -> let imps = getImports modsrc fp = fingerprint modsrc - in return (ModSummary loc (Just (modsrc,fp)) (Just imps)) + in return (ModSummary loc (Just (path,fp)) (Just imps)) ObjectCode mod oPath hiPath -- can we get away with the src summariser -- for interface files? -> readFile hiPath >>= \ hisrc -> let imps = getImports hisrc in return (ModSummary loc Nothing (Just imps)) NotFound - -> pprPanic "summarise:NotFound" (text (show loc)) + -> pprPanic "summarise:NotFound" (ppr loc) fingerprint :: String -> Int fingerprint s - = dofp s 3 3 + = dofp s 3# 3# where -- Copied from hash() in Hugs' storage.c. - dofp :: String -> Int -> Int -> Int - dofp [] m fp = fp - dofp (c:cs) m fp = dofp cs (m+1) (iabs (fp + m * ord c)) - iabs :: Int -> Int - iabs n = if n < 0 then -n else n + dofp :: String -> Int# -> Int# -> Int + dofp [] m fp = I# fp + dofp (c:cs) m fp = dofp cs (m +# 1#) (iabs (fp +# m *# unbox (ord c))) + unbox (I# i) = i + iabs :: Int# -> Int# + iabs n = if n <# 0# then 0# -# n else n \end{code} Collect up the imports from a Haskell source module. This is diff --git a/ghc/compiler/ghci/CompManager.lhs b/ghc/compiler/ghci/CompManager.lhs index f78d037..775abc0 100644 --- a/ghc/compiler/ghci/CompManager.lhs +++ b/ghc/compiler/ghci/CompManager.lhs @@ -13,29 +13,32 @@ where #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 CmStaticInfo ( PCI(..), mkPCI, Package(..) ) import CmFind ( Finder, newFinder, - ModName, ml_modname, isPackageLoc ) + 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 @@ -80,21 +83,22 @@ data 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 + pci :: PCI, -- 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 @@ -120,36 +124,37 @@ cmLoadModule :: CmState 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. 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. @@ -157,7 +162,7 @@ cmLoadModule cmstate1 modname 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 @@ -170,8 +175,13 @@ cmLoadModule cmstate1 modname 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)" @@ -180,16 +190,17 @@ cmLoadModule cmstate1 modname = 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) @@ -201,14 +212,74 @@ cmLoadModule cmstate1 modname = 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 + + +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 -flattenMG :: [SCC ModSummary] -> [ModSummary] -flattenMG = concatMap flatten + +flattenSCCs :: [SCC a] -> [a] +flattenSCCs = concatMap flatten flatten (AcyclicSCC v) = [v] flatten (CyclicSCC vs) = vs @@ -256,7 +327,7 @@ 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 ui lis +add_to_ui ui lis = foldr add1 ui lis where add1 :: Linkable -> UI -> UI @@ -279,7 +350,7 @@ downwards_closure = up_down_closure False 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])] @@ -291,29 +362,21 @@ up_down_closure up modGraph roots = [(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 @@ -326,18 +389,19 @@ upsweep_sccs :: ModThreaded -- PCS & HST & HIT [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 @@ -345,17 +409,19 @@ upsweep_sccs threaded sccOKs newLis errs warns (scc:sccs) 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) @@ -363,13 +429,41 @@ upsweep_mods threaded (mod:mods) 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) @@ -378,12 +472,6 @@ 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 diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index d20cca3..3c33eaa 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -46,16 +46,39 @@ import BSD import IOExts ( unsafePerformIO ) import NativeInfo ( os, arch ) #endif -import StgInterp ( runStgI ) #ifdef GHCI +import StgInterp ( runStgI ) +import CmStaticInfo ( Package(..) ) -- ToDo: maybe zap this? +import CompManager +import System ( getArgs ) -- tmp debugging hack; to be rm'd import Linker ( linkPrelude ) #endif \end{code} \begin{code} +#ifdef GHCI +fptools = "/home/v-julsew/GHCI/fpt" +main = stderr `seq` ghci_main + +ghci_main :: IO () +ghci_main + = do putStr "GHCI main\n" + args <- getArgs + if length args /= 2 + then + do putStrLn "usage: ghci ModuleName" + else + do pci_txt <- readFile (fptools ++ "/ghc/driver/package.conf.inplace") + let raw_package_info = read pci_txt :: [Package] + cmstate <- emptyCmState (args!!0) raw_package_info + junk <- cmLoadModule cmstate (args!!1) + return () + +#else main = stderr `seq` -- Bug fix. Sigh -- _scc_ "main" doIt classifyOpts +#endif \end{code} \begin{code} @@ -90,7 +113,7 @@ doIt (core_cmds, stg_cmds) hPutStr stderr "\n") >> #ifdef GHCI - linkPrelude >> +-- linkPrelude >> #endif -------------------------- Reader ---------------- @@ -224,7 +247,7 @@ doIt (core_cmds, stg_cmds) -------------------------- Final report ------------------------------- reportCompile mod_name (showSDoc (ppSourceStats True rdr_module)) >> -#endif +#endif /* GHCI */ ghcExit 0