X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=7e3aae25065f3690da869f1a2997abe2ea8ce944;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=74484b0a18152eb82eeb3e421238801a94d74077;hpb=0c53bd0e1b02dea0bde32cd7eb8ccb5ee2d3719e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 74484b0..7e3aae2 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 ) @@ -62,9 +62,10 @@ 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 SrcLoc ( srcLocSpan, Located(..), noLoc ) @@ -81,14 +82,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, mkMatchGroup, mkMatch, emptyLocalBinds, collectLStmtsBinders, collectLStmtBinders, nlVarPat, 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 +121,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 ) @@ -188,7 +190,7 @@ tcRnModule hsc_env hsc_src save_rn_decls 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 + Just emptyRnGroup else Nothing }) $ do { @@ -340,10 +342,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} @@ -687,7 +686,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, @@ -733,11 +732,9 @@ checkMain = do { ghci_mode <- getGhciMode ; 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 @@ -766,8 +763,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, @@ -936,8 +948,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 $ FunBind (L loc fresh_it) False matches emptyNameSet + matches = mkMatchGroup [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)) @@ -1024,7 +1037,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}