X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=dab148a7a5dbbee0a1b034b3d856aa6236e49e3a;hp=0654323ade68c934425c8b6ebcd09ed475e96a61;hb=190f24892156953d73b55401d0467a6f1a88ce5d;hpb=26637fd8651f55fd424f3f6190220335ab5b80e9 diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 0654323..dab148a 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -11,13 +11,11 @@ module GHC ( Session, defaultErrorHandler, defaultCleanupHandler, - init, initFromArgs, newSession, -- * Flags and settings DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt, parseDynamicFlags, - initPackages, getSessionDynFlags, setSessionDynFlags, @@ -42,6 +40,9 @@ module GHC ( checkModule, CheckedModule(..), TypecheckedSource, ParsedSource, RenamedSource, + -- * Parsing Haddock comments + parseHaddockComment, + -- * Inspecting the module structure of the program ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), getModuleGraph, @@ -78,7 +79,7 @@ module GHC ( RunResult(..), runStmt, showModule, - compileExpr, HValue, + compileExpr, HValue, dynCompileExpr, lookupName, #endif @@ -111,7 +112,8 @@ module GHC ( TyCon, tyConTyVars, tyConDataCons, tyConArity, isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon, - synTyConDefn, synTyConRhs, + isOpenTyCon, + synTyConDefn, synTyConType, synTyConResKind, -- ** Type variables TyVar, @@ -166,8 +168,6 @@ module GHC ( ToDo: * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt. - * we need to expose DynFlags, so should parseDynamicFlags really be - part of this interface? * what StaticFlags should we expose, if any? -} @@ -175,6 +175,7 @@ module GHC ( #ifdef GHCI import qualified Linker +import Data.Dynamic ( Dynamic ) import Linker ( HValue, extendLinkEnv ) import TcRnDriver ( tcRnLookupRdrName, tcRnGetInfo, tcRnLookupName, getModuleExports ) @@ -193,7 +194,7 @@ import NameSet ( NameSet, nameSetToList, elemNameSet ) import RdrName ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..), globalRdrEnvElts, extendGlobalRdrEnv, emptyGlobalRdrEnv ) -import HsSyn +import HsSyn import Type ( Kind, Type, dropForAlls, PredType, ThetaType, pprThetaArrow, pprParendType, splitForAllTys, funResultTy ) @@ -206,8 +207,9 @@ import Id ( Id, idType, isImplicitId, isDeadBinder, import Var ( TyVar ) import TysPrim ( alphaTyVars ) import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon, - isPrimTyCon, isFunTyCon, tyConArity, - tyConTyVars, tyConDataCons, synTyConDefn, synTyConRhs ) + isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity, + tyConTyVars, tyConDataCons, synTyConDefn, + synTyConType, synTyConResKind ) import Class ( Class, classSCTheta, classTvsFds, classMethods ) import FunDeps ( pprFundeps ) import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon, @@ -230,13 +232,14 @@ import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, cleanTempDirs ) import Module import UniqFM -import PackageConfig ( PackageId ) +import PackageConfig ( PackageId, stringToPackageId ) import FiniteMap import Panic import Digraph -import Bag ( unitBag ) +import Bag ( unitBag, listToBag ) import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg, - mkPlainErrMsg, printBagOfErrors ) + mkPlainErrMsg, printBagOfErrors, printBagOfWarnings, + WarnMsg ) import qualified ErrUtils import Util import StringBuffer ( StringBuffer, hGetStringBuffer ) @@ -244,6 +247,8 @@ import Outputable import BasicTypes import TcType ( tcSplitSigmaTy, isDictTy ) import Maybes ( expectJust, mapCatMaybes ) +import HaddockParse ( parseHaddockParagraphs, parseHaddockString ) +import HaddockLex ( tokenise ) import Control.Concurrent import System.Directory ( getModificationTime, doesFileExist ) @@ -321,46 +326,19 @@ defaultCleanupHandler dflags inner = inner --- | Initialises GHC. This must be done /once/ only. Takes the --- TopDir path without the '-B' prefix. - -init :: Maybe String -> IO () -init mbMinusB = do - -- catch ^C - main_thread <- myThreadId - putMVar interruptTargetThread [main_thread] - installSignalHandlers - - dflags0 <- initSysTools mbMinusB defaultDynFlags - writeIORef v_initDynFlags dflags0 - --- | 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 - -- calls to newSession. - -- | Starts a new session. A session consists of a set of loaded -- modules, a set of options (DynFlags), and an interactive context. -- ToDo: GhcMode should say "keep typechecked code" and\/or "keep renamed -- code". -newSession :: GhcMode -> IO Session -newSession mode = do - dflags0 <- readIORef v_initDynFlags - dflags <- initDynFlags dflags0 +newSession :: GhcMode -> Maybe FilePath -> IO Session +newSession mode mb_top_dir = do + -- catch ^C + main_thread <- myThreadId + putMVar interruptTargetThread [main_thread] + installSignalHandlers + + dflags0 <- initSysTools mb_top_dir defaultDynFlags + dflags <- initDynFlags dflags0 env <- newHscEnv dflags{ ghcMode=mode } ref <- newIORef env return (Session ref) @@ -383,9 +361,23 @@ modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h getSessionDynFlags :: Session -> IO DynFlags getSessionDynFlags s = withSession s (return . hsc_dflags) --- | Updates the DynFlags in a Session -setSessionDynFlags :: Session -> DynFlags -> IO () -setSessionDynFlags s dflags = modifySession s (\h -> h{ hsc_dflags = dflags }) +-- | Updates the DynFlags in a Session. This also reads +-- the package database (unless it has already been read), +-- and prepares the compilers knowledge about packages. It +-- can be called again to load new packages: just add new +-- package flags to (packageFlags dflags). +-- +-- Returns a list of new packages that may need to be linked in using +-- the dynamic linker (see 'linkPackages') as a result of new package +-- flags. If you are not doing linking or doing static linking, you +-- can ignore the list of packages returned. +-- +setSessionDynFlags :: Session -> DynFlags -> IO [PackageId] +setSessionDynFlags (Session ref) dflags = do + hsc_env <- readIORef ref + (dflags', preload) <- initPackages dflags + writeIORef ref $! hsc_env{ hsc_dflags = dflags' } + return preload -- | If there is no -o option, guess the name of target executable -- by using top-level source file name as a base. @@ -488,6 +480,12 @@ setGlobalTypeScope session ids hscEnv{ hsc_global_type_env = extendTypeEnvWithIds emptyTypeEnv ids } -- ----------------------------------------------------------------------------- +-- Parsing Haddock comments + +parseHaddockComment :: String -> Either String (HsDoc RdrName) +parseHaddockComment string = parseHaddockParagraphs (tokenise string) + +-- ----------------------------------------------------------------------------- -- Loading the program -- Perform a dependency analysis starting from the current targets @@ -577,6 +575,11 @@ load2 s@(Session ref) how_much mod_graph = do let mg2_with_srcimps :: [SCC ModSummary] mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + -- If we can determine that any of the {-# SOURCE #-} imports + -- are definitely unnecessary, then emit a warning. + warnUnnecessarySourceImports dflags mg2_with_srcimps + + let -- check the stability property for each module. stable_mods@(stable_obj,stable_bco) | BatchCompile <- ghci_mode = ([],[]) @@ -770,7 +773,8 @@ data CheckedModule = -- fields within CheckedModule. type ParsedSource = Located (HsModule RdrName) -type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name]) +type RenamedSource = (HsGroup Name, [LImportDecl Name], Maybe [LIE Name], + Maybe (HsDoc Name), HaddockModInfo Name) type TypecheckedSource = LHsBinds Id -- NOTE: @@ -1245,13 +1249,29 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key) -- We use integers as the keys for the SCC algorithm nodes :: [(ModSummary, Int, [Int])] - nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod_name s)), + nodes = [(s, expectJust "topSort" $ + lookup_key (ms_hsc_src s) (ms_mod_name s), out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++ - out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ) + out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ++ + (-- see [boot-edges] below + if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile + then [] + else case lookup_key HsBootFile (ms_mod_name s) of + Nothing -> [] + Just k -> [k]) + ) | s <- summaries , not (isBootSummary s && drop_hs_boot_nodes) ] -- Drop the hi-boot ones if told to do so + -- [boot-edges] if this is a .hs and there is an equivalent + -- .hs-boot, add a link from the former to the latter. This + -- has the effect of detecting bogus cases where the .hs-boot + -- depends on the .hs, by introducing a cycle. Additionally, + -- it ensures that we will always process the .hs-boot before + -- the .hs, and so the HomePackageTable will always have the + -- most up to date information. + key_map :: NodeMap Int key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s) | s <- summaries] @@ -1281,6 +1301,24 @@ nodeMapElts = eltsFM ms_mod_name :: ModSummary -> ModuleName ms_mod_name = moduleName . ms_mod +-- If there are {-# SOURCE #-} imports between strongly connected +-- components in the topological sort, then those imports can +-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE +-- were necessary, then the edge would be part of a cycle. +warnUnnecessarySourceImports :: DynFlags -> [SCC ModSummary] -> IO () +warnUnnecessarySourceImports dflags sccs = + printBagOfWarnings dflags (listToBag (concat (map (check.flattenSCC) sccs))) + where check ms = + let mods_in_this_cycle = map ms_mod_name ms in + [ warn m i | m <- ms, i <- ms_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] + + warn :: ModSummary -> Located ModuleName -> WarnMsg + warn ms (L loc mod) = + mkPlainErrMsg loc + (ptext SLIT("Warning: {-# SOURCE #-} unnecessary in import of ") + <+> quotes (ppr mod)) + ----------------------------------------------------------------------------- -- Downsweep (dependency analysis) @@ -1849,7 +1887,9 @@ findModule' hsc_env mod_name maybe_pkg = res <- findImportedModule hsc_env mod_name Nothing case res of Found _ m | modulePackageId m /= this_pkg -> return m - -- not allowed to be a home module + | otherwise -> throwDyn (CmdLineError (showSDoc $ + text "module" <+> pprModule m <+> + text "is not loaded")) err -> let msg = cannotFindModule dflags mod_name err in throwDyn (CmdLineError (showSDoc msg)) @@ -2019,6 +2059,27 @@ compileExpr s expr = withSession s $ \hsc_env -> do _ -> panic "compileExpr" -- ----------------------------------------------------------------------------- +-- Compile an expression into a dynamic + +dynCompileExpr :: Session -> String -> IO (Maybe Dynamic) +dynCompileExpr ses expr = do + (full,exports) <- getContext ses + setContext ses full $ + (mkModule + (stringToPackageId "base") (mkModuleName "Data.Dynamic") + ):exports + let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" + res <- withSession ses (flip hscStmt stmt) + setContext ses full exports + case res of + Nothing -> return Nothing + Just (_, names, hvals) -> do + vals <- (unsafeCoerce# hvals :: IO [Dynamic]) + case (names,vals) of + (_:[], v:[]) -> return (Just v) + _ -> panic "dynCompileExpr" + +-- ----------------------------------------------------------------------------- -- running a statement interactively data RunResult