X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcompMan%2FCompManager.lhs;h=829664d2a74fa4ec57820253c9476b710061a977;hb=8e67f5502e2e316245806ee3735a2f41a844b611;hp=334d89dac5df4b7f00814c6f46ff10260a0cfcb6;hpb=f4eaa144a42d26f70fe8452916131c33b0c56f8f;p=ghc-hetmet.git diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 334d89d..829664d 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -13,6 +13,7 @@ module CompManager ( cmInit, -- :: GhciMode -> IO CmState cmDepAnal, -- :: CmState -> [FilePath] -> IO ModuleGraph + cmDownsweep, cmTopSort, -- :: Bool -> ModuleGraph -> [SCC ModSummary] cyclicModuleErr, -- :: [ModSummary] -> String -- Used by DriverMkDepend @@ -59,8 +60,8 @@ import DriverPipeline ( CompResult(..), preprocess, compile, link ) import HscMain ( newHscEnv ) import DriverState ( v_Output_file, v_NoHsMain, v_MainModIs ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, isHaskellSrcFilename ) -import Finder ( findModule, findLinkable, addHomeModuleToFinder, flushFinderCache, - mkHomeModLocation, FindResult(..), cantFindError ) +import Finder ( findModule, findLinkable, addHomeModuleToFinder, + flushFinderCache, mkHomeModLocation, FindResult(..), cantFindError ) import HscTypes ( ModSummary(..), HomeModInfo(..), ModIface(..), msHsFilePath, HscEnv(..), GhciMode(..), InteractiveContext(..), emptyInteractiveContext, @@ -86,6 +87,7 @@ import FiniteMap import DATA_IOREF ( readIORef ) #ifdef GHCI +import Finder ( findPackageModule ) import HscMain ( hscGetInfo, GetInfoResult, hscStmt, hscTcExpr, hscKcType ) import HscTypes ( TyThing(..), icPrintUnqual, showModMsg ) import TcRnDriver ( mkExportEnv, getModuleContents ) @@ -94,13 +96,13 @@ import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv ) import Name ( Name ) import NameEnv import Id ( idType ) -import Type ( tidyType ) +import Type ( tidyType, dropForAlls ) import VarEnv ( emptyTidyEnv ) import Linker ( HValue, unload, extendLinkEnv ) import GHC.Exts ( unsafeCoerce# ) import Foreign import Control.Exception as Exception ( Exception, try ) -import CmdLineOpts ( DynFlag(..), dopt_unset ) +import CmdLineOpts ( DynFlag(..), dopt_unset, dopt ) #endif import EXCEPTION ( throwDyn ) @@ -240,7 +242,9 @@ cmSetContext cmstate toplevs exports = do hsc_env = cm_hsc cmstate hpt = hsc_HPT hsc_env - export_env <- mkExportEnv hsc_env (map mkModule exports) + let export_mods = map mkModule exports + mapM_ (checkModuleExists (hsc_dflags hsc_env) hpt) export_mods + export_env <- mkExportEnv hsc_env export_mods toplev_envs <- mapM (mkTopLevEnv hpt) toplevs let all_env = foldr plusGlobalRdrEnv export_env toplev_envs @@ -248,11 +252,22 @@ cmSetContext cmstate toplevs exports = do ic_exports = exports, ic_rn_gbl_env = all_env } } +checkModuleExists :: DynFlags -> HomePackageTable -> Module -> IO () +checkModuleExists dflags hpt mod = + case lookupModuleEnv hpt mod of + Just mod_info -> return () + _not_a_home_module -> do + res <- findPackageModule dflags mod True + case res of + Found _ _ -> return () + err -> let msg = cantFindError dflags mod err in + throwDyn (CmdLineError (showSDoc msg)) + mkTopLevEnv :: HomePackageTable -> String -> IO GlobalRdrEnv mkTopLevEnv hpt mod = case lookupModuleEnv hpt (mkModule mod) of Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++ mod)) - Just details -> case hm_globals details of + Just details -> case mi_globals (hm_iface details) of Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not interpreted " ++ mod)) Just env -> return env @@ -263,7 +278,7 @@ cmGetContext CmState{cm_ic=ic} = cmModuleIsInterpreted :: CmState -> String -> IO Bool cmModuleIsInterpreted cmstate str = case lookupModuleEnv (cmHPT cmstate) (mkModule str) of - Just details -> return (isJust (hm_globals details)) + Just details -> return (isJust (mi_globals (hm_iface details))) _not_a_home_module -> return False ----------------------------------------------------------------------------- @@ -394,12 +409,17 @@ cmTypeOfExpr cmstate expr case maybe_stuff of Nothing -> return Nothing - Just ty -> return (Just res_str) + Just ty -> return (Just (showSDocForUser unqual doc)) where - res_str = showSDocForUser unqual (text expr <+> dcolon <+> ppr tidy_ty) + doc = text expr <+> dcolon <+> ppr final_ty unqual = icPrintUnqual (cm_ic cmstate) tidy_ty = tidyType emptyTidyEnv ty - + dflags = hsc_dflags (cm_hsc cmstate) + -- if -fglasgow-exts is on we show the foralls, otherwise + -- we don't. + final_ty + | dopt Opt_GlasgowExts dflags = tidy_ty + | otherwise = dropForAlls tidy_ty ----------------------------------------------------------------------------- -- cmKindOfType: returns a string representing the kind of a type @@ -507,7 +527,7 @@ cmDepAnal cmstate rootnames hPutStrLn stderr (showSDoc (hcat [ text "Chasing modules from: ", hcat (punctuate comma (map text rootnames))])) - downsweep dflags rootnames (cm_mg cmstate) + cmDownsweep dflags rootnames (cm_mg cmstate) [] where hsc_env = cm_hsc cmstate dflags = hsc_dflags hsc_env @@ -1037,11 +1057,10 @@ upsweep_mod hsc_env (old_hpt, old_linkables) summary -- Compilation "succeeded", and may or may not have returned a new -- linkable (depending on whether compilation was actually performed -- or not). - CompOK new_details new_globals new_iface maybe_new_linkable + CompOK new_details new_iface maybe_new_linkable -> do let new_linkable = maybe_new_linkable `orElse` old_linkable new_info = HomeModInfo { hm_iface = new_iface, - hm_globals = new_globals, hm_details = new_details, hm_linkable = new_linkable } return (Just new_info) @@ -1111,9 +1130,18 @@ cmTopSort drop_hs_boot_nodes summaries -- We pass in the previous collection of summaries, which is used as a -- cache to avoid recalculating a module summary if the source is -- unchanged. - -downsweep :: DynFlags -> [FilePath] -> [ModSummary] -> IO [ModSummary] -downsweep dflags roots old_summaries +-- +-- The returned list of [ModSummary] nodes has one node for each home-package +-- module. The imports of these nodes are all there, including the imports +-- of non-home-package modules. + +cmDownsweep :: DynFlags + -> [FilePath] -- Roots + -> [ModSummary] -- Old summaries + -> [Module] -- Ignore dependencies on these; treat them as + -- if they were package modules + -> IO [ModSummary] +cmDownsweep dflags roots old_summaries excl_mods = do rootSummaries <- mapM getRootSummary roots checkDuplicates rootSummaries loop (concatMap msImports rootSummaries) @@ -1134,7 +1162,8 @@ downsweep dflags roots old_summaries exists <- doesFileExist lhs_file if exists then summariseFile dflags lhs_file else do let mod_name = mkModule file - maybe_summary <- summarise dflags emptyNodeMap Nothing False mod_name + maybe_summary <- summarise dflags emptyNodeMap Nothing False + mod_name excl_mods case maybe_summary of Nothing -> packageModErr mod_name Just s -> return s @@ -1166,7 +1195,8 @@ downsweep dflags roots old_summaries loop ((cur_path, wanted_mod, is_boot) : ss) done | key `elemFM` done = loop ss done | otherwise = do { mb_s <- summarise dflags old_summary_map - (Just cur_path) is_boot wanted_mod + (Just cur_path) is_boot + wanted_mod excl_mods ; case mb_s of Nothing -> loop ss done Just s -> loop (msImports s ++ ss) @@ -1218,11 +1248,7 @@ summariseFile dflags file -- to findModule will find it, even if it's not on any search path addHomeModuleToFinder mod location - src_timestamp - <- case ml_hs_file location of - Nothing -> noHsFileErr Nothing mod - Just src_fn -> getModificationTime src_fn - + src_timestamp <- getModificationTime file return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, ms_location = location, ms_hspp_file = Just hspp_fn, @@ -1236,54 +1262,53 @@ summarise :: DynFlags -> Maybe FilePath -- Importing module (for error messages) -> IsBootInterface -- True <=> a {-# SOURCE #-} import -> Module -- Imported module to be summarised + -> [Module] -- Modules to exclude -> IO (Maybe ModSummary) -- Its new summary -summarise dflags old_summary_map cur_mod is_boot wanted_mod +summarise dflags old_summary_map cur_mod is_boot wanted_mod excl_mods + | wanted_mod `elem` excl_mods + = return Nothing + + | Just old_summary <- lookupFM old_summary_map (wanted_mod, hsc_src) + = do { -- Find its new timestamp; all the + -- ModSummaries in the old map have valid ml_hs_files + let location = ms_location old_summary + src_fn = fromJust (ml_hs_file location) + + ; src_timestamp <- getModificationTime src_fn + + -- return the cached summary if the source didn't change + ; if ms_hs_date old_summary == src_timestamp + then return (Just old_summary) + else new_summary location + } + + | otherwise = do { found <- findModule dflags wanted_mod True {-explicit-} ; case found of Found location pkg - | isHomePackage pkg - -> do { summary <- do_summary location - ; return (Just summary) } - | otherwise - -> return Nothing -- Drop an external-package modules - - err -> noModError dflags cur_mod wanted_mod err + | not (isHomePackage pkg) -> return Nothing -- Drop external-pkg + | isJust (ml_hs_file location) -> new_summary location -- Home package + err -> noModError dflags cur_mod wanted_mod err -- Not found } where hsc_src = if is_boot then HsBootFile else HsSrcFile - do_summary location + new_summary location = do { -- Adjust location to point to the hs-boot source file, -- hi file, object file, when is_boot says so - let location' | is_boot = addBootSuffixLocn location - | otherwise = location - - -- Find the source file to summarise - ; src_fn <- case ml_hs_file location' of - Nothing -> noHsFileErr cur_mod wanted_mod - Just src_fn -> return src_fn - - -- In the case of hs-boot files, check that it exists - -- The Finder was dealing only with the main source file - ; if is_boot then do - { exists <- doesFileExist src_fn - ; if exists then return () - else noHsBootFileErr cur_mod src_fn } - else return () - - -- Find its timestamp - ; src_timestamp <- getModificationTime src_fn - - -- return the cached summary if the source didn't change - ; case lookupFM old_summary_map (wanted_mod, hsc_src) of { - Just s | ms_hs_date s == src_timestamp -> return s; - _ -> do - - -- Preprocess the source file - { (dflags', hspp_fn) <- preprocess dflags src_fn - -- The dflags' contains the OPTIONS pragmas - + let location' | is_boot = addBootSuffixLocn location + | otherwise = location + src_fn = fromJust (ml_hs_file location') + + -- Check that it exists + -- It might have been deleted since the Finder last found it + ; exists <- doesFileExist src_fn + ; if exists then return () else noHsFileErr cur_mod src_fn + + -- Preprocess the source file and get its imports + -- The dflags' contains the OPTIONS pragmas + ; (dflags', hspp_fn) <- preprocess dflags src_fn ; buf <- hGetStringBuffer hspp_fn ; (srcimps, the_imps, mod_name) <- getImports dflags' buf hspp_fn @@ -1293,15 +1318,17 @@ summarise dflags old_summary_map cur_mod is_boot wanted_mod <> text ": file name does not match module name" <+> quotes (ppr mod_name)))) - ; return (ModSummary { ms_mod = wanted_mod, - ms_hsc_src = hsc_src, - ms_location = location', - ms_hspp_file = Just hspp_fn, - ms_hspp_buf = Just buf, - ms_srcimps = srcimps, - ms_imps = the_imps, - ms_hs_date = src_timestamp }) - }}} + -- Find its timestamp, and return the summary + ; src_timestamp <- getModificationTime src_fn + ; return (Just ( ModSummary { ms_mod = wanted_mod, + ms_hsc_src = hsc_src, + ms_location = location', + ms_hspp_file = Just hspp_fn, + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, + ms_imps = the_imps, + ms_hs_date = src_timestamp })) + } ----------------------------------------------------------------------------- @@ -1315,14 +1342,7 @@ noModError dflags cur_mod wanted_mod err vcat [cantFindError dflags wanted_mod err, nest 2 (parens (pp_where cur_mod))] -noHsFileErr :: Maybe FilePath -> Module -> IO a --- Complain about not being able to find an imported module -noHsFileErr cur_mod mod - = throwDyn $ CmdLineError $ showSDoc $ - vcat [text "No source file for module" <+> quotes (ppr mod), - nest 2 (parens (pp_where cur_mod))] - -noHsBootFileErr cur_mod path +noHsFileErr cur_mod path = throwDyn $ CmdLineError $ showSDoc $ vcat [text "Can't find" <+> text path, nest 2 (parens (pp_where cur_mod))]