X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FGHC.hs;h=b2c86df78245607b4fac97019983d05aa65823fc;hp=7e0ec2ffeda59fe20a848b2579c6ad29f7d850e5;hb=3eacdc7faf0d0e87a7201253f9f12c1fb4db7249;hpb=9d7da331989abcd1844e9d03b8d1e4163796fa85 diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index 7e0ec2f..b2c86df 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -11,7 +11,7 @@ module GHC ( Session, defaultErrorHandler, defaultCleanupHandler, - init, + init, initFromArgs, newSession, -- * Flags and settings @@ -62,6 +62,7 @@ module GHC ( #ifdef GHCI setContext, getContext, getNamesInScope, + getRdrNamesInScope, moduleIsInterpreted, getInfo, exprType, @@ -83,6 +84,7 @@ module GHC ( Name, nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc, NamedThing(..), + RdrName(Qual,Unqual), -- ** Identifiers Id, idType, @@ -98,7 +100,7 @@ module GHC ( TyCon, tyConTyVars, tyConDataCons, tyConArity, isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, - getSynTyConDefn, + synTyConDefn, synTyConRhs, -- ** Type variables TyVar, @@ -176,7 +178,7 @@ import GHC.Exts ( unsafeCoerce# ) import Packages ( initPackages ) import NameSet ( NameSet, nameSetToList, elemNameSet ) -import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName, +import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..), globalRdrEnvElts ) import HsSyn import Type ( Kind, Type, dropForAlls, PredType, ThetaType, @@ -192,27 +194,26 @@ import Var ( TyVar ) import TysPrim ( alphaTyVars ) import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, tyConArity, - tyConTyVars, tyConDataCons, getSynTyConDefn ) + tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs ) import Class ( Class, classSCTheta, classTvsFds, classMethods ) import FunDeps ( pprFundeps ) import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon, dataConFieldLabels, dataConStrictMarks, dataConIsInfix, isVanillaDataCon ) import Name ( Name, nameModule, NamedThing(..), nameParent_maybe, - nameSrcLoc ) + nameSrcLoc, nameOccName ) import OccName ( parenSymOcc ) import NameEnv ( nameEnvElts ) import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr ) import SrcLoc import DriverPipeline import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) -import GetImports ( getImports ) +import HeaderInfo ( getImports, getOptions ) import Packages ( isHomePackage ) import Finder -import HscMain ( newHscEnv, hscFileCheck, HscResult(..) ) +import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) ) import HscTypes import DynFlags -import StaticFlags import SysTools ( initSysTools, cleanTempFiles ) import Module import FiniteMap @@ -228,20 +229,28 @@ import Outputable import SysTools ( cleanTempFilesExcept ) import BasicTypes import TcType ( tcSplitSigmaTy, isDictTy ) - -import Directory ( getModificationTime, doesFileExist ) -import Maybe ( isJust, isNothing, fromJust ) import Maybes ( expectJust, mapCatMaybes ) -import List ( partition, nub ) -import qualified List -import Monad ( unless, when ) -import System ( exitWith, ExitCode(..) ) -import Time ( ClockTime ) -import EXCEPTION as Exception hiding (handle) -import DATA_IOREF -import IO + +import Control.Concurrent +import System.Directory ( getModificationTime, doesFileExist ) +import Data.Maybe ( isJust, isNothing ) +import Data.List ( partition, nub ) +import qualified Data.List as List +import Control.Monad ( unless, when ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.Time ( ClockTime ) +import Control.Exception as Exception hiding (handle) +import Data.IORef +import System.IO +import System.IO.Error ( isDoesNotExistError ) import Prelude hiding (init) +#if __GLASGOW_HASKELL__ < 600 +import System.IO as System.IO.Error ( try ) +#else +import System.IO.Error ( try ) +#endif + -- ----------------------------------------------------------------------------- -- Exception handlers @@ -297,22 +306,32 @@ defaultCleanupHandler dflags inner = -- | Initialises GHC. This must be done /once/ only. Takes the --- command-line arguments. All command-line arguments which aren't --- understood by GHC will be returned. +-- TopDir path without the '-B' prefix. -init :: [String] -> IO [String] -init args = do +init :: Maybe String -> IO () +init mbMinusB = do -- catch ^C + main_thread <- myThreadId + putMVar interruptTargetThread [main_thread] installSignalHandlers - -- Grab the -B option if there is one - let (minusB_args, argv1) = partition (prefixMatch "-B") args - dflags0 <- initSysTools minusB_args defaultDynFlags + dflags0 <- initSysTools mbMinusB defaultDynFlags writeIORef v_initDynFlags dflags0 - -- Parse the static flags - argv2 <- parseStaticFlags argv1 - return argv2 +-- | Initialises GHC. This must be done /once/ only. Takes the +-- command-line arguments. All command-line arguments which aren't +-- understood by GHC will be returned. + +initFromArgs :: [String] -> IO [String] +initFromArgs args + = do init mbMinusB + return argv1 + where -- Grab the -B option if there is one + (minusB_args, argv1) = partition (prefixMatch "-B") args + mbMinusB | null minusB_args + = Nothing + | otherwise + = Just (drop 2 (last minusB_args)) GLOBAL_VAR(v_initDynFlags, error "initDynFlags", DynFlags) -- stores the DynFlags between the call to init and subsequent @@ -691,7 +710,7 @@ discardProg hsc_env -- 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 ms_hspp_file summaries ] +ppFilesFromSummaries summaries = map ms_hspp_file summaries -- ----------------------------------------------------------------------------- -- Check module @@ -709,13 +728,10 @@ data CheckedModule = -- fields within CheckedModule. type ParsedSource = Located (HsModule RdrName) -type RenamedSource = HsGroup Name +type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name]) type TypecheckedSource = LHsBinds Id -- NOTE: --- - things that aren't in the output of the renamer: --- - the export list --- - the imports -- - things that aren't in the output of the typechecker right now: -- - the export list -- - the imports @@ -744,32 +760,17 @@ checkModule session@(Session ref) mod = do case [ ms | ms <- mg, ms_mod ms == mod ] of [] -> return Nothing (ms:_) -> do - -- Add in the OPTIONS from the source file This is nasty: - -- we've done this once already, in the compilation manager - -- It might be better to cache the flags in the - -- ml_hspp_file field, say - let dflags0 = hsc_dflags hsc_env - hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms) - filename = fromJust (ml_hs_file (ms_location ms)) - opts = getOptionsFromStringBuffer hspp_buf filename - (dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts) - if (not (null leftovers)) - then do printErrorsAndWarnings dflags1 (optionsErrorMsgs leftovers opts filename) - return Nothing - else do - - r <- hscFileCheck hsc_env{hsc_dflags=dflags1} ms - case r of - HscFail -> - return Nothing - HscChecked parsed renamed Nothing -> + mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms + case mbChecked of + Nothing -> return Nothing + Just (HscChecked parsed renamed Nothing) -> return (Just (CheckedModule { parsedSource = parsed, renamedSource = renamed, typecheckedSource = Nothing, checkedModuleInfo = Nothing })) - HscChecked parsed renamed - (Just (tc_binds, rdr_env, details)) -> do + Just (HscChecked parsed renamed + (Just (tc_binds, rdr_env, details))) -> do let minf = ModuleInfo { minf_type_env = md_types details, minf_exports = md_exports details, @@ -781,8 +782,6 @@ checkModule session@(Session ref) mod = do renamedSource = renamed, typecheckedSource = Just tc_binds, checkedModuleInfo = Just minf })) - _other -> - panic "checkModule" -- --------------------------------------------------------------------------- -- Unloading @@ -1419,7 +1418,8 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, ms_location = location, - ms_hspp_file = Just hspp_fn, + ms_hspp_file = hspp_fn, + ms_hspp_opts = dflags', ms_hspp_buf = Just buf, ms_srcimps = srcimps, ms_imps = the_imps, ms_hs_date = src_timestamp, @@ -1428,7 +1428,7 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary findSummaryBySourceFile summaries file = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], - fromJust (ml_hs_file (ms_location ms)) == file ] of + expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of [] -> Nothing (x:xs) -> Just x @@ -1458,7 +1458,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc case maybe_buf of Just (_,t) -> check_timestamp old_summary location src_fn t Nothing -> do - m <- IO.try (getModificationTime src_fn) + m <- System.IO.Error.try (getModificationTime src_fn) case m of Right t -> check_timestamp old_summary location src_fn t Left e | isDoesNotExistError e -> find_it @@ -1529,7 +1529,8 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc return (Just ( ModSummary { ms_mod = wanted_mod, ms_hsc_src = hsc_src, ms_location = location, - ms_hspp_file = Just hspp_fn, + ms_hspp_file = hspp_fn, + ms_hspp_opts = dflags', ms_hspp_buf = Just buf, ms_srcimps = srcimps, ms_imps = the_imps, @@ -1554,9 +1555,9 @@ preprocessFile dflags src_fn mb_phase (Just (buf, time)) = do -- case we bypass the preprocessing stage? let - local_opts = getOptionsFromStringBuffer buf src_fn + local_opts = getOptions buf src_fn -- - (dflags', errs) <- parseDynamicFlags dflags (map snd local_opts) + (dflags', errs) <- parseDynamicFlags dflags (map unLoc local_opts) let needs_preprocessing @@ -1876,6 +1877,25 @@ getNamesInScope :: Session -> IO [Name] getNamesInScope s = withSession s $ \hsc_env -> do return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env)))) +getRdrNamesInScope :: Session -> IO [RdrName] +getRdrNamesInScope s = withSession s $ \hsc_env -> do + let env = ic_rn_gbl_env (hsc_IC hsc_env) + return (concat (map greToRdrNames (globalRdrEnvElts env))) + +-- ToDo: move to RdrName +greToRdrNames :: GlobalRdrElt -> [RdrName] +greToRdrNames GRE{ gre_name = name, gre_prov = prov } + = case prov of + LocalDef -> [unqual] + Imported specs -> concat (map do_spec (map is_decl specs)) + where + occ = nameOccName name + unqual = Unqual occ + do_spec decl_spec + | is_qual decl_spec = [qual] + | otherwise = [unqual,qual] + where qual = Qual (is_as decl_spec) occ + -- | Parses a string as an identifier, and returns the list of 'Name's that -- the identifier can refer to in the current interactive context. parseName :: Session -> String -> IO [Name] @@ -1980,14 +2000,17 @@ runStmt (Session ref) expr writeIORef ref new_hsc_env return (RunOk names) - --- We run the statement in a "sandbox" to protect the rest of the --- system from anything the expression might do. For now, this --- consists of just wrapping it in an exception handler, but see below --- for another version. - +-- When running a computation, we redirect ^C exceptions to the running +-- thread. ToDo: we might want a way to continue even if the target +-- thread doesn't die when it receives the exception... "this thread +-- is not responding". sandboxIO :: IO a -> IO (Either Exception a) -sandboxIO thing = Exception.try thing +sandboxIO thing = do + m <- newEmptyMVar + ts <- takeMVar interruptTargetThread + child <- forkIO (do res <- Exception.try thing; putMVar m res) + putMVar interruptTargetThread (child:ts) + takeMVar m `finally` modifyMVar_ interruptTargetThread (return.tail) {- -- This version of sandboxIO runs the expression in a completely new @@ -2025,6 +2048,6 @@ showModule s mod_summary = withSession s $ \hsc_env -> do Nothing -> panic "missing linkable" Just mod_info -> return (showModMsg obj_linkable mod_summary) where - obj_linkable = isObjectLinkable (fromJust (hm_linkable mod_info)) + obj_linkable = isObjectLinkable (expectJust "showModule" (hm_linkable mod_info)) #endif /* GHCI */