From 937b23b94b458172442ac583f8d5b6f5a093a24b Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 4 Feb 1999 13:45:39 +0000 Subject: [PATCH] [project @ 1999-02-04 13:45:24 by simonpj] a) Fix black hole bug when doing -dshow-rn-trace (Involved reorganising where fixity exports are dealt with in RnNames/RnIfaces.) b) Arrange to apply Lint to imported unfoldings when -dcore-lint c) Add -fwarn-type-defaults to report use of the defaulting rules for types d) Make it so that f (error "help) --> error "help", if f is strict (Changes in Simplify.lhs.) --- ghc/compiler/basicTypes/Var.lhs | 20 ++++-- ghc/compiler/coreSyn/CoreLint.lhs | 31 +++++---- ghc/compiler/main/CmdLineOpts.lhs | 3 + ghc/compiler/rename/RnIfaces.lhs | 25 ++++++-- ghc/compiler/rename/RnNames.lhs | 112 +++++++++++++++------------------ ghc/compiler/simplCore/SimplCore.lhs | 2 +- ghc/compiler/simplCore/SimplUtils.lhs | 4 +- ghc/compiler/simplCore/Simplify.lhs | 40 +++++++----- ghc/compiler/typecheck/TcBinds.lhs | 104 ++++++++++++++++++++++-------- ghc/compiler/typecheck/TcEnv.lhs | 7 ++- ghc/compiler/typecheck/TcIfaceSig.lhs | 16 +++-- ghc/compiler/typecheck/TcModule.lhs | 57 ++++------------- ghc/compiler/typecheck/TcSimplify.lhs | 24 ++++++- 13 files changed, 261 insertions(+), 184 deletions(-) diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index 6bf3a88..e5c820d 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -150,12 +150,24 @@ setTyVarName = setVarName \begin{code} mkTyVar :: Name -> Kind -> TyVar -mkTyVar name kind = Var { varName = name, realUnique = getKey (nameUnique name), - varType = kind, varDetails = TyVar } +mkTyVar name kind = Var { varName = name + , realUnique = getKey (nameUnique name) + , varType = kind + , varDetails = TyVar +#ifdef DEBUG + , varInfo = pprPanic "mkTyVar" (ppr name) +#endif + } mkSysTyVar :: Unique -> Kind -> TyVar -mkSysTyVar uniq kind = Var { varName = name, realUnique = getKey uniq, - varType = kind, varDetails = TyVar } +mkSysTyVar uniq kind = Var { varName = name + , realUnique = getKey uniq + , varType = kind + , varDetails = TyVar +#ifdef DEBUG + , varInfo = pprPanic "mkSysTyVar" (ppr name) +#endif + } where name = mkSysLocalName uniq SLIT("t") diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 2f278b2..2e79cc7 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -21,7 +21,7 @@ import CoreUtils ( idFreeVars ) import Bag import Const ( Con(..), DataCon, conType, conOkForApp, conOkForAlt ) import Id ( isConstantId, idMustBeINLINEd ) -import Var ( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar ) +import Var ( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar, isId ) import VarSet import VarEnv ( mkVarEnv ) import Name ( isLocallyDefined, getSrcLoc ) @@ -147,11 +147,20 @@ We use this to check all unfoldings that come in from interfaces (it is very painful to catch errors otherwise): \begin{code} -lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr +lintUnfolding :: SrcLoc + -> [IdOrTyVar] -- Treat these as in scope + -> CoreExpr + -> Maybe CoreExpr -lintUnfolding locn expr +lintUnfolding locn vars expr + | not opt_DoCoreLinting + = Just expr + + | otherwise = case - initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr)) + initL (addLoc (ImportedUnfolding locn) $ + addInScopeVars vars $ + lintCoreExpr expr) of Nothing -> Just expr Just msg -> @@ -560,13 +569,13 @@ checkBndrIdInScope binder id ppr binder checkInScope :: SDoc -> IdOrTyVar -> LintM () -checkInScope loc_msg id loc scope errs - | isLocallyDefined id - && not (id `elemVarSet` scope) - && not (idMustBeINLINEd id) -- Constructors and dict selectors - -- don't have bindings, - -- just MustInline prags - = (Nothing, addErr errs (hsep [ppr id, loc_msg]) loc) +checkInScope loc_msg var loc scope errs + | isLocallyDefined var + && not (var `elemVarSet` scope) + && not (isId var && idMustBeINLINEd var) -- Constructors and dict selectors + -- don't have bindings, + -- just MustInline prags + = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc) | otherwise = (Nothing,errs) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 494857a..8bf17a6 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -91,6 +91,7 @@ module CmdLineOpts ( opt_UnfoldingKeenessFactor, opt_Verbose, + opt_WarnNameShadowing, opt_WarnUnusedMatches, opt_WarnUnusedBinds, @@ -98,6 +99,7 @@ module CmdLineOpts ( opt_WarnIncompletePatterns, opt_WarnOverlappingPatterns, opt_WarnSimplePatterns, + opt_WarnTypeDefaults, opt_WarnMissingMethods, opt_WarnDuplicateExports, opt_WarnHiShadows, @@ -352,6 +354,7 @@ opt_WarnHiShadows = lookUp SLIT("-fwarn-hi-shadowing") opt_WarnIncompletePatterns = lookUp SLIT("-fwarn-incomplete-patterns") opt_WarnOverlappingPatterns = lookUp SLIT("-fwarn-overlapping-patterns") opt_WarnSimplePatterns = lookUp SLIT("-fwarn-simple-patterns") +opt_WarnTypeDefaults = lookUp SLIT("-fwarn-type-defaults") opt_WarnUnusedMatches = lookUp SLIT("-fwarn-unused-matches") opt_WarnUnusedBinds = lookUp SLIT("-fwarn-unused-binds") opt_WarnUnusedImports = lookUp SLIT("-fwarn-unused-imports") diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 5010eed..5baa12f 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -11,7 +11,7 @@ module RnIfaces ( importDecl, recordSlurp, getImportVersions, getSlurpedNames, getRnStats, getImportedFixities, - checkUpToDate, loadHomeInterface, + checkUpToDate, getDeclBinders, mkSearchPath @@ -72,7 +72,6 @@ import Outputable import IO ( isDoesNotExistError ) import List ( nub ) - \end{code} @@ -784,10 +783,26 @@ getSpecialInstModules = getIfacesRn `thenRn` \ ifaces -> returnRn (iInstMods ifaces) -getImportedFixities :: RnMG FixityEnv -getImportedFixities - = getIfacesRn `thenRn` \ ifaces -> +getImportedFixities :: GlobalRdrEnv -> RnMG FixityEnv + -- Get all imported fixities + -- We first make sure that all the home modules + -- of all in-scope variables are loaded. +getImportedFixities gbl_env + = let + home_modules = [ nameModule name | names <- rdrEnvElts gbl_env, + name <- names, + not (isLocallyDefined name) + ] + in + mapRn load (nub home_modules) `thenRn_` + + -- Now we can snaffle the fixity env + getIfacesRn `thenRn` \ ifaces -> returnRn (iFixes ifaces) + where + load mod = loadInterface doc_str mod + where + doc_str = ptext SLIT("Need fixities from") <+> ppr mod \end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 926fd59..2eb5a8d 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -24,7 +24,7 @@ import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsModule, RdrNameHsDecl ) import RnIfaces ( getInterfaceExports, getDeclBinders, getImportedFixities, - recordSlurp, checkUpToDate, loadHomeInterface + recordSlurp, checkUpToDate ) import RnEnv import RnMonad @@ -42,7 +42,6 @@ import NameSet ( elemNameSet, emptyNameSet ) import Outputable import Unique ( getUnique ) import Util ( removeDups, equivClassesByUniq, sortLt ) -import List ( nubBy ) \end{code} @@ -65,12 +64,15 @@ getGlobalNames :: RdrNameHsModule getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) = -- These two fix-loops are to get the right -- provenance information into a Name - fixRn (\ ~(rec_exp_fn, _) -> + fixRn (\ ~(rec_exported_avails, _) -> fixRn (\ ~(rec_rn_env, _) -> let rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified? rec_unqual_fn = unQualInScope rec_rn_env + + rec_exp_fn :: Name -> ExportFlag + rec_exp_fn = mk_export_fn (availsToNameSet rec_exported_avails) in setOmitQualFn rec_unqual_fn $ setModuleRn this_mod $ @@ -91,11 +93,11 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) imp_gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv imp_gbl_envs gbl_env = imp_gbl_env `plusGlobalRdrEnv` local_gbl_env - export_avails :: ExportAvails - export_avails = foldr plusExportAvails local_mod_avails imp_avails_s + all_avails :: ExportAvails + all_avails = foldr plusExportAvails local_mod_avails imp_avails_s in - returnRn (gbl_env, export_avails) - ) `thenRn` \ (gbl_env, export_avails) -> + returnRn (gbl_env, all_avails) + ) `thenRn` \ (gbl_env, all_avails) -> -- TRY FOR EARLY EXIT -- We can't go for an early exit before this because we have to check @@ -117,23 +119,42 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc) returnRn (junk_exp_fn, Nothing) else - -- FIXITIES - fixitiesFromLocalDecls gbl_env decls `thenRn` \ local_fixity_env -> - getImportedFixities `thenRn` \ imp_fixity_env -> - let - fixity_env = imp_fixity_env `plusNameEnv` local_fixity_env - rn_env = RnEnv gbl_env fixity_env - (_, global_avail_env) = export_avails - in - traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts fixity_env))) `thenRn_` - -- PROCESS EXPORT LISTS - exportsFromAvail this_mod exports export_avails rn_env `thenRn` \ (export_fn, export_env) -> + exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ exported_avails -> -- DONE - returnRn (export_fn, Just (export_env, rn_env, global_avail_env)) - ) `thenRn` \ (_, result) -> - returnRn result + returnRn (exported_avails, Just (all_avails, gbl_env)) + ) `thenRn` \ (exported_avails, maybe_stuff) -> + + case maybe_stuff of { + Nothing -> returnRn Nothing ; + Just (all_avails, gbl_env) -> + + + -- DEAL WITH FIXITIES + fixitiesFromLocalDecls gbl_env decls `thenRn` \ local_fixity_env -> + getImportedFixities gbl_env `thenRn` \ imp_fixity_env -> + let + -- Export only those fixities that are for names that are + -- (a) defined in this module + -- (b) exported + exported_fixities :: [(Name,Fixity)] + exported_fixities = [(name,fixity) | FixitySig name fixity _ <- nameEnvElts local_fixity_env, + isLocallyDefined name + ] + + fixity_env = imp_fixity_env `plusNameEnv` local_fixity_env + in + traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts fixity_env))) `thenRn_` + + --- TIDY UP + let + export_env = ExportEnv exported_avails exported_fixities + rn_env = RnEnv gbl_env fixity_env + (_, global_avail_env) = all_avails + in + returnRn (Just (export_env, rn_env, global_avail_env)) + } where junk_exp_fn = error "RnNames:export_fn" @@ -198,26 +219,6 @@ importsFromImportDecl (ImportDecl imp_mod qual_only as_mod import_spec iloc) filterImports imp_mod import_spec avails `thenRn` \ (filtered_avails, hides, explicits) -> - -- Load all the home modules for the things being - -- bought into scope. This makes sure their fixities - -- are loaded before we grab the FixityEnv from Ifaces - let - home_modules = [name | avail <- filtered_avails, - -- Doesn't take account of hiding, but that doesn't matter - - let name = availName avail, - not (isLocallyDefined name || nameModule name == imp_mod) - -- Don't try to load the module being compiled - -- (this can happen in mutual-recursion situations) - -- or from the module being imported (it's already loaded) - ] - - same_module n1 n2 = nameModule n1 == nameModule n2 - load n = loadHomeInterface (doc_str n) n - doc_str n = ptext SLIT("Need fixities from") <+> ppr (nameModule n) <+> parens (ppr n) - in - mapRn load (nubBy same_module home_modules) `thenRn_` - -- We 'improve' the provenance by setting -- (a) the import-reason field, so that the Name says how it came into scope -- including whether it's explicitly imported @@ -515,40 +516,25 @@ type ExportOccMap = FiniteMap OccName (Name, RdrNameIE) exportsFromAvail :: Module -> Maybe [RdrNameIE] -- Export spec -> ExportAvails - -> RnEnv - -> RnMG (Name -> ExportFlag, ExportEnv) + -> GlobalRdrEnv + -> RnMG Avails -- Complains if two distinct exports have same OccName -- Warns about identical exports. -- Complains about exports items not in scope -exportsFromAvail this_mod Nothing export_avails rn_env - = exportsFromAvail this_mod (Just [IEModuleContents this_mod]) export_avails rn_env +exportsFromAvail this_mod Nothing export_avails global_name_env + = exportsFromAvail this_mod (Just [IEModuleContents this_mod]) + export_avails global_name_env exportsFromAvail this_mod (Just export_items) (mod_avail_env, entity_avail_env) - (RnEnv global_name_env fixity_env) + global_name_env = foldlRn exports_from_item ([], emptyFM, emptyNameEnv) export_items `thenRn` \ (_, _, export_avail_map) -> let export_avails :: [AvailInfo] export_avails = nameEnvElts export_avail_map - - export_names :: NameSet - export_names = availsToNameSet export_avails - - -- Export only those fixities that are for names that are - -- (a) defined in this module - -- (b) exported - export_fixities :: [(Name,Fixity)] - export_fixities = [ (name,fixity) - | FixitySig name fixity _ <- nameEnvElts fixity_env, - name `elemNameSet` export_names, - isLocallyDefined name - ] - - export_fn :: Name -> ExportFlag - export_fn = mk_export_fn export_names in - returnRn (export_fn, ExportEnv export_avails export_fixities) + returnRn export_avails where exports_from_item :: ExportAccum -> RdrNameIE -> RnMG ExportAccum diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index f0b4b72..97e38a3 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -50,7 +50,7 @@ import PrelInfo ( unpackCStringId, unpackCString2Id, int2IntegerId, addr2IntegerId ) import Type ( Type, splitAlgTyConApp_maybe, - isUnLiftedType, mkTyVarTy, + isUnLiftedType, tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars, Type ) diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 6c5d53d..9c5c647 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -30,8 +30,8 @@ import Maybes ( maybeToBool ) import Const ( Con(..) ) import Name ( isLocalName ) import SimplMonad -import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, mkTyVarTys, - splitTyConApp_maybe, mkTyVarTy, substTyVar +import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, + splitTyConApp_maybe, substTyVar, mkTyVarTys ) import Var ( setVarUnique ) import VarSet diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 39ff605..d4063e2 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -1032,7 +1032,13 @@ rebuild :: OutExpr -> SimplCont -> SimplM OutExprStuff rebuild expr cont = tick LeavesExamined `thenSmpl_` - do_rebuild expr cont + case expr of + Var v -> case getIdStrictness v of + NoStrictnessInfo -> do_rebuild expr cont + StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot ) + -- If this happened we'd get an infinite loop + rebuild_strict demands result_bot expr (idType v) cont + other -> do_rebuild expr cont rebuild_done expr = getInScope `thenSmpl` \ in_scope -> @@ -1053,16 +1059,8 @@ do_rebuild expr (ArgOf _ cont_fn _) = cont_fn expr -- ApplyTo continuation do_rebuild expr cont@(ApplyTo _ arg se cont') - = case expr of - Var v -> case getIdStrictness v of - NoStrictnessInfo -> non_strict_case - StrictnessInfo demands result_bot _ -> ASSERT( not (null demands) || result_bot ) - -- If this happened we'd get an infinite loop - rebuild_strict demands result_bot expr (idType v) cont - other -> non_strict_case - where - non_strict_case = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' -> - do_rebuild (App expr arg') cont' + = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' -> + do_rebuild (App expr arg') cont' --------------------------------------------------------- @@ -1072,9 +1070,6 @@ do_rebuild expr (CoerceIt _ to_ty se cont) = setSubstEnv se $ simplType to_ty `thenSmpl` \ to_ty' -> do_rebuild (mk_coerce to_ty' expr) cont - where - mk_coerce to_ty' (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty' from_ty) expr - mk_coerce to_ty' expr = Note (Coerce to_ty' (coreExprType expr)) expr --------------------------------------------------------- @@ -1209,6 +1204,8 @@ If so, then we can replace the case with one of the rhss. \begin{code} --------------------------------------------------------- -- Rebuiling a function with strictness info +-- This just a version of do_rebuild, enhanced with info about +-- the strictness of the thing being rebuilt. rebuild_strict :: [Demand] -> Bool -- Stricness info -> OutExpr -> OutType -- Function and type @@ -1218,6 +1215,11 @@ rebuild_strict :: [Demand] -> Bool -- Stricness info rebuild_strict [] True fun fun_ty cont = rebuild_bot fun fun_ty cont rebuild_strict [] False fun fun_ty cont = do_rebuild fun cont +rebuild_strict ds result_bot fun fun_ty (CoerceIt _ to_ty se cont) + = setSubstEnv se $ + simplType to_ty `thenSmpl` \ to_ty' -> + rebuild_strict ds result_bot (mk_coerce to_ty' fun) to_ty' cont + rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont) -- Type arg; don't consume a demand = setSubstEnv se (simplType ty_arg) `thenSmpl` \ ty_arg' -> @@ -1225,7 +1227,8 @@ rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont) (applyTy fun_ty ty_arg') cont rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont) - | isStrict d || isUnLiftedType arg_ty -- Strict value argument + | isStrict d || isUnLiftedType arg_ty + -- Strict value argument = getInScope `thenSmpl` \ in_scope -> let cont_ty = contResultType in_scope res_ty cont @@ -1248,6 +1251,7 @@ rebuild_strict ds result_bot fun fun_ty cont = do_rebuild fun cont -- Dealing with -- * case (error "hello") of { ... } -- * (error "Hello") arg +-- * f (error "Hello") where f is strict -- etc rebuild_bot expr expr_ty Stop -- No coerce needed @@ -1259,13 +1263,17 @@ rebuild_bot expr expr_ty (CoerceIt _ to_ty se Stop) -- Don't "tick" on this, simplType to_ty `thenSmpl` \ to_ty' -> rebuild_done (mkNote (Coerce to_ty' expr_ty) expr) -rebuild_bot expr expr_ty cont +rebuild_bot expr expr_ty cont -- Abandon the (strict) continuation, + -- and just return expr = tick CaseOfError `thenSmpl_` getInScope `thenSmpl` \ in_scope -> let result_ty = contResultType in_scope expr_ty cont in rebuild_done (mkNote (Coerce result_ty expr_ty) expr) + +mk_coerce to_ty (Note (Coerce _ from_ty) expr) = Note (Coerce to_ty from_ty) expr +mk_coerce to_ty expr = Note (Coerce to_ty (coreExprType expr)) expr \end{code} Blob of helper functions for the "case-of-something-else" situation. diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 1ac48cf..ba0fa38 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -24,6 +24,7 @@ import Inst ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..), ) import TcEnv ( tcExtendLocalValEnv, newSpecPragmaId, + tcLookupTyCon, tcGetGlobalTyVars, tcExtendGlobalTyVars ) import TcSimplify ( tcSimplify, tcSimplifyAndCheck ) @@ -39,11 +40,13 @@ import TcType ( TcType, TcThetaType, ) import TcUnify ( unifyTauTy, unifyTauTyLists ) +import PrelInfo ( main_NAME, ioTyCon_NAME ) + import Id ( mkUserId ) import Var ( idType, idName, setIdInfo ) import IdInfo ( IdInfo, noIdInfo, setInlinePragInfo, InlinePragInfo(..) ) -import Name ( Name ) -import Type ( mkTyVarTy, tyVarsOfTypes, +import Name ( Name, getName ) +import Type ( mkTyVarTy, tyVarsOfTypes, mkTyConApp, splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, mkDictTy, splitRhoTy, mkForAllTy, isUnLiftedType, isUnboxedType, unboxedTypeKind, boxedTypeKind @@ -52,6 +55,7 @@ import Var ( TyVar, tyVarKind ) import VarSet import Bag import Util ( isIn ) +import Maybes ( maybeToBool ) import BasicTypes ( TopLevelFlag(..), RecFlag(..) ) import SrcLoc ( SrcLoc ) import Outputable @@ -250,18 +254,17 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn -- TYPECHECK THE BINDINGS tcMonoBinds mbind tc_ty_sigs is_rec `thenTc` \ (mbind', lie_req, binder_names, mono_ids) -> - let - mono_id_tys = map idType mono_ids - in - -- CHECK THAT THE SIGNATURES MATCH -- (must do this before getTyVarsToGen) - checkSigMatch tc_ty_sigs `thenTc` \ (sig_theta, lie_avail) -> + checkSigMatch top_lvl binder_names mono_ids tc_ty_sigs `thenTc` \ maybe_sig_theta -> -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen -- The tyvars_not_to_gen are free in the environment, and hence -- candidates for generalisation, but sometimes the monomorphism -- restriction means we can't generalise them nevertheless + let + mono_id_tys = map idType mono_ids + in getTyVarsToGen is_unrestricted mono_id_tys lie_req `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) -> -- Finally, zonk the generalised type variables to real TyVars @@ -288,7 +291,8 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn -- No polymorphism, so no need to simplify context returnTc (lie_req, EmptyMonoBinds, []) else - if null tc_ty_sigs then + case maybe_sig_theta of + Nothing -> -- No signatures, so just simplify the lie -- NB: no signatures => no polymorphic recursion, so no -- need to use lie_avail (which will be empty anyway) @@ -296,7 +300,11 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs is_rec prag_info_fn top_lvl real_tyvars_to_gen lie_req `thenTc` \ (lie_free, dict_binds, lie_bound) -> returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound)) - else + Just (sig_theta, lie_avail) -> + -- There are signatures, and their context is sig_theta + -- Furthermore, lie_avail is an LIE containing the 'method insts' + -- for the things bound here + zonkTcThetaType sig_theta `thenNF_Tc` \ sig_theta' -> newDicts SignatureOrigin sig_theta' `thenNF_Tc` \ (dicts_sig, dict_ids) -> -- It's important that sig_theta is zonked, because @@ -682,13 +690,46 @@ The error message here is somewhat unsatisfactory, but it'll do for now (ToDo). \begin{code} -checkSigMatch [] - = returnTc (error "checkSigMatch", emptyLIE) +checkSigMatch top_lvl binder_names mono_ids sigs + | main_bound_here + = mapTc check_one_sig sigs `thenTc_` + mapTc check_main_ctxt sigs `thenTc_` + + -- Now unify the main_id with IO t, for any old t + tcSetErrCtxt mainTyCheckCtxt ( + tcLookupTyCon ioTyCon_NAME `thenTc` \ ioTyCon -> + newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv -> + unifyTauTy ((mkTyConApp ioTyCon [t_tv])) + (idType main_mono_id) + ) `thenTc_` + returnTc (Just ([], emptyLIE)) + + | not (null sigs) + = mapTc check_one_sig sigs `thenTc_` + mapTc check_one_ctxt all_sigs_but_first `thenTc_` + returnTc (Just (theta1, sig_lie)) + + | otherwise + = returnTc Nothing -- No constraints from type sigs + + where + (TySigInfo _ id1 _ theta1 _ _ _ _ : all_sigs_but_first) = sigs + + sig1_dict_tys = mk_dict_tys theta1 + n_sig1_dict_tys = length sig1_dict_tys + sig_lie = mkLIE [inst | TySigInfo _ _ _ _ _ _ inst _ <- sigs] -checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _ _ _) : all_sigs_but_first ) - = -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK + maybe_main = find_main top_lvl binder_names mono_ids + main_bound_here = maybeToBool maybe_main + Just main_mono_id = maybe_main + + -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK -- Doesn't affect substitution - mapTc check_one_sig tc_ty_sigs `thenTc_` + check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc) + = tcAddSrcLoc src_loc $ + tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id)) $ + checkSigTyVars sig_tyvars + -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE -- The type signatures on a mutually-recursive group of definitions @@ -697,15 +738,7 @@ checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _ _ _) : all_sigs_bu -- We unify them because, with polymorphic recursion, their types -- might not otherwise be related. This is a rather subtle issue. -- ToDo: amplify - mapTc check_one_cxt all_sigs_but_first `thenTc_` - - returnTc (theta1, sig_lie) - where - sig1_dict_tys = mk_dict_tys theta1 - n_sig1_dict_tys = length sig1_dict_tys - sig_lie = mkLIE [inst | TySigInfo _ _ _ _ _ _ inst _ <- tc_ty_sigs] - - check_one_cxt sig@(TySigInfo _ id _ theta _ _ _ src_loc) + check_one_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (sigContextsCtxt id1 id) $ checkTc (length this_sig_dict_tys == n_sig1_dict_tys) @@ -714,15 +747,23 @@ checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _ _ _) : all_sigs_bu where this_sig_dict_tys = mk_dict_tys theta - check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc) - = tcAddSrcLoc src_loc $ - tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id)) $ - checkSigTyVars sig_tyvars + -- CHECK THAT FOR A GROUP INVOLVING Main.main, all + -- the signature contexts are empty (what a bore) + check_main_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc) + = tcAddSrcLoc src_loc $ + checkTc (null theta) (mainContextsErr id) mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta] sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"), nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)] + + -- Search for Main.main in the binder_names, return corresponding mono_id + find_main NotTopLevel binder_names mono_ids = Nothing + find_main TopLevel binder_names mono_ids = go binder_names mono_ids + go [] [] = Nothing + go (n:ns) (m:ms) | n == main_NAME = Just m + | otherwise = go ns ms \end{code} @@ -904,11 +945,20 @@ bindSigsCtxt ids ----------------------------------------------- sigContextsErr = ptext SLIT("Mismatched contexts") + sigContextsCtxt s1 s2 = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"), quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)]) 4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)")) +mainContextsErr id + | getName id == main_NAME = ptext SLIT("Main.main cannot be overloaded") + | otherwise + = quotes (ppr id) <+> ptext SLIT("cannot be overloaded, because it is mutually recursive with Main.main") + +mainTyCheckCtxt + = hsep [ptext SLIT("When checking that"), ppr main_NAME, ptext SLIT("has the required type")] + ----------------------------------------------- unliftedBindErr flavour mbind = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed")) diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 158e22b..3c63d34 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -265,7 +265,9 @@ tcLookupTy name maybe_arity | isSynTyCon tc = Just (tyConArity tc) | otherwise = Nothing - Nothing -> pprPanic "tcLookupTy" (ppr name) + Nothing -> -- This can happen if an interface-file + -- unfolding is screwed up + failWithTc (tyNameOutOfScope name) } tcLookupClass :: Name -> NF_TcM s Class @@ -422,4 +424,7 @@ badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor") badPrimOp op = quotes (ppr op) <+> ptext SLIT("is not a primop") + +tyNameOutOfScope name + = quotes (ppr name) <+> ptext SLIT("is not in scope") \end{code} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 40cc5df..9500baf 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -31,6 +31,7 @@ import Const ( Con(..), Literal(..) ) import CoreSyn import CoreUtils ( coreExprType ) import CoreUnfold +import CoreLint ( lintUnfolding ) import WwLib ( mkWrapper ) import PrimOp ( PrimOp(..) ) @@ -41,7 +42,7 @@ import IdInfo import DataCon ( dataConSig, dataConArgTys ) import SpecEnv ( addToSpecEnv ) import Type ( mkSynTy, mkTyVarTys, splitAlgTyConApp ) -import Var ( mkTyVar, tyVarKind ) +import Var ( IdOrTyVar, mkTyVar, tyVarKind ) import VarEnv import Name ( Name, NamedThing(..) ) import Unique ( rationalTyConKey ) @@ -90,7 +91,7 @@ tcIdInfo unf_env name ty info info_ins tcPrag info (HsUnfold inline_prag maybe_expr) = (case maybe_expr of - Just expr -> tcPragExpr unf_env name expr + Just expr -> tcPragExpr unf_env name [] expr Nothing -> returnNF_Tc Nothing ) `thenNF_Tc` \ maybe_expr' -> let @@ -115,7 +116,7 @@ tcIdInfo unf_env name ty info info_ins -- type variables of the function; this is, after all, an -- interface file generated by the compiler! - tcPragExpr unf_env name rhs `thenNF_Tc` \ maybe_rhs' -> + tcPragExpr unf_env name tyvars' rhs `thenNF_Tc` \ maybe_rhs' -> let -- If spec_env isn't looked at, none of this -- actually takes place @@ -165,13 +166,16 @@ For unfoldings we try to do the job lazily, so that we never type check an unfolding that isn't going to be looked at. \begin{code} -tcPragExpr :: ValueEnv -> Name -> UfExpr Name -> NF_TcM s (Maybe CoreExpr) -tcPragExpr unf_env name core_expr +tcPragExpr :: ValueEnv -> Name -> [IdOrTyVar] -> UfExpr Name -> NF_TcM s (Maybe CoreExpr) +tcPragExpr unf_env name in_scope_vars core_expr = forkNF_Tc ( recoverNF_Tc no_unfolding ( tcSetValueEnv unf_env $ tcCoreExpr core_expr `thenTc` \ core_expr' -> - returnTc (Just core_expr') + + -- Check for type consistency in the unfolding + tcGetSrcLoc `thenNF_Tc` \ src_loc -> + returnTc (lintUnfolding src_loc in_scope_vars core_expr') )) where -- The trace tells what wasn't available, for the benefit of diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 0358f11..14e6a7a 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -52,16 +52,15 @@ import Name ( Name, nameUnique, isLocallyDefined, pprModule, NamedThing(..) ) import TyCon ( TyCon, tyConKind ) import DataCon ( dataConId ) import Class ( Class, classSelIds, classTyCon ) -import Type ( mkTyConApp, mkForAllTy, mkTyVarTy, +import Type ( mkTyConApp, mkForAllTy, boxedTypeKind, getTyVar, Type ) import TysWiredIn ( unitTy ) import PrelMods ( mAIN ) -import PrelInfo ( main_NAME, ioTyCon_NAME, - thinAirIdNames, setThinAirIds - ) +import PrelInfo ( main_NAME, thinAirIdNames, setThinAirIds ) import TcUnify ( unifyTauTy ) import Unique ( Unique ) import UniqSupply ( UniqSupply ) +import Maybes ( maybeToBool ) import Util import Bag ( Bag, isEmptyBag ) import Outputable @@ -224,8 +223,6 @@ tcModule rn_name_supply tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) -> - -- Check that "main" has the right signature - tcCheckMainSig mod_name `thenTc_` -- Deal with constant or ambiguous InstIds. How could -- there be ambiguous ones? They can only arise if a @@ -241,9 +238,16 @@ tcModule rn_name_supply in tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds -> + -- Check that Main defines main + (if mod_name == mAIN then + tcLookupValueMaybe main_NAME `thenNF_Tc` \ maybe_main -> + checkTc (maybeToBool maybe_main) noMainErr + else + returnTc () + ) `thenTc_` -- Backsubstitution. This must be done last. - -- Even tcCheckMainSig and tcSimplifyTop may do some unification. + -- Even tcSimplifyTop may do some unification. let all_binds = data_binds `AndMonoBinds` val_binds `AndMonoBinds` @@ -278,45 +282,8 @@ get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls] \begin{code} -tcCheckMainSig mod_name - | mod_name /= mAIN - = returnTc () -- A non-main module - - | otherwise - = -- Check that main is defined - tcLookupTyCon ioTyCon_NAME `thenTc` \ ioTyCon -> - tcLookupValueMaybe main_NAME `thenNF_Tc` \ maybe_main_id -> - case maybe_main_id of { - Nothing -> failWithTc noMainErr ; - Just main_id -> - - -- Check that it has the right type (or a more general one) - -- As of Haskell 98, anything that unifies with (IO a) is OK. - newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv -> - let - tv = getTyVar "tcCheckMainSig" t_tv - expected_tau = typeToTcType ((mkTyConApp ioTyCon [t_tv])) - in - tcId main_NAME `thenNF_Tc` \ (_, lie, main_tau) -> - tcSetErrCtxt mainTyCheckCtxt $ - unifyTauTy expected_tau - main_tau `thenTc_` - checkTc (isEmptyBag lie) (mainTyMisMatch expected_tau (idType main_id)) - } - - -mainTyCheckCtxt - = hsep [ptext SLIT("When checking that"), ppr main_NAME, ptext SLIT("has the required type")] - noMainErr = hsep [ptext SLIT("Module"), quotes (pprModule mAIN), ptext SLIT("must include a definition for"), quotes (ppr main_NAME)] - -mainTyMisMatch :: TcType -> TcType -> Message -mainTyMisMatch expected actual - = hang (hsep [ppr main_NAME, ptext SLIT("has the wrong type")]) - 4 (vcat [ - hsep [ptext SLIT("Expected:"), ppr expected], - hsep [ptext SLIT("Inferred:"), ppr actual] - ]) \end{code} + diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index ad166c1..137c54a 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -123,7 +123,7 @@ module TcSimplify ( #include "HsVersions.h" -import CmdLineOpts ( opt_MaxContextReductionDepth, opt_GlasgowExts ) +import CmdLineOpts ( opt_MaxContextReductionDepth, opt_GlasgowExts, opt_WarnTypeDefaults ) import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList ) import TcHsSyn ( TcExpr, TcId, TcMonoBinds, TcDictBinds @@ -972,7 +972,7 @@ tcSimplifyTop wanted_lie d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2 complain d | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d - | otherwise = addAmbigErr tyVarsOfInst d + | otherwise = addAmbigErr tyVarsOfInst d get_tv d = case getDictClassTys d of (clas, [ty]) -> getTyVar "tcSimplifyTop" ty @@ -1034,8 +1034,9 @@ disambigGroup dicts in unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar) `thenTc_` reduceContext (text "disambig" <+> ppr dicts) - try_me [] dicts `thenTc` \ (binds, frees, ambigs) -> + try_me [] dicts `thenTc` \ (binds, frees, ambigs) -> ASSERT( null frees && null ambigs ) + warnDefault dicts chosen_default_ty `thenTc_` returnTc binds | all isCreturnableClass classes @@ -1112,6 +1113,23 @@ addAmbigErr ambig_tv_fn dict ambig_tvs = varSetElems (ambig_tv_fn tidy_dict) (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict +warnDefault dicts default_ty + | not opt_WarnTypeDefaults + = returnNF_Tc () + + | otherwise + = tcAddSrcLoc (instLoc (head dicts)) $ + warnTc True msg + where + msg | length dicts > 1 + = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty)) + $$ pprInstsInFull tidy_dicts + | otherwise + = ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+> + ptext SLIT("to type") <+> quotes (ppr default_ty) + + (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts + -- Used for top-level irreducibles addTopInstanceErr dict = tcAddSrcLoc (instLoc dict) $ -- 1.7.10.4