X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcModule.lhs;h=eea3a2198f9b5173643145b16e836d1f96164c68;hb=0f95e0dc069bc8406986b2129c086c6698f5dc4e;hp=f6c9f6493c9b6fb351ffaa436c7786da1c489f99;hpb=eb29a057feb42c082896ff9a28831a12aec0b9ee;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index f6c9f64..eea3a21 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -6,17 +6,18 @@ \begin{code} module TcModule ( typecheckModule, typecheckIface, typecheckStmt, typecheckExpr, + typecheckExtraDecls, TcResults(..) ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlag(..), DynFlags ) +import CmdLineOpts ( DynFlag(..), DynFlags, dopt ) import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..), - Stmt(..), InPat(..), HsMatchContext(..), RuleDecl(..), - isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch + Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..), + isIfaceRuleDecl, nullBinds, mkSimpleMatch, placeHolderType ) -import PrelNames ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName, +import PrelNames ( mAIN_Name, mainName, ioTyConName, printName, returnIOName, bindIOName, failIOName, itName ) @@ -32,9 +33,12 @@ import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr, import MkIface ( pprModDetails ) import TcExpr ( tcMonoExpr ) import TcMonad -import TcType ( newTyVarTy, zonkTcType, tcInstType ) +import TcMType ( newTyVarTy, zonkTcType, tcInstType ) +import TcType ( Type, liftedTypeKind, openTypeKind, + tyVarsOfType, tidyType, tcFunResultTy, + mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys + ) import TcMatches ( tcStmtsAndThen ) -import TcUnify ( unifyTauTy ) import Inst ( emptyLIE, plusLIE ) import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2 ) @@ -48,30 +52,28 @@ import TcRules ( tcIfaceRules, tcSourceRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcIfaceSig ( tcInterfaceSigs ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) +import TcUnify ( unifyTauTy ) import TcSimplify ( tcSimplifyTop, tcSimplifyInfer ) import TcTyClsDecls ( tcTyAndClassDecls ) - -import CoreUnfold ( unfoldingTemplate, hasUnfolding ) +import CoreUnfold ( unfoldingTemplate ) import TysWiredIn ( mkListTy, unitTy ) -import Type import ErrUtils ( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, dumpIfSet_dyn_or, showPass ) import Id ( Id, idType, idUnfolding ) import Module ( Module, moduleName ) import Name ( Name ) -import NameEnv ( nameEnvElts, lookupNameEnv ) +import NameEnv ( lookupNameEnv ) import TyCon ( tyConGenInfo ) import BasicTypes ( EP(..), Fixity, RecFlag(..) ) import SrcLoc ( noSrcLoc ) import Outputable +import IO ( stdout ) import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, PackageTypeEnv, ModIface(..), ModDetails(..), DFunId, - TypeEnv, extendTypeEnvList, - TyThing(..), implicitTyThingIds, + TypeEnv, extendTypeEnvList, typeEnvTyCons, typeEnvElts, mkTypeEnv ) -import VarSet \end{code} @@ -90,8 +92,7 @@ typecheckStmt -> PrintUnqualified -- For error printing -> Module -- Is this really needed -> [Name] -- Names bound by the Stmt (empty for expressions) - -> (SyntaxMap, - RenamedStmt, -- The stmt itself + -> (RenamedStmt, -- The stmt itself [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, @@ -100,8 +101,8 @@ typecheckStmt -- The returned [Id] is the same as the input except for -- ExprStmt, in which case the returned [Name] is [itName] -typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (syn_map, stmt, iface_decls) - = typecheck dflags syn_map pcs hst unqual $ +typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (stmt, iface_decls) + = typecheck dflags pcs hst unqual $ -- use the default default settings, i.e. [Integer, Double] tcSetDefaultTys defaultDefaultTys $ @@ -157,15 +158,20 @@ Here is the grand plan, implemented in tcUserStmt \begin{code} tcUserStmt :: [Name] -> RenamedStmt -> TcM (TypecheckedHsExpr, [Id]) -tcUserStmt names (ExprStmt expr loc) +tcUserStmt names (ExprStmt expr _ loc) = ASSERT( null names ) + tcGetUnique `thenNF_Tc` \ uniq -> + let + fresh_it = itName uniq + the_bind = FunMonoBind fresh_it False + [ mkSimpleMatch [] expr placeHolderType loc ] loc + in tryTc_ (traceTc (text "tcs 1b") `thenNF_Tc_` - tc_stmts [itName] [LetStmt (MonoBind the_bind [] NonRecursive), - ExprStmt (HsApp (HsVar printName) (HsVar itName)) loc]) + tc_stmts [fresh_it] [ + LetStmt (MonoBind the_bind [] NonRecursive), + ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) placeHolderType loc]) ( traceTc (text "tcs 1a") `thenNF_Tc_` - tc_stmts [itName] [BindStmt (VarPatIn itName) expr loc]) - where - the_bind = FunMonoBind itName False [mkSimpleMatch [] expr Nothing loc] loc + tc_stmts [fresh_it] [BindStmt (VarPatIn fresh_it) expr loc]) tcUserStmt names stmt = tc_stmts names [stmt] @@ -183,18 +189,18 @@ tc_stmts names stmts -- mk_return builds the expression -- returnIO @ [()] [coerce () x, .., coerce () z] mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy]) - (ExplicitListOut unitTy (map mk_item ids)) + (ExplicitList unitTy (map mk_item ids)) mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy]) (HsVar id) in traceTc (text "tcs 2") `thenNF_Tc_` - tcStmtsAndThen combine DoExpr io_ty stmts ( + tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts ( -- Look up the names right in the middle, -- where they will all be in scope mapNF_Tc tcLookupId names `thenNF_Tc` \ ids -> - returnTc ((ids, [ExprStmt (mk_return ids) noSrcLoc]), emptyLIE) + returnTc ((ids, [ResultStmt (mk_return ids) noSrcLoc]), emptyLIE) ) `thenTc` \ ((ids, tc_stmts), lie) -> -- Simplify the context right here, so that we fail @@ -229,16 +235,15 @@ typecheckExpr :: DynFlags -> TypeEnv -- The interactive context's type envt -> PrintUnqualified -- For error printing -> Module - -> (SyntaxMap, - RenamedHsExpr, -- The expression itself + -> (RenamedHsExpr, -- The expression itself [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, [Id], -- always empty (matches typecheckStmt) Type)) -typecheckExpr dflags pcs hst ic_type_env unqual this_mod (syn_map, expr, decls) - = typecheck dflags syn_map pcs hst unqual $ +typecheckExpr dflags pcs hst ic_type_env unqual this_mod (expr, decls) + = typecheck dflags pcs hst unqual $ -- use the default default settings, i.e. [Integer, Double] tcSetDefaultTys defaultDefaultTys $ @@ -255,8 +260,8 @@ typecheckExpr dflags pcs hst ic_type_env unqual this_mod (syn_map, expr, decls) newTyVarTy openTypeKind `thenTc` \ ty -> tcMonoExpr expr ty `thenTc` \ (e', lie) -> - tcSimplifyInfer smpl_doc (varSetElems (tyVarsOfType ty)) lie - `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) -> + tcSimplifyInfer smpl_doc (tyVarsOfType ty) lie + `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) -> tcSimplifyTop lie_free `thenTc` \ const_binds -> let all_expr = mkHsLet const_binds $ @@ -285,6 +290,33 @@ typecheckExpr dflags pcs hst ic_type_env unqual this_mod (syn_map, expr, decls) %************************************************************************ %* * +\subsection{Typechecking extra declarations} +%* * +%************************************************************************ + +\begin{code} +typecheckExtraDecls + :: DynFlags + -> PersistentCompilerState + -> HomeSymbolTable + -> PrintUnqualified -- For error printing + -> Module -- Is this really needed + -> [RenamedHsDecl] -- extra decls sucked in from interface files + -> IO (Maybe PersistentCompilerState) + +typecheckExtraDecls dflags pcs hst unqual this_mod decls + = typecheck dflags pcs hst unqual $ + fixTc (\ ~(unf_env, _, _, _, _) -> + tcImports unf_env pcs hst get_fixity this_mod decls + ) `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) -> + ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules ) + returnTc new_pcs + where + get_fixity n = pprPanic "typecheckExpr" (ppr n) +\end{code} + +%************************************************************************ +%* * \subsection{Typechecking a module} %* * %************************************************************************ @@ -296,7 +328,7 @@ typecheckModule -> HomeSymbolTable -> ModIface -- Iface for this module -> PrintUnqualified -- For error printing - -> (SyntaxMap, [RenamedHsDecl]) + -> [RenamedHsDecl] -> IO (Maybe (PersistentCompilerState, TcResults)) -- The new PCS is Augmented with imported information, -- (but not stuff from this module) @@ -312,10 +344,10 @@ data TcResults } -typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls) - = do { maybe_tc_result <- typecheck dflags syn_map pcs hst unqual $ +typecheckModule dflags pcs hst mod_iface unqual decls + = do { maybe_tc_result <- typecheck dflags pcs hst unqual $ tcModule pcs hst get_fixity this_mod decls - ; printTcDump dflags maybe_tc_result + ; printTcDump dflags unqual maybe_tc_result ; return maybe_tc_result } where this_mod = mi_module mod_iface @@ -334,7 +366,7 @@ tcModule :: PersistentCompilerState tcModule pcs hst get_fixity this_mod decls = fixTc (\ ~(unf_env, _, _) -> - -- Loop back the final environment, including the fully zonkec + -- Loop back the final environment, including the fully zonked -- versions of bindings from this module. In the presence of mutual -- recursion, interface type signatures may mention variables defined -- in this module, which is why the knot is so big @@ -363,8 +395,9 @@ tcModule pcs hst get_fixity this_mod decls -- Second pass over class and instance declarations, -- plus rules and foreign exports, to generate bindings tcSetEnv env $ + tcClassDecls2 this_mod tycl_decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds, dm_ids) -> + tcExtendGlobalValEnv dm_ids $ tcInstDecls2 local_insts `thenNF_Tc` \ (lie_instdecls, inst_binds) -> - tcClassDecls2 this_mod tycl_decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) -> tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) -> tcSourceRules source_rules `thenNF_Tc` \ (lie_rules, more_local_rules) -> @@ -394,6 +427,7 @@ tcModule pcs hst get_fixity this_mod decls lie_rules in tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds -> + traceTc (text "endsimpltop") `thenTc_` -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. @@ -414,17 +448,7 @@ tcModule pcs hst get_fixity this_mod decls zonkRules more_local_rules `thenNF_Tc` \ more_local_rules' -> - let local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env)) - - -- Create any necessary "implicit" bindings (data constructors etc) - -- Should we create bindings for dictionary constructors? - -- They are always fully applied, and the bindings are just there - -- to support partial applications. But it's easier to let them through. - implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf) - | id <- implicitTyThingIds local_things - , let unf = idUnfolding id - , hasUnfolding unf - ] + let local_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env)) local_type_env :: TypeEnv local_type_env = mkTypeEnv local_things @@ -436,7 +460,7 @@ tcModule pcs hst get_fixity this_mod decls new_pcs, TcResults { tc_env = local_type_env, tc_insts = map iDFunId local_insts, - tc_binds = implicit_binds `AndMonoBinds` all_binds', + tc_binds = all_binds', tc_fords = foi_decls ++ foe_decls', tc_rules = all_local_rules } @@ -462,13 +486,13 @@ typecheckIface -> PersistentCompilerState -> HomeSymbolTable -> ModIface -- Iface for this module (just module & fixities) - -> (SyntaxMap, [RenamedHsDecl]) + -> [RenamedHsDecl] -> IO (Maybe (PersistentCompilerState, ModDetails)) -- The new PCS is Augmented with imported information, -- (but not stuff from this module). -typecheckIface dflags pcs hst mod_iface (syn_map, decls) - = do { maybe_tc_stuff <- typecheck dflags syn_map pcs hst alwaysQualify $ +typecheckIface dflags pcs hst mod_iface decls + = do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $ tcIfaceImports pcs hst get_fixity this_mod decls ; printIfaceDump dflags maybe_tc_stuff ; return maybe_tc_stuff } @@ -486,7 +510,7 @@ typecheckIface dflags pcs hst mod_iface (syn_map, decls) deriv_binds, local_rules) -> ASSERT(nullBinds deriv_binds) let - local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv env)) + local_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv env)) mod_details = ModDetails { md_types = mkTypeEnv local_things, md_insts = map iDFunId local_inst_info, @@ -525,36 +549,37 @@ tcImports unf_env pcs hst get_fixity this_mod decls -- tcImports recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade - traceTc (text "Tc1") `thenNF_Tc_` - tcTyAndClassDecls unf_env tycl_decls `thenTc` \ env -> - tcSetEnv env $ + traceTc (text "Tc1") `thenNF_Tc_` + tcTyAndClassDecls unf_env this_mod tycl_decls `thenTc` \ env -> + tcSetEnv env $ + + -- Interface type signatures + -- We tie a knot so that the Ids read out of interfaces are in scope + -- when we read their pragmas. + -- What we rely on is that pragmas are typechecked lazily; if + -- any type errors are found (ie there's an inconsistency) + -- we silently discard the pragma + traceTc (text "Tc2") `thenNF_Tc_` + tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids -> + tcExtendGlobalValEnv sig_ids $ -- Typecheck the instance decls, includes deriving - traceTc (text "Tc2") `thenNF_Tc_` + -- Note that imported dictionary functions are already + -- in scope from the preceding tcInterfaceSigs + traceTc (text "Tc3") `thenNF_Tc_` tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs) hst unf_env get_fixity this_mod decls `thenTc` \ (new_pcs_insts, inst_env, local_insts, deriv_binds) -> tcSetInstEnv inst_env $ - -- Interface type signatures - -- We tie a knot so that the Ids read out of interfaces are in scope - -- when we read their pragmas. - -- What we rely on is that pragmas are typechecked lazily; if - -- any type errors are found (ie there's an inconsistency) - -- we silently discard the pragma - traceTc (text "Tc3") `thenNF_Tc_` - tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids -> - tcExtendGlobalValEnv sig_ids $ - - - tcIfaceRules (pcs_rules pcs) this_mod iface_rules `thenNF_Tc` \ (new_pcs_rules, local_rules) -> + tcIfaceRules unf_env (pcs_rules pcs) this_mod iface_rules `thenNF_Tc` \ (new_pcs_rules, local_rules) -> -- When relinking this module from its interface-file decls -- we'll have IfaceRules that are in fact local to this module -- That's the reason we we get any local_rules out here tcGetEnv `thenTc` \ unf_env -> let - all_things = nameEnvElts (getTcGEnv unf_env) + all_things = typeEnvElts (getTcGEnv unf_env) -- sometimes we're compiling in the context of a package module -- (on the GHCi command line, for example). In this case, we @@ -638,16 +663,15 @@ noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name), \begin{code} typecheck :: DynFlags - -> SyntaxMap -> PersistentCompilerState -> HomeSymbolTable -> PrintUnqualified -- For error printing -> TcM r -> IO (Maybe r) -typecheck dflags syn_map pcs hst unqual thing_inside +typecheck dflags pcs hst unqual thing_inside = do { showPass dflags "Typechecker"; - ; env <- initTcEnv syn_map hst (pcs_PTE pcs) + ; env <- initTcEnv hst (pcs_PTE pcs) ; (maybe_tc_result, errs) <- initTc dflags env thing_inside @@ -668,10 +692,11 @@ typecheck dflags syn_map pcs hst unqual thing_inside %************************************************************************ \begin{code} -printTcDump dflags Nothing = return () -printTcDump dflags (Just (_, results)) - = do dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc] - "Interface" (dump_tc_iface results) +printTcDump dflags unqual Nothing = return () +printTcDump dflags unqual (Just (_, results)) + = do if dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags then + printForUser stdout unqual (dump_tc_iface dflags results) + else return () dumpIfSet_dyn dflags Opt_D_dump_tc "Typechecked" (ppr (tc_binds results)) @@ -682,13 +707,16 @@ printIfaceDump dflags (Just (_, details)) = dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc] "Interface" (pprModDetails details) -dump_tc_iface results +dump_tc_iface dflags results = vcat [pprModDetails (ModDetails {md_types = tc_env results, md_insts = tc_insts results, md_rules = [], md_binds = []}) , ppr_rules (tc_rules results), - ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)] + if dopt Opt_Generics dflags then + ppr_gen_tycons (typeEnvTyCons (tc_env results)) + else + empty ] ppr_rules [] = empty @@ -709,11 +737,10 @@ ppr_gen_tycon tycon | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable") ppr_ep (EP from to) - = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau), + = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau), ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)), ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to)) ] where - (_,from_tau) = splitForAllTys (idType from) - + (_,from_tau) = tcSplitForAllTys (idType from) \end{code}