X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcompMan%2FCompManager.lhs;h=1722ddcd47d89bc138ebf726cfcccb7ad4b894e2;hb=9bb32dd2adae0a71b558b366bb73c4d4771ef80a;hp=3b3a2aa33f2c8b5eb74de052891536372a7f1090;hpb=a2bbefda37e2181e078b9636bca456f3b22872ff;p=ghc-hetmet.git diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 3b3a2aa..1722ddc 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -57,7 +57,7 @@ where #include "HsVersions.h" import DriverPipeline ( CompResult(..), preprocess, compile, link ) -import DriverState ( v_Output_file ) +import DriverState ( v_Output_file, v_NoHsMain ) import DriverPhases import DriverUtil import Finder @@ -88,7 +88,7 @@ import DATA_IOREF ( readIORef ) import HscMain ( hscThing, hscStmt, hscTcExpr ) import Module ( moduleUserString ) import TcRnDriver ( mkGlobalContext, getModuleContents ) -import Name ( Name, NamedThing(..), isExternalName ) +import Name ( Name, NamedThing(..), isExternalName, nameModule ) import Id ( idType ) import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) @@ -232,9 +232,9 @@ moduleNameToModule hpt mn = do _not_a_home_module -> do maybe_stuff <- findModule mn case maybe_stuff of - Nothing -> throwDyn (CmdLineError ("can't find module `" + Left _ -> throwDyn (CmdLineError ("can't find module `" ++ moduleNameUserString mn ++ "'")) - Just (m,_) -> return m + Right (m,_) -> return m cmGetContext :: CmState -> IO ([String],[String]) cmGetContext CmState{ic=ic} = @@ -256,18 +256,19 @@ cmModuleIsInterpreted cmstate str cmInfoThing :: CmState -> DynFlags -> String -> IO (CmState, [(TyThing,Fixity)]) cmInfoThing cmstate dflags id = do (new_pcs, things) <- hscThing hsc_env pcs icontext id - let pairs = map (\x -> (x, getFixity new_pcs (getName x))) things + let new_pit = eps_PIT (pcs_EPS new_pcs) + pairs = map (\x -> (x, getFixity new_pit (getName x))) things return (cmstate{ pcs=new_pcs }, pairs) where CmState{ hpt=hpt, pcs=pcs, ic=icontext } = cmstate hsc_env = HscEnv { hsc_mode = Interactive, hsc_dflags = dflags, hsc_HPT = hpt } - pit = eps_PIT (pcs_EPS pcs) - getFixity :: PersistentCompilerState -> Name -> Fixity - getFixity pcs name + + getFixity :: PackageIfaceTable -> Name -> Fixity + getFixity pit name | isExternalName name, - Just iface <- lookupIface hpt pit name, + Just iface <- lookupIface hpt pit (nameModule name), Just (FixitySig _ fixity _) <- lookupNameEnv (mi_fixities iface) name = fixity | otherwise @@ -455,7 +456,7 @@ cmCompileExpr cmstate dflags expr cmUnload :: CmState -> DynFlags -> IO CmState cmUnload state@CmState{ gmode=mode, pcs=pcs } dflags = do -- Throw away the old home dir cache - emptyHomeDirCache + flushFinderCache -- Unload everything the linker knows about cm_unload mode dflags [] @@ -489,7 +490,7 @@ cmDepAnal cmstate dflags rootnames = do showPass dflags "Chasing dependencies" when (verbosity dflags >= 1 && gmode cmstate == Batch) $ hPutStrLn stderr (showSDoc (hcat [ - text progName, text ": chasing modules from: ", + text "Chasing modules from: ", hcat (punctuate comma (map text rootnames))])) downsweep rootnames (mg cmstate) @@ -570,7 +571,7 @@ cmLoadModules cmstate1 dflags mg2unsorted valid_old_linkables when (verb >= 2) $ - putStrLn (showSDoc (text "Stable modules:" + hPutStrLn stderr (showSDoc (text "Stable modules:" <+> sep (map (text.moduleNameUserString) stable_mods))) -- Unload any modules which are going to be re-linked this @@ -637,15 +638,22 @@ cmLoadModules cmstate1 dflags mg2unsorted -- clean up after ourselves cleanTempFilesExcept verb (ppFilesFromSummaries modsDone) - -- issue a warning for the confusing case where the user said '-o foo' - -- but we're not going to do any linking. ofile <- readIORef v_Output_file - when (ghci_mode == Batch && isJust ofile && not a_root_is_Main + no_hs_main <- readIORef v_NoHsMain + + -- Issue a warning for the confusing case where the user + -- said '-o foo' but we're not going to do any linking. + -- We attempt linking if either (a) one of the modules is + -- called Main, or (b) the user said -no-hs-main, indicating + -- that main() is going to come from somewhere else. + -- + let do_linking = a_root_is_Main || no_hs_main + when (ghci_mode == Batch && isJust ofile && not do_linking && verb > 0) $ hPutStrLn stderr "Warning: output was redirected with -o, but no output will be generated\nbecause there is no Main module." -- link everything together - linkresult <- link ghci_mode dflags a_root_is_Main (hptLinkables hpt3) + linkresult <- link ghci_mode dflags do_linking hpt3 cmLoadFinish Succeeded linkresult hpt3 modsDone ghci_mode pcs3 @@ -672,7 +680,7 @@ cmLoadModules cmstate1 dflags mg2unsorted cleanTempFilesExcept verb (ppFilesFromSummaries mods_to_keep) -- Link everything together - linkresult <- link ghci_mode dflags False (hptLinkables hpt4) + linkresult <- link ghci_mode dflags False hpt4 cmLoadFinish Failed linkresult hpt4 mods_to_keep ghci_mode pcs3 @@ -697,18 +705,11 @@ cmLoadFinish ok Succeeded hpt mods ghci_mode pcs return (new_cmstate, ok, mods_loaded) --- used to fish out the preprocess output files for the purposes --- of cleaning up. +-- used to fish out the preprocess output files for the purposes of +-- cleaning up. The preprocessed file *might* be the same as the +-- source file, but that doesn't do any harm. ppFilesFromSummaries summaries - = [ fn | Just fn <- map toPpFile summaries ] - where - toPpFile sum - | hspp /= ml_hs_file loc = hspp - | otherwise = Nothing - where - loc = ms_location sum - hspp = ml_hspp_file loc - + = [ fn | Just fn <- map (ml_hspp_file.ms_location) summaries ] ----------------------------------------------------------------------------- -- getValidLinkables @@ -801,9 +802,7 @@ getValidLinkable old_linkables objects_allowed new_linkables summary <- if (not objects_allowed) then return Nothing - else case ml_obj_file (ms_location summary) of - Just obj_fn -> maybe_getFileLinkable mod_name obj_fn - Nothing -> return Nothing + else findLinkable mod_name (ms_location summary) let old_linkable = findModuleLinkable_maybe old_linkables mod_name @@ -847,20 +846,6 @@ getValidLinkable old_linkables objects_allowed new_linkables summary return (new_linkables' ++ new_linkables) -maybe_getFileLinkable :: ModuleName -> FilePath -> IO (Maybe Linkable) -maybe_getFileLinkable mod obj_fn - = do obj_exist <- doesFileExist obj_fn - if not obj_exist - then return Nothing - else - do let stub_fn = case splitFilename3 obj_fn of - (dir, base, ext) -> dir ++ "/" ++ base ++ ".stub_o" - stub_exist <- doesFileExist stub_fn - obj_time <- getModificationTime obj_fn - if stub_exist - then return (Just (LM obj_time mod [DotO obj_fn, DotO stub_fn])) - else return (Just (LM obj_time mod [DotO obj_fn])) - hptLinkables :: HomePackageTable -> [Linkable] -- Get all the linkables from the home package table, one for each module -- Once the HPT is up to date, these are the ones we should link @@ -1177,15 +1162,13 @@ downsweep roots old_summaries getSummary (currentMod,nm) = do found <- findModule nm case found of - Just (mod, location) -> do + Right (mod, location) -> do let old_summary = findModInSummaries old_summaries mod summarise mod location old_summary - Nothing -> - throwDyn (CmdLineError - ("can't find module `" - ++ showSDoc (ppr nm) ++ "' (while processing " - ++ show currentMod ++ ")")) + Left files -> do + dflags <- getDynFlags + throwDyn (noModError dflags currentMod nm files) -- loop invariant: env doesn't contain package modules loop :: [(FilePath,ModuleName)] -> ModuleEnv ModSummary -> IO [ModSummary] @@ -1206,6 +1189,18 @@ downsweep roots old_summaries loop new_imps (extendModuleEnvList env [ (ms_mod s, s) | s <- new_home_summaries ]) +-- ToDo: we don't have a proper line number for this error +noModError dflags loc mod_nm files = ProgramError (showSDoc ( + hang (text loc <> colon) 4 $ + (text "Can't find module" <+> quotes (ppr mod_nm) $$ extra) + )) + where + extra + | verbosity dflags < 3 = + text "(use -v to see a list of the files searched for)" + | otherwise = + hang (ptext SLIT("locations searched:")) 4 (vcat (map text files)) + ----------------------------------------------------------------------------- -- Summarising modules @@ -1224,21 +1219,20 @@ summariseFile file = do hspp_fn <- preprocess 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. + let -- 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 + (mod, location) <- mkHomeModLocation mod_name file src_timestamp <- case ml_hs_file location of Nothing -> noHsFileErr mod_name Just src_fn -> getModificationTime src_fn - return (ModSummary mod - location{ml_hspp_file=Just hspp_fn} - srcimps the_imps src_timestamp) + return (ModSummary { ms_mod = mod, + ms_location = location{ml_hspp_file=Just hspp_fn}, + ms_srcimps = srcimps, ms_imps = the_imps, + ms_hs_date = src_timestamp }) -- Summarise a module, and pick up source and timestamp. summarise :: Module -> ModLocation -> Maybe ModSummary