cmDepAnal, -- :: CmState -> DynFlags -> [FilePath] -> IO ModuleGraph
cmLoadModules, -- :: CmState -> DynFlags -> ModuleGraph
- -- -> IO (CmState, [String])
+ -- -> IO (CmState, Bool, [String])
cmUnload, -- :: CmState -> DynFlags -> IO CmState
#include "HsVersions.h"
-import MkIface --tmp
-import HsSyn -- tmp
-
import CmLink
import CmTypes
import DriverPipeline
#else
import HscMain ( initPersistentCompilerState )
#endif
-import HscTypes
+import HscTypes hiding ( moduleNameToModule )
import Name ( Name, NamedThing(..), nameRdrName, nameModule,
- isHomePackageName, isGlobalName )
+ isHomePackageName, isExternalName )
import NameEnv
+import PrelNames ( gHC_PRIM_Name )
import Rename ( mkGlobalContext )
import RdrName ( emptyRdrEnv )
import Module
import Outputable
import Panic
import CmdLineOpts ( DynFlags(..), getDynFlags )
+import Maybes ( expectJust )
import IOExts
getFixity :: PersistentCompilerState -> Name -> Fixity
getFixity pcs name
- | isGlobalName name,
+ | isExternalName name,
Just iface <- lookupModuleEnv iface_table (nameModule name),
Just fixity <- lookupNameEnv (mi_fixities iface) name
= fixity
-- Sort out which linkables we wish to keep in the unlinked image.
-- See getValidLinkables below for details.
(valid_old_linkables, new_linkables)
- <- getValidLinkables ui1 mg2unsorted_names mg2_with_srcimps
+ <- getValidLinkables ghci_mode ui1
+ mg2unsorted_names mg2_with_srcimps
-- putStrLn (showSDoc (vcat [ppr valid_old_linkables, ppr new_linkables]))
-- clean up between compilations
let cleanup = cleanTempFilesExcept verb
- (ppFilesFromSummaries (flattenSCCs upsweep_these))
+ (ppFilesFromSummaries (flattenSCCs mg2))
(upsweep_complete_success, threaded3, modsUpswept, newLis)
<- upsweep_mods ghci_mode dflags valid_linkables reachable_from
-----------------------------------------------------------------------------
--- getValidLin
+-- getValidLinkables
-- For each module (or SCC of modules), we take:
--
--
-- - the old linkable, otherwise (and if one is available).
--
--- and we throw away the linkable if it is older than the source
--- file. We ignore the on-disk linkables unless all of the dependents
--- of this SCC also have on-disk linkables.
+-- and we throw away the linkable if it is older than the source file.
+-- In interactive mode, we also ignore the on-disk linkables unless
+-- all of the dependents of this SCC also have on-disk linkables (we
+-- can't have dynamically loaded objects that depend on interpreted
+-- modules in GHCi).
--
-- If a module has a valid linkable, then it may be STABLE (see below),
-- and it is classified as SOURCE UNCHANGED for the purposes of calling
-- ToDo: this pass could be merged with the preUpsweep.
getValidLinkables
- :: [Linkable] -- old linkables
+ :: GhciMode
+ -> [Linkable] -- old linkables
-> [ModuleName] -- all home modules
-> [SCC ModSummary] -- all modules in the program, dependency order
-> IO ( [Linkable], -- still-valid linkables
[Linkable] -- new linkables we just found
)
-getValidLinkables old_linkables all_home_mods module_graph = do
- ls <- foldM (getValidLinkablesSCC old_linkables all_home_mods)
+getValidLinkables mode old_linkables all_home_mods module_graph = do
+ ls <- foldM (getValidLinkablesSCC mode old_linkables all_home_mods)
[] module_graph
return (partition_it ls [] [])
where
| otherwise = partition_it ls (l:valid) new
-getValidLinkablesSCC old_linkables all_home_mods new_linkables scc0
+getValidLinkablesSCC mode old_linkables all_home_mods new_linkables scc0
= let
scc = flattenSCC scc0
scc_names = map modSummaryName scc
Nothing -> False
Just l -> isObjectLinkable l
- objects_allowed = all has_object scc_allhomeimps
+ objects_allowed = mode == Batch || all has_object scc_allhomeimps
in do
new_linkables'
done `elem` names_in_this_cycle])
chewed_rest = chew rest
in
- if not (null mods_in_this_cycle)
+ if notNull mods_in_this_cycle
&& length mods_in_this_cycle < length names_in_this_cycle
then mods_in_this_cycle ++ chewed_rest
else chewed_rest
retainInTopLevelEnvs reachable_only (hst1,hit1,[])
old_linkable
- = unJust "upsweep_mod:old_linkable" maybe_old_linkable
+ = expectJust "upsweep_mod:old_linkable" maybe_old_linkable
have_object
| Just l <- maybe_old_linkable, isObjectLinkable l = True
downsweep :: [FilePath] -> [ModSummary] -> IO [ModSummary]
downsweep roots old_summaries
= do rootSummaries <- mapM getRootSummary roots
+ checkDuplicates rootSummaries
all_summaries
- <- loop (concat (map ms_imps rootSummaries))
+ <- loop (concat (map (\ m -> zip (repeat (fromMaybe "<unknown>" (ml_hs_file (ms_location m))))
+ (ms_imps m)) rootSummaries))
(mkModuleEnv [ (mod, s) | s <- rootSummaries,
let mod = ms_mod s, isHomeModule mod
])
exists <- doesFileExist lhs_file
if exists then summariseFile lhs_file else do
let mod_name = mkModuleName file
- maybe_summary <- getSummary mod_name
+ maybe_summary <- getSummary (file, mod_name)
case maybe_summary of
Nothing -> packageModErr mod_name
Just s -> return s
hs_file = file ++ ".hs"
lhs_file = file ++ ".lhs"
- getSummary :: ModuleName -> IO (Maybe ModSummary)
- getSummary nm
+ -- In a root module, the filename is allowed to diverge from the module
+ -- name, so we have to check that there aren't multiple root files
+ -- defining the same module (otherwise the duplicates will be silently
+ -- ignored, leading to confusing behaviour).
+ checkDuplicates :: [ModSummary] -> IO ()
+ checkDuplicates summaries = mapM_ check summaries
+ where check summ =
+ case dups of
+ [] -> return ()
+ files -> multiRootsErr modl files
+ where modl = ms_mod summ
+ dups =
+ [ fromJust (ml_hs_file (ms_location summ'))
+ | summ' <- summaries, ms_mod summ' == modl ]
+
+ getSummary :: (FilePath,ModuleName) -> IO (Maybe ModSummary)
+ getSummary (currentMod,nm)
= do found <- findModule nm
case found of
Just (mod, location) -> do
let old_summary = findModInSummaries old_summaries mod
summarise mod location old_summary
- Nothing -> throwDyn (CmdLineError
+ Nothing ->
+ throwDyn (CmdLineError
("can't find module `"
- ++ showSDoc (ppr nm) ++ "'"))
+ ++ showSDoc (ppr nm) ++ "' (while processing "
+ ++ show currentMod ++ ")"))
-- loop invariant: env doesn't contain package modules
- loop :: [ModuleName] -> ModuleEnv ModSummary -> IO [ModSummary]
+ loop :: [(FilePath,ModuleName)] -> ModuleEnv ModSummary -> IO [ModSummary]
loop [] env = return (moduleEnvElts env)
loop imps env
= do -- imports for modules we don't already have
- let needed_imps = nub (filter (not . (`elemUFM` env)) imps)
+ let needed_imps = nub (filter (not . (`elemUFM` env).snd) imps)
-- summarise them
needed_summaries <- mapM getSummary needed_imps
let new_home_summaries = [ s | Just s <- needed_summaries ]
-- loop, checking the new imports
- let new_imps = concat (map ms_imps new_home_summaries)
+ let new_imps = concat (map (\ m -> zip (repeat (fromMaybe "<unknown>" (ml_hs_file (ms_location m))))
+ (ms_imps m)) new_home_summaries)
loop new_imps (extendModuleEnvList env
[ (ms_mod s, s) | s <- new_home_summaries ])
(srcimps,imps,mod_name) <- getImportsFromFile hspp_fn
let (path, basename, _ext) = splitFilename3 file
+ -- GHC.Prim doesn't exist physically, so don't go looking for it.
+ the_imps = filter (/= gHC_PRIM_Name) imps
(mod, location)
<- mkHomeModuleLocn mod_name (path ++ '/':basename) file
return (ModSummary mod
location{ml_hspp_file=Just hspp_fn}
- srcimps imps src_timestamp)
+ srcimps the_imps src_timestamp)
-- Summarise a module, and pick up source and timestamp.
summarise :: Module -> ModuleLocation -> Maybe ModSummary
summarise mod location old_summary
| not (isHomeModule mod) = return Nothing
| otherwise
- = do let hs_fn = unJust "summarise" (ml_hs_file location)
+ = do let hs_fn = expectJust "summarise" (ml_hs_file location)
case ml_hs_file location of {
Nothing -> noHsFileErr mod;
hspp_fn <- preprocess hs_fn
(srcimps,imps,mod_name) <- getImportsFromFile hspp_fn
+ let
+ -- GHC.Prim doesn't exist physically, so don't go looking for it.
+ the_imps = filter (/= gHC_PRIM_Name) imps
when (mod_name /= moduleName mod) $
throwDyn (ProgramError
<+> quotes (ppr (moduleName mod)))))
return (Just (ModSummary mod location{ml_hspp_file=Just hspp_fn}
- srcimps imps src_timestamp))
+ srcimps the_imps src_timestamp))
}
}
= throwDyn (CmdLineError (showSDoc (text "module" <+>
quotes (ppr mod) <+>
text "is a package module")))
+
+multiRootsErr mod files
+ = throwDyn (ProgramError (showSDoc (
+ text "module" <+> quotes (ppr mod) <+>
+ text "is defined in multiple files:" <+>
+ sep (map text files))))
\end{code}
projects / ghc-hetmet.git / blobdiff