X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=a9c8f98d582242246bc5e33073ac3cda444f4eaf;hb=f1fdf769b432ca383b2033f5c973494905d225d1;hp=74484b0a18152eb82eeb3e421238801a94d74077;hpb=0c53bd0e1b02dea0bde32cd7eb8ccb5ee2d3719e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 74484b0..a9c8f98 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -29,11 +29,11 @@ import StaticFlags ( opt_PprStyle_Debug ) import Packages ( checkForPackageConflicts, mkHomeModules ) import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..), LHsBinds, - emptyGroup, appendGroups, + emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds, nlHsApp, nlHsVar, pprLHsBinds ) import RdrHsSyn ( findSplice ) -import PrelNames ( runMainIOName, rootMainName, mAIN, +import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN, main_RDR_Unqual ) import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv ) import TcHsSyn ( zonkTopDecls ) @@ -53,6 +53,7 @@ import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import LoadIface ( loadOrphanModules ) import RnNames ( importsFromLocalDecls, rnImports, rnExports, + mkRdrEnvAndImports, mkExportNameSet, reportUnusedNames, reportDeprecations ) import RnEnv ( lookupSrcOcc_maybe ) import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) @@ -62,11 +63,12 @@ import DataCon ( dataConWrapId ) import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( Id, mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) -import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, elemModuleEnv ) -import OccName ( mkVarOcc ) -import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName ) +import Module ( Module, ModuleEnv, moduleEnvElts, elemModuleEnv ) +import OccName ( mkVarOccFS ) +import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName, + mkExternalName ) import NameSet -import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind ) +import TyCon ( tyConHasGenerics, isSynTyCon, synTyConDefn, tyConKind ) import SrcLoc ( srcLocSpan, Located(..), noLoc ) import DriverPhases ( HscSource(..), isHsBoot ) import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails, @@ -81,14 +83,15 @@ import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails, import Outputable #ifdef GHCI -import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..), - LStmt, LHsExpr, LHsType, mkVarBind, +import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), + HsLocalBinds(..), HsValBinds(..), + LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds, collectLStmtsBinders, collectLStmtBinders, nlVarPat, - placeHolderType, noSyntaxExpr ) + mkFunBind, placeHolderType, noSyntaxExpr ) import RdrName ( GlobalRdrElt(..), globalRdrEnvElts, unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv ) import RnSource ( addTcgDUs ) -import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs ) +import TcHsSyn ( mkHsDictLet, zonkTopLExpr, zonkTopBndrs ) import TcHsType ( kcHsType ) import TcMType ( zonkTcType, zonkQuantifiedTyVar ) import TcMatches ( tcStmts, tcDoStmt ) @@ -119,8 +122,8 @@ import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName, import HscTypes ( InteractiveContext(..), ModIface(..), icPrintUnqual, Dependencies(..) ) -import BasicTypes ( RecFlag(..), Fixity ) -import SrcLoc ( unLoc, noSrcSpan ) +import BasicTypes ( Fixity, RecFlag(..) ) +import SrcLoc ( unLoc ) #endif import FastString ( mkFastString ) @@ -147,7 +150,7 @@ tcRnModule :: HscEnv -> Located (HsModule RdrName) -> IO (Messages, Maybe TcGblEnv) -tcRnModule hsc_env hsc_src save_rn_decls +tcRnModule hsc_env hsc_src save_rn_syntax (L loc (HsModule maybe_mod export_ies import_decls local_decls mod_deprec)) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; @@ -159,8 +162,9 @@ tcRnModule hsc_env hsc_src save_rn_decls initTc hsc_env hsc_src this_mod $ setSrcSpan loc $ do { - -- Deal with imports; sets tcg_rdr_env, tcg_imports - (rdr_env, imports) <- rnImports import_decls ; + -- Deal with imports; + rn_imports <- rnImports import_decls ; + (rdr_env, imports) <- mkRdrEnvAndImports rn_imports ; let { dep_mods :: ModuleEnv (Module, IsBootInterface) ; dep_mods = imp_dep_mods imports @@ -187,8 +191,12 @@ tcRnModule hsc_env hsc_src save_rn_decls gbl { tcg_rdr_env = rdr_env, tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, tcg_imports = tcg_imports gbl `plusImportAvails` imports, - tcg_rn_decls = if save_rn_decls then - Just emptyGroup + tcg_rn_imports = if save_rn_syntax then + Just rn_imports + else + Nothing, + tcg_rn_decls = if save_rn_syntax then + Just emptyRnGroup else Nothing }) $ do { @@ -221,7 +229,8 @@ tcRnModule hsc_env hsc_src save_rn_decls reportDeprecations tcg_env ; -- Process the export list - exports <- rnExports (isJust maybe_mod) export_ies ; + rn_exports <- rnExports export_ies ; + exports <- mkExportNameSet (isJust maybe_mod) rn_exports ; -- Check whether the entire module is deprecated -- This happens only once per module @@ -229,6 +238,9 @@ tcRnModule hsc_env hsc_src save_rn_decls -- Add exports and deprecations to envt let { final_env = tcg_env { tcg_exports = exports, + tcg_rn_exports = if save_rn_syntax then + rn_exports + else Nothing, tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports, tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs` mod_deprecs } @@ -340,10 +352,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) }}}} mkFakeGroup decls -- Rather clumsy; lots of unused fields - = HsGroup { hs_tyclds = decls, -- This is the one we want - hs_valds = [], hs_fords = [], - hs_instds = [], hs_fixds = [], hs_depds = [], - hs_ruleds = [], hs_defds = [] } + = emptyRdrGroup { hs_tyclds = decls } \end{code} @@ -387,6 +396,7 @@ tcRnSrcDecls decls TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, tcg_rules = rules, tcg_fords = fords } = tcg_env } ; + tcDump tcg_env ; (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds) rules fords ; @@ -561,8 +571,8 @@ check_thing (ATyCon boot_tc) (ATyCon real_tc) | tyConKind boot_tc == tyConKind real_tc = return () where - (tvs1, defn1) = getSynTyConDefn boot_tc - (tvs2, defn2) = getSynTyConDefn boot_tc + (tvs1, defn1) = synTyConDefn boot_tc + (tvs2, defn2) = synTyConDefn boot_tc check_thing (AnId boot_id) (AnId real_id) | idType boot_id `tcEqType` idType real_id @@ -687,7 +697,7 @@ tcTopSrcDecls boot_details -- We also typecheck any extra binds that came out -- of the "deriving" process (deriv_binds) traceTc (text "Tc5") ; - (tc_val_binds, tcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ; + (tc_val_binds, tcl_env) <- tcTopBinds (val_binds `plusHsValBinds` deriv_binds) ; setLclTypeEnv tcl_env $ do { -- Second pass over class and instance declarations, @@ -730,21 +740,19 @@ tcTopSrcDecls boot_details checkMain :: TcM TcGblEnv -- If we are in module Main, check that 'main' is defined. checkMain - = do { ghci_mode <- getGhciMode ; + = do { ghc_mode <- getGhcMode ; tcg_env <- getGblEnv ; dflags <- getDOpts ; - let { main_mod = case mainModIs dflags of { - Just mod -> mkModule mod ; - Nothing -> mAIN } ; + let { main_mod = mainModIs dflags ; main_fn = case mainFunIs dflags of { - Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ; + Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ; Nothing -> main_RDR_Unqual } } ; - check_main ghci_mode tcg_env main_mod main_fn + check_main ghc_mode tcg_env main_mod main_fn } -check_main ghci_mode tcg_env main_mod main_fn +check_main ghc_mode tcg_env main_mod main_fn | mod /= main_mod = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >> return tcg_env @@ -766,8 +774,23 @@ check_main ghci_mode tcg_env main_mod main_fn ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $ tcInferRho rhs - ; let { root_main_id = mkExportedLocalId rootMainName ty ; - main_bind = noLoc (VarBind root_main_id main_expr) } + -- The function that the RTS invokes is always :Main.main, + -- which we call root_main_id. + -- (Because GHC allows the user to have a module not called + -- Main as the main module, we can't rely on the main function + -- being called "Main.main". That's why root_main_id has a fixed + -- module ":Main".) + -- We also make root_main_id an implicit Id, by making main_name + -- its parent (hence (Just main_name)). That has the effect + -- of preventing its type and unfolding from getting out into + -- the interface file. Otherwise we can end up with two defns + -- for 'main' in the interface file! + + ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN + (mkVarOccFS FSLIT("main")) + (Just main_name) (getSrcLoc main_name) + ; root_main_id = mkExportedLocalId root_main_name ty + ; main_bind = noLoc (VarBind root_main_id main_expr) } ; return (tcg_env { tcg_binds = tcg_binds tcg_env `snocBag` main_bind, @@ -780,7 +803,7 @@ check_main ghci_mode tcg_env main_mod main_fn where mod = tcg_mod tcg_env - complain_no_main | ghci_mode == Interactive = return () + complain_no_main | ghc_mode == Interactive = return () | otherwise = failWithTc noMainMsg -- In interactive mode, don't worry about the absence of 'main' -- In other modes, fail altogether, so that we don't go on @@ -936,8 +959,9 @@ mkPlan :: LStmt Name -> TcM PlanResult mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt = do { uniq <- newUnique -- is treated very specially ; let fresh_it = itName uniq - the_bind = mkVarBind noSrcSpan fresh_it expr - let_stmt = L loc $ LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive] + the_bind = L loc $ mkFunBind (L loc fresh_it) matches + matches = [mkMatch [] expr emptyLocalBinds] + let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] [])) bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr (HsVar bindIOName) noSyntaxExpr print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) @@ -1015,7 +1039,7 @@ tcGhciStmts stmts -- OK, we're ready to typecheck the stmts traceTc (text "tcs 2") ; ((tc_stmts, ids), lie) <- getLIE $ - tcStmts DoExpr (tcDoStmt io_ty io_ret_ty) stmts $ + tcStmts DoExpr (tcDoStmt io_ty) stmts io_ret_ty $ \ _ -> mappM tcLookupId names ; -- Look up the names right in the middle, -- where they will all be in scope @@ -1024,7 +1048,7 @@ tcGhciStmts stmts const_binds <- checkNoErrs (tcSimplifyInteractive lie) ; -- checkNoErrs ensures that the plan fails if context redn fails - return (ids, mkHsLet const_binds $ + return (ids, mkHsDictLet const_binds $ noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty)) } \end{code}