\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"
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 -> [] }
-> 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
#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
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
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.
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
+
+
+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
-- 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
projects / ghc-hetmet.git / commitdiff