From 2a8cdc3aee5997374273e27365f92c161aca8453 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Tue, 10 Oct 2006 04:46:56 +0000 Subject: [PATCH] Rough matches for family instances - Class and type family instances just got a lot more similar. - FamInst, like Instance, now has a rough match signature. The idea is the same: if the rough match doesn't match, there is no need to pull in the while tycon describing the instance (from a lazily read iface). - IfaceFamInst changes in a similar way and the list of all IFaceFamInsts is now written into the binary iface (as for class instances), as deriving it from the tycon (as before) would render the whole rough matching useless. - As a result of this, the plumbing of class instances and type instances through the various environments, ModIface, ModGuts, and ModDetails is now almost the same. (The remaining difference are mostly because the dfun of a class instance is an Id, but type instance refer to a TyCon, not an Id.) *** WARNING: The interface file format changed! *** *** Rebuild from scratch. *** --- compiler/deSugar/Desugar.lhs | 32 +++++---- compiler/iface/BinIface.hs | 15 ++-- compiler/iface/IfaceSyn.lhs | 39 +++++----- compiler/iface/IfaceType.lhs | 6 +- compiler/iface/LoadIface.lhs | 48 +++++++------ compiler/iface/MkIface.lhs | 56 +++++++++------ compiler/iface/TcIface.lhs | 37 ++++++---- compiler/iface/TcIface.lhs-boot | 18 ++--- compiler/main/HscMain.lhs | 6 +- compiler/main/HscTypes.lhs | 75 ++++++++++--------- compiler/main/TidyPgm.lhs | 58 ++++++++------- compiler/typecheck/FamInst.lhs | 10 +-- compiler/typecheck/TcInstDcls.lhs | 8 ++- compiler/typecheck/TcRnDriver.lhs | 70 +++++++++++------- compiler/typecheck/TcRnMonad.lhs | 1 + compiler/typecheck/TcRnTypes.lhs | 13 ++-- compiler/types/FamInstEnv.lhs | 143 ++++++++++++++++++++++++++++++------- 17 files changed, 397 insertions(+), 238 deletions(-) diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index c2ee0a5..1f9ebe8 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -71,7 +71,8 @@ deSugar hsc_env tcg_binds = binds, tcg_fords = fords, tcg_rules = rules, - tcg_insts = insts }) + tcg_insts = insts, + tcg_fam_insts = fam_insts }) = do { showPass dflags "Desugar" -- Desugar the program @@ -140,20 +141,21 @@ deSugar hsc_env -- sort to get into canonical order mod_guts = ModGuts { - mg_module = mod, - mg_boot = isHsBoot hsc_src, - mg_exports = exports, - mg_deps = deps, - mg_usages = usages, - mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods], - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_deprecs = deprecs, - mg_types = type_env, - mg_insts = insts, - mg_rules = ds_rules, - mg_binds = ds_binds, - mg_foreign = ds_fords } + mg_module = mod, + mg_boot = isHsBoot hsc_src, + mg_exports = exports, + mg_deps = deps, + mg_usages = usages, + mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods], + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_deprecs = deprecs, + mg_types = type_env, + mg_insts = insts, + mg_fam_insts = fam_insts, + mg_rules = ds_rules, + mg_binds = ds_binds, + mg_foreign = ds_fords } ; return (Just mod_guts) }}} diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 41bcaed..3e9895a 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -104,6 +104,7 @@ instance Binary ModIface where mi_deprecs = deprecs, mi_decls = decls, mi_insts = insts, + mi_fam_insts = fam_insts, mi_rules = rules, mi_rule_vers = rule_vers }) = do put_ bh (show opt_HiVersion) @@ -121,6 +122,7 @@ instance Binary ModIface where lazyPut bh deprecs put_ bh decls put_ bh insts + put_ bh fam_insts lazyPut bh rules put_ bh rule_vers @@ -156,6 +158,7 @@ instance Binary ModIface where deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh decls <- {-# SCC "bin_tycldecls" #-} get bh insts <- {-# SCC "bin_insts" #-} get bh + fam_insts <- {-# SCC "bin_fam_insts" #-} get bh rules <- {-# SCC "bin_rules" #-} lazyGet bh rule_vers <- get bh return (ModIface { @@ -172,7 +175,7 @@ instance Binary ModIface where mi_decls = decls, mi_globals = Nothing, mi_insts = insts, - mi_fam_insts = mkIfaceFamInstsCache . map snd $ decls, + mi_fam_insts = fam_insts, mi_rules = rules, mi_rule_vers = rule_vers, -- And build the cached values @@ -963,12 +966,14 @@ instance Binary IfaceInst where return (IfaceInst cls tys dfun flag orph) instance Binary IfaceFamInst where - put_ bh (IfaceFamInst tycon tys) = do - put_ bh tycon + put_ bh (IfaceFamInst fam tys tycon) = do + put_ bh fam put_ bh tys - get bh = do tycon <- get bh + put_ bh tycon + get bh = do fam <- get bh tys <- get bh - return (IfaceFamInst tycon tys) + tycon <- get bh + return (IfaceFamInst fam tys tycon) instance Binary OverlapFlag where put_ bh NoOverlap = putByte bh 0 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index b3dd586..8ac4eec 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -20,7 +20,7 @@ module IfaceSyn ( IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..), -- Misc - visibleIfConDecls, extractIfFamInsts, + visibleIfConDecls, -- Equality IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy, @@ -80,7 +80,7 @@ data IfaceDecl -- been compiled with -- different flags to the -- current compilation unit - ifFamInst :: Maybe IfaceFamInst + ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) -- Just <=> instance of family } @@ -150,15 +150,11 @@ data IfaceInst -- and if the head does not change it won't be used if it wasn't before data IfaceFamInst - = IfaceFamInst { ifFamInstTyCon :: IfaceTyCon -- Family tycon - , ifFamInstTys :: [IfaceType] -- Instance types + = IfaceFamInst { ifFamInstFam :: IfaceExtName -- Family tycon + , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types + , ifFamInstTyCon :: IfaceTyCon -- Instance decl } -extractIfFamInsts :: [IfaceDecl] -> [(IfaceFamInst, IfaceDecl)] -extractIfFamInsts decls = - [(famInst, decl) | decl@IfaceData {ifFamInst = Just famInst} <- decls] - -- !!!TODO: we also need a similar case for synonyms - data IfaceRule = IfaceRule { ifRuleName :: RuleName, @@ -325,7 +321,7 @@ pprIfaceConDecl tc con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app]) tc_app = IfaceTyConApp (IfaceTc (LocalTop tc)) [IfaceTyVar tv | (tv,_) <- univ_tvs] - -- Gruesome, but jsut for debug print + -- Gruesome, but just for debug print instance Outputable IfaceRule where ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, @@ -340,15 +336,19 @@ instance Outputable IfaceInst where ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag, ifInstCls = cls, ifInstTys = mb_tcs}) = hang (ptext SLIT("instance") <+> ppr flag - <+> ppr cls <+> brackets (pprWithCommas ppr_mb mb_tcs)) + <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) 2 (equals <+> ppr dfun_id) - where - ppr_mb Nothing = dot - ppr_mb (Just tc) = ppr tc instance Outputable IfaceFamInst where - ppr (IfaceFamInst {ifFamInstTyCon = tycon, ifFamInstTys = tys}) - = ppr tycon <+> hsep (map ppr tys) + ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs, + ifFamInstTyCon = tycon_id}) + = hang (ptext SLIT("family instance") <+> + ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs)) + 2 (equals <+> ppr tycon_id) + +ppr_rough :: Maybe IfaceTyCon -> SDoc +ppr_rough Nothing = dot +ppr_rough (Just tc) = ppr tc \end{code} @@ -567,11 +567,10 @@ eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) -- over the constructors (any more), but they do scope -- over the stupid context in the IfaceConDecls where - Nothing `eqIfTc_fam` Nothing = Equal - (Just (IfaceFamInst fam1 tys1)) - `eqIfTc_fam` (Just (IfaceFamInst fam2 tys2)) = + Nothing `eqIfTc_fam` Nothing = Equal + (Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) = fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2 - _ `eqIfTc_fam` _ = NotEqual + _ `eqIfTc_fam` _ = NotEqual eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {}) = bool (ifName d1 == ifName d2) &&& diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index 70399e7..ee37891 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -10,7 +10,7 @@ module IfaceType ( IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion, IfaceExtName(..), mkIfaceExtName, isLocalIfaceExtName, - ifaceTyConName, + ifaceTyConName, ifaceTyConOccName, -- Conversion from Type -> IfaceType toIfaceType, toIfacePred, toIfaceContext, @@ -145,7 +145,9 @@ ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName ifaceTyConName (IfaceTc ext) = pprPanic "ifaceTyConName" (ppr ext) - +ifaceTyConOccName :: IfaceTyCon -> OccName -- Works for all! +ifaceTyConOccName (IfaceTc ext) = ifaceExtOcc ext +ifaceTyConOccName tycon = nameOccName . ifaceTyConName $ tycon \end{code} diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 0dbb17e..e322276 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -16,7 +16,8 @@ module LoadIface ( #include "HsVersions.h" -import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst ) +import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst, + tcIfaceFamInst ) import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) ) import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), @@ -42,6 +43,7 @@ import PrelInfo ( ghcPrimExports ) import PrelRules ( builtinRules ) import Rules ( extendRuleBaseList, mkRuleBase ) import InstEnv ( emptyInstEnv, extendInstEnvList ) +import FamInstEnv ( emptyFamInstEnv, extendFamInstEnvList ) import Name ( Name {-instance NamedThing-}, getOccName, nameModule, nameIsLocalOrFrom, isWiredInName ) import NameEnv @@ -239,22 +241,29 @@ loadInterface doc_str mod from -- If we do loadExport first the wrong info gets into the cache (unless we -- explicitly tag each export which seems a bit of a bore) - ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas - ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface) - ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) - ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas + ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface) + ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) + ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) ; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT", mi_insts = panic "No mi_insts in PIT", mi_rules = panic "No mi_rules in PIT" } } ; updateEps_ $ \ eps -> - eps { eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, - eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, - eps_rule_base = extendRuleBaseList (eps_rule_base eps) new_eps_rules, - eps_inst_env = extendInstEnvList (eps_inst_env eps) new_eps_insts, - eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls) - (length new_eps_insts) (length new_eps_rules) } + eps { + eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, + eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, + eps_rule_base = extendRuleBaseList (eps_rule_base eps) + new_eps_rules, + eps_inst_env = extendInstEnvList (eps_inst_env eps) + new_eps_insts, + eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps) + new_eps_fam_insts, + eps_stats = addEpsInStats (eps_stats eps) + (length new_eps_decls) + (length new_eps_insts) (length new_eps_rules) } ; return (Succeeded final_iface) }}}} @@ -337,10 +346,8 @@ loadDecl ignore_prags mod (_version, decl) (importedSrcLoc (showSDoc (ppr (moduleName mod)))) -- ToDo: qualify with the package name if necessary - ifFamily (IfaceData { - ifFamInst = Just (IfaceFamInst {ifFamInstTyCon = famTyCon})}) - = Just famTyCon - ifFamily _ = Nothing + ifFamily (IfaceData {ifFamInst = Just (famTyCon, _)}) = Just famTyCon + ifFamily _ = Nothing doc = ptext SLIT("Declaration for") <+> ppr (ifName decl) @@ -522,11 +529,12 @@ readIface wanted_mod file_path is_hi_boot_file initExternalPackageState :: ExternalPackageState initExternalPackageState = EPS { - eps_is_boot = emptyUFM, - eps_PIT = emptyPackageIfaceTable, - eps_PTE = emptyTypeEnv, - eps_inst_env = emptyInstEnv, - eps_rule_base = mkRuleBase builtinRules, + eps_is_boot = emptyUFM, + eps_PIT = emptyPackageIfaceTable, + eps_PTE = emptyTypeEnv, + eps_inst_env = emptyInstEnv, + eps_fam_inst_env = emptyFamInstEnv, + eps_rule_base = mkRuleBase builtinRules, -- Initialise the EPS rule pool with the built-in rules eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0 , n_insts_in = 0, n_insts_out = 0 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index b1618da..11235ce 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -176,7 +176,8 @@ compiled with -O. I think this is the case.] #include "HsVersions.h" import IfaceSyn -- All of it -import IfaceType ( toIfaceTvBndrs, toIfaceType, toIfaceContext ) +import IfaceType ( toIfaceTvBndrs, toIfaceType, toIfaceContext, + ifaceTyConOccName ) import LoadIface ( readIface, loadInterface, pprModIface ) import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe ) import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), @@ -200,13 +201,14 @@ import Type ( TyThing(..), splitForAllTys, funResultTy ) import TcType ( deNoteType ) import TysPrim ( alphaTyVars ) import InstEnv ( Instance(..) ) +import FamInstEnv ( FamInst(..) ) import TcRnMonad import HscTypes ( ModIface(..), ModDetails(..), ModGuts(..), HscEnv(..), hscEPS, Dependencies(..), FixItem(..), ModSummary(..), msHiFilePath, mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache, - typeEnvElts, mkIfaceFamInstsCache, + typeEnvElts, GenAvailInfo(..), availName, ExternalPackageState(..), Usage(..), IsBootInterface, @@ -266,18 +268,18 @@ mkIface :: HscEnv -- is identical, so no need to write it mkIface hsc_env maybe_old_iface - (ModGuts{ mg_module = this_mod, - mg_boot = is_boot, - mg_usages = usages, - mg_deps = deps, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_deprecs = src_deprecs }) - (ModDetails{ md_insts = insts, - md_fam_insts= _fam_inst, -- we use the type_env instead - md_rules = rules, - md_types = type_env, - md_exports = exports }) + (ModGuts{ mg_module = this_mod, + mg_boot = is_boot, + mg_usages = usages, + mg_deps = deps, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_deprecs = src_deprecs }) + (ModDetails{ md_insts = insts, + md_fam_insts = fam_insts, + md_rules = rules, + md_types = type_env, + md_exports = exports }) -- NB: notice that mkIface does not look at the bindings -- only at the TypeEnv. The previous Tidy phase has @@ -301,7 +303,8 @@ mkIface hsc_env maybe_old_iface ; iface_rules = map (coreRuleToIfaceRule ext_nm_lhs ext_nm_rhs) rules ; iface_insts = map (instanceToIfaceInst ext_nm_lhs) insts - ; iface_fam_insts = extractIfFamInsts decls + ; iface_fam_insts = map (famInstToIfaceFamInst ext_nm_lhs) + fam_insts ; intermediate_iface = ModIface { mi_module = this_mod, @@ -310,7 +313,7 @@ mkIface hsc_env maybe_old_iface mi_usages = usages, mi_exports = mkIfaceExports exports, mi_insts = sortLe le_inst iface_insts, - mi_fam_insts= mkIfaceFamInstsCache decls, + mi_fam_insts= sortLe le_fam_inst iface_fam_insts, mi_rules = sortLe le_rule iface_rules, mi_fixities = fixities, mi_deprecs = deprecs, @@ -344,11 +347,13 @@ mkIface hsc_env maybe_old_iface ; return (new_iface, no_change_at_all) } where - r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 - i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2 + r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 + i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2 + i1 `le_fam_inst` i2 = ifFamInstTyConOcc i1 <= ifFamInstTyConOcc i2 dflags = hsc_dflags hsc_env deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) + ifFamInstTyConOcc = ifaceTyConOccName . ifFamInstTyCon ----------------------------- @@ -1094,9 +1099,7 @@ tyThingToIfaceDecl ext (ATyCon tycon) famInstToIface Nothing = Nothing famInstToIface (Just (famTyCon, instTys)) = - Just $ IfaceFamInst { ifFamInstTyCon = toIfaceTyCon ext famTyCon - , ifFamInstTys = map (toIfaceType ext) instTys - } + Just (toIfaceTyCon ext famTyCon, map (toIfaceType ext) instTys) tyThingToIfaceDecl ext (ADataCon dc) = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier @@ -1117,6 +1120,17 @@ instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n) -------------------------- +famInstToIfaceFamInst :: (Name -> IfaceExtName) -> FamInst -> IfaceFamInst +famInstToIfaceFamInst ext_lhs fi@(FamInst { fi_tycon = tycon, + fi_fam = fam, fi_tcs = mb_tcs }) + = IfaceFamInst { ifFamInstTyCon = toIfaceTyCon ext_lhs tycon + , ifFamInstFam = ext_lhs fam + , ifFamInstTys = map do_rough mb_tcs } + where + do_rough Nothing = Nothing + do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n) + +-------------------------- toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem] toIfaceIdInfo ext id_info = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index ac458d5..fa227e6 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -6,7 +6,7 @@ \begin{code} module TcIface ( tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, - tcIfaceDecl, tcIfaceInst, tcIfaceRules, tcIfaceGlobal, + tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceGlobal, tcExtCoreBindings ) where @@ -33,8 +33,9 @@ import HscTypes ( ExternalPackageState(..), TyThing(..), tyThingClass, tyThingTyCon, ModIface(..), ModDetails(..), HomeModInfo(..), emptyModDetails, lookupTypeEnv, lookupType, - typeEnvIds, mkDetailsFamInstCache ) + typeEnvIds ) import InstEnv ( Instance(..), mkImportedInstance ) +import FamInstEnv ( FamInst(..), mkImportedFamInst ) import CoreSyn import CoreUtils ( exprType, dataConRepFSInstPat ) import CoreUnfold @@ -210,8 +211,9 @@ typecheckIface iface ; writeMutVar tc_env_var type_env -- Now do those rules and instances - ; dfuns <- mapM tcIfaceInst (mi_insts iface) - ; rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; insts <- mapM tcIfaceInst (mi_insts iface) + ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + ; rules <- tcIfaceRules ignore_prags (mi_rules iface) -- Exports ; exports <- ifaceExportNames (mi_exports iface) @@ -220,8 +222,8 @@ typecheckIface iface ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface), text "Type envt:" <+> ppr type_env]) ; return $ ModDetails { md_types = type_env - , md_insts = dfuns - , md_fam_insts = mkDetailsFamInstCache type_env + , md_insts = insts + , md_fam_insts = fam_insts , md_rules = rules , md_exports = exports } @@ -373,9 +375,7 @@ tcIfaceDecl ignore_prags ; famInst <- case mb_family of Nothing -> return Nothing - Just (IfaceFamInst { ifFamInstTyCon = fam - , ifFamInstTys = tys - }) -> + Just (fam, tys) -> do { famTyCon <- tcIfaceTyCon fam ; insttys <- mapM tcIfaceType tys ; return $ Just (famTyCon, insttys) @@ -513,11 +513,22 @@ tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, = do { dfun <- forkM (ptext SLIT("Dict fun") <+> ppr dfun_occ) $ tcIfaceExtId (LocalTop dfun_occ) ; cls' <- lookupIfaceExt cls - ; mb_tcs' <- mapM do_tc mb_tcs + ; mb_tcs' <- mapM tc_rough mb_tcs ; return (mkImportedInstance cls' mb_tcs' orph dfun oflag) } - where - do_tc Nothing = return Nothing - do_tc (Just tc) = do { tc' <- lookupIfaceTc tc; return (Just tc') } + +tcIfaceFamInst :: IfaceFamInst -> IfL FamInst +tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, + ifFamInstFam = fam, ifFamInstTys = mb_tcs }) +-- = do { tycon' <- forkM (ptext SLIT("Inst tycon") <+> ppr tycon) $ +-- ^^^this line doesn't work, but vvv this does => CPP in Haskell = evil! + = do { tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $ + tcIfaceTyCon tycon + ; fam' <- lookupIfaceExt fam + ; mb_tcs' <- mapM tc_rough mb_tcs + ; return (mkImportedFamInst fam' mb_tcs' tycon') } + +tc_rough Nothing = return Nothing +tc_rough (Just tc) = do { tc' <- lookupIfaceTc tc; return (Just tc') } \end{code} diff --git a/compiler/iface/TcIface.lhs-boot b/compiler/iface/TcIface.lhs-boot index e9ed235..ac3e880 100644 --- a/compiler/iface/TcIface.lhs-boot +++ b/compiler/iface/TcIface.lhs-boot @@ -1,13 +1,15 @@ \begin{code} module TcIface where -import IfaceSyn ( IfaceDecl, IfaceInst, IfaceRule ) -import TypeRep ( TyThing ) -import TcRnTypes ( IfL ) -import InstEnv ( Instance ) -import CoreSyn ( CoreRule ) +import IfaceSyn ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule ) +import TypeRep ( TyThing ) +import TcRnTypes ( IfL ) +import InstEnv ( Instance ) +import FamInstEnv ( FamInst ) +import CoreSyn ( CoreRule ) -tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing -tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] -tcIfaceInst :: IfaceInst -> IfL Instance +tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing +tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] +tcIfaceInst :: IfaceInst -> IfL Instance +tcIfaceFamInst :: IfaceFamInst -> IfL FamInst \end{code} diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index c511aa2..01c27ab 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -678,9 +678,9 @@ hscFileCheck hsc_env mod_summary = do { let type_env = tcg_type_env tc_result md = ModDetails { md_types = type_env, - md_exports = tcg_exports tc_result, - md_insts = tcg_insts tc_result, - md_fam_insts = mkDetailsFamInstCache type_env, + md_exports = tcg_exports tc_result, + md_insts = tcg_insts tc_result, + md_fam_insts = tcg_fam_insts tc_result, md_rules = [panic "no rules"] } -- Rules are CoreRules, not the -- RuleDecls we get out of the typechecker diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 8b126e6..6bc1197 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -30,7 +30,7 @@ module HscTypes ( icPrintUnqual, mkPrintUnqualified, ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, - emptyIfaceDepCache, mkIfaceFamInstsCache, mkDetailsFamInstCache, + emptyIfaceDepCache, Deprecs(..), IfaceDeprecs, @@ -78,7 +78,7 @@ import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv, extendOccEnv ) import Module import InstEnv ( InstEnv, Instance ) -import FamInstEnv ( FamInst, extractFamInsts ) +import FamInstEnv ( FamInstEnv, FamInst ) import Rules ( RuleBase ) import CoreSyn ( CoreBind ) import Id ( Id ) @@ -96,7 +96,7 @@ import BasicTypes ( Version, initialVersion, IPName, Fixity, defaultFixity, DeprecTxt ) import IfaceSyn ( IfaceInst, IfaceFamInst, IfaceRule, - IfaceDecl(ifName), extractIfFamInsts ) + IfaceDecl(ifName) ) import FiniteMap ( FiniteMap ) import CoreSyn ( CoreRule ) @@ -420,8 +420,7 @@ data ModIface -- Instance declarations and rules mi_insts :: [IfaceInst], -- Sorted - mi_fam_insts :: [(IfaceFamInst, IfaceDecl)], -- Cached value - -- ...from mi_decls (not in iface file) + mi_fam_insts :: [IfaceFamInst], -- Sorted mi_rules :: [IfaceRule], -- Sorted mi_rule_vers :: !Version, -- Version number for rules and -- instances combined @@ -437,10 +436,6 @@ data ModIface -- seeing if we are up to date wrt the old interface } --- Pre-compute the set of type instances from the declaration list. -mkIfaceFamInstsCache :: [IfaceDecl] -> [(IfaceFamInst, IfaceDecl)] -mkIfaceFamInstsCache = extractIfFamInsts - -- Should be able to construct ModDetails from mi_decls in ModIface data ModDetails = ModDetails { @@ -462,10 +457,6 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_rules = [], md_fam_insts = [] } --- Pre-compute the set of type instances from the type environment. -mkDetailsFamInstCache :: TypeEnv -> [FamInst] -mkDetailsFamInstCache = extractFamInsts . typeEnvElts - -- A ModGuts is carried through the compiler, accumulating stuff as it goes -- There is only one ModGuts at any time, the one for the module -- being compiled right now. Once it is compiled, a ModIface and @@ -473,23 +464,26 @@ mkDetailsFamInstCache = extractFamInsts . typeEnvElts data ModGuts = ModGuts { - mg_module :: !Module, - mg_boot :: IsBootInterface, -- Whether it's an hs-boot module - mg_exports :: !NameSet, -- What it exports - mg_deps :: !Dependencies, -- What is below it, directly or otherwise - mg_dir_imps :: ![Module], -- Directly-imported modules; used to - -- generate initialisation code - mg_usages :: ![Usage], -- Version info for what it needed - - mg_rdr_env :: !GlobalRdrEnv, -- Top-level lexical environment - mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in this module - mg_deprecs :: !Deprecations, -- Deprecations declared in the module - - mg_types :: !TypeEnv, - mg_insts :: ![Instance], -- Instances - mg_rules :: ![CoreRule], -- Rules from this module - mg_binds :: ![CoreBind], -- Bindings for this module - mg_foreign :: !ForeignStubs + mg_module :: !Module, + mg_boot :: IsBootInterface, -- Whether it's an hs-boot module + mg_exports :: !NameSet, -- What it exports + mg_deps :: !Dependencies, -- What is below it, directly or + -- otherwise + mg_dir_imps :: ![Module], -- Directly-imported modules; used to + -- generate initialisation code + mg_usages :: ![Usage], -- Version info for what it needed + + mg_rdr_env :: !GlobalRdrEnv, -- Top-level lexical environment + mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in + -- this module + mg_deprecs :: !Deprecations, -- Deprecations declared in the module + + mg_types :: !TypeEnv, + mg_insts :: ![Instance], -- Instances + mg_fam_insts :: ![FamInst], -- Instances + mg_rules :: ![CoreRule], -- Rules from this module + mg_binds :: ![CoreBind], -- Bindings for this module + mg_foreign :: !ForeignStubs } -- The ModGuts takes on several slightly different forms: @@ -948,9 +942,10 @@ data Usage %************************************************************************ \begin{code} -type PackageTypeEnv = TypeEnv -type PackageRuleBase = RuleBase -type PackageInstEnv = InstEnv +type PackageTypeEnv = TypeEnv +type PackageRuleBase = RuleBase +type PackageInstEnv = InstEnv +type PackageFamInstEnv = FamInstEnv data ExternalPackageState = EPS { @@ -971,8 +966,8 @@ data ExternalPackageState -- The ModuleIFaces for modules in external packages -- whose interfaces we have opened -- The declarations in these interface files are held in - -- eps_decls, eps_inst_env, eps_rules (below), not in the - -- mi_decls fields of the iPIT. + -- eps_decls, eps_inst_env, eps_fam_inst_env, eps_rules + -- (below), not in the mi_decls fields of the iPIT. -- What _is_ in the iPIT is: -- * The Module -- * Version info @@ -980,11 +975,13 @@ data ExternalPackageState -- * Fixities -- * Deprecations - eps_PTE :: !PackageTypeEnv, -- Domain = external-package modules + eps_PTE :: !PackageTypeEnv, -- Domain = external-package modules - eps_inst_env :: !PackageInstEnv, -- The total InstEnv accumulated from - -- all the external-package modules - eps_rule_base :: !PackageRuleBase, -- Ditto RuleEnv + eps_inst_env :: !PackageInstEnv, -- The total InstEnv accumulated + -- from all the external-package + -- modules + eps_fam_inst_env :: !PackageFamInstEnv,-- Ditto FamInstEnv + eps_rule_base :: !PackageRuleBase, -- Ditto RuleEnv eps_stats :: !EpsStats } diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 976c32e..b04830b 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -46,7 +46,6 @@ import Module ( Module ) import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..), TypeEnv, typeEnvIds, typeEnvElts, typeEnvTyCons, extendTypeEnvWithIds, lookupTypeEnv, - mkDetailsFamInstCache, ModGuts(..), TyThing(..), ModDetails(..), Dependencies(..) ) @@ -124,24 +123,25 @@ mkBootModDetails :: HscEnv -> ModGuts -> IO ModDetails -- We don't look at the bindings at all -- there aren't any -- for hs-boot files -mkBootModDetails hsc_env (ModGuts { mg_module = mod, - mg_exports = exports, - mg_types = type_env, - mg_insts = ispecs }) +mkBootModDetails hsc_env (ModGuts { mg_module = mod + , mg_exports = exports + , mg_types = type_env + , mg_insts = insts + , mg_fam_insts = fam_insts }) = do { let dflags = hsc_dflags hsc_env ; showPass dflags "Tidy [hoot] type env" - ; let { ispecs' = tidyInstances tidyExternalId ispecs - ; type_env1 = filterNameEnv (not . isWiredInThing) type_env - ; type_env2 = mapNameEnv tidyBootThing type_env1 - ; type_env' = extendTypeEnvWithIds type_env2 - (map instanceDFunId ispecs') + ; let { insts' = tidyInstances tidyExternalId insts + ; type_env1 = filterNameEnv (not . isWiredInThing) type_env + ; type_env2 = mapNameEnv tidyBootThing type_env1 + ; type_env' = extendTypeEnvWithIds type_env2 + (map instanceDFunId insts') } - ; return (ModDetails { md_types = type_env', - md_insts = ispecs', - md_fam_insts = mkDetailsFamInstCache type_env', - md_rules = [], - md_exports = exports }) + ; return (ModDetails { md_types = type_env' + , md_insts = insts' + , md_fam_insts = fam_insts + , md_rules = [] + , md_exports = exports }) } where @@ -238,7 +238,8 @@ RHSs, so that they print nicely in interfaces. tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) tidyProgram hsc_env mod_impl@(ModGuts { mg_module = mod, mg_exports = exports, - mg_types = type_env, mg_insts = insts_tc, + mg_types = type_env, + mg_insts = insts, mg_fam_insts = fam_insts, mg_binds = binds, mg_rules = imp_rules, mg_dir_imps = dir_imps, mg_deps = deps, @@ -260,18 +261,22 @@ tidyProgram hsc_env -- (It's a sort of mutual recursion.) } - ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids binds + ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids + binds - ; let { tidy_type_env = tidyTypeEnv omit_prags exports type_env tidy_binds - ; tidy_ispecs = tidyInstances (lookup_dfun tidy_type_env) insts_tc + ; let { tidy_type_env = tidyTypeEnv omit_prags exports type_env + tidy_binds + ; 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 - -- we want Global, IdInfo-rich (or not) DFunId in the tidy_ispecs + -- we want Global, IdInfo-rich (or not) DFunId in the + -- tidy_insts ; tidy_rules = tidyRules tidy_env ext_rules -- You might worry that the tidy_env contains IdInfo-rich stuff - -- and indeed it does, but if omit_prags is on, ext_rules is empty + -- and indeed it does, but if omit_prags is on, ext_rules is + -- empty ; implicit_binds = getImplicitBinds type_env ; all_tidy_binds = implicit_binds ++ tidy_binds @@ -290,12 +295,11 @@ tidyProgram hsc_env cg_foreign = foreign_stubs, cg_dep_pkgs = dep_pkgs deps }, - ModDetails { md_types = tidy_type_env, - md_rules = tidy_rules, - md_insts = tidy_ispecs, - md_fam_insts = mkDetailsFamInstCache - tidy_type_env, - md_exports = exports }) + ModDetails { md_types = tidy_type_env, + md_rules = tidy_rules, + md_insts = tidy_insts, + md_fam_insts = fam_insts, + md_exports = exports }) } lookup_dfun type_env dfun_id diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index 68c4096..e38a3b1 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -7,12 +7,13 @@ module FamInst ( #include "HsVersions.h" +import HscTypes ( ExternalPackageState(..) ) import FamInstEnv ( FamInstEnv, FamInst(..), famInstTyCon, extendFamInstEnv, pprFamInst, pprFamInsts ) import TcMType ( tcInstSkolType ) import TcType ( SkolemInfo(..), tcSplitTyConApp ) import TcRnMonad ( TcM, TcGblEnv(..), setGblEnv, getGblEnv, foldlM, - setSrcSpan, addErr ) + setSrcSpan, addErr, getEps ) import TyCon ( tyConFamInst_maybe ) import Type ( mkTyConApp ) import Name ( getSrcLoc ) @@ -34,7 +35,8 @@ tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a tcExtendLocalFamInstEnv fam_insts thing_inside = do { env <- getGblEnv ; inst_env' <- foldlM addLocalFamInst (tcg_fam_inst_env env) fam_insts - ; let env' = env { tcg_fam_inst_env = inst_env' } + ; let env' = env { tcg_fam_insts = fam_insts ++ tcg_fam_insts env, + tcg_fam_inst_env = inst_env' } ; setGblEnv env' thing_inside } @@ -42,7 +44,7 @@ tcExtendLocalFamInstEnv fam_insts thing_inside -- and then add it to the home inst env addLocalFamInst :: FamInstEnv -> FamInst -> TcM FamInstEnv addLocalFamInst home_fie famInst - = do { -- Instantiate the family instance type extend the instance + = do { -- To instantiate the family instance type, 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 @@ -57,12 +59,12 @@ addLocalFamInst home_fie famInst ; let (fam, tys') = tcSplitTyConApp tau' -{- !!!TODO: Need to complete this: -- Load imported instances, so that we report -- overlaps correctly ; eps <- getEps ; let inst_envs = (eps_fam_inst_env eps, home_fie) +{- !!!TODO: Need to complete this: -- Check for overlapping instance decls ; let { (matches, _) = lookupFamInstEnv inst_envs fam tys' ; dup_ispecs = [ dup_ispec --!!!adapt diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 468d9a9..0b4f8b0 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -24,7 +24,7 @@ import Inst ( newDictBndr, newDictBndrs, instToId, showLIE, getOverlapFlag, tcExtendLocalInstEnv ) import InstEnv ( mkLocalInstance, instanceDFunId ) import FamInst ( tcExtendLocalFamInstEnv ) -import FamInstEnv ( extractFamInsts ) +import FamInstEnv ( mkLocalFamInst ) import TcDeriv ( tcDeriving ) import TcEnv ( InstInfo(..), InstBindings(..), newDFunName, tcExtendIdEnv, tcExtendGlobalEnv @@ -227,7 +227,11 @@ addInsts infos thing_inside addFamInsts :: [TyThing] -> TcM a -> TcM a addFamInsts tycons thing_inside - = tcExtendLocalFamInstEnv (extractFamInsts tycons) thing_inside + = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside + where + mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon + mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts" + (ppr tything) \end{code} \begin{code} diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 372ccab..8f11232 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -40,7 +40,9 @@ import TcExpr ( tcInferRho ) import TcRnMonad import TcType ( tidyTopType, tcEqType ) import Inst ( showLIE ) -import InstEnv ( extendInstEnvList, Instance, pprInstances, instanceDFunId ) +import InstEnv ( extendInstEnvList, Instance, pprInstances, + instanceDFunId ) +import FamInstEnv ( FamInst, pprFamInsts ) import TcBinds ( tcTopBinds, tcHsBootSigs ) import TcDefaults ( tcDefaults ) import TcEnv ( tcExtendGlobalValEnv, iDFunId ) @@ -134,6 +136,7 @@ import FastString ( mkFastString ) import Util ( sortLe ) import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags ) +import Control.Monad ( unless ) import Data.Maybe ( isJust ) \end{code} @@ -323,22 +326,23 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; - mod_guts = ModGuts { mg_module = this_mod, - mg_boot = False, - mg_usages = [], -- ToDo: compute usage - mg_dir_imps = [], -- ?? - mg_deps = noDependencies, -- ?? - mg_exports = my_exports, - mg_types = final_type_env, - mg_insts = tcg_insts tcg_env, - mg_rules = [], - mg_binds = core_binds, + mod_guts = ModGuts { mg_module = this_mod, + mg_boot = False, + mg_usages = [], -- ToDo: compute usage + mg_dir_imps = [], -- ?? + 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_rules = [], + mg_binds = core_binds, -- Stubs - mg_rdr_env = emptyGlobalRdrEnv, - mg_fix_env = emptyFixityEnv, - mg_deprecs = NoDeprecs, - mg_foreign = NoStubs + mg_rdr_env = emptyGlobalRdrEnv, + mg_fix_env = emptyFixityEnv, + mg_deprecs = NoDeprecs, + mg_foreign = NoStubs } } ; tcCoreDump mod_guts ; @@ -525,11 +529,19 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id) -- hs-boot file, such as $fbEqT = $fEqT checkHiBootIface - (TcGblEnv { tcg_insts = local_insts, tcg_type_env = local_type_env }) - (ModDetails { md_insts = boot_insts, md_types = boot_type_env }) + (TcGblEnv { tcg_insts = local_insts, tcg_fam_insts = local_fam_insts, + tcg_type_env = local_type_env }) + (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, + md_types = boot_type_env }) = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ; ; mapM_ check_one (typeEnvElts boot_type_env) ; dfun_binds <- mapM check_inst boot_insts + ; unless (null boot_fam_insts) $ + panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ + "instances in boot files yet...") + -- FIXME: Why? The actual comparison is not hard, but what would + -- be the equivalent to the dfun bindings returned for class + -- instances? We can't easily equate tycons... ; return (unionManyBags dfun_binds) } where check_one boot_thing @@ -1288,12 +1300,14 @@ tcCoreDump mod_guts -- It's unpleasant having both pprModGuts and pprModDetails here pprTcGblEnv :: TcGblEnv -> SDoc -pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, - tcg_insts = dfun_ids, - tcg_rules = rules, - tcg_imports = imports }) - = vcat [ ppr_types dfun_ids type_env - , ppr_insts dfun_ids +pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_rules = rules, + tcg_imports = imports }) + = vcat [ ppr_types insts type_env + , ppr_insts insts + , ppr_fam_insts fam_insts , vcat (map ppr rules) , ppr_gen_tycons (typeEnvTyCons type_env) , ptext SLIT("Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports)) @@ -1305,12 +1319,11 @@ pprModGuts (ModGuts { mg_types = type_env, = vcat [ ppr_types [] type_env, ppr_rules rules ] - ppr_types :: [Instance] -> TypeEnv -> SDoc -ppr_types ispecs type_env +ppr_types insts type_env = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids) where - dfun_ids = map instanceDFunId ispecs + dfun_ids = map instanceDFunId insts ids = [id | id <- typeEnvIds type_env, want_sig id] want_sig id | opt_PprStyle_Debug = True | otherwise = isLocalId id && @@ -1325,6 +1338,11 @@ ppr_insts :: [Instance] -> SDoc ppr_insts [] = empty ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs) +ppr_fam_insts :: [FamInst] -> SDoc +ppr_fam_insts [] = empty +ppr_fam_insts fam_insts = + text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts) + ppr_sigs :: [Var] -> SDoc ppr_sigs ids -- Print type signatures; sort by OccName diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index d9fe12a..12f0cf6 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -117,6 +117,7 @@ initTc hsc_env hsc_src mod do_this tcg_binds = emptyLHsBinds, tcg_deprecs = NoDeprecs, tcg_insts = [], + tcg_fam_insts= [], tcg_rules = [], tcg_fords = [], tcg_dfun_n = dfun_n_var, diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 4283924..46ff1e8 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -54,7 +54,7 @@ import TcType ( TcTyVarSet, TcType, TcThetaType, SkolemInfo, TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes, pprSkolInfo ) import InstEnv ( Instance, InstEnv ) -import FamInstEnv ( FamInstEnv ) +import FamInstEnv ( FamInst, FamInstEnv ) import IOEnv import RdrName ( GlobalRdrEnv, LocalRdrEnv ) import Name ( Name ) @@ -223,11 +223,12 @@ data TcGblEnv tcg_rn_decls :: Maybe (HsGroup Name), -- renamed decls, maybe -- Nothing <=> Don't retain renamed decls - tcg_binds :: LHsBinds Id, -- Value bindings in this module - tcg_deprecs :: Deprecations, -- ...Deprecations - tcg_insts :: [Instance], -- ...Instances - tcg_rules :: [LRuleDecl Id], -- ...Rules - tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports + tcg_binds :: LHsBinds Id, -- Value bindings in this module + tcg_deprecs :: Deprecations, -- ...Deprecations + tcg_insts :: [Instance], -- ...Instances + tcg_fam_insts :: [FamInst], -- ...Family instances + tcg_rules :: [LRuleDecl Id], -- ...Rules + tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports tcg_doc :: Maybe (HsDoc Name), -- Maybe Haddock documentation tcg_hmi :: HaddockModInfo Name -- Haddock module information diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs index ec50fbc..acc0960 100644 --- a/compiler/types/FamInstEnv.lhs +++ b/compiler/types/FamInstEnv.lhs @@ -2,28 +2,31 @@ \begin{code} module FamInstEnv ( - FamInst(..), famInstTyCon, extractFamInsts, - pprFamInst, pprFamInstHdr, pprFamInsts, - {-famInstHead, mkLocalFamInst, mkImportedFamInst-} + FamInst(..), famInstTyCon, pprFamInst, pprFamInstHdr, pprFamInsts, + famInstHead, mkLocalFamInst, mkImportedFamInst, FamInstEnv, emptyFamInstEnv, extendFamInstEnv, extendFamInstEnvList, famInstEnvElts, familyInstances, - {-lookupFamInstEnv-} + lookupFamInstEnv ) where #include "HsVersions.h" +import InstEnv ( roughMatchTcs, instanceCantMatch ) +import Unify ( tcMatchTys ) import TcType ( Type ) -import Type ( TyThing (ATyCon), pprParendType ) +import Type ( TvSubst, TyThing (ATyCon), pprParendType ) import TyCon ( TyCon, isDataTyCon, isNewTyCon, isSynTyCon, tyConName, tyConTyVars, tyConFamInst_maybe ) import VarSet ( TyVarSet, mkVarSet ) +import Var ( TyVar ) import Name ( Name, getOccName, NamedThing(..), getSrcLoc ) import OccName ( parenSymOcc ) import SrcLoc ( pprDefnLoc ) import UniqFM ( UniqFM, lookupUFM, emptyUFM, addToUFM_C, eltsUFM ) import Outputable +import Maybe ( isJust, isNothing ) import Monad ( mzero ) \end{code} @@ -37,6 +40,11 @@ import Monad ( mzero ) \begin{code} data FamInst = FamInst { fi_fam :: Name -- Family name + + -- Used for "rough matching"; same idea as for class instances + , fi_tcs :: [Maybe Name] -- Top of type args + + -- Used for "proper matching"; ditto , fi_tvs :: TyVarSet -- Template tyvars for full match , fi_tys :: [Type] -- Full arg types @@ -47,21 +55,6 @@ data FamInst -- famInstTyCon :: FamInst -> TyCon famInstTyCon = fi_tycon - --- Extract all family instances. --- -extractFamInsts :: [TyThing] -> [FamInst] -extractFamInsts tythings - = do { ATyCon tycon <- tythings - ; case tyConFamInst_maybe tycon of - Nothing -> mzero - Just (fam, tys) -> - return $ FamInst { fi_fam = tyConName fam - , fi_tvs = mkVarSet . tyConTyVars $ tycon - , fi_tys = tys - , fi_tycon = tycon - } - } \end{code} \begin{code} @@ -90,6 +83,44 @@ pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon}) pprFamInsts :: [FamInst] -> SDoc pprFamInsts finsts = vcat (map pprFamInst finsts) + +famInstHead :: FamInst -> ([TyVar], TyCon, [Type]) +famInstHead (FamInst {fi_tycon = tycon}) + = case tyConFamInst_maybe tycon of + Nothing -> panic "FamInstEnv.famInstHead" + Just (fam, tys) -> (tyConTyVars tycon, fam, tys) + +-- Make a family instance representation from a tycon. This is used for local +-- instances, where we can safely pull on the tycon. +-- +mkLocalFamInst :: TyCon -> FamInst +mkLocalFamInst tycon + = case tyConFamInst_maybe tycon of + Nothing -> panic "FamInstEnv.mkLocalFamInst" + Just (fam, tys) -> + FamInst { + fi_fam = tyConName fam, + fi_tcs = roughMatchTcs tys, + fi_tvs = mkVarSet . tyConTyVars $ tycon, + fi_tys = tys, + fi_tycon = tycon + } + +-- Make a family instance representation from the information found in an +-- unterface file. In particular, we get the rough match info from the iface +-- (instead of computing it here). +-- +mkImportedFamInst :: Name -> [Maybe Name] -> TyCon -> FamInst +mkImportedFamInst fam mb_tcs tycon + = FamInst { + fi_fam = fam, + fi_tcs = mb_tcs, + fi_tvs = mkVarSet . tyConTyVars $ tycon, + fi_tys = case tyConFamInst_maybe tycon of + Nothing -> panic "FamInstEnv.mkImportedFamInst" + Just (_, tys) -> tys, + fi_tycon = tycon + } \end{code} @@ -102,7 +133,13 @@ pprFamInsts finsts = vcat (map pprFamInst finsts) InstEnv maps a family name to the list of known instances for that family. \begin{code} -type FamInstEnv = UniqFM [FamInst] -- Maps a family to its instances +type FamInstEnv = UniqFM FamilyInstEnv -- Maps a family to its instances + +data FamilyInstEnv + = FamIE [FamInst] -- The instances for a particular family, in any order + Bool -- True <=> there is an instance of form T a b c + -- If *not* then the common case of looking up + -- (T a b c) can fail immediately -- INVARIANTS: -- * The fs_tvs are distinct in each FamInst @@ -112,23 +149,75 @@ emptyFamInstEnv :: FamInstEnv emptyFamInstEnv = emptyUFM famInstEnvElts :: FamInstEnv -> [FamInst] -famInstEnvElts = concat . eltsUFM +famInstEnvElts fi = [elt | FamIE elts _ <- eltsUFM fi, elt <- elts] familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] familyInstances (pkg_fie, home_fie) fam = get home_fie ++ get pkg_fie where get env = case lookupUFM env fam of - Just insts -> insts - Nothing -> [] + Just (FamIE insts _) -> insts + Nothing -> [] extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv extendFamInstEnvList inst_env fis = foldl extendFamInstEnv inst_env fis extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv -extendFamInstEnv inst_env ins_item@(FamInst {fi_fam = cls_nm}) - = addToUFM_C add inst_env cls_nm [ins_item] +extendFamInstEnv 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 items _ = ins_item:items + add (FamIE items tyvar) _ = FamIE (ins_item:items) + (ins_tyvar || tyvar) + ins_tyvar = not (any isJust mb_tcs) \end{code} +%************************************************************************ +%* * +\subsection{Looking up a family instance} +%* * +%************************************************************************ + +@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match. +Multiple matches are only possible in case of type families (not data +families), and then, it doesn't matter which match we choose (as the +instances are guaranteed confluent). + +\begin{code} +lookupFamInstEnv :: (FamInstEnv -- External package inst-env + ,FamInstEnv) -- Home-package inst-env + -> TyCon -> [Type] -- What we are looking for + -> [(TvSubst, FamInst)] -- Successful matches +lookupFamInstEnv (pkg_ie, home_ie) fam tys + = home_matches ++ pkg_matches + where + rough_tcs = roughMatchTcs tys + all_tvs = all isNothing rough_tcs + home_matches = lookup home_ie + pkg_matches = lookup pkg_ie + + -------------- + lookup env = case lookupUFM env fam of + Nothing -> [] -- No instances for this class + Just (FamIE insts has_tv_insts) + -- Short cut for common case: + -- The thing we are looking up is of form (C a + -- b c), and the FamIE has no instances of + -- that form, so don't bother to search + | all_tvs && not has_tv_insts -> [] + | otherwise -> find insts + + -------------- + find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, + fi_tys = tpl_tys, fi_tycon = tycon }) : rest) + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find rest + + -- Proper check + | Just subst <- tcMatchTys tpl_tvs tpl_tys tys + = (subst, item) : find rest + + -- No match => try next + | otherwise + = find rest +\end{code} -- 1.7.10.4