X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcompMan%2FCompManager.lhs;h=dbf82f1531487fad0e42552b44684a4330fb0ad0;hb=5e392a5623fe7f896389f1b7c3fb3f340bea46a8;hp=1e5fdd69e25c5fce228567952db0ac2ee8bdd27b;hpb=db50cb717e4f876cd3a720d66f3ab8a3347dc27f;p=ghc-hetmet.git diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 1e5fdd6..dbf82f1 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -15,7 +15,7 @@ module CompManager ( cmDepAnal, -- :: CmState -> DynFlags -> [FilePath] -> IO ModuleGraph cmLoadModules, -- :: CmState -> DynFlags -> ModuleGraph - -- -> IO (CmState, [String]) + -- -> IO (CmState, Bool, [String]) cmUnload, -- :: CmState -> DynFlags -> IO CmState @@ -57,9 +57,6 @@ where #include "HsVersions.h" -import MkIface --tmp -import HsSyn -- tmp - import CmLink import CmTypes import DriverPipeline @@ -73,10 +70,11 @@ import HscMain ( initPersistentCompilerState, hscThing, #else import HscMain ( initPersistentCompilerState ) #endif -import HscTypes +import HscTypes hiding ( moduleNameToModule ) import Name ( Name, NamedThing(..), nameRdrName, nameModule, isHomePackageName, isExternalName ) import NameEnv +import PrelNames ( gHC_PRIM_Name ) import Rename ( mkGlobalContext ) import RdrName ( emptyRdrEnv ) import Module @@ -90,8 +88,9 @@ import Util import Outputable import Panic import CmdLineOpts ( DynFlags(..), getDynFlags ) +import Maybes ( expectJust ) -import IOExts +import DATA_IOREF ( readIORef ) #ifdef GHCI import RdrName ( lookupRdrEnv ) @@ -101,14 +100,12 @@ import VarEnv ( emptyTidyEnv ) import BasicTypes ( Fixity, defaultFixity ) import Interpreter ( HValue ) import HscMain ( hscStmt ) -import GlaExts ( unsafeCoerce# ) +import GHC.Exts ( unsafeCoerce# ) import Foreign -import CForeign -import Exception ( Exception, try ) +import Control.Exception as Exception ( Exception, try ) #endif --- lang -import Exception ( throwDyn ) +import EXCEPTION ( throwDyn ) -- std import Directory ( getModificationTime, doesFileExist ) @@ -608,7 +605,7 @@ cmLoadModules cmstate1 dflags mg2unsorted -- 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 @@ -933,7 +930,7 @@ findPartiallyCompletedCycles modsDone theGraph 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 @@ -1037,7 +1034,7 @@ upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me 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 @@ -1149,8 +1146,10 @@ topological_sort include_source_imports summaries 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 "" (ml_hs_file (ms_location m)))) + (ms_imps m)) rootSummaries)) (mkModuleEnv [ (mod, s) | s <- rootSummaries, let mod = ms_mod s, isHomeModule mod ]) @@ -1168,7 +1167,7 @@ downsweep roots old_summaries 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 @@ -1176,24 +1175,42 @@ downsweep roots old_summaries 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 () + [_one] -> return () + many -> multiRootsErr modl many + 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 @@ -1202,7 +1219,8 @@ downsweep roots old_summaries 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 "" (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 ]) @@ -1225,6 +1243,8 @@ summariseFile file (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 @@ -1236,7 +1256,7 @@ summariseFile 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 @@ -1244,7 +1264,7 @@ 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; @@ -1259,6 +1279,9 @@ summarise mod location old_summary 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 @@ -1267,7 +1290,7 @@ summarise mod location old_summary <+> quotes (ppr (moduleName mod))))) return (Just (ModSummary mod location{ml_hspp_file=Just hspp_fn} - srcimps imps src_timestamp)) + srcimps the_imps src_timestamp)) } } @@ -1279,4 +1302,10 @@ packageModErr mod = 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}