diff options
35 files changed, 1255 insertions, 642 deletions
diff --git a/compiler/basicTypes/DataCon.lhs-boot b/compiler/basicTypes/DataCon.lhs-boot index c5e05c9ecd..3477a4b2e4 100644 --- a/compiler/basicTypes/DataCon.lhs-boot +++ b/compiler/basicTypes/DataCon.lhs-boot @@ -5,4 +5,6 @@ import Name( Name ) data DataCon dataConName :: DataCon -> Name isVanillaDataCon :: DataCon -> Bool +instance Eq DataCon +instance Ord DataCon \end{code} diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index db24f7508b..754f6292b2 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -435,17 +435,17 @@ instance OutputableBndr Name where pprBndr _ name = pprName name pprName :: Name -> SDoc -pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ}) +pprName n@(Name {n_sort = sort, n_uniq = u, n_occ = occ}) = getPprStyle $ \ sty -> case sort of - WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin - External mod -> pprExternal sty uniq mod occ False UserSyntax + WiredIn mod _ builtin -> pprExternal sty uniq mod occ n True builtin + External mod -> pprExternal sty uniq mod occ n False UserSyntax System -> pprSystem sty uniq occ Internal -> pprInternal sty uniq occ where uniq = mkUniqueGrimily (iBox u) -pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc -pprExternal sty uniq mod occ is_wired is_builtin +pprExternal :: PprStyle -> Unique -> Module -> OccName -> Name -> Bool -> BuiltInSyntax -> SDoc +pprExternal sty uniq mod occ name is_wired is_builtin | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ -- In code style, always qualify -- ToDo: maybe we could print all wired-in things unqualified @@ -455,7 +455,7 @@ pprExternal sty uniq mod occ is_wired is_builtin pprNameSpaceBrief (occNameSpace occ), pprUnique uniq]) | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax - | otherwise = pprModulePrefix sty mod occ <> ppr_occ_name occ + | otherwise = pprModulePrefix sty mod name <> ppr_occ_name occ where pp_mod | opt_SuppressModulePrefixes = empty | otherwise = ppr mod <> dot @@ -482,14 +482,14 @@ pprSystem sty uniq occ -- so print the unique -pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc +pprModulePrefix :: PprStyle -> Module -> Name -> SDoc -- Print the "M." part of a name, based on whether it's in scope or not -- See Note [Printing original names] in HscTypes -pprModulePrefix sty mod occ +pprModulePrefix sty mod name | opt_SuppressModulePrefixes = empty | otherwise - = case qualName sty mod occ of -- See Outputable.QualifyName: + = case qualName sty name of -- See Outputable.QualifyName: NameQual modname -> ppr modname <> dot -- Name is in scope NameNotInScope1 -> ppr mod <> dot -- Not in scope NameNotInScope2 -> ppr (modulePackageId mod) <> colon -- Module not in diff --git a/compiler/basicTypes/Name.lhs-boot b/compiler/basicTypes/Name.lhs-boot index 167ce4242d..27b71d944f 100644 --- a/compiler/basicTypes/Name.lhs-boot +++ b/compiler/basicTypes/Name.lhs-boot @@ -1,5 +1,9 @@ \begin{code} module Name where +import {-# SOURCE #-} Module + data Name + +nameModule :: Name -> Module \end{code} diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index 7f7d04802e..b410d5914c 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -66,6 +66,7 @@ import Maybes import SrcLoc import FastString import Outputable +import Unique import Util import StaticFlags( opt_PprStyle_Debug ) @@ -247,7 +248,9 @@ instance Outputable RdrName where ppr (Exact name) = ppr name ppr (Unqual occ) = ppr occ ppr (Qual mod occ) = ppr mod <> dot <> ppr occ - ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ) + ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod name <> ppr occ) + where name = mkExternalName (mkUniqueGrimily 0) mod occ noSrcSpan + -- Note [Outputable Orig RdrName] in HscTypes instance OutputableBndr RdrName where pprBndr _ n diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 6cbda9e09e..9001ec7cf5 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -56,24 +56,26 @@ deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) deSugar hsc_env mod_loc tcg_env@(TcGblEnv { tcg_mod = mod, - tcg_src = hsc_src, - tcg_type_env = type_env, - tcg_imports = imports, - tcg_exports = exports, - tcg_keep = keep_var, + tcg_src = hsc_src, + tcg_type_env = type_env, + tcg_imports = imports, + tcg_exports = exports, + tcg_keep = keep_var, tcg_th_splice_used = tc_splice_used, tcg_rdr_env = rdr_env, - tcg_fix_env = fix_env, - tcg_inst_env = inst_env, - tcg_fam_inst_env = fam_inst_env, - tcg_warns = warns, - tcg_anns = anns, - tcg_binds = binds, - tcg_imp_specs = imp_specs, + tcg_fix_env = fix_env, + tcg_inst_env = inst_env, + tcg_fam_inst_env = fam_inst_env, + tcg_warns = warns, + tcg_anns = anns, + tcg_binds = binds, + tcg_imp_specs = imp_specs, tcg_ev_binds = ev_binds, tcg_fords = fords, tcg_rules = rules, tcg_vects = vects, + tcg_tcs = tcs, + tcg_clss = clss, tcg_insts = insts, tcg_fam_insts = fam_insts, tcg_hpc = other_hpc_info }) @@ -96,8 +98,7 @@ deSugar hsc_env <- if (opt_Hpc || target == HscInterpreted) && (not (isHsBoot hsc_src)) - then addCoverageTicksToBinds dflags mod mod_loc - (typeEnvTyCons type_env) binds + then addCoverageTicksToBinds dflags mod mod_loc tcs binds else return (binds, hpcInfo, emptyModBreaks) initDs hsc_env mod rdr_env type_env $ do do { ds_ev_binds <- dsEvBinds ev_binds @@ -151,26 +152,27 @@ deSugar hsc_env ; used_th <- readIORef tc_splice_used ; let mod_guts = ModGuts { - mg_module = mod, - mg_boot = isHsBoot hsc_src, - mg_exports = exports, - mg_deps = deps, - mg_used_names = used_names, + mg_module = mod, + mg_boot = isHsBoot hsc_src, + mg_exports = exports, + mg_deps = deps, + mg_used_names = used_names, mg_used_th = used_th, mg_dir_imps = imp_mods imports, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_warns = warns, - mg_anns = anns, - mg_types = type_env, - mg_insts = insts, - mg_fam_insts = fam_insts, - mg_inst_env = inst_env, - mg_fam_inst_env = fam_inst_env, - mg_rules = ds_rules_for_imps, - mg_binds = ds_binds, - mg_foreign = ds_fords, - mg_hpc_info = ds_hpc_info, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_warns = warns, + mg_anns = anns, + mg_tcs = tcs, + mg_clss = clss, + mg_insts = insts, + mg_fam_insts = fam_insts, + mg_inst_env = inst_env, + mg_fam_inst_env = fam_inst_env, + mg_rules = ds_rules_for_imps, + mg_binds = ds_binds, + mg_foreign = ds_fords, + mg_hpc_info = ds_hpc_info, mg_modBreaks = modBreaks, mg_vect_decls = ds_vects, mg_vect_info = noVectInfo, diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index d4ddcc4ba2..4cd7729608 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -254,7 +254,7 @@ lookupIE ie con_nm linkFail :: String -> String -> IO a linkFail who what = ghcError (ProgramError $ - unlines [ "" + unlines [ "",who , "During interactive linking, GHCi couldn't find the following symbol:" , ' ' : ' ' : what , "This may be due to you not asking GHCi to load extra object files," diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index d27aedb960..e859609527 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -87,7 +87,7 @@ pprintClosureCommand bindThings force str = do tidyTermTyVars :: GhcMonad m => Term -> m Term tidyTermTyVars t = withSession $ \hsc_env -> do - let env_tvs = tyVarsOfTypes (map idType (ic_tmp_ids (hsc_IC hsc_env))) + let env_tvs = tyThingsTyVars $ ic_tythings $ hsc_IC hsc_env my_tvs = termTyVars t tvs = env_tvs `minusVarSet` my_tvs tyvarOccName = nameOccName . tyVarName @@ -110,7 +110,7 @@ bindSuspensions t = do let (names, tys, hvals) = unzip3 stuff let ids = [ mkVanillaGlobal name ty | (name,ty) <- zip names tys] - new_ic = extendInteractiveContext ictxt ids + new_ic = extendInteractiveContext ictxt (map AnId ids) liftIO $ extendLinkEnv (zip names hvals) modifySession $ \_ -> hsc_env {hsc_IC = new_ic } return t' @@ -187,10 +187,8 @@ showTerm term = do bindToFreshName hsc_env ty userName = do name <- newGrimName userName - let ictxt = hsc_IC hsc_env - tmp_ids = ic_tmp_ids ictxt - id = mkVanillaGlobal name ty - new_ic = ictxt { ic_tmp_ids = id : tmp_ids } + let id = AnId $ mkVanillaGlobal name ty + new_ic = extendInteractiveContext (hsc_IC hsc_env) [id] return (hsc_env {hsc_IC = new_ic }, name) -- Create new uniques and give them sequentially numbered names @@ -202,20 +200,19 @@ newGrimName userName = do name = mkInternalName unique occname noSrcSpan return name -pprTypeAndContents :: GhcMonad m => [Id] -> m SDoc -pprTypeAndContents ids = do +pprTypeAndContents :: GhcMonad m => Id -> m SDoc +pprTypeAndContents id = do dflags <- GHC.getSessionDynFlags let pefas = dopt Opt_PrintExplicitForalls dflags pcontents = dopt Opt_PrintBindContents dflags + pprdId = (pprTyThing pefas . AnId) id if pcontents then do let depthBound = 100 - terms <- mapM (GHC.obtainTermFromId depthBound False) ids - docs_terms <- mapM showTerm terms - return $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts) - (map (pprTyThing pefas . AnId) ids) - docs_terms - else return $ vcat $ map (pprTyThing pefas . AnId) ids + term <- GHC.obtainTermFromId depthBound False id + docs_term <- showTerm term + return $ pprdId <+> equals <+> docs_term + else return pprdId -------------------------------------------------------------- -- Utils diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 747edde140..2f8943ef24 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -12,7 +12,7 @@ -- -fno-cse is needed for GLOBAL_VAR's to behave properly module Linker ( HValue, getHValue, showLinkerState, - linkExpr, unload, withExtendedLinkEnv, + linkExpr, linkDecls, unload, withExtendedLinkEnv, extendLinkEnv, deleteFromLinkEnv, extendLoadedPkgs, linkPackages,initDynLinker,linkModule, @@ -52,6 +52,7 @@ import UniqSet import FastString import Config import SysTools +import PrelNames -- Standard libraries import Control.Monad @@ -427,9 +428,9 @@ linkExpr hsc_env span root_ul_bco needed_mods :: [Module] needed_mods = [ nameModule n | n <- free_names, - isExternalName n, -- Names from other modules - not (isWiredInName n) -- Exclude wired-in names - ] -- (see note below) + isExternalName n, -- Names from other modules + not (isWiredInName n) -- Exclude wired-in names + ] -- (see note below) -- Exclude wired-in names because we may not have read -- their interface files, so getLinkDeps will fail -- All wired-in names are in the base package, which we link @@ -476,7 +477,9 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods -- Find all the packages and linkables that a set of modules depends on = do { -- 1. Find the dependent home-pkg-modules/packages from each iface - (mods_s, pkgs_s) <- follow_deps mods emptyUniqSet emptyUniqSet; + -- (omitting iINTERACTIVE, which is already linked) + (mods_s, pkgs_s) <- follow_deps (filter ((/=) iNTERACTIVE) mods) + emptyUniqSet emptyUniqSet; let { -- 2. Exclude ones already linked @@ -488,7 +491,6 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods (objs_loaded pls ++ bcos_loaded pls) } ; --- putStrLn (showSDoc (ppr mods_s)) ; -- 3. For each dependent module, find its linkable -- This will either be in the HPT or (in the case of one-shot -- compilation) we may need to use maybe_getFileLinkable @@ -594,6 +596,53 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods adjust_ul _ _ = panic "adjust_ul" \end{code} + +%************************************************************************ +%* * + Loading a Decls statement +%* * +%************************************************************************ +\begin{code} +linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO () --[HValue] +linkDecls hsc_env span (ByteCode unlinkedBCOs itblEnv) = do + -- Initialise the linker (if it's not been done already) + let dflags = hsc_dflags hsc_env + initDynLinker dflags + + -- Take lock for the actual work. + modifyPLS $ \pls0 -> do + + -- Link the packages and modules required + (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods + if failed ok + then ghcError (ProgramError "") + else do + + -- Link the expression itself + let ie = plusNameEnv (itbl_env pls) itblEnv + ce = closure_env pls + + -- Link the necessary packages and linkables + (final_gce, _) <- linkSomeBCOs False ie ce unlinkedBCOs + let pls2 = pls { closure_env = final_gce, + itbl_env = ie } + return (pls2, ()) --hvals) + where + free_names = concatMap (nameSetToList . bcoFreeNames) unlinkedBCOs + + needed_mods :: [Module] + needed_mods = [ nameModule n | n <- free_names, + isExternalName n, -- Names from other modules + not (isWiredInName n) -- Exclude wired-in names + ] -- (see note below) + -- Exclude wired-in names because we may not have read + -- their interface files, so getLinkDeps will fail + -- All wired-in names are in the base package, which we link + -- by default, so we can safely ignore them here. +\end{code} + + + %************************************************************************ %* * Loading a single module diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index 0b28525148..798164c448 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -71,39 +71,49 @@ allocateGlobalBinder -> (NameCache, Name) allocateGlobalBinder name_supply mod occ loc = case lookupOrigNameCache (nsNames name_supply) mod occ of - -- A hit in the cache! We are at the binding site of the name. - -- This is the moment when we know the SrcLoc - -- of the Name, so we set this field in the Name we return. - -- - -- Then (bogus) multiple bindings of the same Name - -- get different SrcLocs can can be reported as such. - -- - -- Possible other reason: it might be in the cache because we - -- encountered an occurrence before the binding site for an - -- implicitly-imported Name. Perhaps the current SrcLoc is - -- better... but not really: it'll still just say 'imported' - -- - -- IMPORTANT: Don't mess with wired-in names. - -- Their wired-in-ness is in their NameSort - -- and their Module is correct. - - Just name | isWiredInName name -> (name_supply, name) - | otherwise -> (new_name_supply, name') - where - uniq = nameUnique name - name' = mkExternalName uniq mod occ loc - new_cache = extendNameCache (nsNames name_supply) mod occ name' - new_name_supply = name_supply {nsNames = new_cache} - - -- Miss in the cache! - -- Build a completely new Name, and put it in the cache - Nothing -> (new_name_supply, name) - where - (uniq, us') = takeUniqFromSupply (nsUniqs name_supply) - name = mkExternalName uniq mod occ loc - new_cache = extendNameCache (nsNames name_supply) mod occ name - new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} - + -- A hit in the cache! We are at the binding site of the name. + -- This is the moment when we know the SrcLoc + -- of the Name, so we set this field in the Name we return. + -- + -- Then (bogus) multiple bindings of the same Name + -- get different SrcLocs can can be reported as such. + -- + -- Possible other reason: it might be in the cache because we + -- encountered an occurrence before the binding site for an + -- implicitly-imported Name. Perhaps the current SrcLoc is + -- better... but not really: it'll still just say 'imported' + -- + -- IMPORTANT: Don't mess with wired-in names. + -- Their wired-in-ness is in their NameSort + -- and their Module is correct. + + Just name | isWiredInName name -> (name_supply, name) + | mod /= iNTERACTIVE -> (new_name_supply, name') + -- Note [interactive name cache] + where + uniq = nameUnique name + name' = mkExternalName uniq mod occ loc + new_cache = extendNameCache (nsNames name_supply) mod occ name' + new_name_supply = name_supply {nsNames = new_cache} + + -- Miss in the cache! + -- Build a completely new Name, and put it in the cache + _ -> (new_name_supply, name) + where + (uniq, us') = takeUniqFromSupply (nsUniqs name_supply) + name = mkExternalName uniq mod occ loc + new_cache = extendNameCache (nsNames name_supply) mod occ name + new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} + +{- Note [interactive name cache] + +In GHCi we always create Names with the same Module, ":Interactive". +However, we want to be able to shadow older declarations with newer +ones, and we don't want the Name cache giving us back the same Unique +for the new Name as for the old, hence this special case. + +See also Note [Outputable Orig RdrName] in HscTypes. +-} newImplicitBinder :: Name -- Base name -> (OccName -> OccName) -- Occurrence name modifier diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 7489ea3115..d803ea85fb 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -80,7 +80,7 @@ module GHC ( PrintUnqualified, alwaysQualify, -- * Interactive evaluation - getBindings, getPrintUnqual, + getBindings, getInsts, getPrintUnqual, findModule, lookupModule, #ifdef GHCI @@ -94,7 +94,7 @@ module GHC ( typeKind, parseName, RunResult(..), - runStmt, runStmtWithLocation, + runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation, parseImportDecl, SingleStep(..), resume, Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, @@ -166,7 +166,9 @@ module GHC ( -- ** Instances Instance, - instanceDFunId, pprInstance, pprInstanceHdr, + instanceDFunId, + pprInstance, pprInstanceHdr, + pprFamInst, pprFamInstHdr, -- ** Types and Kinds Type, splitForAllTys, funResultTy, @@ -264,8 +266,9 @@ import Class import DataCon import Name hiding ( varName ) import InstEnv +import FamInstEnv import SrcLoc -import CoreSyn ( CoreBind ) +import CoreSyn import TidyPgm import DriverPhases ( Phase(..), isHaskellSrcFilename ) import Finder @@ -864,11 +867,15 @@ compileCore simplify fn = do -- we just have a ModGuts. gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule gutsToCoreModule (Left (cg, md)) = CoreModule { - cm_module = cg_module cg, cm_types = md_types md, + cm_module = cg_module cg, + cm_types = md_types md, cm_binds = cg_binds cg } gutsToCoreModule (Right mg) = CoreModule { - cm_module = mg_module mg, cm_types = mg_types mg, + cm_module = mg_module mg, + cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) + (mg_tcs mg) (mg_clss mg) + (mg_fam_insts mg), cm_binds = mg_binds mg } @@ -899,13 +906,12 @@ isLoaded m = withSession $ \hsc_env -> -- | Return the bindings for the current interactive session. getBindings :: GhcMonad m => m [TyThing] getBindings = withSession $ \hsc_env -> - -- we have to implement the shadowing behaviour of ic_tmp_ids here - -- (see InteractiveContext) and the quickest way is to use an OccEnv. - let - occ_env = mkOccEnv [ (nameOccName (idName id), AnId id) - | id <- ic_tmp_ids (hsc_IC hsc_env) ] - in - return (occEnvElts occ_env) + return $ icInScopeTTs $ hsc_IC hsc_env + +-- | Return the instances for the current interactive session. +getInsts :: GhcMonad m => m ([Instance], [FamInst]) +getInsts = withSession $ \hsc_env -> + return $ ic_instances (hsc_IC hsc_env) getPrintUnqual :: GhcMonad m => m PrintUnqualified getPrintUnqual = withSession $ \hsc_env -> diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 30a0c651b2..b688d4cf6a 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -63,6 +63,7 @@ module HscMain , hscRnImportDecls , hscTcRnLookupRdrName , hscStmt, hscStmtWithLocation + , hscDecls, hscDeclsWithLocation , hscTcExpr, hscImport, hscKcType , hscCompileCoreExpr #endif @@ -71,13 +72,11 @@ module HscMain #ifdef GHCI import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) -import Linker ( HValue, linkExpr ) +import Linker import CoreTidy ( tidyExpr ) import Type ( Type ) -import TcType ( tyVarsOfTypes ) -import PrelNames ( iNTERACTIVE ) +import PrelNames import {- Kind parts of -} Type ( Kind ) -import Id ( idType ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) import VarSet @@ -85,7 +84,7 @@ import VarEnv ( emptyTidyEnv ) import Panic #endif -import Id ( Id ) +import Id import Module import Packages import RdrName @@ -100,7 +99,7 @@ import TcIface ( typecheckIface ) import TcRnMonad import IfaceEnv ( initNameCache ) import LoadIface ( ifaceStats, initExternalPackageState ) -import PrelInfo ( wiredInThings, basicKnownKeyNames ) +import PrelInfo import MkIface import Desugar import SimplCore @@ -111,8 +110,9 @@ import qualified StgCmm ( codeGen ) import StgSyn import CostCentre import ProfInit -import TyCon ( TyCon, isDataTyCon ) -import Name ( Name, NamedThing(..) ) +import TyCon +import Class +import Name import SimplStg ( stg2stg ) import CodeGen ( codeGen ) import OldCmm as Old ( CmmGroup ) @@ -127,7 +127,7 @@ import CodeOutput import NameEnv ( emptyNameEnv ) import NameSet ( emptyNameSet ) import InstEnv -import FamInstEnv ( emptyFamInstEnv ) +import FamInstEnv import Fingerprint ( Fingerprint ) import DynFlags @@ -1287,8 +1287,8 @@ hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do tcRnStmt hsc_env icontext parsed_stmt -- Desugar it let rdr_env = ic_rn_gbl_env icontext - type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext)) - ds_expr <- ioMsgMaybe $ + type_env = mkTypeEnvWithImplicits (ic_tythings icontext) + ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr handleWarnings @@ -1297,7 +1297,90 @@ hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do hsc_env <- getHscEnv hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr - return $ Just (ids, hval) + return $ Just (ids, hval) + +hscDecls -- Compile a decls + :: HscEnv + -> String -- The statement + -> IO ([TyThing], InteractiveContext) +hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1 + +hscDeclsWithLocation -- Compile a decls + :: HscEnv + -> String -- The statement + -> String -- the source + -> Int -- ^ starting line + -> IO ([TyThing], InteractiveContext) +hscDeclsWithLocation hsc_env str source linenumber = runHsc hsc_env $ do + L _ (HsModule{hsmodDecls=decls}) <- + hscParseThingWithLocation source linenumber parseModule str + + -- Rename and typecheck it + let icontext = hsc_IC hsc_env + tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env icontext decls + + -- Grab the new instances + -- We grab the whole environment because of the overlapping that may have + -- been done. See the notes at the definition of InteractiveContext + -- (ic_instances) for more details. + let finsts = famInstEnvElts $ tcg_fam_inst_env tc_gblenv + insts = instEnvElts $ tcg_inst_env tc_gblenv + + -- Desugar it + -- We use a basically null location for iNTERACTIVE + let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing, + ml_hi_file = undefined, + ml_obj_file = undefined} + ds_result <- ioMsgMaybe $ deSugar hsc_env iNTERACTIVELoc tc_gblenv + handleWarnings + + -- Simplify + simpl_mg <- liftIO $ hscSimplify hsc_env ds_result + + -- Tidy + (tidy_cg, _mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg + + let dflags = hsc_dflags hsc_env + CgGuts{ cg_binds = core_binds, + cg_tycons = tycons, + cg_modBreaks = mod_breaks } = tidy_cg + data_tycons = filter isDataTyCon tycons + + ------------------- + -- PREPARE FOR CODE GENERATION + -- Do saturation and convert to A-normal form + prepd_binds <- {-# SCC "CorePrep" #-} + liftIO $ corePrepPgm dflags core_binds data_tycons + + ----------------- Generate byte code ------------------ + cbc <- liftIO $ byteCodeGen dflags prepd_binds data_tycons mod_breaks + + let src_span = srcLocSpan interactiveSrcLoc + hsc_env <- getHscEnv + liftIO $ linkDecls hsc_env src_span cbc + + -- pprTrace "te" (ppr te) $ return () + + let + tcs = filter (not . isImplicitTyCon) $ mg_tcs simpl_mg + clss = mg_clss simpl_mg + tythings = map ATyCon tcs ++ map (ATyCon . classTyCon) clss + sys_vars = filter (isExternalName . idName) $ + bindersOfBinds (cg_binds tidy_cg) + -- we only need to keep around the external bindings + -- (as decided by TidyPgm), since those are the only ones + -- that might be referenced elsewhere. + + -- pprTrace "new tycons" (ppr tcs) $ return () + -- pprTrace "new classes" (ppr clss) $ return () + -- pprTrace "new sys Ids" (ppr sys_vars) $ return () + + let ictxt1 = extendInteractiveContext icontext tythings + ictxt = ictxt1 { + ic_sys_vars = sys_vars ++ ic_sys_vars ictxt1, + ic_instances = (insts, finsts) } + + return $ (tythings, ictxt) hscImport :: HscEnv -> String -> IO (ImportDecl RdrName) hscImport hsc_env str = runHsc hsc_env $ do @@ -1311,7 +1394,7 @@ hscImport hsc_env str = runHsc hsc_env $ do hscTcExpr -- Typecheck an expression (but don't run it) :: HscEnv - -> String -- The expression + -> String -- The expression -> IO Type hscTcExpr hsc_env expr = runHsc hsc_env $ do @@ -1326,7 +1409,7 @@ hscTcExpr hsc_env expr = runHsc hsc_env $ do -- | Find the kind of a type hscKcType :: HscEnv - -> String -- ^ The type + -> String -- ^ The type -> IO Kind hscKcType hsc_env str = runHsc hsc_env $ do @@ -1414,7 +1497,8 @@ mkModGuts mod binds = ModGuts { mg_used_th = False, mg_rdr_env = emptyGlobalRdrEnv, mg_fix_env = emptyFixityEnv, - mg_types = emptyTypeEnv, + mg_tcs = [], + mg_clss = [], mg_insts = [], mg_fam_insts = [], mg_rules = [], @@ -1463,9 +1547,11 @@ hscCompileCoreExpr hsc_env srcspan ds_expr -- ToDo: improve SrcLoc when lint_on $ let ictxt = hsc_IC hsc_env - tyvars = varSetElems (tyVarsOfTypes (map idType (ic_tmp_ids ictxt))) + te = mkTypeEnvWithImplicits (ic_tythings ictxt ++ map AnId (ic_sys_vars ictxt)) + tyvars = varSetElems $ tyThingsTyVars $ typeEnvElts $ te + vars = typeEnvIds te in - case lintUnfolding noSrcLoc tyvars prepd_expr of + case lintUnfolding noSrcLoc (tyvars ++ vars) prepd_expr of Just err -> pprPanic "hscCompileCoreExpr" err Nothing -> return () diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 7fab8d0ff7..0b90fd9668 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -41,10 +41,10 @@ module HscTypes ( prepareAnnotations, -- * Interactive context - InteractiveContext(..), emptyInteractiveContext, - InteractiveImport(..), - icPrintUnqual, extendInteractiveContext, - substInteractiveContext, + InteractiveContext(..), emptyInteractiveContext, + icPrintUnqual, icInScopeTTs, icPlusGblRdrEnv, + extendInteractiveContext, substInteractiveContext, + InteractiveImport(..), mkPrintUnqualified, pprModulePrefix, -- * Interfaces @@ -55,15 +55,17 @@ module HscTypes ( FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, -- * TyThings and type environments - TyThing(..), + TyThing(..), tyThingAvailInfo, tyThingTyCon, tyThingDataCon, - tyThingId, tyThingCoAxiom, tyThingParent_maybe, - implicitTyThings, implicitTyConThings, implicitClassThings, isImplicitTyThing, + tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyVars, + implicitTyThings, implicitTyConThings, implicitClassThings, + isImplicitTyThing, TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, + typeEnvFromEntities, mkTypeEnvWithImplicits, extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv, typeEnvElts, typeEnvTyCons, typeEnvIds, - typeEnvDataCons, typeEnvCoAxioms, + typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses, -- * MonadThings MonadThings(..), @@ -73,8 +75,8 @@ module HscTypes ( Dependencies(..), noDependencies, NameCache(..), OrigNameCache, OrigIParamCache, Avails, availsToNameSet, availsToNameEnv, availName, availNames, - AvailInfo(..), - IfaceExport, stableAvailCmp, + AvailInfo(..), gresFromAvails, gresFromAvail, + IfaceExport, stableAvailCmp, -- * Warnings Warnings(..), WarningTxt(..), plusWarns, @@ -118,7 +120,7 @@ import NameEnv import NameSet import Module import InstEnv ( InstEnv, Instance ) -import FamInstEnv ( FamInstEnv, FamInst ) +import FamInstEnv import Rules ( RuleBase ) import CoreSyn ( CoreBind ) import VarEnv @@ -129,23 +131,24 @@ import IdInfo ( IdDetails(..) ) import Type import Annotations -import Class ( Class, classAllSelIds, classATs, classTyCon ) +import Class import TyCon -import DataCon ( DataCon, dataConImplicitIds, dataConWrapId, dataConTyCon ) +import DataCon import PrelNames ( gHC_PRIM ) import Packages hiding ( Version(..) ) import DynFlags -import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) -import BasicTypes ( IPName, defaultFixity, WarningTxt(..) ) +import DriverPhases +import BasicTypes import OptimizationFuel ( OptFuelState ) import IfaceSyn import CoreSyn ( CoreRule, CoreVect ) -import Maybes ( orElse, expectJust, catMaybes ) +import Maybes import Outputable import BreakArray import SrcLoc -import UniqFM ( lookupUFM, eltsUFM, emptyUFM ) -import UniqSupply ( UniqSupply ) +import Unique +import UniqFM +import UniqSupply import FastString import StringBuffer ( StringBuffer ) import Fingerprint @@ -159,7 +162,6 @@ import System.Time ( ClockTime ) import Data.IORef import Data.Array ( Array, array ) import Data.Map ( Map ) -import Data.List import Data.Word import Control.Monad ( mplus, guard, liftM, when ) import Exception @@ -747,7 +749,8 @@ data ModGuts -- These fields all describe the things **declared in this module** mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module -- TODO: I'm unconvinced this is actually used anywhere - mg_types :: !TypeEnv, -- ^ Types declared in this module + mg_tcs :: ![TyCon], -- ^ TyCons declared in this module + mg_clss :: ![Class], -- ^ Classes declared in this module mg_insts :: ![Instance], -- ^ Class instances declared in this module mg_fam_insts :: ![FamInst], -- ^ Family instances declared in this module mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains @@ -895,70 +898,130 @@ data InteractiveContext -- ^ The GHCi context is extended with these imports ic_rn_gbl_env :: GlobalRdrEnv, - -- ^ The contexts' cached 'GlobalRdrEnv', built by - -- 'InteractiveEval.setContext' + -- ^ The cached 'GlobalRdrEnv', built by + -- 'InteractiveEval.setContext' and updated regularly - ic_tmp_ids :: [Id], - -- ^ Names bound during interaction with the user. Later - -- Ids shadow earlier ones with the same OccName - -- Expressions are typed with these Ids in the envt For - -- runtime-debugging, these Ids may have free TcTyVars of - -- RuntimUnkSkol flavour, but no free TyVars (because the - -- typechecker doesn't expect that) + ic_tythings :: [TyThing], + -- ^ TyThings defined by the user, in reverse order of + -- definition. + + ic_sys_vars :: [Id], + -- ^ Variables defined automatically by the system (e.g. + -- record field selectors). See Notes [ic_sys_vars] + + ic_instances :: ([Instance], [FamInst]), + -- ^ All instances and family instances created during + -- this session. These are grabbed en masse after each + -- update to be sure that proper overlapping is retained. + -- That is, rather than re-check the overlapping each + -- time we update the context, we just take the results + -- from the instance code that already does that. #ifdef GHCI - ic_resume :: [Resume], + ic_resume :: [Resume], -- ^ The stack of breakpoint contexts #endif - ic_cwd :: Maybe FilePath + ic_cwd :: Maybe FilePath -- virtual CWD of the program } -data InteractiveImport - = IIDecl (ImportDecl RdrName) -- Bring the exports of a particular module - -- (filtered by an import decl) into scope +{- +Note [ic_sys_vars] - | IIModule Module -- Bring into scope the entire top-level envt of - -- of this module, including the things imported - -- into it. - +This list constains any Ids that arise from TyCons, Classes or +instances defined interactively, but that are not given by +'implicitTyThings'. This includes record selectors, default methods, +and dfuns. + +We *could* get rid of this list and generate these Ids from +ic_tythings: + + - dfuns come from Instances + - record selectors from TyCons + - default methods from Classes + +For record selectors the TyCon gives the Name, but in order to make an +Id we would have to construct the type ourselves. Similarly for +default methods. So for now we collect the Ids after tidying (see +hscDeclsWithLocation) and save them in ic_sys_vars. +-} + +-- | Constructs an empty InteractiveContext. emptyInteractiveContext :: InteractiveContext -emptyInteractiveContext - = InteractiveContext { ic_imports = [], - ic_rn_gbl_env = emptyGlobalRdrEnv, - ic_tmp_ids = [] +emptyInteractiveContext = InteractiveContext { + ic_imports = [], + ic_rn_gbl_env = emptyGlobalRdrEnv, + ic_tythings = [], + ic_sys_vars = [], + ic_instances = ([],[]), #ifdef GHCI - , ic_resume = [] + ic_resume = [], #endif - , ic_cwd = Nothing - } - -icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified -icPrintUnqual dflags ictxt = mkPrintUnqualified dflags (ic_rn_gbl_env ictxt) + ic_cwd = Nothing } +-- | This function returns the list of visible TyThings (useful for +-- e.g. showBindings) +icInScopeTTs :: InteractiveContext -> [TyThing] +icInScopeTTs = ic_tythings +-- | Get the PrintUnqualified function based on the flags and this InteractiveContext +icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified +icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } = + mkPrintUnqualified dflags grenv + +-- | This function is called with new TyThings recently defined to update the +-- InteractiveContext to include them. Ids are easily removed when shadowed, +-- but Classes and TyCons are not. Some work could be done to determine +-- whether they are entirely shadowed, but as you could still have references +-- to them (e.g. instances for classes or values of the type for TyCons), it's +-- not clear whether removing them is even the appropriate behavior. extendInteractiveContext :: InteractiveContext - -> [Id] + -> [TyThing] -> InteractiveContext -extendInteractiveContext ictxt ids - = ictxt { ic_tmp_ids = snub ((ic_tmp_ids ictxt \\ ids) ++ ids) - -- NB. must be this way around, because we want - -- new ids to shadow existing bindings. +extendInteractiveContext ictxt new_tythings + = ictxt { ic_tythings = new_tythings ++ old_tythings + , ic_rn_gbl_env = new_tythings `icPlusGblRdrEnv` ic_rn_gbl_env ictxt } - where snub = map head . group . sort + where + old_tythings = filter (not . shadowed) (ic_tythings ictxt) + + shadowed (AnId id) = ((`elem` new_names) . nameOccName . idName) id + shadowed _ = False + + new_names = [ nameOccName (getName id) | AnId id <- new_tythings ] + + -- XXX should not add Ids to the gbl env here + +-- | Add TyThings to the GlobalRdrEnv, earlier ones in the list +-- shadowing later ones, and shadowing existing entries in the +-- GlobalRdrEnv. +icPlusGblRdrEnv :: [TyThing] -> GlobalRdrEnv -> GlobalRdrEnv +icPlusGblRdrEnv tythings env = extendOccEnvList env list + where new_gres = gresFromAvails LocalDef (map tyThingAvailInfo tythings) + list = [ (nameOccName (gre_name gre), [gre]) | gre <- new_gres ] substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext substInteractiveContext ictxt subst | isEmptyTvSubst subst = ictxt -substInteractiveContext ictxt@InteractiveContext{ic_tmp_ids=ids} subst - = ictxt { ic_tmp_ids = map subst_ty ids } +substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst + = ictxt { ic_tythings = map subst_ty tts } where - subst_ty id = id `setIdType` substTy subst (idType id) + subst_ty (AnId id) = AnId $ id `setIdType` substTy subst (idType id) + subst_ty tt = tt + +data InteractiveImport + = IIDecl (ImportDecl RdrName) -- Bring the exports of a particular module + -- (filtered by an import decl) into scope + + | IIModule Module -- Bring into scope the entire top-level envt of + -- of this module, including the things imported + -- into it. instance Outputable InteractiveImport where ppr (IIModule m) = char '*' <> ppr m ppr (IIDecl d) = ppr d + \end{code} %************************************************************************ @@ -1003,7 +1066,7 @@ the (ppr mod) of case (3), in Name.pprModulePrefix mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified mkPrintUnqualified dflags env = (qual_name, qual_mod) where - qual_name mod occ -- The (mod,occ) pair is the original name of the thing + qual_name name | [gre] <- unqual_gres, right_name gre = NameUnqual -- If there's a unique entity that's in scope unqualified with 'occ' -- AND that entity is the right one, then we can use the unqualified name @@ -1017,7 +1080,15 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod) | otherwise = panic "mkPrintUnqualified" where - right_name gre = nameModule_maybe (gre_name gre) == Just mod + mod = nameModule name + occ = nameOccName name + + is_rdr_orig = nameUnique name == mkUniqueGrimily 0 + -- Note [Outputable Orig RdrName] + + right_name gre + | is_rdr_orig = nameModule_maybe (gre_name gre) == Just mod + | otherwise = gre_name gre == name unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env qual_gres = filter right_name (lookupGlobalRdrEnv env occ) @@ -1041,6 +1112,25 @@ mkPrintUnqualified dflags env = (qual_name, qual_mod) | otherwise = True where lookup = lookupModuleInAllPackages dflags (moduleName mod) + +-- Note [Outputable Orig RdrName] +-- +-- This is a Grotesque Hack. The Outputable instance for RdrEnv wants +-- to print Orig names, which are just pairs of (Module,OccName). But +-- we want to use full Names here, because in GHCi we might have Ids +-- that have the same (Module,OccName) pair but a different Unique +-- (this happens when you shadow a TyCon or Class in GHCi). +-- +-- So in Outputable RdrName we just use a dummy Unique (0), and check +-- for it here. +-- +-- Arguably GHCi is invalidating the assumption that (Module,OccName) +-- uniquely identifies an entity. But we do want to be able to shadow +-- old declarations with new ones in GHCi, and it would be hard to +-- delete all references to the old declaration when that happened. +-- See also Note [interactive name cache] in IfaceEnv for somewhere +-- else that this broken assumption bites. +-- \end{code} @@ -1090,6 +1180,8 @@ implicitTyConThings tc -- for each data constructor in order, -- the contructor, worker, and (possibly) wrapper concatMap (extras_plus . ADataCon) (tyConDataCons tc) + -- NB. record selectors are *not* implicit, they have fully-fledged + -- bindings that pass through the compilation pipeline as normal. where class_stuff = case tyConClass_maybe tc of Nothing -> [] @@ -1121,26 +1213,49 @@ isImplicitTyThing (AnId id) = isImplicitId id isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc isImplicitTyThing (ACoAxiom {}) = True -extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv -extendTypeEnvWithIds env ids - = extendNameEnvList env [(getName id, AnId id) | id <- ids] - tyThingParent_maybe :: TyThing -> Maybe TyThing -- (tyThingParent_maybe x) returns (Just p) -- when pprTyThingInContext sould print a declaration for p -- (albeit with some "..." in it) when asked to show x -- It returns the *immediate* parent. So a datacon returns its tycon --- but the tycon could be the assocated type of a class, so it in turn +-- but the tycon could be the associated type of a class, so it in turn -- might have a parent. tyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc)) tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of Just cls -> Just (ATyCon (classTyCon cls)) Nothing -> Nothing tyThingParent_maybe (AnId id) = case idDetails id of - RecSelId { sel_tycon = tc } -> Just (ATyCon tc) + RecSelId { sel_tycon = tc } -> Just (ATyCon tc) ClassOpId cls -> Just (ATyCon (classTyCon cls)) _other -> Nothing tyThingParent_maybe _other = Nothing + +tyThingsTyVars :: [TyThing] -> TyVarSet +tyThingsTyVars tts = + unionVarSets $ map ttToVarSet tts + where + ttToVarSet (AnId id) = tyVarsOfType $ idType id + ttToVarSet (ADataCon dc) = tyVarsOfType $ dataConRepType dc + ttToVarSet (ATyCon tc) + = case tyConClass_maybe tc of + Just cls -> (mkVarSet . fst . classTvsFds) cls + Nothing -> tyVarsOfType $ tyConKind tc + ttToVarSet _ = emptyVarSet + +-- | The Names that a TyThing should bring into scope. Used to build +-- the GlobalRdrEnv for the InteractiveContext. +tyThingAvailInfo :: TyThing -> AvailInfo +tyThingAvailInfo (ATyCon t) + = case tyConClass_maybe t of + Just c -> AvailTC n (n : map getName (classMethods c) + ++ map getName (classATs c)) + where n = getName c + Nothing -> AvailTC n (n : map getName dcs ++ + concatMap dataConFieldLabels dcs) + where n = getName t + dcs = tyConDataCons t +tyThingAvailInfo t + = Avail (getName t) \end{code} %************************************************************************ @@ -1160,6 +1275,7 @@ typeEnvTyCons :: TypeEnv -> [TyCon] typeEnvCoAxioms :: TypeEnv -> [CoAxiom] typeEnvIds :: TypeEnv -> [Id] typeEnvDataCons :: TypeEnv -> [DataCon] +typeEnvClasses :: TypeEnv -> [Class] lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing emptyTypeEnv = emptyNameEnv @@ -1168,10 +1284,27 @@ typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] typeEnvIds env = [id | AnId id <- typeEnvElts env] typeEnvDataCons env = [dc | ADataCon dc <- typeEnvElts env] +typeEnvClasses env = [cl | tc <- typeEnvTyCons env, + Just cl <- [tyConClass_maybe tc]] mkTypeEnv :: [TyThing] -> TypeEnv mkTypeEnv things = extendTypeEnvList emptyTypeEnv things +mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv +mkTypeEnvWithImplicits things = + mkTypeEnv things + `plusNameEnv` + mkTypeEnv (concatMap implicitTyThings things) + +typeEnvFromEntities :: [Id] -> [TyCon] -> [Class] -> [FamInst] -> TypeEnv +typeEnvFromEntities ids tcs clss faminsts = + mkTypeEnv ( map AnId ids + ++ map ATyCon all_tcs + ++ concatMap implicitTyConThings all_tcs + ) + where + all_tcs = tcs ++ map classTyCon clss ++ map famInstTyCon faminsts + lookupTypeEnv = lookupNameEnv -- Extend the type environment @@ -1180,6 +1313,11 @@ extendTypeEnv env thing = extendNameEnv env (getName thing) thing extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv extendTypeEnvList env things = foldl extendTypeEnv env things + +extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv +extendTypeEnvWithIds env ids + = extendNameEnvList env [(getName id, AnId id) | id <- ids] + \end{code} \begin{code} @@ -1377,6 +1515,25 @@ availNames :: AvailInfo -> [Name] availNames (Avail n) = [n] availNames (AvailTC _ ns) = ns +-- | make a 'GlobalRdrEnv' where all the elements point to the same +-- import declaration (useful for "hiding" imports, or imports with +-- no details). +gresFromAvails :: Provenance -> [AvailInfo] -> [GlobalRdrElt] +gresFromAvails prov avails + = concatMap (gresFromAvail (const prov)) avails + +gresFromAvail :: (Name -> Provenance) -> AvailInfo -> [GlobalRdrElt] +gresFromAvail prov_fn avail + = [ GRE {gre_name = n, + gre_par = parent n avail, + gre_prov = prov_fn n} + | n <- availNames avail ] + where + parent _ (Avail _) = NoParent + parent n (AvailTC m _) | n == m = NoParent + | otherwise = ParentIs m + + instance Outputable AvailInfo where ppr = pprAvail diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index d94e514ab8..3e763d55eb 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -9,7 +9,7 @@ module InteractiveEval ( #ifdef GHCI RunResult(..), Status(..), Resume(..), History(..), - runStmt, runStmtWithLocation, + runStmt, runStmtWithLocation, runDecls, runDeclsWithLocation, parseImportDecl, SingleStep(..), resume, abandon, abandonAll, @@ -42,7 +42,6 @@ import GhcMonad import HscMain import HsSyn import HscTypes -import RnNames (gresFromAvails) import InstEnv import Type hiding( typeKind ) import TcType hiding( typeKind ) @@ -93,8 +92,7 @@ import System.IO.Unsafe data RunResult = RunOk [Name] -- ^ names bound by this evaluation - | RunFailed -- ^ statement failed compilation - | RunException SomeException -- ^ statement raised an exception + | RunException SomeException -- ^ statement raised an exception | RunBreak ThreadId [Name] (Maybe BreakInfo) data Status @@ -109,7 +107,7 @@ data Resume resumeThreadId :: ThreadId, -- thread running the computation resumeBreakMVar :: MVar (), resumeStatMVar :: MVar Status, - resumeBindings :: [Id], + resumeBindings :: ([TyThing], GlobalRdrEnv), resumeFinalIds :: [Id], -- [Id] to bind on completion resumeApStack :: HValue, -- The object from which we can get -- value of the free variables. @@ -203,9 +201,9 @@ runStmtWithLocation source linenumber expr step = r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber case r of - Nothing -> return RunFailed -- empty statement / comment + Nothing -> return (RunOk []) -- empty statement / comment - Just (ids, hval) -> do + Just (tyThings, hval) -> do status <- withVirtualCWD $ withBreakAction (isStep step) dflags' breakMVar statusMVar $ do @@ -213,16 +211,38 @@ runStmtWithLocation source linenumber expr step = liftIO $ sandboxIO dflags' statusMVar thing_to_run let ic = hsc_IC hsc_env - bindings = ic_tmp_ids ic + bindings = (ic_tythings ic, ic_rn_gbl_env ic) case step of RunAndLogSteps -> - traceRunStatus expr bindings ids + traceRunStatus expr bindings tyThings breakMVar statusMVar status emptyHistory _other -> - handleRunStatus expr bindings ids + handleRunStatus expr bindings tyThings breakMVar statusMVar status emptyHistory +runDecls :: GhcMonad m => String -> m [Name] +runDecls = runDeclsWithLocation "<interactive>" 1 + +runDeclsWithLocation :: GhcMonad m => String -> Int -> String -> m [Name] +runDeclsWithLocation source linenumber expr = + do + hsc_env <- getSession + + -- Turn off -fwarn-unused-bindings when running a statement, to hide + -- warnings about the implicit bindings we introduce. + let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds + hsc_env' = hsc_env{ hsc_dflags = dflags' } + + (tyThings, ic) <- liftIO $ hscDeclsWithLocation hsc_env' expr source linenumber + + setSession $ hsc_env { hsc_IC = ic } + hsc_env <- getSession + hsc_env' <- liftIO $ rttiEnvironment hsc_env + modifySession (\_ -> hsc_env') + return (map getName tyThings) + + withVirtualCWD :: GhcMonad m => m a -> m a withVirtualCWD m = do hsc_env <- getSession @@ -251,7 +271,7 @@ emptyHistory :: BoundedList History emptyHistory = nilBL 50 -- keep a log of length 50 handleRunStatus :: GhcMonad m => - String-> [Id] -> [Id] + String-> ([TyThing],GlobalRdrEnv) -> [Id] -> MVar () -> MVar Status -> Status -> BoundedList History -> m RunResult handleRunStatus expr bindings final_ids breakMVar statusMVar status @@ -280,15 +300,16 @@ handleRunStatus expr bindings final_ids breakMVar statusMVar status Left e -> return (RunException e) Right hvals -> do hsc_env <- getSession - let final_ic = extendInteractiveContext (hsc_IC hsc_env) final_ids - final_names = map idName final_ids + let final_ic = extendInteractiveContext (hsc_IC hsc_env) + (map AnId final_ids) + final_names = map getName final_ids liftIO $ Linker.extendLinkEnv (zip final_names hvals) hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} modifySession (\_ -> hsc_env') return (RunOk final_names) traceRunStatus :: GhcMonad m => - String -> [Id] -> [Id] + String -> ([TyThing], GlobalRdrEnv) -> [Id] -> MVar () -> MVar Status -> Status -> BoundedList History -> m RunResult traceRunStatus expr bindings final_ids @@ -448,15 +469,16 @@ resume canLogSpan step -- unbind the temporary locals by restoring the TypeEnv from -- before the breakpoint, and drop this Resume from the -- InteractiveContext. - let resume_tmp_ids = resumeBindings r - ic' = ic { ic_tmp_ids = resume_tmp_ids, + let (resume_tmp_te,resume_rdr_env) = resumeBindings r + ic' = ic { ic_tythings = resume_tmp_te, + ic_rn_gbl_env = resume_rdr_env, ic_resume = rs } modifySession (\_ -> hsc_env{ hsc_IC = ic' }) -- remove any bindings created since the breakpoint from the -- linker's environment - let new_names = map idName (filter (`notElem` resume_tmp_ids) - (ic_tmp_ids ic)) + let new_names = map getName (filter (`notElem` resume_tmp_te) + (ic_tythings ic)) liftIO $ Linker.deleteFromLinkEnv new_names when (isStep step) $ liftIO setStepFlag @@ -555,7 +577,7 @@ bindLocalsAtBreakpoint hsc_env apStack Nothing = do e_fs = fsLit "e" e_name = mkInternalName (getUnique e_fs) (mkTyVarOccFS e_fs) span e_tyvar = mkRuntimeUnkTyVar e_name liftedTypeKind - exn_id = Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar) + exn_id = AnId $ Id.mkVanillaGlobal exn_name (mkTyVarTy e_tyvar) ictxt0 = hsc_IC hsc_env ictxt1 = extendInteractiveContext ictxt0 [exn_id] @@ -627,7 +649,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys final_ids = zipWith setIdType all_ids tidy_tys ictxt0 = hsc_IC hsc_env - ictxt1 = extendInteractiveContext ictxt0 final_ids + ictxt1 = extendInteractiveContext ictxt0 (map AnId final_ids) Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ] when result_ok $ Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)] @@ -656,7 +678,7 @@ bindLocalsAtBreakpoint hsc_env apStack (Just info) = do rttiEnvironment :: HscEnv -> IO HscEnv rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do - let InteractiveContext{ic_tmp_ids=tmp_ids} = ic + let tmp_ids = [id | AnId id <- ic_tythings ic] incompletelyTypedIds = [id | id <- tmp_ids , not $ noSkolems id @@ -666,7 +688,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do where noSkolems = isEmptyVarSet . tyVarsOfType . idType improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do - let InteractiveContext{ic_tmp_ids=tmp_ids} = ic + let tmp_ids = [id | AnId id <- ic_tythings ic] Just id = find (\i -> idName i == name) tmp_ids if noSkolems id then return hsc_env @@ -783,9 +805,10 @@ setContext imports = do { hsc_env <- getSession ; let old_ic = hsc_IC hsc_env ; all_env <- liftIO $ findGlobalRdrEnv hsc_env imports + ; let final_rdr_env = ic_tythings old_ic `icPlusGblRdrEnv` all_env ; modifySession $ \_ -> hsc_env{ hsc_IC = old_ic { ic_imports = imports - , ic_rn_gbl_env = all_env }}} + , ic_rn_gbl_env = final_rdr_env }}} findGlobalRdrEnv :: HscEnv -> [InteractiveImport] -> IO GlobalRdrEnv -- Compute the GlobalRdrEnv for the interactive context @@ -880,11 +903,8 @@ getRdrNamesInScope = withSession $ \hsc_env -> do let ic = hsc_IC hsc_env gbl_rdrenv = ic_rn_gbl_env ic - ids = ic_tmp_ids ic - gbl_names = concat (map greToRdrNames (globalRdrEnvElts gbl_rdrenv)) - lcl_names = map (mkRdrUnqual.nameOccName.idName) ids - -- - return (gbl_names ++ lcl_names) + gbl_names = concatMap greToRdrNames $ globalRdrEnvElts gbl_rdrenv + return gbl_names -- ToDo: move to RdrName diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index e1e4d87f63..050931c813 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -4,13 +4,13 @@ \section{Tidying up Core} \begin{code} -module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc, - tidyProgram, globaliseAndTidyId ) where +module TidyPgm ( + mkBootModDetailsTc, tidyProgram, globaliseAndTidyId + ) where #include "HsVersions.h" import TcRnTypes -import FamInstEnv import DynFlags import CoreSyn import CoreUnfold @@ -20,13 +20,13 @@ import CoreMonad import CoreUtils import Rules import CoreArity ( exprArity, exprBotStrictness_maybe ) -import Class ( classAllSelIds ) import VarEnv import VarSet import Var import Id import IdInfo import InstEnv +import FamInstEnv import Demand import BasicTypes import Name hiding (varName) @@ -36,6 +36,7 @@ import NameEnv import TcType import DataCon import TyCon +import Class import Module import Packages( isDllName ) import HscTypes @@ -117,30 +118,19 @@ Plan A: mkBootModDetails: omit pragmas, make interfaces small mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails mkBootModDetailsTc hsc_env TcGblEnv{ tcg_exports = exports, - tcg_type_env = type_env, + tcg_type_env = type_env, -- just for the Ids + tcg_tcs = tcs, + tcg_clss = clss, tcg_insts = insts, tcg_fam_insts = fam_insts } - = mkBootModDetails hsc_env exports type_env insts fam_insts - -mkBootModDetailsDs :: HscEnv -> ModGuts -> IO ModDetails -mkBootModDetailsDs hsc_env - ModGuts{ mg_exports = exports, - mg_types = type_env, - mg_insts = insts, - mg_fam_insts = fam_insts - } - = mkBootModDetails hsc_env exports type_env insts fam_insts - -mkBootModDetails :: HscEnv -> [AvailInfo] -> NameEnv TyThing - -> [Instance] -> [FamInstEnv.FamInst] -> IO ModDetails -mkBootModDetails hsc_env exports type_env insts fam_insts - = do { let dflags = hsc_dflags hsc_env + = do { let dflags = hsc_dflags hsc_env ; showPass dflags CoreTidy ; let { insts' = tidyInstances globaliseAndTidyId insts ; dfun_ids = map instanceDFunId insts' - ; type_env1 = tidyBootTypeEnv (availsToNameSet exports) type_env + ; type_env1 = mkBootTypeEnv (availsToNameSet exports) + (typeEnvIds type_env) tcs clss fam_insts ; type_env' = extendTypeEnvWithIds type_env1 dfun_ids } ; return (ModDetails { md_types = type_env' @@ -154,21 +144,26 @@ mkBootModDetails hsc_env exports type_env insts fam_insts } where -tidyBootTypeEnv :: NameSet -> TypeEnv -> TypeEnv -tidyBootTypeEnv exports type_env - = tidyTypeEnv True False exports type_env final_ids +mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [Class] -> [FamInst] -> TypeEnv +mkBootTypeEnv exports ids tcs clss fam_insts + = tidyTypeEnv True False exports $ + typeEnvFromEntities final_ids tcs clss fam_insts where - -- Find the LocalIds in the type env that are exported + -- Find the LocalIds in the type env that are exported -- Make them into GlobalIds, and tidy their types -- -- It's very important to remove the non-exported ones -- because we don't tidy the OccNames, and if we don't remove -- the non-exported ones we'll get many things with the -- same name in the interface file, giving chaos. - final_ids = [ globaliseAndTidyId id - | id <- typeEnvIds type_env - , isLocalId id - , keep_it id ] + -- + -- Do make sure that we keep Ids that are already Global. + -- When typechecking an .hs-boot file, the Ids come through as + -- GlobalIds. + final_ids = [ if isLocalId id then globaliseAndTidyId id + else id + | id <- ids + , keep_it id ] -- default methods have their export flag set, but everything -- else doesn't (yet), because this is pre-desugaring, so we @@ -289,7 +284,8 @@ RHSs, so that they print nicely in interfaces. tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) tidyProgram hsc_env (ModGuts { mg_module = mod , mg_exports = exports - , mg_types = type_env + , mg_tcs = tcs + , mg_clss = clss , mg_insts = insts , mg_fam_insts = fam_insts , mg_binds = binds @@ -309,12 +305,16 @@ tidyProgram hsc_env (ModGuts { mg_module = mod } ; showPass dflags CoreTidy - ; let { implicit_binds = getImplicitBinds type_env } + ; let { type_env = typeEnvFromEntities [] tcs clss fam_insts + + ; implicit_binds + = concatMap getClassImplicitBinds (typeEnvClasses type_env) ++ + concatMap getTyConImplicitBinds (typeEnvTyCons type_env) + } ; (unfold_env, tidy_occ_env) <- chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_rules (vectInfoVar vect_info) - ; let { ext_rules = findExternalRules omit_prags binds imp_rules unfold_env } -- Glom together imp_rules and rules currently attached to binders -- Then pick just the ones we need to expose @@ -326,9 +326,11 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; let { export_set = availsToNameSet exports ; final_ids = [ id | id <- bindersOfBinds tidy_binds, isExternalName (idName id)] + ; tidy_type_env = tidyTypeEnv omit_prags th export_set - type_env final_ids - ; tidy_insts = tidyInstances (lookup_dfun tidy_type_env) insts + (extendTypeEnvWithIds type_env final_ids) + + ; tidy_insts = tidyInstances (lookup_dfun tidy_type_env) insts -- A DFunId will have a binding in tidy_binds, and so -- will now be in final_env, replete with IdInfo -- Its name will be unchanged since it was born, but @@ -345,12 +347,21 @@ tidyProgram hsc_env (ModGuts { mg_module = mod -- See Note [Injecting implicit bindings] ; all_tidy_binds = implicit_binds ++ tidy_binds + -- get the TyCons to generate code for. Careful! We must use + -- the untidied TypeEnv here, because we need + -- (a) implicit TyCons arising from types and classes defined + -- in this module + -- (b) wired-in TyCons, which are normally removed from the + -- TypeEnv we put in the ModDetails + -- (c) Constructors even if they are not exported (the + -- tidied TypeEnv has trimmed these away) ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) } ; endPass dflags CoreTidy all_tidy_binds tidy_rules - -- If the endPass didn't print the rules, but ddump-rules is on, print now + -- If the endPass didn't print the rules, but ddump-rules is + -- on, print now ; dumpIfSet (dopt Opt_D_dump_rules dflags && (not (dopt Opt_D_dump_simpl dflags))) CoreTidy @@ -374,7 +385,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod cg_hpc_info = hpc_info, cg_modBreaks = modBreaks }, - ModDetails { md_types = tidy_type_env, + ModDetails { md_types = tidy_type_env, md_rules = tidy_rules, md_insts = tidy_insts, md_vect_info = tidy_vect_info, @@ -391,40 +402,29 @@ lookup_dfun type_env dfun_id _other -> pprPanic "lookup_dfun" (ppr dfun_id) -------------------------- -tidyTypeEnv :: Bool -- Compiling without -O, so omit prags - -> Bool -- Template Haskell is on - -> NameSet -> TypeEnv -> [Id] -> TypeEnv +tidyTypeEnv :: Bool -- Compiling without -O, so omit prags + -> Bool -- Template Haskell is on + -> NameSet -> TypeEnv -> TypeEnv -- The competed type environment is gotten from --- Dropping any wired-in things, and then --- a) keeping the types and classes --- b) removing all Ids, --- c) adding Ids with correct IdInfo, including unfoldings, +-- a) the types and classes defined here (plus implicit things) +-- b) adding Ids with correct IdInfo, including unfoldings, -- gotten from the bindings --- From (c) we keep only those Ids with External names; +-- From (b) we keep only those Ids with External names; -- the CoreTidy pass makes sure these are all and only -- the externally-accessible ones -- This truncates the type environment to include only the -- exported Ids and things needed from them, which saves space -tidyTypeEnv omit_prags th exports type_env final_ids - = let type_env1 = filterNameEnv keep_it type_env - type_env2 = extendTypeEnvWithIds type_env1 final_ids - type_env3 | omit_prags = mapNameEnv (trimThing th exports) type_env2 - | otherwise = type_env2 - in - type_env3 - where - -- We keep GlobalIds, because they won't appear - -- in the bindings from which final_ids are derived! - -- (The bindings bind LocalIds.) - keep_it thing | isWiredInThing thing = False - keep_it (AnId id) = isGlobalId id -- Keep GlobalIds (e.g. class ops) - keep_it _other = True -- Keep all TyCons, DataCons, and Classes - --------------------------- -isWiredInThing :: TyThing -> Bool -isWiredInThing thing = isWiredInName (getName thing) +tidyTypeEnv omit_prags th exports type_env + = let + type_env1 = filterNameEnv (not . isWiredInName . getName) type_env + -- (1) remove wired-in things + type_env2 | omit_prags = mapNameEnv (trimThing th exports) type_env1 + | otherwise = type_env1 + -- (2) trimmed if necessary + in + type_env2 -------------------------- trimThing :: Bool -> NameSet -> TyThing -> TyThing @@ -576,16 +576,14 @@ really just a code generation trick.... binding itself makes no sense. See CorePrep Note [Data constructor workers]. \begin{code} -getImplicitBinds :: TypeEnv -> [CoreBind] -getImplicitBinds type_env - = map get_defn (concatMap implicit_ids (typeEnvElts type_env)) - where - implicit_ids (ATyCon tc) = class_ids ++ mapCatMaybes dataConWrapId_maybe (tyConDataCons tc) - where class_ids = maybe [] classAllSelIds (tyConClass_maybe tc) - implicit_ids _ = [] - - get_defn :: Id -> CoreBind - get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) +getTyConImplicitBinds :: TyCon -> [CoreBind] +getTyConImplicitBinds tc = map get_defn (mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)) + +getClassImplicitBinds :: Class -> [CoreBind] +getClassImplicitBinds cls = map get_defn (classAllSelIds cls) + +get_defn :: Id -> CoreBind +get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) \end{code} diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 0606c59673..77c5499265 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -51,14 +51,10 @@ module PrelNames ( import Module import OccName -import RdrName ( RdrName, nameRdrName, mkOrig, rdrNameOcc, mkUnqual ) -import Unique ( Unique, Uniquable(..), hasKey, - mkPreludeMiscIdUnique, mkPreludeDataConUnique, - mkPreludeTyConUnique, mkPreludeClassUnique, - mkTupleTyConUnique - ) -import BasicTypes ( TupleSort(..), Arity ) -import Name ( Name, mkInternalName, mkExternalName, mkSystemVarName ) +import RdrName +import Unique +import BasicTypes +import Name import SrcLoc import FastString \end{code} diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index ef842f261e..574550f1ff 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -397,6 +397,7 @@ extendGlobalRdrEnvRn :: [AvailInfo] extendGlobalRdrEnvRn avails new_fixities = do { (gbl_env, lcl_env) <- getEnvs ; stage <- getStage + ; isGHCi <- getIsGHCi ; let rdr_env = tcg_rdr_env gbl_env fix_env = tcg_fix_env gbl_env @@ -406,10 +407,12 @@ extendGlobalRdrEnvRn avails new_fixities -- See Note [Top-level Names in Template Haskell decl quotes] shadowP = isBrackStage stage new_occs = map (nameOccName . gre_name) gres - rdr_env1 = transformGREs qual_gre new_occs rdr_env + rdr_env_TH = transformGREs qual_gre new_occs rdr_env + rdr_env_GHCi = delListFromOccEnv rdr_env new_occs lcl_env1 = lcl_env { tcl_rdr = delListFromOccEnv (tcl_rdr lcl_env) new_occs } - (rdr_env2, lcl_env2) | shadowP = (rdr_env1, lcl_env1) - | otherwise = (rdr_env, lcl_env) + (rdr_env2, lcl_env2) | shadowP = (rdr_env_TH, lcl_env1) + | isGHCi = (rdr_env_GHCi, lcl_env1) + | otherwise = (rdr_env, lcl_env) rdr_env3 = foldl extendGlobalRdrEnv rdr_env2 gres fix_env' = foldl extend_fix_env fix_env gres @@ -802,20 +805,6 @@ catMaybeErr ms = [ a | Succeeded a <- ms ] %************************************************************************ \begin{code} --- | make a 'GlobalRdrEnv' where all the elements point to the same --- import declaration (useful for "hiding" imports, or imports with --- no details). -gresFromAvails :: Provenance -> [AvailInfo] -> [GlobalRdrElt] -gresFromAvails prov avails - = concatMap (gresFromAvail (const prov)) avails - -gresFromAvail :: (Name -> Provenance) -> AvailInfo -> [GlobalRdrElt] -gresFromAvail prov_fn avail - = [ GRE {gre_name = n, - gre_par = availParent n avail, - gre_prov = prov_fn n} - | n <- availNames avail ] - greExportAvail :: GlobalRdrElt -> AvailInfo greExportAvail gre = case gre_par gre of @@ -840,11 +829,6 @@ plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2)) (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) -availParent :: Name -> AvailInfo -> Parent -availParent _ (Avail _) = NoParent -availParent n (AvailTC m _) | n == m = NoParent - | otherwise = ParentIs m - trimAvail :: AvailInfo -> Name -> AvailInfo trimAvail (Avail n) _ = Avail n trimAvail (AvailTC n ns) m = ASSERT( m `elem` ns) AvailTC n [m] @@ -1734,8 +1718,13 @@ addDupDeclErr [] addDupDeclErr names@(name : _) = addErrAt (getSrcSpan (last sorted_names)) $ -- Report the error at the later location - vcat [ptext (sLit "Multiple declarations of") <+> quotes (ppr name), - ptext (sLit "Declared at:") <+> vcat (map (ppr . nameSrcLoc) sorted_names)] + vcat [ptext (sLit "Multiple declarations of") <+> + quotes (ppr (nameOccName name)), + -- NB. print the OccName, not the Name, because the + -- latter might not be in scope in the RdrEnv and so will + -- be printed qualified. + ptext (sLit "Declared at:") <+> + vcat (map (ppr . nameSrcLoc) sorted_names)] where sorted_names = sortWith nameSrcLoc names diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index d30769d0fa..0a3d3ffc25 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -163,6 +163,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- Haddock docs; no free vars rn_docs <- mapM (wrapLocM rnDocDecl) docs ; + last_tcg_env <- getGblEnv ; -- (I) Compute the results and return let {rn_group = HsGroup { hs_valds = rn_val_decls, hs_tyclds = rn_tycl_decls, @@ -189,7 +190,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- Instance decls may have occurrences of things bound in bind_dus -- so we must put other_fvs last - final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus) + final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus) in -- we return the deprecs in the env, not in the HsGroup above tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns }; } ; diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index ccdbf579dc..e2d1206380 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -147,18 +147,25 @@ tcExtendLocalFamInstEnv fam_insts thing_inside -- Check that the proposed new instance is OK, -- and then add it to the home inst env addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv -addLocalFamInst home_fie famInst - = do { -- Load imported instances, so that we report - -- overlaps correctly - ; eps <- getEps - ; let inst_envs = (eps_fam_inst_env eps, home_fie) - - -- Check for conflicting instance decls - ; checkForConflicts inst_envs famInst - - -- OK, now extend the envt - ; return (extendFamInstEnv home_fie famInst) - } +addLocalFamInst home_fie famInst = do + -- Load imported instances, so that we report + -- overlaps correctly + eps <- getEps + let inst_envs = (eps_fam_inst_env eps, home_fie) + + -- Check for conflicting instance decls + skol_tvs <- tcInstSkolTyVars (tyConTyVars (famInstTyCon famInst)) + let conflicts = lookupFamInstEnvConflicts inst_envs famInst skol_tvs + -- If there are any conflicts, we should probably error + -- But, if we're allowed to overwrite and the conflict is in the home FIE, + -- then overwrite instead of error. + isGHCi <- getIsGHCi + case conflicts of + dup : _ -> case (isGHCi, home_conflicts) of + (True, _ : _) -> return (overwriteFamInstEnv home_fie famInst) + (_, _) -> conflictInstErr famInst (fst dup) >> return (extendFamInstEnv home_fie famInst) + where home_conflicts = lookupFamInstEnvConflicts' home_fie famInst skol_tvs + [] -> return (extendFamInstEnv home_fie famInst) \end{code} %************************************************************************ @@ -186,7 +193,6 @@ checkForConflicts inst_envs famInst ; unless (null conflicts) $ conflictInstErr famInst (fst (head conflicts)) } - where conflictInstErr :: FamInst -> FamInst -> TcRn () conflictInstErr famInst conflictingFamInst diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 1690079bba..64acaf367a 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -399,52 +399,65 @@ tcExtendLocalInstEnv dfuns thing_inside addLocalInst :: InstEnv -> Instance -> TcM InstEnv -- Check that the proposed new instance is OK, -- and then add it to the home inst env -addLocalInst home_ie ispec - = do { -- Instantiate the dfun type so that we extend the instance - -- envt with completely fresh template variables - -- This is important because the template variables must - -- not overlap with anything in the things being looked up - -- (since we do unification). - -- - -- We use tcInstSkolType because we don't want to allocate fresh - -- *meta* type variables. - -- - -- We use UnkSkol --- and *not* InstSkol or PatSkol --- because - -- these variables must be bindable by tcUnifyTys. See - -- the call to tcUnifyTys in InstEnv, and the special - -- treatment that instanceBindFun gives to isOverlappableTyVar - -- This is absurdly delicate. - - let dfun = instanceDFunId ispec - ; (tvs', theta', tau') <- tcInstSkolType (idType dfun) - ; let (cls, tys') = tcSplitDFunHead tau' - dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau') - ispec' = setInstanceDFunId ispec dfun' - - -- Load imported instances, so that we report - -- duplicates correctly - ; eps <- getEps - ; let inst_envs = (eps_inst_env eps, home_ie) - - -- Check functional dependencies - ; case checkFunDeps inst_envs ispec' of - Just specs -> funDepErr ispec' specs - Nothing -> return () - - -- Check for duplicate instance decls - ; let { (matches, _, _) = lookupInstEnv inst_envs cls tys' - ; dup_ispecs = [ dup_ispec - | (dup_ispec, _) <- matches - , let (_,_,_,dup_tys) = instanceHead dup_ispec - , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] } - -- Find memebers of the match list which ispec itself matches. - -- If the match is 2-way, it's a duplicate - ; case dup_ispecs of - dup_ispec : _ -> dupInstErr ispec' dup_ispec - [] -> return () - - -- OK, now extend the envt - ; return (extendInstEnv home_ie ispec') } +-- If overwrite_inst, then we can overwrite a direct match +addLocalInst home_ie ispec = do + -- Instantiate the dfun type so that we extend the instance + -- envt with completely fresh template variables + -- This is important because the template variables must + -- not overlap with anything in the things being looked up + -- (since we do unification). + -- + -- We use tcInstSkolType because we don't want to allocate fresh + -- *meta* type variables. + -- + -- We use UnkSkol --- and *not* InstSkol or PatSkol --- because + -- these variables must be bindable by tcUnifyTys. See + -- the call to tcUnifyTys in InstEnv, and the special + -- treatment that instanceBindFun gives to isOverlappableTyVar + -- This is absurdly delicate. + + let dfun = instanceDFunId ispec + (tvs', theta', tau') <- tcInstSkolType (idType dfun) + let (cls, tys') = tcSplitDFunHead tau' + dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau') + ispec' = setInstanceDFunId ispec dfun' + + -- Load imported instances, so that we report + -- duplicates correctly + eps <- getEps + let inst_envs = (eps_inst_env eps, home_ie) + + -- Check functional dependencies + case checkFunDeps inst_envs ispec' of + Just specs -> funDepErr ispec' specs + Nothing -> return () + + -- Check for duplicate instance decls + let (matches, unifs, _) = lookupInstEnv inst_envs cls tys' + dup_ispecs = [ dup_ispec + | (dup_ispec, _) <- matches + , let (_,_,_,dup_tys) = instanceHead dup_ispec + , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] + + -- Find memebers of the match list which ispec itself matches. + -- If the match is 2-way, it's a duplicate + -- If it's a duplicate, but we can overwrite home package dups, then overwrite + isGHCi <- getIsGHCi + overlapFlag <- getOverlapFlag + case isGHCi of + False -> case dup_ispecs of + dup : _ -> dupInstErr ispec' dup >> return (extendInstEnv home_ie ispec') + [] -> return (extendInstEnv home_ie ispec') + True -> case (dup_ispecs, home_ie_matches, unifs, overlapFlag) of + (_, _:_, _, _) -> return (overwriteInstEnv home_ie ispec') + (dup:_, [], _, _) -> dupInstErr ispec' dup >> return (extendInstEnv home_ie ispec') + ([], _, u:_, NoOverlap _) -> overlappingInstErr ispec' u >> return (extendInstEnv home_ie ispec') + _ -> return (extendInstEnv home_ie ispec') + where (homematches, _) = lookupInstEnv' home_ie cls tys' + home_ie_matches = [ dup_ispec + | (dup_ispec, _) <- homematches + , let (_,_,_,dup_tys) = instanceHead dup_ispec + , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] traceDFuns :: [Instance] -> TcRn () traceDFuns ispecs @@ -463,6 +476,11 @@ dupInstErr ispec dup_ispec = addDictLoc ispec $ addErr (hang (ptext (sLit "Duplicate instance declarations:")) 2 (pprInstances [ispec, dup_ispec])) +overlappingInstErr :: Instance -> Instance -> TcRn () +overlappingInstErr ispec dup_ispec + = addDictLoc ispec $ + addErr (hang (ptext (sLit "Overlapping instance declarations:")) + 2 (pprInstances [ispec, dup_ispec])) addDictLoc :: Instance -> TcRn a -> TcRn a addDictLoc ispec thing_inside diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 5cec582b8f..678731bf76 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -12,7 +12,7 @@ module TcEnv( InstBindings(..), -- Global environment - tcExtendGlobalEnv, setGlobalTypeEnv, + tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv, tcExtendGlobalValEnv, tcLookupLocatedGlobal, tcLookupGlobal, tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, @@ -274,10 +274,28 @@ setGlobalTypeEnv tcg_env new_type_env writeMutVar (tcg_type_env_var tcg_env) new_type_env ; return (tcg_env { tcg_type_env = new_type_env }) } + tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r - -- Given a mixture of Ids, TyCons, Classes, all from the + -- Given a mixture of Ids, TyCons, Classes, all defined in the -- module being compiled, extend the global environment tcExtendGlobalEnv things thing_inside + = do { env <- getGblEnv + ; let env' = env { tcg_tcs = [ tc | ATyCon tc <- things, + not (isClassTyCon tc)] + ++ tcg_tcs env + , tcg_clss = [ cl | ATyCon tc <- things, + Just cl <- [tyConClass_maybe tc]] + ++ tcg_clss env } + ; setGblEnv env' $ + tcExtendGlobalEnvImplicit things thing_inside + } + +tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r + -- Extend the global environment with some TyThings that can be obtained + -- via implicitTyThings from other entities in the environment. Examples + -- are dfuns, famInstTyCons, data cons, etc. + -- These TyThings are not added to tcg_tcs or tcg_clss. +tcExtendGlobalEnvImplicit things thing_inside = do { tcg_env <- getGblEnv ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things ; tcg_env' <- setGlobalTypeEnv tcg_env ge' diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 5026b563de..dbca41c533 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -361,7 +361,7 @@ tcInstDecls1 -- Deal with both source-code and imported instance decls -- contains all dfuns for this module HsValBinds Name) -- Supporting bindings for derived instances -tcInstDecls1 tycl_decls inst_decls deriv_decls +tcInstDecls1 tycl_decls inst_decls deriv_decls = checkNoErrs $ do { -- Stop if addInstInfos etc discovers any errors -- (they recover, so that we get more than one error each @@ -380,7 +380,8 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- (2) Add the tycons of indexed types and their implicit -- tythings to the global environment - ; tcExtendGlobalEnv (map ATyCon at_idx_tycons ++ implicit_things) $ do { + ; tcExtendGlobalEnvImplicit + (map ATyCon at_idx_tycons ++ implicit_things) $ do { -- Next, construct the instance environment so far, consisting @@ -405,7 +406,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- the generic representation ; let all_tycons = map ATyCon (deriv_tys ++ deriv_ty_insts) ; gbl_env <- tcExtendGlobalEnv all_tycons $ - tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $ + tcExtendGlobalEnvImplicit (concatMap implicitTyThings all_tycons) $ addFamInsts deriv_ty_insts $ addInsts deriv_inst_info getGblEnv diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index a19a68fdbe..21b71b2c6a 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -10,6 +10,7 @@ module TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType, tcRnLookupRdrName, getModuleInterface, + tcRnDeclsi, #endif tcRnImports, tcRnLookupName, @@ -336,36 +337,34 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) my_exports = map (Avail . idName) bndrs ; -- ToDo: export the data types also? - final_type_env = - extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; - mod_guts = ModGuts { mg_module = this_mod, - mg_boot = False, - mg_used_names = emptyNameSet, -- ToDo: compute usage + mg_boot = False, + mg_used_names = emptyNameSet, -- ToDo: compute usage mg_used_th = False, mg_dir_imps = emptyModuleEnv, -- ?? - mg_deps = noDependencies, -- ?? - mg_exports = my_exports, - mg_types = final_type_env, - mg_insts = tcg_insts tcg_env, - mg_fam_insts = tcg_fam_insts tcg_env, - mg_inst_env = tcg_inst_env tcg_env, - mg_fam_inst_env = tcg_fam_inst_env tcg_env, - mg_rules = [], - mg_vect_decls = [], - mg_anns = [], - mg_binds = core_binds, - - -- Stubs - mg_rdr_env = emptyGlobalRdrEnv, - mg_fix_env = emptyFixityEnv, - mg_warns = NoWarnings, - mg_foreign = NoStubs, - mg_hpc_info = emptyHpcInfo False, + mg_deps = noDependencies, -- ?? + mg_exports = my_exports, + mg_tcs = tcg_tcs tcg_env, + mg_clss = tcg_clss tcg_env, + mg_insts = tcg_insts tcg_env, + mg_fam_insts = tcg_fam_insts tcg_env, + mg_inst_env = tcg_inst_env tcg_env, + mg_fam_inst_env = tcg_fam_inst_env tcg_env, + mg_rules = [], + mg_vect_decls = [], + mg_anns = [], + mg_binds = core_binds, + + -- Stubs + mg_rdr_env = emptyGlobalRdrEnv, + mg_fix_env = emptyFixityEnv, + mg_warns = NoWarnings, + mg_foreign = NoStubs, + mg_hpc_info = emptyHpcInfo False, mg_modBreaks = emptyModBreaks, mg_vect_info = noVectInfo, mg_trust_pkg = False - } } ; + } } ; tcCoreDump mod_guts ; @@ -390,9 +389,9 @@ tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv -- Reason: solely to report unused imports and bindings tcRnSrcDecls boot_iface decls = do { -- Do all the declarations - (tc_envs, lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ; + ((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ; ; traceTc "Tc8" empty ; - ; setEnvs tc_envs $ + ; setEnvs (tcg_env, tcl_env) $ do { -- Finish simplifying class constraints @@ -403,7 +402,7 @@ tcRnSrcDecls boot_iface decls -- and no subsequent decl instantiates its type. -- -- We do this after checkMain, so that we use the type info - -- thaat checkMain adds + -- that checkMain adds -- -- We do it with both global and local env in scope: -- * the global env exposes the instances to simplifyTop @@ -419,8 +418,7 @@ tcRnSrcDecls boot_iface decls -- Zonk the final code. This must be done last. -- Even simplifyTop may do some unification. -- This pass also warns about missing type signatures - let { (tcg_env, _) = tc_envs - ; TcGblEnv { tcg_type_env = type_env, + let { TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, tcg_sigs = sig_ns, tcg_ev_binds = cur_ev_binds, @@ -441,20 +439,22 @@ tcRnSrcDecls boot_iface decls tcg_vects = vects', tcg_fords = fords' } } ; - setGlobalTypeEnv tcg_env' final_type_env + setGlobalTypeEnv tcg_env' final_type_env } } -tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) +tc_rn_src_decls :: ModDetails + -> [LHsDecl RdrName] + -> TcM (TcGblEnv, TcLclEnv) -- Loops around dealing with each top level inter-splice group -- in turn, until it's dealt with the entire module tc_rn_src_decls boot_details ds = do { (first_group, group_tail) <- findSplice ds ; -- If ds is [] we get ([], Nothing) - + -- Deal with decls up to, but not including, the first splice (tcg_env, rn_decls) <- rnTopSrcDecls first_group ; -- rnTopSrcDecls fails if there are any errors - + (tcg_env, tcl_env) <- setGblEnv tcg_env $ tcTopSrcDecls boot_details rn_decls ; @@ -860,7 +860,7 @@ rnTopSrcDecls group ------------------------------------------------ tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) -tcTopSrcDecls boot_details +tcTopSrcDecls boot_details (HsGroup { hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_derivds = deriv_decls, @@ -1082,28 +1082,63 @@ setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a setInteractiveContext hsc_env icxt thing_inside = let -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnModule. - (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True) - in - updGblEnv (\env -> env { - tcg_rdr_env = ic_rn_gbl_env icxt, - tcg_inst_env = extendInstEnvList (tcg_inst_env env) home_insts, - tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env) - home_fam_insts - }) $ - - tcExtendGhciEnv (ic_tmp_ids icxt) $ - -- tcExtendGhciEnv does lots: - -- - it extends the local type env (tcl_env) with the given Ids, - -- - it extends the local rdr env (tcl_rdr) with the Names from - -- the given Ids - -- - it adds the free tyvars of the Ids to the tcl_tyvars - -- set. + (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True) + (ic_insts, ic_finsts) = ic_instances icxt + + -- Note [GHCi temporary Ids] + -- Ideally we would just make a type_env from ic_tythings + -- and ic_sys_vars, adding in implicit things. However, Ids + -- bound interactively might have some free type variables + -- (RuntimeUnk things), and if we don't register these free + -- TyVars as global TyVars then the typechecker will try to + -- quantify over them and fall over in zonkQuantifiedTyVar. + -- + -- So we must add any free TyVars to the typechecker's global + -- TyVar set. This is what happens when the local environment + -- is extended, so we use tcExtendGhciEnv below which extends + -- the local environment with the Ids. + -- + -- However, any Ids bound this way will shadow other Ids in + -- the GlobalRdrEnv, so we have to be careful to only add Ids + -- which are visible in the GlobalRdrEnv. -- - -- later ids in ic_tmp_ids must shadow earlier ones with the same - -- OccName, and tcExtendIdEnv implements this behaviour. + -- Perhaps it would be better to just extend the global TyVar + -- list from the free tyvars in the Ids here? Anyway, at least + -- this hack is localised. + + (tmp_ids, types_n_classes) = partitionWith sel_id (ic_tythings icxt) + where sel_id (AnId id) = Left id + sel_id other = Right other + + type_env = mkTypeEnvWithImplicits + (map AnId (ic_sys_vars icxt) ++ types_n_classes) - do { traceTc "setIC" (ppr (ic_tmp_ids icxt)) - ; thing_inside } + visible_tmp_ids = filter visible tmp_ids + where visible id = not (null (lookupGRE_Name (ic_rn_gbl_env icxt) + (idName id))) + + con_fields = [ (dataConName c, dataConFieldLabels c) + | ATyCon t <- types_n_classes + , c <- tyConDataCons t ] + in + updGblEnv (\env -> env { + tcg_rdr_env = ic_rn_gbl_env icxt + , tcg_type_env = type_env + , tcg_inst_env = extendInstEnvList + (extendInstEnvList (tcg_inst_env env) ic_insts) + home_insts + , tcg_fam_inst_env = extendFamInstEnvList + (extendFamInstEnvList (tcg_fam_inst_env env) + ic_finsts) + home_fam_insts + , tcg_field_env = RecFields (mkNameEnv con_fields) + (mkNameSet (concatMap snd con_fields)) + -- setting tcg_field_env is necessary to make RecordWildCards work + -- (test: ghci049) + }) $ + + tcExtendGhciEnv visible_tmp_ids $ -- Note [GHCi temporary Ids] + thing_inside \end{code} @@ -1176,9 +1211,9 @@ tcRnStmt hsc_env ictxt rdr_stmt Note [Interactively-bound Ids in GHCi] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The Ids bound by previous Stmts in Template Haskell are currently +The Ids bound by previous Stmts in GHCi are currently a) GlobalIds - b) with an Internal Name (not External) + b) with an Internal Name (not External) c) and a tidied type (a) They must be GlobalIds (not LocalIds) otherwise when we come to @@ -1341,11 +1376,11 @@ tcRnExpr just finds the type of an expression \begin{code} tcRnExpr :: HscEnv - -> InteractiveContext + -> InteractiveContext -> LHsExpr RdrName -> IO (Messages, Maybe Type) tcRnExpr hsc_env ictxt rdr_expr - = initTcPrintErrors hsc_env iNTERACTIVE $ + = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { (rn_expr, _fvs) <- rnLExpr rdr_expr ; @@ -1372,11 +1407,11 @@ tcRnType just finds the kind of a type \begin{code} tcRnType :: HscEnv - -> InteractiveContext + -> InteractiveContext -> LHsType RdrName -> IO (Messages, Maybe Kind) tcRnType hsc_env ictxt rdr_type - = initTcPrintErrors hsc_env iNTERACTIVE $ + = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env ictxt $ do { rn_type <- rnLHsType doc rdr_type ; @@ -1389,6 +1424,53 @@ tcRnType hsc_env ictxt rdr_type where doc = ptext (sLit "In GHCi input") +\end{code} + +tcRnDeclsi exists to allow class, data, and other declarations in GHCi. + +\begin{code} +tcRnDeclsi :: HscEnv + -> InteractiveContext + -> [LHsDecl RdrName] + -> IO (Messages, Maybe TcGblEnv) + +tcRnDeclsi hsc_env ictxt local_decls = + initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext hsc_env ictxt $ do + + ((tcg_env, tclcl_env), lie) <- + captureConstraints $ tc_rn_src_decls emptyModDetails local_decls + setEnvs (tcg_env, tclcl_env) $ do + + new_ev_binds <- simplifyTop lie + failIfErrsM + let TcGblEnv { tcg_type_env = type_env, + tcg_binds = binds, + tcg_sigs = sig_ns, + tcg_ev_binds = cur_ev_binds, + tcg_imp_specs = imp_specs, + tcg_rules = rules, + tcg_vects = vects, + tcg_fords = fords } = tcg_env + all_ev_binds = cur_ev_binds `unionBags` new_ev_binds + + (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') + <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords + + let --global_ids = map globaliseAndTidyId bind_ids + final_type_env = extendTypeEnvWithIds type_env bind_ids --global_ids + tcg_env' = tcg_env { tcg_binds = binds', + tcg_ev_binds = ev_binds', + tcg_imp_specs = imp_specs', + tcg_rules = rules', + tcg_vects = vects', + tcg_fords = fords' } + + tcg_env'' <- setGlobalTypeEnv tcg_env' final_type_env + + return tcg_env'' + + #endif /* GHCi */ \end{code} @@ -1411,45 +1493,44 @@ getModuleInterface hsc_env mod loadModuleInterface (ptext (sLit "getModuleInterface")) mod tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name]) -tcRnLookupRdrName hsc_env rdr_name - = initTcPrintErrors hsc_env iNTERACTIVE $ +tcRnLookupRdrName hsc_env rdr_name + = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env (hsc_IC hsc_env) $ lookup_rdr_name rdr_name lookup_rdr_name :: RdrName -> TcM [Name] -lookup_rdr_name rdr_name = do { - -- If the identifier is a constructor (begins with an - -- upper-case letter), then we need to consider both - -- constructor and type class identifiers. - let { rdr_names = dataTcOccs rdr_name } ; - - -- results :: [Either Messages Name] - results <- mapM (tryTcErrs . lookupOccRn) rdr_names ; - - traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]); - -- The successful lookups will be (Just name) - let { (warns_s, good_names) = unzip [ (msgs, name) - | (msgs, Just name) <- results] ; - errs_s = [msgs | (msgs, Nothing) <- results] } ; - - -- Fail if nothing good happened, else add warnings - if null good_names then - -- No lookup succeeded, so - -- pick the first error message and report it - -- ToDo: If one of the errors is "could be Foo.X or Baz.X", - -- while the other is "X is not in scope", - -- we definitely want the former; but we might pick the latter - do { addMessages (head errs_s) ; failM } - else -- Add deprecation warnings - mapM_ addMessages warns_s ; - +lookup_rdr_name rdr_name = do + -- If the identifier is a constructor (begins with an + -- upper-case letter), then we need to consider both + -- constructor and type class identifiers. + let rdr_names = dataTcOccs rdr_name + + -- results :: [Either Messages Name] + results <- mapM (tryTcErrs . lookupOccRn) rdr_names + + traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]) + -- The successful lookups will be (Just name) + let (warns_s, good_names) = unzip [ (msgs, name) + | (msgs, Just name) <- results] + errs_s = [msgs | (msgs, Nothing) <- results] + + -- Fail if nothing good happened, else add warnings + if null good_names + then addMessages (head errs_s) >> failM + -- No lookup succeeded, so + -- pick the first error message and report it + -- ToDo: If one of the errors is "could be Foo.X or Baz.X", + -- while the other is "X is not in scope", + -- we definitely want the former; but we might pick the latter + else mapM_ addMessages warns_s + -- Add deprecation warnings return good_names - } + #endif tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing) tcRnLookupName hsc_env name - = initTcPrintErrors hsc_env iNTERACTIVE $ + = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env (hsc_IC hsc_env) $ tcRnLookupName' name @@ -1491,7 +1572,7 @@ tcRnGetInfo' hsc_env name -- That way we will find all the instance declarations -- (Packages have not orphan modules, and we assume that -- in the home package all relevant modules are loaded.) - loadUnqualIfaces ictxt + loadUnqualIfaces hsc_env ictxt thing <- tcRnLookupName' name fixity <- lookupFixityRn name @@ -1519,15 +1600,18 @@ lookupInsts (ATyCon tc) lookupInsts _ = return [] -loadUnqualIfaces :: InteractiveContext -> TcM () --- Load the home module for everything that is in scope unqualified +loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM () +-- Load the interface for everything that is in scope unqualified -- This is so that we can accurately report the instances for -- something -loadUnqualIfaces ictxt - = initIfaceTcRn $ +loadUnqualIfaces hsc_env ictxt + = initIfaceTcRn $ do mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) where - unqual_mods = [ nameModule name + this_pkg = thisPackage (hsc_dflags hsc_env) + + unqual_mods = filter ((/= this_pkg) . modulePackageId) + [ nameModule name | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt), let name = gre_name gre, not (isInternalName name), @@ -1601,9 +1685,11 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, (is_boot1 `compare` is_boot2) pprModGuts :: ModGuts -> SDoc -pprModGuts (ModGuts { mg_types = type_env, - mg_rules = rules }) - = vcat [ ppr_types [] type_env, +pprModGuts (ModGuts { mg_tcs = tcs + , mg_clss = clss + , mg_rules = rules }) + = vcat [ ppr_types [] (mkTypeEnv (map ATyCon tcs + ++ map (ATyCon . classTyCon) clss)), ppr_rules rules ] ppr_types :: [Instance] -> TypeEnv -> SDoc diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 6a45bb8e1f..6fcc8a9fb8 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -14,6 +14,7 @@ module TcRnMonad( import TcRnTypes -- Re-export all import IOEnv -- Re-export all +import Coercion import HsSyn hiding (LIE) import HscTypes import Module @@ -23,8 +24,7 @@ import Type import TcType import InstEnv import FamInstEnv -import PrelNames ( iNTERACTIVE ) -import Coercion +import PrelNames import Var import Id @@ -117,6 +117,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_ev_binds = emptyBag, tcg_warns = NoWarnings, tcg_anns = [], + tcg_tcs = [], + tcg_clss = [], tcg_insts = [], tcg_fam_insts = [], tcg_rules = [], @@ -1145,19 +1147,6 @@ initIfaceTc iface do_this mod = mi_module iface doc = ptext (sLit "The interface for") <+> quotes (ppr mod) -initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a --- Used when sucking in new Rules in SimplCore --- We have available the type envt of the module being compiled, and we must use it -initIfaceRules hsc_env guts do_this - = do { let { - type_info = (mg_module guts, return (mg_types guts)) - ; gbl_env = IfGblEnv { if_rec_types = Just type_info } ; - } - - -- Run the thing; any exceptions just bubble out from here - ; initTcRnIf 'i' hsc_env gbl_env () do_this - } - initIfaceLcl :: Module -> SDoc -> IfL a -> IfM lcl a initIfaceLcl mod loc_doc thing_inside = setLclEnv (mkIfLclEnv mod loc_doc) thing_inside diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index ba022cf8b0..58c3aa6a43 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -65,6 +65,7 @@ import HsSyn import HscTypes import Type import Class ( Class ) +import TyCon ( TyCon ) import DataCon ( DataCon, dataConUserType ) import TcType import Annotations @@ -266,6 +267,8 @@ data TcGblEnv tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids tcg_warns :: Warnings, -- ...Warnings and deprecations tcg_anns :: [Annotation], -- ...Annotations + tcg_tcs :: [TyCon], -- ...TyCons + tcg_clss :: [Class], -- ...Classes tcg_insts :: [Instance], -- ...Instances tcg_fam_insts :: [FamInst], -- ...Family instances tcg_rules :: [LRuleDecl Id], -- ...Rules diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index c938001da6..d99e19116b 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -69,10 +69,10 @@ import Data.List \begin{code} tcTyAndClassDecls :: ModDetails - -> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order - -> TcM (TcGblEnv, -- Input env extended by types and classes - -- and their implicit Ids,DataCons - HsValBinds Name) -- Renamed bindings for record selectors + -> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order + -> TcM (TcGblEnv, -- Input env extended by types and classes + -- and their implicit Ids,DataCons + HsValBinds Name) -- Renamed bindings for record selectors -- Fails if there are any errors tcTyAndClassDecls boot_details decls_s @@ -114,12 +114,13 @@ tcTyAndClassDecls boot_details decls_s -- the same. ; let { implicit_things = concatMap implicitTyThings tyclss ; rec_sel_binds = mkRecSelBinds [tc | ATyCon tc <- tyclss] - ; dm_ids = mkDefaultMethodIds tyclss } + ; dm_ids = mkDefaultMethodIds tyclss } - ; env <- tcExtendGlobalEnv implicit_things $ - tcExtendGlobalValEnv dm_ids $ - getGblEnv - ; return (env, rec_sel_binds) } } + ; tcg_env <- tcExtendGlobalEnvImplicit implicit_things $ + tcExtendGlobalValEnv dm_ids $ + getGblEnv + + ; return (tcg_env, rec_sel_binds) } } zipRecTyClss :: [[LTyClDecl Name]] -> [TyThing] -- Knot-tied diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index da6f26f449..c429a9b179 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -11,10 +11,10 @@ module FamInstEnv ( famInstHead, mkLocalFamInst, mkImportedFamInst, FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, - extendFamInstEnv, extendFamInstEnvList, + extendFamInstEnv, overwriteFamInstEnv, extendFamInstEnvList, famInstEnvElts, familyInstances, - lookupFamInstEnv, lookupFamInstEnvConflicts, + lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvConflicts', -- Normalisation topNormaliseType @@ -225,6 +225,43 @@ extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs}) add (FamIE items tyvar) _ = FamIE (ins_item:items) (ins_tyvar || tyvar) ins_tyvar = not (any isJust mb_tcs) + +overwriteFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv +overwriteFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm, fi_tcs = mb_tcs}) + = addToUFM_C add inst_env cls_nm (FamIE [ins_item] ins_tyvar) + where + add (FamIE items tyvar) _ = FamIE (replaceFInst items) + (ins_tyvar || tyvar) + ins_tyvar = not (any isJust mb_tcs) + match _ tpl_tvs tpl_tys tys = tcMatchTys tpl_tvs tpl_tys tys + + inst_tycon = famInstTyCon ins_item + (fam, tys) = expectJust "FamInstEnv.lookuFamInstEnvConflicts" + (tyConFamInst_maybe inst_tycon) + arity = tyConArity fam + n_tys = length tys + match_tys + | arity > n_tys = take arity tys + | otherwise = tys + rough_tcs = roughMatchTcs match_tys + + replaceFInst [] = [ins_item] + replaceFInst (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, + fi_tys = tpl_tys }) : rest) + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = item : replaceFInst rest + + -- Proper check + | Just _ <- match item tpl_tvs tpl_tys match_tys + = ins_item : rest + + -- No match => try next + | otherwise + = item : replaceFInst rest + + + \end{code} %************************************************************************ @@ -265,6 +302,58 @@ lookupFamInstEnv where match _ tpl_tvs tpl_tys tys = tcMatchTys tpl_tvs tpl_tys tys +lookupFamInstEnvConflicts' + :: FamInstEnv + -> FamInst -- Putative new instance + -> [TyVar] -- Unique tyvars, matching arity of FamInst + -> [FamInstMatch] -- Conflicting matches +-- E.g. when we are about to add +-- f : type instance F [a] = a->a +-- we do (lookupFamInstConflicts f [b]) +-- to find conflicting matches +-- The skolem tyvars are needed because we don't have a +-- unique supply to hand +-- +-- Precondition: the tycon is saturated (or over-saturated) + +lookupFamInstEnvConflicts' env fam_inst skol_tvs + = lookup_fam_inst_env' my_unify False env fam tys' + where + inst_tycon = famInstTyCon fam_inst + (fam, tys) = expectJust "FamInstEnv.lookuFamInstEnvConflicts" + (tyConFamInst_maybe inst_tycon) + skol_tys = mkTyVarTys skol_tvs + tys' = substTys (zipTopTvSubst (tyConTyVars inst_tycon) skol_tys) tys + -- In example above, fam tys' = F [b] + + my_unify old_fam_inst tpl_tvs tpl_tys match_tys + = ASSERT2( tyVarsOfTypes tys `disjointVarSet` tpl_tvs, + (ppr fam <+> ppr tys) $$ + (ppr tpl_tvs <+> ppr tpl_tys) ) + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + case tcUnifyTys instanceBindFun tpl_tys match_tys of + Just subst | conflicting old_fam_inst subst -> Just subst + _other -> Nothing + + -- - In the case of data family instances, any overlap is fundamentally a + -- conflict (as these instances imply injective type mappings). + -- - In the case of type family instances, overlap is admitted as long as + -- the right-hand sides of the overlapping rules coincide under the + -- overlap substitution. We require that they are syntactically equal; + -- anything else would be difficult to test for at this stage. + conflicting old_fam_inst subst + | isAlgTyCon fam = True + | otherwise = not (old_rhs `eqType` new_rhs) + where + old_tycon = famInstTyCon old_fam_inst + old_tvs = tyConTyVars old_tycon + old_rhs = mkTyConApp old_tycon (substTyVars subst old_tvs) + new_rhs = mkTyConApp inst_tycon (substTyVars subst skol_tvs) + + + + lookupFamInstEnvConflicts :: FamInstEnvs -> FamInst -- Putative new instance @@ -336,25 +425,19 @@ type MatchFun = FamInst -- The FamInst template type OneSidedMatch = Bool -- Are optimisations that are only valid for -- one sided matches allowed? -lookup_fam_inst_env -- The worker, local to this module +lookup_fam_inst_env' -- The worker, local to this module :: MatchFun -> OneSidedMatch - -> FamInstEnvs + -> FamInstEnv -> TyCon -> [Type] -- What we are looking for -> [FamInstMatch] -- Successful matches - --- Precondition: the tycon is saturated (or over-saturated) - -lookup_fam_inst_env match_fun one_sided (pkg_ie, home_ie) fam tys +lookup_fam_inst_env' match_fun one_sided ie fam tys | not (isFamilyTyCon fam) = [] | otherwise = ASSERT2( n_tys >= arity, ppr fam <+> ppr tys ) -- Family type applications must be saturated - home_matches ++ pkg_matches + lookup ie where - home_matches = lookup home_ie - pkg_matches = lookup pkg_ie - -- See Note [Over-saturated matches] arity = tyConArity fam n_tys = length tys @@ -394,6 +477,21 @@ lookup_fam_inst_env match_fun one_sided (pkg_ie, home_ie) fam tys -- No match => try next | otherwise = find rest +-- Precondition: the tycon is saturated (or over-saturated) + +lookup_fam_inst_env -- The worker, local to this module + :: MatchFun + -> OneSidedMatch + -> FamInstEnvs + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] -- Successful matches + +-- Precondition: the tycon is saturated (or over-saturated) + +lookup_fam_inst_env match_fun one_sided (pkg_ie, home_ie) fam tys = + lookup_fam_inst_env' match_fun one_sided home_ie fam tys ++ + lookup_fam_inst_env' match_fun one_sided pkg_ie fam tys + \end{code} Note [Over-saturated matches] diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index dd70be8748..ab90be248a 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -13,8 +13,8 @@ module InstEnv ( instanceHead, mkLocalInstance, mkImportedInstance, instanceDFunId, setInstanceDFunId, instanceRoughTcs, - InstEnv, emptyInstEnv, extendInstEnv, - extendInstEnvList, lookupInstEnv, instEnvElts, + InstEnv, emptyInstEnv, extendInstEnv, overwriteInstEnv, + extendInstEnvList, lookupInstEnv', lookupInstEnv, instEnvElts, classInstances, instanceBindFun, instanceCantMatch, roughMatchTcs ) where @@ -387,6 +387,29 @@ extendInstEnv inst_env ins_item@(Instance { is_cls = cls_nm }) = addToUFM_C add inst_env cls_nm (ClsIE [ins_item]) where add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts) + +overwriteInstEnv :: InstEnv -> Instance -> InstEnv +overwriteInstEnv inst_env ins_item@(Instance { is_cls = cls_nm, is_tys = tys }) + = addToUFM_C add inst_env cls_nm (ClsIE [ins_item]) + where + add (ClsIE cur_insts) _ = ClsIE (replaceInst cur_insts) + + rough_tcs = roughMatchTcs tys + replaceInst [] = [ins_item] + replaceInst (item@(Instance { is_tcs = mb_tcs, is_tvs = tpl_tvs, + is_tys = tpl_tys, + is_dfun = dfun }) : rest) + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = item : replaceInst rest + + | Just _ <- tcMatchTys tpl_tvs tpl_tys tys + = let (dfun_tvs, _) = tcSplitForAllTys (idType dfun) + in ASSERT( all (`elemVarSet` tpl_tvs) dfun_tvs ) -- Check invariant + ins_item : rest + + | otherwise + = item : replaceInst rest \end{code} @@ -418,17 +441,15 @@ might have some tyvars that *only* appear in arguments When we match this against D [ty], we return the instantiating types [Right ty, Left b] where the Nothing indicates that 'b' can be freely instantiated. -(The caller instantiates it to a flexi type variable, which will presumably +(The caller instantiates it to a flexi type variable, which will presumably later become fixed via functional dependencies.) \begin{code} -lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env - -> Class -> [Type] -- What we are looking for - -> ([InstMatch], -- Successful matches - [Instance], -- These don't match but do unify - Bool) -- True if error condition caused by - -- Safe Haskell condition. +lookupInstEnv' :: InstEnv -- InstEnv to look in + -> Class -> [Type] -- What we are looking for + -> ([InstMatch], -- Successful matches + [Instance]) -- These don't match but do unify -- The second component of the result pair happens when we look up -- Foo [a] -- in an InstEnv that has entries for @@ -439,53 +460,11 @@ lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env -- but Foo [Int] is a unifier. This gives the caller a better chance of -- giving a suitable error message -lookupInstEnv (pkg_ie, home_ie) cls tys - = (safe_matches, all_unifs, safe_fail) +lookupInstEnv' ie cls tys + = lookup ie where rough_tcs = roughMatchTcs tys all_tvs = all isNothing rough_tcs - (home_matches, home_unifs) = lookup home_ie - (pkg_matches, pkg_unifs) = lookup pkg_ie - all_matches = home_matches ++ pkg_matches - all_unifs = home_unifs ++ pkg_unifs - pruned_matches = foldr insert_overlapping [] all_matches - (safe_matches, safe_fail) = if length pruned_matches == 1 - then check_safe (head pruned_matches) all_matches - else (pruned_matches, False) - -- Even if the unifs is non-empty (an error situation) - -- we still prune the matches, so that the error message isn't - -- misleading (complaining of multiple matches when some should be - -- overlapped away) - - -- Safe Haskell: We restrict code compiled in 'Safe' mode from - -- overriding code compiled in any other mode. The rational is - -- that code compiled in 'Safe' mode is code that is untrusted - -- by the ghc user. So we shouldn't let that code change the - -- behaviour of code the user didn't compile in 'Safe' mode - -- since thats the code they trust. So 'Safe' instances can only - -- overlap instances from the same module. A same instance origin - -- policy for safe compiled instances. - check_safe match@(inst,_) others - = case isSafeOverlap (is_flag inst) of - -- most specific isn't from a Safe module so OK - False -> ([match], False) - -- otherwise we make sure it only overlaps instances from - -- the same module - True -> (go [] others, True) - where - go bad [] = match:bad - go bad (i@(x,_):unchecked) = - if inSameMod x - then go bad unchecked - else go (i:bad) unchecked - - inSameMod b = - let na = getName $ getName inst - la = isInternalName na - nb = getName $ getName b - lb = isInternalName nb - in (la && lb) || (nameModule na == nameModule nb) - -------------- lookup env = case lookupUFM env cls of Nothing -> ([],[]) -- No instances for this class @@ -531,6 +510,60 @@ lookupInstEnv (pkg_ie, home_ie) cls tys Nothing -> Left tv --------------- +-- This is the common way to call this function. +lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env + -> Class -> [Type] -- What we are looking for + -> ([InstMatch], -- Successful matches + [Instance], -- These don't match but do unify + Bool) -- True if error condition caused by + -- SafeHaskell condition. + +lookupInstEnv (pkg_ie, home_ie) cls tys + = (safe_matches, all_unifs, safe_fail) + where + (home_matches, home_unifs) = lookupInstEnv' home_ie cls tys + (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie cls tys + all_matches = home_matches ++ pkg_matches + all_unifs = home_unifs ++ pkg_unifs + pruned_matches = foldr insert_overlapping [] all_matches + (safe_matches, safe_fail) = if length pruned_matches == 1 + then check_safe (head pruned_matches) all_matches + else (pruned_matches, False) + -- Even if the unifs is non-empty (an error situation) + -- we still prune the matches, so that the error message isn't + -- misleading (complaining of multiple matches when some should be + -- overlapped away) + + -- Safe Haskell: We restrict code compiled in 'Safe' mode from + -- overriding code compiled in any other mode. The rational is + -- that code compiled in 'Safe' mode is code that is untrusted + -- by the ghc user. So we shouldn't let that code change the + -- behaviour of code the user didn't compile in 'Safe' mode + -- since that's the code they trust. So 'Safe' instances can only + -- overlap instances from the same module. A same instance origin + -- policy for safe compiled instances. + check_safe match@(inst,_) others + = case isSafeOverlap (is_flag inst) of + -- most specific isn't from a Safe module so OK + False -> ([match], False) + -- otherwise we make sure it only overlaps instances from + -- the same module + True -> (go [] others, True) + where + go bad [] = match:bad + go bad (i@(x,_):unchecked) = + if inSameMod x + then go bad unchecked + else go (i:bad) unchecked + + inSameMod b = + let na = getName $ getName inst + la = isInternalName na + nb = getName $ getName b + lb = isInternalName nb + in (la && lb) || (nameModule na == nameModule nb) + +--------------- --------------- insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] -- Add a new solution, knocking out strictly less specific ones diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 178ffdc00e..2908047ad3 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -288,6 +288,7 @@ data TyThing = AnId Id | ADataCon DataCon | ATyCon TyCon | ACoAxiom CoAxiom + deriving (Eq, Ord) instance Outputable TyThing where ppr = pprTyThing @@ -303,6 +304,7 @@ pprTyThingCategory (ACoAxiom _) = ptext (sLit "Coercion axiom") pprTyThingCategory (AnId _) = ptext (sLit "Identifier") pprTyThingCategory (ADataCon _) = ptext (sLit "Data constructor") + instance NamedThing TyThing where -- Can't put this with the type getName (AnId id) = getName id -- decl, because the DataCon instance getName (ATyCon tc) = getName tc -- isn't visible there diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 8cfb8e2919..833309e6aa 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -70,7 +70,7 @@ module Outputable ( ) where import {-# SOURCE #-} Module( Module, ModuleName, moduleName ) -import {-# SOURCE #-} OccName( OccName ) +import {-# SOURCE #-} Name( Name, nameModule ) import StaticFlags import FastString @@ -145,7 +145,7 @@ data Depth = AllTheWay -- as @Exception.catch@, this fuction will return @Just "Exception"@. -- Note that the return value is a ModuleName, not a Module, because -- in source code, names are qualified by ModuleNames. -type QueryQualifyName = Module -> OccName -> QualifyName +type QueryQualifyName = Name -> QualifyName -- See Note [Printing original names] in HscTypes data QualifyName -- given P:M.T @@ -166,10 +166,10 @@ type QueryQualifyModule = Module -> Bool type PrintUnqualified = (QueryQualifyName, QueryQualifyModule) alwaysQualifyNames :: QueryQualifyName -alwaysQualifyNames m _ = NameQual (moduleName m) +alwaysQualifyNames n = NameQual (moduleName (nameModule n)) neverQualifyNames :: QueryQualifyName -neverQualifyNames _ _ = NameUnqual +neverQualifyNames _ = NameUnqual alwaysQualifyModules :: QueryQualifyModule alwaysQualifyModules _ = True @@ -278,8 +278,8 @@ getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx \begin{code} qualName :: PprStyle -> QueryQualifyName -qualName (PprUser (qual_name,_) _) m n = qual_name m n -qualName _other m _n = NameQual (moduleName m) +qualName (PprUser (qual_name,_) _) n = qual_name n +qualName _other n = NameQual (moduleName (nameModule n)) qualModule :: PprStyle -> QueryQualifyModule qualModule (PprUser (_,qual_mod) _) m = qual_mod m diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 649f33f2db..083b2b05a5 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -61,7 +61,7 @@ vectoriseIO hsc_env guts -- Vectorise a single module, in the VM monad. -- vectModule :: ModGuts -> VM ModGuts -vectModule guts@(ModGuts { mg_types = types +vectModule guts@(ModGuts { mg_tcs = tycons , mg_binds = binds , mg_fam_insts = fam_insts , mg_vect_decls = vect_decls @@ -69,12 +69,14 @@ vectModule guts@(ModGuts { mg_types = types = do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $ pprCoreBindings binds - -- Vectorise the type environment. This will add vectorised type constructors, their - -- representaions, and the conrresponding data constructors. Moreover, we produce - -- bindings for dfuns and family instances of the classes and type families used in the - -- DPH library to represent array types. - ; (types', new_fam_insts, tc_binds) <- vectTypeEnv types [vd - | vd@(VectType _ _) <- vect_decls] + -- Vectorise the type environment. This will add vectorised + -- type constructors, their representaions, and the + -- conrresponding data constructors. Moreover, we produce + -- bindings for dfuns and family instances of the classes + -- and type families used in the DPH library to represent + -- array types. + ; (tycons', new_fam_insts, tc_binds) <- vectTypeEnv tycons [vd + | vd@(VectType _ _) <- vect_decls] ; (_, fam_inst_env) <- readGEnv global_fam_inst_env @@ -82,7 +84,7 @@ vectModule guts@(ModGuts { mg_types = types ; binds_top <- mapM vectTopBind binds ; binds_imp <- mapM vectImpBind [imp_id | Vect imp_id _ <- vect_decls, isGlobalId imp_id] - ; return $ guts { mg_types = types' + ; return $ guts { mg_tcs = tycons' , mg_binds = Rec tc_binds : (binds_top ++ binds_imp) , mg_fam_inst_env = fam_inst_env , mg_fam_insts = fam_insts ++ new_fam_insts diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs index 5220d5a0fe..99c1e230de 100644 --- a/compiler/vectorise/Vectorise/Env.hs +++ b/compiler/vectorise/Vectorise/Env.hs @@ -202,8 +202,8 @@ setPRFunsEnv ps genv -- data constructors referenced in VECTORISE pragmas, even if they are defined in an imported -- module. -- -modVectInfo :: GlobalEnv -> TypeEnv -> [CoreVect]-> VectInfo -> VectInfo -modVectInfo env tyenv vectDecls info +modVectInfo :: GlobalEnv -> [TyCon] -> [CoreVect]-> VectInfo -> VectInfo +modVectInfo env tycons vectDecls info = info { vectInfoVar = mk_env ids (global_vars env) , vectInfoTyCon = mk_env tyCons (global_tycons env) @@ -216,9 +216,10 @@ modVectInfo env tyenv vectDecls info vectIds = [id | Vect id _ <- vectDecls] vectTypeTyCons = [tycon | VectType tycon _ <- vectDecls] vectDataCons = concatMap tyConDataCons vectTypeTyCons - ids = typeEnvIds tyenv ++ vectIds - tyCons = typeEnvTyCons tyenv ++ vectTypeTyCons - dataCons = typeEnvDataCons tyenv ++ vectDataCons + ids = {- typeEnvIds tyenv ++ -} vectIds + -- XXX: what Ids do you want here? + tyCons = tycons ++ vectTypeTyCons + dataCons = concatMap tyConDataCons tycons ++ vectDataCons -- Produce an entry for every declaration that is mentioned in the domain of the 'inspectedEnv' mk_env decls inspectedEnv diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index 9a61c6d013..0c9766e33e 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -55,7 +55,11 @@ initV :: HscEnv -> VM a -> IO (Maybe (VectInfo, a)) initV hsc_env guts info thing_inside - = do { (_, Just res) <- initDs hsc_env (mg_module guts) (mg_rdr_env guts) (mg_types guts) go + = do { + let type_env = typeEnvFromEntities [] (mg_tcs guts) (mg_clss guts) (mg_fam_insts guts) + -- XXX should we try to get the Ids here? + ; (_, Just res) <- initDs hsc_env (mg_module guts) + (mg_rdr_env guts) type_env go ; dumpIfVtTrace "Incoming VectInfo" (ppr info) ; case res of @@ -110,7 +114,7 @@ initV hsc_env guts info thing_inside } } } - new_info genv = modVectInfo genv (mg_types guts) (mg_vect_decls guts) info + new_info genv = modVectInfo genv (mg_tcs guts) (mg_vect_decls guts) info selectBackendErr = sLit "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq" diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 063e04dd5e..35dbcb92e6 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -22,7 +22,6 @@ import Vectorise.Type.PRepr import Vectorise.Type.Repr import Vectorise.Utils -import HscTypes import CoreSyn import CoreUtils import CoreUnfold @@ -90,13 +89,13 @@ import Data.List -- |Vectorise a type environment. -- -vectTypeEnv :: TypeEnv -- Original type environment +vectTypeEnv :: [TyCon] -- TyCons defined in this module -> [CoreVect] -- All 'VECTORISE [SCALAR] type' declarations in this module - -> VM ( TypeEnv -- Vectorised type environment. + -> VM ( [TyCon] -- old TyCons ++ new TyCons , [FamInst] -- New type family instances. , [(Var, CoreExpr)]) -- New top level bindings. -vectTypeEnv env vectTypeDecls - = do { traceVt "** vectTypeEnv" $ ppr env +vectTypeEnv tycons vectTypeDecls + = do { traceVt "** vectTypeEnv" $ ppr tycons -- Build a map containing all vectorised type constructor. If they are scalar, they are -- mapped to 'False' (vectorised type constructor == original type constructor). @@ -115,7 +114,7 @@ vectTypeEnv env vectTypeDecls localScalarTyConNames = mkNameSet (map tyConName localScalarTyCons) notLocalScalarTyCon tc = not $ (tyConName tc) `elemNameSet` localScalarTyConNames - maybeVectoriseTyCons = filter notLocalScalarTyCon (typeEnvTyCons env) + maybeVectoriseTyCons = filter notLocalScalarTyCon tycons (conv_tcs, keep_tcs) = classifyTyCons vectTyConFlavour maybeVectoriseTyCons orig_tcs = keep_tcs ++ conv_tcs keep_dcs = concatMap tyConDataCons keep_tcs @@ -166,16 +165,11 @@ vectTypeEnv env vectTypeDecls ; return (dfuns, binds) } - -- We add to the type environment: (1) the vectorised type constructors, (2) their - -- 'PRepr' & 'PData' instance constructors, and (3) the data constructors of the fomer - -- two. - ; let all_new_tcs = new_tcs ++ inst_tcs - new_env = extendTypeEnvList env - $ map ATyCon all_new_tcs ++ - [ADataCon dc | tc <- all_new_tcs - , dc <- tyConDataCons tc] + -- We return: (1) the vectorised type constructors, (2) + -- their 'PRepr' & 'PData' instance constructors two. + ; let new_tycons = tycons ++ new_tcs ++ inst_tcs - ; return (new_env, fam_insts, binds) + ; return (new_tycons, fam_insts, binds) } diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index ba58d8c21f..d7d5b447be 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -247,16 +247,27 @@ printForUserPartWay doc = do unqual <- GHC.getPrintUnqual liftIO $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc -runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult +runStmt :: String -> GHC.SingleStep -> GHCi (Maybe GHC.RunResult) runStmt expr step = do st <- getGHCiState reifyGHCi $ \x -> withProgName (progname st) $ withArgs (args st) $ reflectGHCi x $ do - GHC.handleSourceError (\e -> do GHC.printException e - return GHC.RunFailed) $ do - GHC.runStmtWithLocation (progname st) (line_number st) expr step + GHC.handleSourceError (\e -> do GHC.printException e; + return Nothing) $ do + r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step + return (Just r) + +runDecls :: String -> GHCi [GHC.Name] +runDecls decls = do + st <- getGHCiState + reifyGHCi $ \x -> + withProgName (progname st) $ + withArgs (args st) $ + reflectGHCi x $ do + GHC.handleSourceError (\e -> do GHC.printException e; return []) $ do + GHC.runDeclsWithLocation (progname st) (line_number st) decls resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult resume canLogSpan step = do diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 8b9e8192fc..e72533a8f7 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -449,7 +449,7 @@ runGHCi paths maybe_exprs = do Nothing -> do -- enter the interactive loop - runGHCiInput $ runCommands True $ nextInputLine show_prompt is_tty + runGHCiInput $ runCommands False $ nextInputLine show_prompt is_tty Just exprs -> do -- just evaluate the expression we were given enqueueCommands exprs @@ -463,7 +463,7 @@ runGHCi paths maybe_exprs = do -- this used to be topHandlerFastExit, see #2228 $ topHandler e runInputTWithPrefs defaultPrefs defaultSettings $ do - runCommands' handle True (return Nothing) + runCommands' handle False (return Nothing) -- and finally, exit liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." @@ -723,6 +723,10 @@ enqueueCommands cmds = do st <- getGHCiState setGHCiState st{ cmdqueue = cmds ++ cmdqueue st } +-- | If we one of these strings prefixes a command, then we treat it as a decl +-- rather than a stmt. +declPrefixes :: [String] +declPrefixes = ["class ","data ","newtype ","type ","instance ", "deriving "] runStmt :: String -> SingleStep -> GHCi Bool runStmt stmt step @@ -730,6 +734,10 @@ runStmt stmt step = return False | "import " `isPrefixOf` stmt = do addImportToContext stmt; return False + | any (flip isPrefixOf stmt) declPrefixes + = do _ <- liftIO $ tryIO $ hFlushAll stdin + result <- GhciMonad.runDecls stmt + afterRunStmt (const True) (GHC.RunOk result) | otherwise = do -- In the new IO library, read handles buffer data even if the Handle -- is set to NoBuffering. This causes problems for GHCi where there @@ -737,8 +745,10 @@ runStmt stmt step -- GHCi's stdin Handle here (only relevant if stdin is attached to -- a file, otherwise the read buffer can't be flushed). _ <- liftIO $ tryIO $ hFlushAll stdin - result <- GhciMonad.runStmt stmt step - afterRunStmt (const True) result + m_result <- GhciMonad.runStmt stmt step + case m_result of + Nothing -> return False + Just result -> afterRunStmt (const True) result --afterRunStmt :: GHC.RunResult -> GHCi Bool -- False <=> the statement failed to compile @@ -791,8 +801,8 @@ printStoppedAtBreakInfo resume names = do -- printTypeOfNames session names let namesSorted = sortBy compareNames names tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted - docs <- pprTypeAndContents [id | AnId id <- tythings] - printForUserPartWay docs + docs <- mapM pprTypeAndContents [id | AnId id <- tythings] + printForUserPartWay $ vcat docs printTypeOfNames :: [Name] -> GHCi () printTypeOfNames names @@ -918,20 +928,19 @@ help _ = liftIO (putStr helpText) info :: String -> InputT GHCi () info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'") -info s = handleSourceError GHC.printException $ - do { let names = words s - ; dflags <- getDynFlags - ; let pefas = dopt Opt_PrintExplicitForalls dflags - ; mapM_ (infoThing pefas) names } - where - infoThing pefas str = do - names <- GHC.parseName str - mb_stuffs <- mapM GHC.getInfo names - let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) - unqual <- GHC.getPrintUnqual - liftIO $ putStrLn $ showSDocForUser unqual $ - vcat (intersperse (text "") $ - map (pprInfo pefas) filtered) +info s = handleSourceError GHC.printException $ do + unqual <- GHC.getPrintUnqual + sdocs <- mapM infoThing (words s) + mapM_ (liftIO . putStrLn . showSDocForUser unqual) sdocs + +infoThing :: GHC.GhcMonad m => String -> m SDoc +infoThing str = do + dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + names <- GHC.parseName str + mb_stuffs <- mapM GHC.getInfo names + let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) + return $ vcat (intersperse (text "") $ map (pprInfo pefas) filtered) -- Filter out names whose parent is also there Good -- example is '[]', which is both a type and data @@ -1947,13 +1956,30 @@ getLoadedModules = do showBindings :: GHCi () showBindings = do - bindings <- GHC.getBindings - docs <- pprTypeAndContents - [ id | AnId id <- sortBy compareTyThings bindings] - printForUserPartWay docs + bindings <- GHC.getBindings + (insts, finsts) <- GHC.getInsts + docs <- mapM makeDoc ({- sortBy compareTyThings -} bindings) +-- docs <- mapM pprTypeAndContents +-- [ id | AnId id <- sortBy compareTyThings bindings] + let idocs = map GHC.pprInstanceHdr insts + fidocs = map GHC.pprFamInstHdr finsts + mapM_ printForUserPartWay (docs ++ idocs ++ fidocs) + where + makeDoc (AnId id) = pprTypeAndContents id + makeDoc tt = do + dflags <- getDynFlags + let pefas = dopt Opt_PrintExplicitForalls dflags + mb_stuff <- GHC.getInfo (getName tt) + return $ maybe (text "") (pprTT pefas) mb_stuff + pprTT :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc + pprTT pefas (thing, fixity, _insts) = + pprTyThing pefas thing + $$ show_fixity fixity + where + show_fixity fix + | fix == GHC.defaultFixity = empty + | otherwise = ppr fix <+> ppr (GHC.getName thing) -compareTyThings :: TyThing -> TyThing -> Ordering -t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2 printTyThing :: TyThing -> GHCi () printTyThing tyth = do dflags <- getDynFlags |