X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcompMan%2FCompManager.lhs;h=bf8d0cf137d5db5ff2c7ee89a0fc0accb46f69a2;hb=f4eba96b198baf4499ca6ccd7242d9daa41337ac;hp=f2ba82a76fd1f04500c0aed5523e9f8513c46c19;hpb=51a571c0f5b0201ea53bec60fcaafb78c01c017e;p=ghc-hetmet.git diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index f2ba82a..bf8d0cf 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -34,31 +34,28 @@ where import CmLink import CmTypes +import CmStaticInfo ( GhciMode(..) ) +import DriverPipeline +import DriverFlags ( getDynFlags ) +import DriverPhases +import DriverUtil +import Finder +import HscMain ( initPersistentCompilerState ) import HscTypes import RnEnv ( unQualInScope ) import Id ( idType, idName ) -import Name ( Name, NamedThing(..) ) +import Name ( Name, NamedThing(..), nameRdrName ) import NameEnv -import RdrName ( emptyRdrEnv ) -import Module ( Module, ModuleName, moduleName, isHomeModule, - mkModuleName, moduleNameUserString, moduleUserString ) -import CmStaticInfo ( GhciMode(..) ) -import DriverPipeline +import RdrName ( lookupRdrEnv, emptyRdrEnv ) +import Module import GetImports import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) -import HscTypes -import HscMain ( initPersistentCompilerState ) -import Finder import UniqFM import Unique ( Uniquable ) import Digraph ( SCC(..), stronglyConnComp, flattenSCC ) -import DriverFlags ( getDynFlags ) -import DriverPhases -import DriverUtil ( splitFilename3 ) import ErrUtils ( showPass ) import Util -import DriverUtil import TmpFiles import Outputable import Panic @@ -75,7 +72,6 @@ import PrelGHC ( unsafeCoerce# ) import Exception ( throwDyn ) -- std -import Time ( ClockTime ) import Directory ( getModificationTime, doesFileExist ) import IO import Monad @@ -153,7 +149,7 @@ cmSetContext cmstate str Nothing -> do mod <- moduleNameToModule mn if isHomeModule mod - then throwDyn (OtherError (showSDoc + then throwDyn (UserError (showSDoc (quotes (ppr (moduleName mod)) <+> text "is not currently loaded"))) else return mod @@ -167,7 +163,7 @@ moduleNameToModule :: ModuleName -> IO Module moduleNameToModule mn = do maybe_stuff <- findModule mn case maybe_stuff of - Nothing -> throwDyn (OtherError ("can't find module `" + Nothing -> throwDyn (UserError ("can't find module `" ++ moduleNameUserString mn ++ "'")) Just (m,_) -> return m @@ -194,12 +190,18 @@ cmRunStmt cmstate dflags expr -- update the interactive context let - new_rn_env = extendLocalRdrEnv rn_env (map idName ids) + names = map idName ids - -- Extend the renamer-env from bound_ids, not - -- bound_names, because the latter may contain - -- [it] when the former is empty - new_type_env = extendNameEnvList type_env + -- these names have just been shadowed + shadowed = [ n | r <- map nameRdrName names, + Just n <- [lookupRdrEnv rn_env r] ] + + new_rn_env = extendLocalRdrEnv rn_env names + + -- remove any shadowed bindings from the type_env + filtered_type_env = delListFromNameEnv type_env shadowed + + new_type_env = extendNameEnvList filtered_type_env [ (getName id, AnId id) | id <- ids] new_ic = icontext { ic_rn_env = new_rn_env, @@ -212,9 +214,11 @@ cmRunStmt cmstate dflags expr let thing_to_run = unsafeCoerce# hval :: IO [HValue] hvals <- thing_to_run - -- get the newly bound things, and bind them - let names = map idName ids - new_pls <- updateClosureEnv pls (zip names hvals) + -- Get the newly bound things, and bind them. Don't forget + -- to delete any shadowed bindings from the closure_env, lest + -- we end up with a space leak. + pls <- delListFromClosureEnv pls shadowed + new_pls <- addListToClosureEnv pls (zip names hvals) return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names) where @@ -624,13 +628,10 @@ getValidLinkable old_linkables objects_allowed new_linkables summary | otherwise = maybeToList maybe_old_linkable -- only linkables newer than the source code are valid - maybe_src_date = ms_hs_date summary + src_date = ms_hs_date summary valid_linkable - = case maybe_src_date of - Nothing -> panic "valid_linkable_list" - Just src_date - -> filter (\l -> linkableTime l > src_date) linkable + = filter (\l -> linkableTime l > src_date) linkable return (valid_linkable ++ new_linkables) @@ -801,7 +802,7 @@ upsweep_mod :: GhciMode -> [ModuleName] -> IO (CmThreaded, Maybe Linkable) -upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_from_here +upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me = do let mod_name = name_of_summary summary1 let verb = verbosity dflags @@ -813,54 +814,40 @@ upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_from_here source_unchanged = isJust maybe_old_linkable + reachable_only = filter (/= (name_of_summary summary1)) + reachable_inc_me + -- in interactive mode, all home modules below us *must* have an -- interface in the HIT. We never demand-load home interfaces in -- interactive mode. (hst1_strictDC, hit1_strictDC) = ASSERT(ghci_mode == Batch || - all (`elemUFM` hit1) reachable_from_here) - retainInTopLevelEnvs - (filter (/= (name_of_summary summary1)) reachable_from_here) - (hst1,hit1) + all (`elemUFM` hit1) reachable_only) + retainInTopLevelEnvs reachable_only (hst1,hit1) old_linkable = unJust "upsweep_mod:old_linkable" maybe_old_linkable + have_object + | Just l <- maybe_old_linkable, isObjectLinkable l = True + | otherwise = False + compresult <- compile ghci_mode summary1 source_unchanged - old_iface hst1_strictDC hit1_strictDC pcs1 + have_object old_iface hst1_strictDC hit1_strictDC pcs1 case compresult of - -- Compilation "succeeded", but didn't return a new - -- linkable, meaning that compilation wasn't needed, and the - -- new details were manufactured from the old iface. - CompOK pcs2 new_details new_iface Nothing - -> do let hst2 = addToUFM hst1 mod_name new_details - hit2 = addToUFM hit1 mod_name new_iface - threaded2 = CmThreaded pcs2 hst2 hit2 - - if ghci_mode == Interactive && verb >= 1 then - -- if we're using an object file, tell the user - case old_linkable of - (LM _ _ objs@(DotO _:_)) - -> do hPutStrLn stderr (showSDoc (space <> - parens (hsep (text "using": - punctuate comma - [ text o | DotO o <- objs ])))) - _ -> return () - else - return () - - return (threaded2, Just old_linkable) - - -- Compilation really did happen, and succeeded. A new - -- details, iface and linkable are returned. - CompOK pcs2 new_details new_iface (Just new_linkable) + -- Compilation "succeeded", and may or may not have returned a new + -- linkable (depending on whether compilation was actually performed + -- or not). + CompOK pcs2 new_details new_iface maybe_new_linkable -> do let hst2 = addToUFM hst1 mod_name new_details hit2 = addToUFM hit1 mod_name new_iface threaded2 = CmThreaded pcs2 hst2 hit2 - return (threaded2, Just new_linkable) + return (threaded2, if isJust maybe_new_linkable + then maybe_new_linkable + else Just old_linkable) -- Compilation failed. compile may still have updated -- the PCS, tho. @@ -896,8 +883,12 @@ retainInTopLevelEnvs keep_these (hst, hit) downwards_closure_of_module :: [ModSummary] -> ModuleName -> [ModuleName] downwards_closure_of_module summaries root = let toEdge :: ModSummary -> (ModuleName,[ModuleName]) - toEdge summ = (name_of_summary summ, ms_allimps summ) - res = simple_transitive_closure (map toEdge summaries) [root] + toEdge summ = (name_of_summary summ, + filter (`elem` all_mods) (ms_allimps summ)) + + all_mods = map name_of_summary summaries + + res = simple_transitive_closure (map toEdge summaries) [root] in --trace (showSDoc (text "DC of mod" <+> ppr root -- <+> text "=" <+> ppr res)) ( @@ -954,7 +945,9 @@ downsweep rootNm old_summaries rootSummaries all_summaries <- loop (concat (map ms_imps rootSummaries)) - (filter (isHomeModule.ms_mod) rootSummaries) + (mkModuleEnv [ (mod, s) | s <- rootSummaries, + let mod = ms_mod s, isHomeModule mod + ]) return (all_summaries, a_root_is_Main) where getRootSummary :: FilePath -> IO ModSummary @@ -962,52 +955,50 @@ downsweep rootNm old_summaries | haskellish_file file = do exists <- doesFileExist file if exists then summariseFile file else do - throwDyn (OtherError ("can't find file `" ++ file ++ "'")) + throwDyn (UserError ("can't find file `" ++ file ++ "'")) | otherwise = do exists <- doesFileExist hs_file if exists then summariseFile hs_file else do exists <- doesFileExist lhs_file if exists then summariseFile lhs_file else do - getSummary (mkModuleName file) + let mod_name = mkModuleName file + maybe_summary <- getSummary mod_name + case maybe_summary of + Nothing -> packageModErr mod_name + Just s -> return s where hs_file = file ++ ".hs" lhs_file = file ++ ".lhs" - getSummary :: ModuleName -> IO ModSummary + getSummary :: ModuleName -> IO (Maybe ModSummary) getSummary nm = do found <- findModule nm case found of Just (mod, location) -> do let old_summary = findModInSummaries old_summaries mod - new_summary <- summarise mod location old_summary - case new_summary of - Nothing -> return (fromJust old_summary) - Just s -> return s + summarise mod location old_summary - Nothing -> throwDyn (OtherError + Nothing -> throwDyn (UserError ("can't find module `" ++ showSDoc (ppr nm) ++ "'")) - - -- loop invariant: home_summaries doesn't contain package modules - loop :: [ModuleName] -> [ModSummary] -> IO [ModSummary] - loop [] home_summaries = return home_summaries - loop imps home_summaries - = do -- all modules currently in homeSummaries - let all_home = map (moduleName.ms_mod) home_summaries - -- imports for modules we don't already have - let needed_imps = nub (filter (`notElem` all_home) imps) + -- loop invariant: env doesn't contain package modules + loop :: [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) -- summarise them needed_summaries <- mapM getSummary needed_imps -- get just the "home" modules - let new_home_summaries - = filter (isHomeModule.ms_mod) needed_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) - loop new_imps (new_home_summaries ++ home_summaries) + loop new_imps (extendModuleEnvList env + [ (ms_mod s, s) | s <- new_home_summaries ]) ----------------------------------------------------------------------------- -- Summarising modules @@ -1033,60 +1024,53 @@ summariseFile file Just (mod, location) <- mkHomeModuleLocn mod_name (path ++ '/':basename) file - maybe_src_timestamp + src_timestamp <- case ml_hs_file location of - Nothing -> return Nothing - Just src_fn -> maybe_getModificationTime src_fn + Nothing -> noHsFileErr mod_name + Just src_fn -> getModificationTime src_fn return (ModSummary mod location{ml_hspp_file=Just hspp_fn} - srcimps imps - maybe_src_timestamp) + srcimps imps src_timestamp) -- Summarise a module, and pick up source and timestamp. -summarise :: Module -> ModuleLocation -> Maybe ModSummary - -> IO (Maybe ModSummary) +summarise :: Module -> ModuleLocation -> Maybe ModSummary + -> IO (Maybe ModSummary) summarise mod location old_summary | isHomeModule mod = do let hs_fn = unJust "summarise" (ml_hs_file location) - maybe_src_timestamp + src_timestamp <- case ml_hs_file location of - Nothing -> return Nothing - Just src_fn -> maybe_getModificationTime src_fn + Nothing -> noHsFileErr mod + Just src_fn -> getModificationTime src_fn -- return the cached summary if the source didn't change case old_summary of { - Just s | ms_hs_date s == maybe_src_timestamp -> return Nothing; + Just s | ms_hs_date s == src_timestamp -> return (Just s); _ -> do hspp_fn <- preprocess hs_fn modsrc <- readFile hspp_fn let (srcimps,imps,mod_name) = getImports modsrc - maybe_src_timestamp - <- case ml_hs_file location of - Nothing -> return Nothing - Just src_fn -> maybe_getModificationTime src_fn - when (mod_name /= moduleName mod) $ - throwDyn (OtherError - (showSDoc (text "file name does not match module name: " - <+> ppr (moduleName mod) <+> text "vs" - <+> ppr mod_name))) + throwDyn (UserError + (showSDoc (text modsrc + <> text ": file name does not match module name" + <+> quotes (ppr (moduleName mod))))) return (Just (ModSummary mod location{ml_hspp_file=Just hspp_fn} - srcimps imps - maybe_src_timestamp)) + srcimps imps src_timestamp)) } - | otherwise - = return (Just (ModSummary mod location [] [] Nothing)) + | otherwise = return Nothing + +noHsFileErr mod + = panic (showSDoc (text "no source file for module" <+> quotes (ppr mod))) -maybe_getModificationTime :: FilePath -> IO (Maybe ClockTime) -maybe_getModificationTime fn - = (do time <- getModificationTime fn - return (Just time)) - `catch` - (\err -> return Nothing) +packageModErr mod + = throwDyn (UserError (showSDoc (text "module" <+> + quotes (ppr mod) <+> + text "is a package module"))) \end{code}