X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscMain.lhs;h=841125a0c5ef927fb7e5aa5d96657a1079d94e08;hb=61d1a81bfdebc51b9ba0fe73502dfafdf2d7f0fa;hp=582b80da6c51f5dbe204f97fe424287dc495b367;hpb=f2aaae9757e7532485c97f6c9a9ed5437542d1dd;p=ghc-hetmet.git diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 582b80d..841125a 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -58,11 +58,12 @@ module HscMain , hscParseIdentifier , hscTcRcLookupName , hscTcRnGetInfo - , hscRnImportDecls #ifdef GHCI + , hscRnImportDecls , hscGetModuleExports , hscTcRnLookupRdrName - , hscStmt, hscTcExpr, hscImport, hscKcType + , hscStmt, hscStmtWithLocation + , hscTcExpr, hscImport, hscKcType , hscCompileCoreExpr #endif @@ -96,7 +97,6 @@ import SrcLoc import TcRnDriver import TcIface ( typecheckIface ) import TcRnMonad -import RnNames ( rnImports ) import IfaceEnv ( initNameCache ) import LoadIface ( ifaceStats, initExternalPackageState ) import PrelInfo ( wiredInThings, basicKnownKeyNames ) @@ -294,7 +294,6 @@ hscTcRnGetInfo hsc_env name = hscGetModuleExports :: HscEnv -> Module -> IO (Maybe [AvailInfo]) hscGetModuleExports hsc_env mdl = runHsc hsc_env $ ioMsgMaybe' $ getModuleExports hsc_env mdl -#endif -- ----------------------------------------------------------------------------- -- | Rename some import declarations @@ -305,11 +304,14 @@ hscRnImportDecls -> [LImportDecl RdrName] -> IO GlobalRdrEnv -hscRnImportDecls hsc_env this_mod import_decls = runHsc hsc_env $ do - (_, r, _, _) <- - ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $ - rnImports import_decls - return r +-- It is important that we use tcRnImports instead of calling rnImports directly +-- because tcRnImports will force-load any orphan modules necessary, making extra +-- instances/family instances visible (GHC #4832) +hscRnImportDecls hsc_env this_mod import_decls + = runHsc hsc_env $ ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $ + fmap tcg_rdr_env $ tcRnImports hsc_env this_mod import_decls + +#endif -- ----------------------------------------------------------------------------- -- | parse a file, returning the abstract syntax @@ -458,7 +460,8 @@ error. This is the only thing that isn't caught by the type-system. data HscStatus' a = HscNoRecomp | HscRecomp - Bool -- Has stub files. This is a hack. We can't compile C files here + (Maybe FilePath) + -- Has stub files. This is a hack. We can't compile C files here -- since it's done in DriverPipeline. For now we just return True -- if we want the caller to compile them for us. a @@ -594,14 +597,14 @@ hscOneShotCompiler = , hscBackend = \ tc_result mod_summary mb_old_hash -> do dflags <- getDynFlags case hscTarget dflags of - HscNothing -> return (HscRecomp False ()) + HscNothing -> return (HscRecomp Nothing ()) _otherw -> genericHscBackend hscOneShotCompiler tc_result mod_summary mb_old_hash , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface hscWriteIface iface changed mod_summary - return (HscRecomp False ()) + return (HscRecomp Nothing ()) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 @@ -647,7 +650,7 @@ hscBatchCompiler = , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do (iface, changed, details) <- hscSimpleIface tc_result mb_old_iface hscWriteIface iface changed mod_summary - return (HscRecomp False (), iface, details) + return (HscRecomp Nothing (), iface, details) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 @@ -679,7 +682,7 @@ hscInteractiveCompiler = , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface - return (HscRecomp False Nothing, iface, details) + return (HscRecomp Nothing Nothing, iface, details) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do guts <- hscSimplify' guts0 @@ -708,7 +711,7 @@ hscNothingCompiler = , hscBackend = \tc_result _mod_summary mb_old_iface -> do handleWarnings (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface - return (HscRecomp False (), iface, details) + return (HscRecomp Nothing (), iface, details) , hscGenBootOutput = \_ _ _ -> panic "hscCompileNothing: hscGenBootOutput should not be called" @@ -850,7 +853,7 @@ hscWriteIface iface no_change mod_summary -- | Compile to hard-code. hscGenHardCode :: CgGuts -> ModSummary - -> Hsc Bool -- ^ @True@ <=> stub.c exists + -> Hsc (Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode cgguts mod_summary = do hsc_env <- getHscEnv @@ -897,7 +900,7 @@ hscGenHardCode cgguts mod_summary -- unless certain dflags are on, the identity function ------------------ Code output ----------------------- rawcmms <- cmmToRawCmm cmms - dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr rawcmms) + dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (ppr rawcmms) (_stub_h_exists, stub_c_exists) <- codeOutput dflags this_mod location foreign_stubs dependencies rawcmms @@ -1075,8 +1078,17 @@ hscStmt -- Compile a stmt all the way to an HValue, but don't run it -> String -- The statement -> IO (Maybe ([Id], HValue)) -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error -hscStmt hsc_env stmt = runHsc hsc_env $ do - maybe_stmt <- hscParseStmt stmt +hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "" 1 + +hscStmtWithLocation -- Compile a stmt all the way to an HValue, but don't run it + :: HscEnv + -> String -- The statement + -> String -- the source + -> Int -- ^ starting line + -> IO (Maybe ([Id], HValue)) + -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error +hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do + maybe_stmt <- hscParseStmtWithLocation source linenumber stmt case maybe_stmt of Nothing -> return Nothing Just parsed_stmt -> do -- The real stuff @@ -1142,6 +1154,11 @@ hscKcType hsc_env str = runHsc hsc_env $ do hscParseStmt :: String -> Hsc (Maybe (LStmt RdrName)) hscParseStmt = hscParseThing parseStmt +hscParseStmtWithLocation :: String -> Int + -> String -> Hsc (Maybe (LStmt RdrName)) +hscParseStmtWithLocation source linenumber stmt = + hscParseThingWithLocation source linenumber parseStmt stmt + hscParseType :: String -> Hsc (LHsType RdrName) hscParseType = hscParseThing parseType #endif @@ -1150,19 +1167,24 @@ hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) hscParseIdentifier hsc_env str = runHsc hsc_env $ hscParseThing parseIdentifier str - hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing +hscParseThing = hscParseThingWithLocation "" 1 -hscParseThing parser str +hscParseThingWithLocation :: (Outputable thing) + => String -> Int + -> Lexer.P thing + -> String + -> Hsc thing +hscParseThingWithLocation source linenumber parser str = {-# SCC "Parser" #-} do dflags <- getDynFlags liftIO $ showPass dflags "Parser" - + let buf = stringToStringBuffer str - loc = mkSrcLoc (fsLit "") 1 1 + loc = mkSrcLoc (fsLit source) linenumber 1 case unP parser (mkPState dflags buf loc) of