diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2012-04-05 11:39:46 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2012-04-05 11:39:46 +0100 |
| commit | 012596565fe588037fda352b6e9fc6dd29c723ff (patch) | |
| tree | 73df8f8e0cba4b002cdfacb5d76a429b71083cc2 /compiler | |
| parent | 70b0f1608784cccaf02fbbc6227c96be20ca7c7a (diff) | |
| parent | 1a4ae306f9e87aea921522276e0ef26ec01f97b4 (diff) | |
| download | haskell-012596565fe588037fda352b6e9fc6dd29c723ff.tar.gz | |
Merge branch 'master' of http://darcs.haskell.org//ghc
Diffstat (limited to 'compiler')
38 files changed, 2442 insertions, 2051 deletions
diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index c8f7c169fd..7af33a4196 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -348,7 +348,7 @@ extendLocalRdrEnv (env, ns) name extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv extendLocalRdrEnvList (env, ns) names - = (extendOccEnvList env [(nameOccName n, n) | n <- names], addListToNameSet ns names) + = (extendOccEnvList env [(nameOccName n, n) | n <- names], addListToNameSet ns names) lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name lookupLocalRdrEnv (env, _) (Unqual occ) = lookupOccEnv env occ diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index b9054f43db..4af5b1c143 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -271,7 +271,7 @@ lintCoreExpr (Cast expr co) = do { expr_ty <- lintCoreExpr expr ; co' <- applySubstCo co ; (_, from_ty, to_ty) <- lintCoercion co' - ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty) + ; checkTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty) ; return to_ty } lintCoreExpr (Tick (Breakpoint _ ids) expr) @@ -1270,12 +1270,14 @@ mkUnboxedTupleMsg binder = vcat [hsep [ptext (sLit "A variable has unboxed tuple type:"), ppr binder], hsep [ptext (sLit "Binder's type:"), ppr (idType binder)]] -mkCastErr :: Type -> Type -> MsgDoc -mkCastErr from_ty expr_ty +mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc +mkCastErr expr co from_ty expr_ty = vcat [ptext (sLit "From-type of Cast differs from type of enclosed expression"), ptext (sLit "From-type:") <+> ppr from_ty, - ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty - ] + ptext (sLit "Type of enclosed expr:") <+> ppr expr_ty, + ptext (sLit "Actual enclosed expr:") <+> ppr expr, + ptext (sLit "Coercion used in cast:") <+> ppr co + ] dupVars :: [[Var]] -> MsgDoc dupVars vars diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 44aebb8169..df7277893c 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -400,18 +400,23 @@ trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args \begin{code} filterAlts :: [Unique] -- ^ Supply of uniques used in case we have to manufacture a new AltCon -> Type -- ^ Type of scrutinee (used to prune possibilities) - -> [AltCon] -- ^ Constructors known to be impossible due to the form of the scrutinee + -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee -> [(AltCon, [Var], a)] -- ^ Alternatives -> ([AltCon], Bool, [(AltCon, [Var], a)]) -- Returns: - -- 1. Constructors that will never be encountered by the *default* case (if any) - -- 2. Whether we managed to refine the default alternative into a specific constructor (for statistcs only) - -- 3. The new alternatives + -- 1. Constructors that will never be encountered by the + -- *default* case (if any). A superset of imposs_cons + -- 2. Whether we managed to refine the default alternative into a specific constructor (for statistics only) + -- 3. The new alternatives, trimmed by + -- a) remove imposs_cons + -- b) remove constructors which can't match because of GADTs + -- and with the DEFAULT expanded to a DataAlt if there is exactly + -- remaining constructor that can match -- -- NB: the final list of alternatives may be empty: -- This is a tricky corner case. If the data type has no constructors, - -- which GHC allows, then the case expression will have at most a default - -- alternative. + -- which GHC allows, or if the imposs_cons covers all constructors (after taking + -- account of GADTs), then no alternatives can match. -- -- If callers need to preserve the invariant that there is always at least one branch -- in a "case" statement then they will need to manually add a dummy case branch that just diff --git a/compiler/coreSyn/TrieMap.lhs b/compiler/coreSyn/TrieMap.lhs index 5855ed6d93..df7cef738a 100644 --- a/compiler/coreSyn/TrieMap.lhs +++ b/compiler/coreSyn/TrieMap.lhs @@ -14,7 +14,7 @@ {-# LANGUAGE TypeFamilies #-} module TrieMap( CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, - TypeMap, foldTypeMap, + TypeMap, foldTypeMap, lookupTypeMap_mod, CoercionMap, MaybeMap, ListMap, @@ -527,6 +527,39 @@ lkT env ty m go (LitTy l) = tm_tylit >.> lkTyLit l go (ForAllTy tv ty) = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv + +lkT_mod :: CmEnv + -> TyVarEnv a -- A substitution + -> (a -> Type) + -> Type + -> TypeMap b -> Maybe b +lkT_mod env s f ty m + | EmptyTM <- m = Nothing + | Just ty' <- coreView ty + = lkT_mod env s f ty' m + | isEmptyVarEnv candidates + = go env s ty m + | otherwise + = Just $ head (varEnvElts candidates) -- Yikes! + where + candidates = filterVarEnv_Directly find_matching (vm_fvar $ tm_var m) + find_matching tv _b = case lookupVarEnv_Directly s tv of + Nothing -> False + Just a -> f a `eqType` ty + go env _s (TyVarTy v) = tm_var >.> lkVar env v + go env s (AppTy t1 t2) = tm_app >.> lkT_mod env s f t1 >=> lkT_mod env s f t2 + go env s (FunTy t1 t2) = tm_fun >.> lkT_mod env s f t1 >=> lkT_mod env s f t2 + go env s (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT_mod env s f) tys + go _env _s (LitTy l) = tm_tylit >.> lkTyLit l + go _env _s (ForAllTy _tv _ty) = const Nothing + {- DV TODO: Add proper lookup for ForAll -} + +lookupTypeMap_mod :: TyVarEnv a -- A substitution to be applied to the /keys/ of type map + -> (a -> Type) + -> Type + -> TypeMap b -> Maybe b +lookupTypeMap_mod = lkT_mod emptyCME + ----------------- xtT :: CmEnv -> Type -> XT a -> TypeMap a -> TypeMap a xtT env ty f m diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 673ca37a3e..ba3651851a 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -20,6 +20,7 @@ import StaticFlags import HscTypes import HsSyn import TcRnTypes +import TcRnMonad ( finalSafeMode ) import MkIface import Id import Name @@ -169,6 +170,7 @@ deSugar hsc_env ; used_th <- readIORef tc_splice_used ; dep_files <- readIORef dependent_files + ; safe_mode <- finalSafeMode dflags tcg_env ; let mod_guts = ModGuts { mg_module = mod, @@ -194,6 +196,7 @@ deSugar hsc_env mg_modBreaks = modBreaks, mg_vect_decls = ds_vects, mg_vect_info = noVectInfo, + mg_safe_haskell = safe_mode, mg_trust_pkg = imp_trust_own_pkg imports, mg_dependent_files = dep_files } diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index af3d76bd75..586453df8e 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -115,8 +115,9 @@ repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec])) repTopDs group - = do { let { bndrs = hsGroupBinders group } ; - ss <- mkGenSyms bndrs ; + = do { let { tv_bndrs = hsSigTvBinders (hs_valds group) + ; bndrs = tv_bndrs ++ hsGroupBinders group } ; + ss <- pprTrace "reptop" (ppr bndrs $$ ppr tv_bndrs) $ mkGenSyms bndrs ; -- Bind all the names mainly to avoid repeated use of explicit strings. -- Thus we get @@ -146,8 +147,35 @@ repTopDs group } -{- Note [Binders and occurrences] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +hsSigTvBinders :: HsValBinds Name -> [Name] +-- See Note [Scoped type variables in bindings] +hsSigTvBinders binds + = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit tvs _ _))) <- sigs, tv <- tvs] + where + sigs = case binds of + ValBindsIn _ sigs -> sigs + ValBindsOut _ sigs -> sigs + + +{- Notes + +Note [Scoped type variables in bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: forall a. a -> a + f x = x::a +Here the 'forall a' brings 'a' into scope over the binding group. +To achieve this we + + a) Gensym a binding for 'a' at the same time as we do one for 'f' + collecting the relevant binders with hsSigTvBinders + + b) When processing the 'forall', don't gensym + +The relevant places are signposted with references to this Note + +Note [Binders and occurrences] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we desugar [d| data T = MkT |] we want to get Data "T" [] [Con "MkT" []] [] @@ -497,7 +525,7 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Singleton => Ok -- Empty => Too hard, signature ignored -rep_sig (L loc (TypeSig nms ty)) = rep_proto nms ty loc +rep_sig (L loc (TypeSig nms ty)) = mapM (rep_ty_sig loc ty) nms rep_sig (L _ (GenericSig nm _)) = failWithDs msg where msg = vcat [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm) , ptext (sLit "Default signatures are not supported by Template Haskell") ] @@ -506,16 +534,27 @@ rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc rep_sig _ = return [] -rep_proto :: [Located Name] -> LHsType Name -> SrcSpan - -> DsM [(SrcSpan, Core TH.DecQ)] -rep_proto nms ty loc - = mapM f nms +rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name + -> DsM (SrcSpan, Core TH.DecQ) +rep_ty_sig loc (L _ ty) nm + = do { nm1 <- lookupLOcc nm + ; ty1 <- rep_ty ty + ; sig <- repProto nm1 ty1 + ; return (loc, sig) } where - f nm = do { nm1 <- lookupLOcc nm - ; ty1 <- repLTy ty - ; sig <- repProto nm1 ty1 - ; return (loc, sig) - } + -- We must special-case the top-level explicit for-all of a TypeSig + -- See Note [Scoped type variables in bindings] + rep_ty (HsForAllTy Explicit tvs ctxt ty) + = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) + ; repTyVarBndrWithKind tv name } + ; bndrs1 <- mapM rep_in_scope_tv tvs + ; bndrs2 <- coreList tyVarBndrTyConName bndrs1 + ; ctxt1 <- repLContext ctxt + ; ty1 <- repLTy ty + ; repTForall bndrs2 ctxt1 ty1 } + + rep_ty ty = repTy ty + rep_inline :: Located Name -> InlinePragma -- Never defaultInlinePragma @@ -675,7 +714,7 @@ repTy (HsForAllTy _ tvs ctxt ty) = repTy (HsTyVar n) | isTvOcc (nameOccName n) = do - tv1 <- lookupTvOcc n + tv1 <- lookupOcc n repTvar tv1 | otherwise = do tc1 <- lookupOcc n @@ -976,11 +1015,12 @@ repBinds EmptyLocalBinds repBinds b@(HsIPBinds _) = notHandled "Implicit parameters" (ppr b) repBinds (HsValBinds decs) - = do { let { bndrs = collectHsValBinders decs } + = do { let { bndrs = hsSigTvBinders decs ++ collectHsValBinders decs } -- No need to worrry about detailed scopes within -- the binding group, because we are talking Names -- here, so we can safely treat it as a mutually -- recursive group + -- For hsSigTvBinders see Note [Scoped type variables in bindings] ; ss <- mkGenSyms bndrs ; prs <- addBinds ss (rep_val_binds decs) ; core_list <- coreList decQTyConName @@ -1212,18 +1252,6 @@ lookupOcc n Just (Splice _) -> pprPanic "repE:lookupOcc" (ppr n) } -lookupTvOcc :: Name -> DsM (Core TH.Name) --- Type variables can't be staged and are not lexically scoped in TH -lookupTvOcc n - = do { mb_val <- dsLookupMetaEnv n ; - case mb_val of - Just (Bound x) -> return (coreVar x) - _ -> failWithDs msg - } - where - msg = vcat [ ptext (sLit "Illegal lexically-scoped type variable") <+> quotes (ppr n) - , ptext (sLit "Lexically scoped type variables are not supported by Template Haskell") ] - globalVar :: Name -> DsM (Core TH.Name) -- Not bound by the meta-env -- Could be top-level; or could be local diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 20a2e47a6b..090c34ffc0 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -20,12 +20,6 @@ Category: Development Build-Type: Simple Cabal-Version: >= 1.2.3 -Flag base4 - Description: Choose the even newer, even smaller, split-up base package. - -Flag base3 - Description: Choose the new smaller, split-up base package. - Flag dynlibs Description: Dynamic library support Default: False @@ -54,26 +48,20 @@ Flag stage3 Library Exposed: False - if flag(base4) - Build-Depends: base >= 4 && < 5 - if flag(base3) - Build-Depends: base >= 3 && < 4 - if !flag(base3) && !flag(base4) - Build-Depends: base < 3 + Build-Depends: base >= 4 && < 5, + directory >= 1 && < 1.2, + process >= 1 && < 1.2, + bytestring >= 0.9 && < 0.11, + time < 1.5, + containers >= 0.1 && < 0.6, + array >= 0.1 && < 0.5, + filepath >= 1 && < 1.4, + Cabal, + hpc if flag(stage1) && impl(ghc < 7.5) Build-Depends: old-time >= 1 && < 1.2 - if flag(base3) || flag(base4) - Build-Depends: directory >= 1 && < 1.2, - process >= 1 && < 1.2, - bytestring >= 0.9 && < 0.11, - time < 1.5, - containers >= 0.1 && < 0.6, - array >= 0.1 && < 0.5 - - Build-Depends: filepath >= 1 && < 1.4 - Build-Depends: Cabal, hpc if os(windows) Build-Depends: Win32 else @@ -89,14 +77,10 @@ Library Build-Depends: bin-package-db Build-Depends: hoopl - -- GHC 6.4.2 needs to be able to find WCsubst.c, which needs to be - -- able to find WCsubst.h - Include-Dirs: ../libraries/base/cbits, ../libraries/base/include - Extensions: CPP, MagicHash, UnboxedTuples, PatternGuards, ForeignFunctionInterface, EmptyDataDecls, TypeSynonymInstances, MultiParamTypeClasses, - FlexibleInstances, Rank2Types, ScopedTypeVariables, + FlexibleInstances, RankNTypes, ScopedTypeVariables, DeriveDataTypeable, BangPatterns if impl(ghc >= 7.1) Extensions: NondecreasingIndentation diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 90deaa7edf..7a15120567 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -183,7 +183,7 @@ cvtDec (NewtypeD ctxt tc tvs constr derivs) = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs - ; let defn = TyData { td_ND = DataType, td_cType = Nothing + ; let defn = TyData { td_ND = NewType, td_cType = Nothing , td_ctxt = ctxt' , td_kindSig = Nothing , td_cons = [con'], td_derivs = derivs' } diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 877de44330..3c8050cff2 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -135,32 +135,35 @@ mkIface :: HscEnv -- to write it mkIface hsc_env maybe_old_fingerprint mod_details - ModGuts{ mg_module = this_mod, - mg_boot = is_boot, - mg_used_names = used_names, - mg_used_th = used_th, - mg_deps = deps, - mg_dir_imps = dir_imp_mods, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_warns = warns, - mg_hpc_info = hpc_info, - mg_trust_pkg = self_trust, + ModGuts{ mg_module = this_mod, + mg_boot = is_boot, + mg_used_names = used_names, + mg_used_th = used_th, + mg_deps = deps, + mg_dir_imps = dir_imp_mods, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_warns = warns, + mg_hpc_info = hpc_info, + mg_safe_haskell = safe_mode, + mg_trust_pkg = self_trust, mg_dependent_files = dependent_files } = mkIface_ hsc_env maybe_old_fingerprint this_mod is_boot used_names used_th deps rdr_env fix_env - warns hpc_info dir_imp_mods self_trust dependent_files mod_details + warns hpc_info dir_imp_mods self_trust dependent_files + safe_mode mod_details -- | make an interface from the results of typechecking only. Useful -- for non-optimising compilation, or where we aren't generating any -- object code at all ('HscNothing'). mkIfaceTc :: HscEnv -> Maybe Fingerprint -- The old fingerprint, if we have it + -> SafeHaskellMode -- The safe haskell mode -> ModDetails -- gotten from mkBootModDetails, probably -> TcGblEnv -- Usages, deprecations, etc -> IO (Messages, Maybe (ModIface, Bool)) -mkIfaceTc hsc_env maybe_old_fingerprint mod_details +mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details tc_result@TcGblEnv{ tcg_mod = this_mod, tcg_src = hsc_src, tcg_imports = imports, @@ -180,7 +183,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint mod_details mkIface_ hsc_env maybe_old_fingerprint this_mod (isHsBoot hsc_src) used_names used_th deps rdr_env fix_env warns hpc_info (imp_mods imports) - (imp_trust_own_pkg imports) dep_files mod_details + (imp_trust_own_pkg imports) dep_files safe_mode mod_details mkUsedNames :: TcGblEnv -> NameSet @@ -226,11 +229,12 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface -> NameEnv FixItem -> Warnings -> HpcInfo -> ImportedMods -> Bool -> [FilePath] + -> SafeHaskellMode -> ModDetails -> IO (Messages, Maybe (ModIface, Bool)) mkIface_ hsc_env maybe_old_fingerprint this_mod is_boot used_names used_th deps rdr_env fix_env src_warns - hpc_info dir_imp_mods pkg_trust_req dependent_files + hpc_info dir_imp_mods pkg_trust_req dependent_files safe_mode ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, @@ -244,7 +248,6 @@ mkIface_ hsc_env maybe_old_fingerprint -- to expose in the interface = do { usages <- mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files - ; safeInf <- hscGetSafeInf hsc_env ; let { entities = typeEnvElts type_env ; decls = [ tyThingToIfaceDecl entity @@ -263,13 +266,7 @@ mkIface_ hsc_env maybe_old_fingerprint ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts ; iface_vect_info = flattenVectInfo vect_info - - -- Check if we are in Safe Inference mode - -- but we failed to pass the muster - ; safeMode = if safeInferOn dflags && not safeInf - then Sf_None - else safeHaskell dflags - ; trust_info = setSafeMode safeMode + ; trust_info = setSafeMode safe_mode ; intermediate_iface = ModIface { mi_module = this_mod, diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index c24e5772e7..2cc8446ba1 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -48,6 +48,7 @@ module DynFlags ( safeHaskellOn, safeImportsOn, safeLanguageOn, safeInferOn, packageTrustOn, safeDirectImpsReq, safeImplicitImpsReq, + unsafeFlags, -- ** System tool settings and locations Settings(..), @@ -1151,6 +1152,19 @@ combineSafeFlags a b | a == Sf_SafeInfered = return b where errm = "Incompatible Safe Haskell flags! (" ++ showPpr a ++ ", " ++ showPpr b ++ ")" +-- | A list of unsafe flags under Safe Haskell. Tuple elements are: +-- * name of the flag +-- * function to get srcspan that enabled the flag +-- * function to test if the flag is on +-- * function to turn the flag off +unsafeFlags :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] +unsafeFlags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc, + xopt Opt_GeneralizedNewtypeDeriving, + flip xopt_unset Opt_GeneralizedNewtypeDeriving), + ("-XTemplateHaskell", thOnLoc, + xopt Opt_TemplateHaskell, + flip xopt_unset Opt_TemplateHaskell)] + -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from -> (DynFlags -> [a]) -- ^ Relevant record accessor: one of the @opt_*@ accessors @@ -1364,12 +1378,13 @@ safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) safeFlagCheck _ dflags | not (safeLanguageOn dflags || safeInferOn dflags) = (dflags, []) +-- safe or safe-infer ON safeFlagCheck cmdl dflags = case safeLanguageOn dflags of True -> (dflags', warns) -- throw error if -fpackage-trust by itself with no safe haskell flag - False | not cmdl && safeInferOn dflags && packageTrustOn dflags + False | not cmdl && packageTrustOn dflags -> (dopt_unset dflags' Opt_PackageTrust, [L (pkgTrustOnLoc dflags') $ "-fpackage-trust ignored;" ++ @@ -1387,10 +1402,10 @@ safeFlagCheck cmdl dflags = -- TODO: Can we do better than this for inference? safeInfOk = not $ xopt Opt_OverlappingInstances dflags - (dflags', warns) = foldl check_method (dflags, []) bad_flags + (dflags', warns) = foldl check_method (dflags, []) unsafeFlags check_method (df, warns) (str,loc,test,fix) - | test df = (apFix fix df, warns ++ safeFailure loc str) + | test df = (apFix fix df, warns ++ safeFailure (loc dflags) str) | otherwise = (df, warns) apFix f = if safeInferOn dflags then id else f @@ -1398,14 +1413,6 @@ safeFlagCheck cmdl dflags = safeFailure loc str = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " ++ str] - bad_flags = [("-XGeneralizedNewtypeDeriving", newDerivOnLoc dflags, - xopt Opt_GeneralizedNewtypeDeriving, - flip xopt_unset Opt_GeneralizedNewtypeDeriving), - ("-XTemplateHaskell", thOnLoc dflags, - xopt Opt_TemplateHaskell, - flip xopt_unset Opt_TemplateHaskell)] - - {- ********************************************************************** %* * DynFlags specifications diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index be7f2544e6..dc73257967 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -9,7 +9,7 @@ module ErrUtils ( ErrMsg, WarnMsg, Severity(..), Messages, ErrorMessages, WarningMessages, errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, - MsgDoc, mkLocMessage, pprMessageBag, pprErrMsgBag, + MsgDoc, mkLocMessage, pprMessageBag, pprErrMsgBag, pprErrMsgBagWithLoc, pprLocErrMsg, makeIntoWarning, errorsFound, emptyMessages, @@ -144,6 +144,9 @@ pprErrMsgBag bag errMsgExtraInfo = e, errMsgContext = unqual } <- sortMsgBag bag ] +pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc] +pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag bag ] + pprLocErrMsg :: ErrMsg -> SDoc pprLocErrMsg (ErrMsg { errMsgSpans = spans , errMsgShortDoc = d diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 9e33aae2bb..15e488bd09 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -72,10 +72,12 @@ module GHC ( modInfoIsExportedName, modInfoLookupName, modInfoIface, + modInfoSafe, lookupGlobalName, findGlobalAnns, mkPrintUnqualifiedForModule, ModIface(..), + SafeHaskellMode(..), -- * Querying the environment packageDbModules, @@ -254,6 +256,7 @@ import HscMain import GhcMake import DriverPipeline ( compile' ) import GhcMonad +import TcRnMonad ( finalSafeMode ) import TcRnTypes import Packages import NameSet @@ -737,6 +740,7 @@ typecheckModule pmod = do HsParsedModule { hpm_module = parsedSource pmod, hpm_src_files = pm_extra_src_files pmod } details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env + safe <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env return $ TypecheckedModule { tm_internals_ = (tc_gbl_env, details), @@ -749,7 +753,8 @@ typecheckModule pmod = do minf_exports = availsToNameSet $ md_exports details, minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), minf_instances = md_insts details, - minf_iface = Nothing + minf_iface = Nothing, + minf_safe = safe #ifdef GHCI ,minf_modBreaks = emptyModBreaks #endif @@ -823,12 +828,16 @@ data CoreModule -- | Type environment for types declared in this module cm_types :: !TypeEnv, -- | Declarations - cm_binds :: CoreProgram + cm_binds :: CoreProgram, + -- | Safe Haskell mode + cm_safe :: SafeHaskellMode } instance Outputable CoreModule where - ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) = - text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb) + ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb, + cm_safe = sf}) + = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te + $$ vcat (map ppr cb) -- | This is the way to get access to the Core bindings corresponding -- to a module. 'compileToCore' parses, typechecks, and @@ -865,7 +874,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do modLocation <- liftIO $ mkHiOnlyModLocation dflags (hiSuf dflags) cwd ((moduleNameSlashes . moduleName) mName) - let modSummary = ModSummary { ms_mod = mName, + let modSum = ModSummary { ms_mod = mName, ms_hsc_src = ExtCoreFile, ms_location = modLocation, -- By setting the object file timestamp to Nothing, @@ -884,7 +893,7 @@ compileCoreToObj simplify cm@(CoreModule{ cm_module = mName }) = do } hsc_env <- getSession - liftIO $ hscCompileCore hsc_env simplify modSummary (cm_binds cm) + liftIO $ hscCompileCore hsc_env simplify (cm_safe cm) modSum (cm_binds cm) compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule @@ -902,7 +911,7 @@ compileCore simplify fn = do mod_guts <- coreModule `fmap` -- TODO: space leaky: call hsc* directly? (desugarModule =<< typecheckModule =<< parseModule modSummary) - liftM gutsToCoreModule $ + liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $ if simplify then do -- If simplify is true: simplify (hscSimplify), then tidy @@ -919,18 +928,22 @@ compileCore simplify fn = do where -- two versions, based on whether we simplify (thus run tidyProgram, -- which returns a (CgGuts, ModDetails) pair, or not (in which case -- we just have a ModGuts. - gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule - gutsToCoreModule (Left (cg, md)) = CoreModule { + gutsToCoreModule :: SafeHaskellMode + -> Either (CgGuts, ModDetails) ModGuts + -> CoreModule + gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule { cm_module = cg_module cg, - cm_types = md_types md, - cm_binds = cg_binds cg + cm_types = md_types md, + cm_binds = cg_binds cg, + cm_safe = safe_mode } - gutsToCoreModule (Right mg) = CoreModule { + gutsToCoreModule safe_mode (Right mg) = CoreModule { cm_module = mg_module mg, cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) (mg_tcs mg) (mg_fam_insts mg), - cm_binds = mg_binds mg + cm_binds = mg_binds mg, + cm_safe = safe_mode } -- %************************************************************************ @@ -977,9 +990,10 @@ data ModuleInfo = ModuleInfo { minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod minf_instances :: [ClsInst], - minf_iface :: Maybe ModIface + minf_iface :: Maybe ModIface, + minf_safe :: SafeHaskellMode #ifdef GHCI - ,minf_modBreaks :: ModBreaks + ,minf_modBreaks :: ModBreaks #endif } -- We don't want HomeModInfo here, because a ModuleInfo applies @@ -1020,6 +1034,7 @@ getPackageModuleInfo hsc_env mdl minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, minf_instances = error "getModuleInfo: instances for package module unimplemented", minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface, minf_modBreaks = emptyModBreaks })) #else @@ -1040,7 +1055,8 @@ getHomeModuleInfo hsc_env mdl = minf_exports = availsToNameSet (md_exports details), minf_rdr_env = mi_globals $! hm_iface hmi, minf_instances = md_insts details, - minf_iface = Just iface + minf_iface = Just iface, + minf_safe = getSafeMode $ mi_trust iface #ifdef GHCI ,minf_modBreaks = getModBreaks hmi #endif @@ -1085,6 +1101,10 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do modInfoIface :: ModuleInfo -> Maybe ModIface modInfoIface = minf_iface +-- | Retrieve module safe haskell mode +modInfoSafe :: ModuleInfo -> SafeHaskellMode +modInfoSafe = minf_safe + #ifdef GHCI modInfoModBreaks :: ModuleInfo -> ModBreaks modInfoModBreaks = minf_modBreaks diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index efad3b7d3c..491814f0c5 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -171,7 +171,6 @@ newHscEnv dflags = do fc_var <- newIORef emptyUFM mlc_var <- newIORef emptyModuleEnv optFuel <- initOptFuelState - safe_var <- newIORef True return HscEnv { hsc_dflags = dflags, hsc_targets = [], hsc_mod_graph = [], @@ -182,8 +181,7 @@ newHscEnv dflags = do hsc_FC = fc_var, hsc_MLC = mlc_var, hsc_OptFuel = optFuel, - hsc_type_env_var = Nothing, - hsc_safeInf = safe_var } + hsc_type_env_var = Nothing } knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, @@ -405,10 +403,7 @@ type RenamedStuff = hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule -> IO (TcGblEnv, RenamedStuff) hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do - tc_result <- {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ - tcRnModule hsc_env (ms_hsc_src mod_summary) - True rdr_module + tc_result <- tcRnModule' hsc_env mod_summary True rdr_module -- This 'do' is in the Maybe monad! let rn_info = do decl <- tcg_rn_decls tc_result @@ -419,6 +414,34 @@ hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do return (tc_result, rn_info) +-- wrapper around tcRnModule to handle safe haskell extras +tcRnModule' :: HscEnv -> ModSummary -> Bool -> HsParsedModule + -> Hsc TcGblEnv +tcRnModule' hsc_env sum save_rn_syntax mod = do + tcg_res <- {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ + tcRnModule hsc_env (ms_hsc_src sum) save_rn_syntax mod + + tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_res) + dflags <- getDynFlags + + -- end of the Safe Haskell line, how to respond to user? + if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK) + -- if safe haskell off or safe infer failed, wipe trust + then wipeTrust tcg_res emptyBag + + -- module safe, throw warning if needed + else do + tcg_res' <- hscCheckSafeImports tcg_res + safe <- liftIO $ readIORef (tcg_safeInfer tcg_res') + when (safe && wopt Opt_WarnSafe dflags) + (logWarnings $ unitBag $ + mkPlainWarnMsg (warnSafeOnLoc dflags) $ errSafe tcg_res') + return tcg_res' + where + pprMod t = ppr $ moduleName $ tcg_mod t + errSafe t = quotes (pprMod t) <+> text "has been infered as safe!" + -- | Convert a typechecked module to Core hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts hscDesugar hsc_env mod_summary tc_result = @@ -443,9 +466,11 @@ hscDesugar' mod_location tc_result = do -- we should use fingerprint versions instead. makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails -> IO (ModIface,Bool) -makeSimpleIface hsc_env maybe_old_iface tc_result details = - runHsc hsc_env $ ioMsgMaybe $ - mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result +makeSimpleIface hsc_env maybe_old_iface tc_result details = runHsc hsc_env $ do + safe_mode <- hscGetSafeMode tc_result + ioMsgMaybe $ do + mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) safe_mode + details tc_result -- | Make a 'ModDetails' from the results of typechecking. Used when -- typechecking only, as opposed to full compilation. @@ -545,7 +570,7 @@ data HsCompiler a = HsCompiler { -> Hsc a, -- | Code generation for normal modules. - hscGenOutput :: ModGuts -> ModSummary -> Maybe Fingerprint + hscGenOutput :: ModGuts -> ModSummary -> Maybe Fingerprint -> Hsc a } @@ -836,30 +861,8 @@ hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv hscFileFrontEnd mod_summary = do hpm <- hscParse' mod_summary hsc_env <- getHscEnv - dflags <- getDynFlags - tcg_env <- - {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ - tcRnModule hsc_env (ms_hsc_src mod_summary) False hpm - tcSafeOK <- liftIO $ readIORef (tcg_safeInfer tcg_env) - - -- end of the Safe Haskell line, how to respond to user? - if not (safeHaskellOn dflags) || (safeInferOn dflags && not tcSafeOK) - - -- if safe haskell off or safe infer failed, wipe trust - then wipeTrust tcg_env emptyBag - - -- module safe, throw warning if needed - else do - tcg_env' <- hscCheckSafeImports tcg_env - safe <- liftIO $ hscGetSafeInf hsc_env - when (safe && wopt Opt_WarnSafe dflags) - (logWarnings $ unitBag $ - mkPlainWarnMsg (warnSafeOnLoc dflags) $ errSafe tcg_env') - return tcg_env' - where - pprMod t = ppr $ moduleName $ tcg_mod t - errSafe t = quotes (pprMod t) <+> text "has been infered as safe!" + tcg_env <- tcRnModule' hsc_env mod_summary False hpm + return tcg_env -------------------------------------------------------------- -- Safe Haskell @@ -1031,8 +1034,8 @@ hscCheckSafe' dflags m l = do case iface of -- can't load iface to check trust! Nothing -> throwErrors $ unitBag $ mkPlainErrMsg l - $ text "Can't load the interface file for" <+> ppr m <> - text ", to check that it can be safely imported" + $ text "Can't load the interface file for" <+> ppr m + <> text ", to check that it can be safely imported" -- got iface, check trust Just iface' -> do @@ -1052,13 +1055,16 @@ hscCheckSafe' dflags m l = do return (trust == Sf_Trustworthy, pkgRs) where - pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $ ppr m - <+> text "can't be safely imported!" <+> text "The package (" - <> ppr (modulePackageId m) - <> text ") the module resides in isn't trusted." - modTrustErr = unitBag $ mkPlainErrMsg l $ ppr m - <+> text "can't be safely imported!" - <+> text "The module itself isn't safe." + pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $ + sep [ ppr (moduleName m) + <> text ": Can't be safely imported!" + , text "The package (" <> ppr (modulePackageId m) + <> text ") the module resides in isn't trusted." + ] + modTrustErr = unitBag $ mkPlainErrMsg l $ + sep [ ppr (moduleName m) + <> text ": Can't be safely imported!" + , text "The module itself isn't safe." ] -- | Check the package a module resides in is trusted. Safe compiled -- modules are trusted without requiring that their package is trusted. For @@ -1112,8 +1118,8 @@ checkPkgTrust dflags pkgs = = Nothing | otherwise = Just $ mkPlainErrMsg noSrcSpan - $ text "The package (" <> ppr pkg <> text ") is required" - <> text " to be trusted but it isn't!" + $ text "The package (" <> ppr pkg <> text ") is required" <> + text " to be trusted but it isn't!" -- | Set module to unsafe and wipe trust information. -- @@ -1121,23 +1127,34 @@ checkPkgTrust dflags pkgs = -- it should be a central and single failure method. wipeTrust :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv wipeTrust tcg_env whyUnsafe = do - env <- getHscEnv dflags <- getDynFlags when (wopt Opt_WarnUnsafe dflags) (logWarnings $ unitBag $ - mkPlainWarnMsg (warnUnsafeOnLoc dflags) whyUnsafe') + mkPlainWarnMsg (warnUnsafeOnLoc dflags) (whyUnsafe' dflags)) - liftIO $ hscSetSafeInf env False + liftIO $ writeIORef (tcg_safeInfer tcg_env) False return $ tcg_env { tcg_imports = wiped_trust } where - wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] } - pprMod = ppr $ moduleName $ tcg_mod tcg_env - whyUnsafe' = vcat [ quotes pprMod <+> text "has been infered as unsafe!" - , text "Reason:" - , nest 4 (vcat $ pprErrMsgBag whyUnsafe) ] - + wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] } + pprMod = ppr $ moduleName $ tcg_mod tcg_env + whyUnsafe' df = vcat [ quotes pprMod <+> text "has been infered as unsafe!" + , text "Reason:" + , nest 4 $ (vcat $ badFlags df) $+$ + (vcat $ pprErrMsgBagWithLoc whyUnsafe) + ] + badFlags df = concat $ map (badFlag df) unsafeFlags + badFlag df (str,loc,on,_) + | on df = [mkLocMessage SevOutput (loc df) $ + text str <+> text "is not allowed in Safe Haskell"] + | otherwise = [] + +-- | Figure out the final correct safe haskell mode +hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode +hscGetSafeMode tcg_env = do + dflags <- getDynFlags + liftIO $ finalSafeMode dflags tcg_env -------------------------------------------------------------- -- Simplifiers @@ -1160,12 +1177,13 @@ hscSimpleIface :: TcGblEnv -> Maybe Fingerprint -> Hsc (ModIface, Bool, ModDetails) hscSimpleIface tc_result mb_old_iface = do - hsc_env <- getHscEnv - details <- liftIO $ mkBootModDetailsTc hsc_env tc_result + hsc_env <- getHscEnv + details <- liftIO $ mkBootModDetailsTc hsc_env tc_result + safe_mode <- hscGetSafeMode tc_result (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} ioMsgMaybe $ - mkIfaceTc hsc_env mb_old_iface details tc_result + mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result -- And the answer is ... liftIO $ dumpIfaceStats hsc_env return (new_iface, no_change, details) @@ -1579,21 +1597,23 @@ hscParseThingWithLocation source linenumber parser str liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing) return thing -hscCompileCore :: HscEnv -> Bool -> ModSummary -> CoreProgram -> IO () -hscCompileCore hsc_env simplify mod_summary binds = runHsc hsc_env $ do - guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) binds) - (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing - hscWriteIface iface changed mod_summary - _ <- hscGenHardCode cgguts mod_summary - return () +hscCompileCore :: HscEnv -> Bool -> SafeHaskellMode -> ModSummary + -> CoreProgram -> IO () +hscCompileCore hsc_env simplify safe_mode mod_summary binds + = runHsc hsc_env $ do + guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) safe_mode binds) + (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing + hscWriteIface iface changed mod_summary + _ <- hscGenHardCode cgguts mod_summary + return () where maybe_simplify mod_guts | simplify = hscSimplify' mod_guts | otherwise = return mod_guts -- Makes a "vanilla" ModGuts. -mkModGuts :: Module -> CoreProgram -> ModGuts -mkModGuts mod binds = +mkModGuts :: Module -> SafeHaskellMode -> CoreProgram -> ModGuts +mkModGuts mod safe binds = ModGuts { mg_module = mod, mg_boot = False, @@ -1618,6 +1638,7 @@ mkModGuts mod binds = mg_vect_info = noVectInfo, mg_inst_env = emptyInstEnv, mg_fam_inst_env = emptyFamInstEnv, + mg_safe_haskell = safe, mg_trust_pkg = False, mg_dependent_files = [] } diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index adc98765cf..e55d78e6fd 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -95,7 +95,6 @@ module HscTypes ( noIfaceVectInfo, isNoIfaceVectInfo, -- * Safe Haskell information - hscGetSafeInf, hscSetSafeInf, IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo, trustInfoToNum, numToTrustInfo, IsSafeImport, @@ -324,24 +323,12 @@ data HscEnv -- by limiting the number of transformations, -- we can use binary search to help find compiler bugs. - hsc_type_env_var :: Maybe (Module, IORef TypeEnv), + hsc_type_env_var :: Maybe (Module, IORef TypeEnv) -- ^ Used for one-shot compilation only, to initialise -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for -- 'TcRunTypes.TcGblEnv' - - hsc_safeInf :: {-# UNPACK #-} !(IORef Bool) - -- ^ Have we infered the module being compiled as - -- being safe? } --- | Get if the current module is considered safe or not by inference. -hscGetSafeInf :: HscEnv -> IO Bool -hscGetSafeInf hsc_env = readIORef (hsc_safeInf hsc_env) - --- | Set if the current module is considered safe or not by inference. -hscSetSafeInf :: HscEnv -> Bool -> IO () -hscSetSafeInf hsc_env b = writeIORef (hsc_safeInf hsc_env) b - -- | Retrieve the ExternalPackageState cache. hscEPS :: HscEnv -> IO ExternalPackageState hscEPS hsc_env = readIORef (hsc_EPS hsc_env) @@ -842,6 +829,8 @@ data ModGuts mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance enviroment for /home-package/ modules -- (including this one); c.f. 'tcg_fam_inst_env' + mg_safe_haskell :: SafeHaskellMode, + -- ^ Safe Haskell mode mg_trust_pkg :: Bool, -- ^ Do we need to trust our own package for Safe Haskell? -- See Note [RnNames . Trust Own Package] diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 1d6ad4a472..aa5a432762 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -2,51 +2,44 @@ % (c) The University of Glasgow, 2006 % \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -- | Package manipulation module Packages ( - module PackageConfig, - - -- * The PackageConfigMap - PackageConfigMap, emptyPackageConfigMap, lookupPackage, - extendPackageConfigMap, dumpPackages, - - -- * Reading the package config, and processing cmdline args - PackageState(..), - initPackages, - getPackageDetails, - lookupModuleInAllPackages, lookupModuleWithSuggestions, - - -- * Inspecting the set of packages in scope - getPackageIncludePath, - getPackageLibraryPath, - getPackageLinkOpts, - getPackageExtraCcOpts, - getPackageFrameworkPath, - getPackageFrameworks, - getPreloadPackagesAnd, + module PackageConfig, + + -- * The PackageConfigMap + PackageConfigMap, emptyPackageConfigMap, lookupPackage, + extendPackageConfigMap, dumpPackages, + + -- * Reading the package config, and processing cmdline args + PackageState(..), + initPackages, + getPackageDetails, + lookupModuleInAllPackages, lookupModuleWithSuggestions, + + -- * Inspecting the set of packages in scope + getPackageIncludePath, + getPackageLibraryPath, + getPackageLinkOpts, + getPackageExtraCcOpts, + getPackageFrameworkPath, + getPackageFrameworks, + getPreloadPackagesAnd, collectIncludeDirs, collectLibraryPaths, collectLinkOpts, packageHsLibs, - -- * Utils - isDllName + -- * Utils + isDllName ) where #include "HsVersions.h" -import PackageConfig +import PackageConfig import DynFlags import StaticFlags -import Config ( cProjectVersion ) -import Name ( Name, nameModule_maybe ) +import Config ( cProjectVersion ) +import Name ( Name, nameModule_maybe ) import UniqFM import Module import Util @@ -81,12 +74,12 @@ import qualified Data.Set as Set -- -- The package state is computed by 'initPackages', and kept in DynFlags. -- --- * @-package <pkg>@ causes @<pkg>@ to become exposed, and all other packages --- with the same name to become hidden. --- +-- * @-package <pkg>@ causes @<pkg>@ to become exposed, and all other packages +-- with the same name to become hidden. +-- -- * @-hide-package <pkg>@ causes @<pkg>@ to become hidden. --- --- * Let @exposedPackages@ be the set of packages thus exposed. +-- +-- * Let @exposedPackages@ be the set of packages thus exposed. -- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of -- their dependencies. -- @@ -107,28 +100,28 @@ import qualified Data.Set as Set -- Notes on DLLs -- ~~~~~~~~~~~~~ --- When compiling module A, which imports module B, we need to --- know whether B will be in the same DLL as A. --- If it's in the same DLL, we refer to B_f_closure --- If it isn't, we refer to _imp__B_f_closure +-- When compiling module A, which imports module B, we need to +-- know whether B will be in the same DLL as A. +-- If it's in the same DLL, we refer to B_f_closure +-- If it isn't, we refer to _imp__B_f_closure -- When compiling A, we record in B's Module value whether it's -- in a different DLL, by setting the DLL flag. data PackageState = PackageState { - pkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig - -- The exposed flags are adjusted according to -package and - -- -hide-package flags, and -ignore-package removes packages. + pkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig + -- The exposed flags are adjusted according to -package and + -- -hide-package flags, and -ignore-package removes packages. preloadPackages :: [PackageId], - -- The packages we're going to link in eagerly. This list - -- should be in reverse dependency order; that is, a package - -- is always mentioned before the packages it depends on. + -- The packages we're going to link in eagerly. This list + -- should be in reverse dependency order; that is, a package + -- is always mentioned before the packages it depends on. - moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping - -- Derived from pkgIdMap. - -- Maps Module to (pkgconf,exposed), where pkgconf is the - -- PackageConfig for the package containing the module, and - -- exposed is True if the package exposes that module. + moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)], -- ModuleEnv mapping + -- Derived from pkgIdMap. + -- Maps Module to (pkgconf,exposed), where pkgconf is the + -- PackageConfig for the package containing the module, and + -- exposed is True if the package exposes that module. installedPackageIdMap :: InstalledPackageIdMap } @@ -149,7 +142,7 @@ lookupPackage = lookupUFM extendPackageConfigMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap -extendPackageConfigMap pkg_map new_pkgs +extendPackageConfigMap pkg_map new_pkgs = foldl add pkg_map new_pkgs where add pkg_map p = addToUFM pkg_map (packageConfigId p) p @@ -175,14 +168,14 @@ getPackageDetails ps pid = expectJust "getPackageDetails" (lookupPackage (pkgIdM -- 'pkgState' in 'DynFlags' and return a list of packages to -- link in. initPackages :: DynFlags -> IO (DynFlags, [PackageId]) -initPackages dflags = do +initPackages dflags = do pkg_db <- case pkgDatabase dflags of Nothing -> readPackageConfigs dflags Just db -> return $ setBatchPackageFlags dflags db - (pkg_state, preload, this_pkg) + (pkg_state, preload, this_pkg) <- mkPackageState dflags pkg_db [] (thisPackage dflags) return (dflags{ pkgDatabase = Just pkg_db, - pkgState = pkg_state, + pkgState = pkg_state, thisPackage = this_pkg }, preload) @@ -195,13 +188,13 @@ readPackageConfigs dflags = do system_pkgconfs <- getSystemPackageConfigs dflags let pkgconfs = case e_pkg_path of - Left _ -> system_pkgconfs - Right path - | last cs == "" -> init cs ++ system_pkgconfs - | otherwise -> cs - where cs = parseSearchPath path - -- if the path ends in a separator (eg. "/foo/bar:") - -- the we tack on the system paths. + Left _ -> system_pkgconfs + Right path + | last cs == "" -> init cs ++ system_pkgconfs + | otherwise -> cs + where cs = parseSearchPath path + -- if the path ends in a separator (eg. "/foo/bar:") + -- the we tack on the system paths. pkgs <- mapM (readPackageConfig dflags) (pkgconfs ++ reverse (extraPkgConfs dflags)) @@ -214,16 +207,16 @@ readPackageConfigs dflags = do getSystemPackageConfigs :: DynFlags -> IO [FilePath] getSystemPackageConfigs dflags = do - -- System one always comes first + -- System one always comes first let system_pkgconf = systemPackageConfig dflags - -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf) - -- unless the -no-user-package-conf flag was given. + -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf) + -- unless the -no-user-package-conf flag was given. user_pkgconf <- do if not (dopt Opt_ReadUserPackageConf dflags) then return [] else do appdir <- getAppUserDataDirectory "ghc" - let - dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) + let + dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion) pkgconf = dir </> "package.conf.d" -- exist <- doesDirectoryExist pkgconf @@ -236,17 +229,17 @@ readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig] readPackageConfig dflags conf_file = do isdir <- doesDirectoryExist conf_file - proto_pkg_configs <- + proto_pkg_configs <- if isdir then do let filename = conf_file </> "package.cache" debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename) conf <- readBinPackageDB filename return (map installedPackageInfoToPackageConfig conf) - else do + else do isfile <- doesFileExist conf_file when (not isfile) $ - ghcError $ InstallationError $ + ghcError $ InstallationError $ "can't find a package database at " ++ conf_file debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file) str <- readFile conf_file @@ -293,7 +286,7 @@ mungePackagePaths top_dir pkgroot pkg = haddockInterfaces = munge_paths (haddockInterfaces pkg), haddockHTMLs = munge_urls (haddockHTMLs pkg) } - where + where munge_paths = map munge_path munge_urls = map munge_url @@ -340,23 +333,23 @@ applyPackageFlag unusable pkgs flag = case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr flag ps Right (p:ps,qs) -> return (p':ps') - where p' = p {exposed=True} - ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) + where p' = p {exposed=True} + ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) _ -> panic "applyPackageFlag" ExposePackageId str -> case selectPackages (matchingId str) pkgs unusable of Left ps -> packageFlagErr flag ps Right (p:ps,qs) -> return (p':ps') - where p' = p {exposed=True} - ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) + where p' = p {exposed=True} + ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) _ -> panic "applyPackageFlag" HidePackage str -> case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr flag ps Right (ps,qs) -> return (map hide ps ++ qs) - where hide p = p {exposed=False} + where hide p = p {exposed=False} -- we trust all matching packages. Maybe should only trust first one? -- and leave others the same or set them untrusted @@ -364,21 +357,21 @@ applyPackageFlag unusable pkgs flag = case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr flag ps Right (ps,qs) -> return (map trust ps ++ qs) - where trust p = p {trusted=True} + where trust p = p {trusted=True} DistrustPackage str -> case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr flag ps Right (ps,qs) -> return (map distrust ps ++ qs) - where distrust p = p {trusted=False} + where distrust p = p {trusted=False} _ -> panic "applyPackageFlag" where - -- When a package is requested to be exposed, we hide all other - -- packages with the same name. - hideAll name ps = map maybe_hide ps - where maybe_hide p + -- When a package is requested to be exposed, we hide all other + -- packages with the same name. + hideAll name ps = map maybe_hide ps + where maybe_hide p | pkgName (sourcePackageId p) == name = p {exposed=False} | otherwise = p @@ -401,8 +394,8 @@ selectPackages matches pkgs unusable -- version, or just the name if it is unambiguous. matchingStr :: String -> PackageConfig -> Bool matchingStr str p - = str == display (sourcePackageId p) - || str == display (pkgName (sourcePackageId p)) + = str == display (sourcePackageId p) + || str == display (pkgName (sourcePackageId p)) matchingId :: String -> PackageConfig -> Bool matchingId str p = InstalledPackageId str == installedPackageId p @@ -424,9 +417,9 @@ packageFlagErr (ExposePackage pkg) [] | is_dph_package pkg where dph_err = text "the " <> text pkg <> text " package is not installed." $$ text "To install it: \"cabal install dph\"." is_dph_package pkg = "dph" `isPrefixOf` pkg - + packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err)) - where err = text "cannot satisfy " <> ppr_flag <> + where err = text "cannot satisfy " <> ppr_flag <> (if null reasons then empty else text ": ") $$ nest 4 (ppr_reasons $$ text "(use -v for more information)") @@ -452,20 +445,20 @@ packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err)) hideOldPackages :: DynFlags -> [PackageConfig] -> IO [PackageConfig] hideOldPackages dflags pkgs = mapM maybe_hide pkgs where maybe_hide p - | not (exposed p) = return p - | (p' : _) <- later_versions = do - debugTraceMsg dflags 2 $ - (ptext (sLit "hiding package") <+> pprSPkg p <+> - ptext (sLit "to avoid conflict with later version") <+> - pprSPkg p') - return (p {exposed=False}) - | otherwise = return p - where myname = pkgName (sourcePackageId p) - myversion = pkgVersion (sourcePackageId p) - later_versions = [ p | p <- pkgs, exposed p, - let pkg = sourcePackageId p, - pkgName pkg == myname, - pkgVersion pkg > myversion ] + | not (exposed p) = return p + | (p' : _) <- later_versions = do + debugTraceMsg dflags 2 $ + (ptext (sLit "hiding package") <+> pprSPkg p <+> + ptext (sLit "to avoid conflict with later version") <+> + pprSPkg p') + return (p {exposed=False}) + | otherwise = return p + where myname = pkgName (sourcePackageId p) + myversion = pkgVersion (sourcePackageId p) + later_versions = [ p | p <- pkgs, exposed p, + let pkg = sourcePackageId p, + pkgName pkg == myname, + pkgVersion pkg > myversion ] -- ----------------------------------------------------------------------------- -- Wired-in packages @@ -494,43 +487,43 @@ findWiredInPackages dflags pkgs = do matches :: PackageConfig -> String -> Bool pc `matches` pid = display (pkgName (sourcePackageId pc)) == pid - -- find which package corresponds to each wired-in package - -- delete any other packages with the same name - -- update the package and any dependencies to point to the new - -- one. + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. -- -- When choosing which package to map to a wired-in package -- name, we prefer exposed packages, and pick the latest -- version. To override the default choice, -hide-package -- could be used to hide newer versions. -- - findWiredInPackage :: [PackageConfig] -> String - -> IO (Maybe InstalledPackageId) - findWiredInPackage pkgs wired_pkg = + findWiredInPackage :: [PackageConfig] -> String + -> IO (Maybe InstalledPackageId) + findWiredInPackage pkgs wired_pkg = let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in - case all_ps of - [] -> notfound - many -> pick (head (sortByVersion many)) + case all_ps of + [] -> notfound + many -> pick (head (sortByVersion many)) where notfound = do - debugTraceMsg dflags 2 $ - ptext (sLit "wired-in package ") - <> text wired_pkg - <> ptext (sLit " not found.") - return Nothing - pick :: InstalledPackageInfo_ ModuleName + debugTraceMsg dflags 2 $ + ptext (sLit "wired-in package ") + <> text wired_pkg + <> ptext (sLit " not found.") + return Nothing + pick :: InstalledPackageInfo_ ModuleName -> IO (Maybe InstalledPackageId) pick pkg = do debugTraceMsg dflags 2 $ - ptext (sLit "wired-in package ") - <> text wired_pkg - <> ptext (sLit " mapped to ") - <> pprIPkg pkg - return (Just (installedPackageId pkg)) + ptext (sLit "wired-in package ") + <> text wired_pkg + <> ptext (sLit " mapped to ") + <> pprIPkg pkg + return (Just (installedPackageId pkg)) mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids - let + let wired_in_ids = catMaybes mb_wired_in_ids -- this is old: we used to assume that if there were @@ -541,13 +534,13 @@ findWiredInPackages dflags pkgs = do -- wrappers that depend on this one. e.g. base-4.0 is the -- latest, base-3.0 is a compat wrapper depending on base-4.0. {- - deleteOtherWiredInPackages pkgs = filterOut bad pkgs - where bad p = any (p `matches`) wired_in_pkgids + deleteOtherWiredInPackages pkgs = filterOut bad pkgs + where bad p = any (p `matches`) wired_in_pkgids && package p `notElem` map fst wired_in_ids -} - updateWiredInDependencies pkgs = map upd_pkg pkgs - where upd_pkg p + updateWiredInDependencies pkgs = map upd_pkg pkgs + where upd_pkg p | installedPackageId p `elem` wired_in_ids = p { sourcePackageId = (sourcePackageId p){ pkgVersion = Version [] [] } } | otherwise @@ -650,9 +643,9 @@ ignorePackages flags pkgs = Map.fromList (concatMap doit flags) case partition (matchingStr str) pkgs of (ps, _) -> [ (installedPackageId p, IgnoredWithFlag) | p <- ps ] - -- missing package is not an error for -ignore-package, - -- because a common usage is to -ignore-package P as - -- a preventative measure just in case P exists. + -- missing package is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. doit _ = panic "ignorePackages" -- ----------------------------------------------------------------------------- @@ -665,7 +658,7 @@ depClosure index ipids = closure Map.empty ipids closure set [] = Map.keys set closure set (ipid : ipids) | ipid `Map.member` set = closure set ipids - | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set) + | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set) (depends p ++ ipids) | otherwise = closure set ipids @@ -688,7 +681,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do {- Plan. - 1. P = transitive closure of packages selected by -package-id + 1. P = transitive closure of packages selected by -package-id 2. Apply shadowing. When there are multiple packages with the same sourcePackageId, @@ -746,7 +739,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do ipid_selected = depClosure ipid_map [ InstalledPackageId i | ExposePackageId i <- flags ] - + (ignore_flags, other_flags) = partition is_ignore flags is_ignore IgnorePackage{} = True is_ignore _ = False @@ -808,7 +801,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- set up preloaded package when we are just building it preload3 = nub $ filter (/= this_package) $ (basicLinkedPackages ++ preload2) - + -- Close the preload packages with their dependencies dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload @@ -820,7 +813,7 @@ mkPackageState dflags pkgs0 preload0 this_package = do } return (pstate, new_dep_preload, this_package) - + -- ----------------------------------------------------------------------------- -- Make the mapping from module to package info @@ -831,15 +824,15 @@ mkModuleMap mkModuleMap pkg_db = foldr extend_modmap emptyUFM pkgids where pkgids = map packageConfigId (eltsUFM pkg_db) - - extend_modmap pkgid modmap = - addListToUFM_C (++) modmap - ([(m, [(pkg, True)]) | m <- exposed_mods] ++ - [(m, [(pkg, False)]) | m <- hidden_mods]) - where - pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid) - exposed_mods = exposedModules pkg - hidden_mods = hiddenModules pkg + + extend_modmap pkgid modmap = + addListToUFM_C (++) modmap + ([(m, [(pkg, True)]) | m <- exposed_mods] ++ + [(m, [(pkg, False)]) | m <- hidden_mods]) + where + pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid) + exposed_mods = exposedModules pkg + hidden_mods = hiddenModules pkg pprSPkg :: PackageConfig -> SDoc pprSPkg p = text (display (sourcePackageId p)) @@ -863,7 +856,7 @@ getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String] getPackageIncludePath dflags pkgs = collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs -collectIncludeDirs :: [PackageConfig] -> [FilePath] +collectIncludeDirs :: [PackageConfig] -> [FilePath] collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps)) -- | Find all the library paths in these and the preload packages @@ -876,14 +869,14 @@ collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps)) -- | Find all the link options in these and the preload packages getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String] -getPackageLinkOpts dflags pkgs = +getPackageLinkOpts dflags pkgs = collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs collectLinkOpts :: DynFlags -> [PackageConfig] -> [String] collectLinkOpts dflags ps = concat (map all_opts ps) where - libs p = packageHsLibs dflags p ++ extraLibraries p - all_opts p = map ("-l" ++) (libs p) ++ ldOptions p + libs p = packageHsLibs dflags p ++ extraLibraries p + all_opts p = map ("-l" ++) (libs p) ++ ldOptions p packageHsLibs :: DynFlags -> PackageConfig -> [String] packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) @@ -895,7 +888,7 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) -- we leave out the _dyn, because it is superfluous -- debug RTS includes support for -eventlog - ways2 | WayDebug `elem` map wayName ways1 + ways2 | WayDebug `elem` map wayName ways1 = filter ((/= WayEventLog) . wayName) ways1 | otherwise = ways1 @@ -903,14 +896,14 @@ packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) tag = mkBuildTag (filter (not . wayRTSOnly) ways2) rts_tag = mkBuildTag ways2 - mkDynName | opt_Static = id - | otherwise = (++ ("-ghc" ++ cProjectVersion)) + mkDynName | opt_Static = id + | otherwise = (++ ("-ghc" ++ cProjectVersion)) addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) addSuffix other_lib = other_lib ++ (expandTag tag) expandTag t | null t = "" - | otherwise = '_':t + | otherwise = '_':t -- | Find all the C-compiler options in these and the preload packages getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String] @@ -933,7 +926,7 @@ getPackageFrameworks dflags pkgs = do -- ----------------------------------------------------------------------------- -- Package Utils --- | Takes a 'Module', and if the module is in a package returns +-- | Takes a 'Module', and if the module is in a package returns -- @(pkgconf, exposed)@ where pkgconf is the PackageConfig for that package, -- and exposed is @True@ if the package exposes the module. lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)] @@ -968,7 +961,7 @@ lookupModuleWithSuggestions dflags m -- 'PackageConfig's getPreloadPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig] getPreloadPackagesAnd dflags pkgids = - let + let state = pkgState dflags pkg_map = pkgIdMap state ipid_map = installedPackageIdMap state @@ -988,8 +981,8 @@ closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps) throwErr :: MaybeErr MsgDoc a -> IO a throwErr m = case m of - Failed e -> ghcError (CmdLineError (showSDoc e)) - Succeeded r -> return r + Failed e -> ghcError (CmdLineError (showSDoc e)) + Succeeded r -> return r closeDepsErr :: PackageConfigMap -> Map InstalledPackageId PackageId @@ -998,21 +991,21 @@ closeDepsErr :: PackageConfigMap closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps -- internal helper -add_package :: PackageConfigMap +add_package :: PackageConfigMap -> Map InstalledPackageId PackageId -> [PackageId] -> (PackageId,Maybe PackageId) -> MaybeErr MsgDoc [PackageId] add_package pkg_db ipid_map ps (p, mb_parent) - | p `elem` ps = return ps -- Check if we've already added this package + | p `elem` ps = return ps -- Check if we've already added this package | otherwise = case lookupPackage pkg_db p of - Nothing -> Failed (missingPackageMsg (packageIdString p) <> + Nothing -> Failed (missingPackageMsg (packageIdString p) <> missingDependencyMsg mb_parent) Just pkg -> do - -- Add the package's dependents also - ps' <- foldM add_package_ipid ps (depends pkg) - return (p : ps') + -- Add the package's dependents also + ps' <- foldM add_package_ipid ps (depends pkg) + return (p : ps') where add_package_ipid ps ipid@(InstalledPackageId str) | Just pid <- Map.lookup ipid ipid_map @@ -1049,9 +1042,9 @@ isDllName this_pkg name -- | Show package info on console, if verbosity is >= 3 dumpPackages :: DynFlags -> IO () dumpPackages dflags - = do let pkg_map = pkgIdMap (pkgState dflags) - putMsg dflags $ - vcat (map (text . showInstalledPackageInfo - . packageConfigToInstalledPackageInfo) - (eltsUFM pkg_map)) + = do let pkg_map = pkgIdMap (pkgState dflags) + putMsg dflags $ + vcat (map (text . showInstalledPackageInfo + . packageConfigToInstalledPackageInfo) + (eltsUFM pkg_map)) \end{code} diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 94b2019e9e..378a25c8e1 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -321,6 +321,10 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } "[" @varid "|" / { ifExtension qqEnabled } { lex_quasiquote_tok } + + -- qualified quasi-quote (#5555) + "[" @qual @varid "|" / { ifExtension qqEnabled } + { lex_qquasiquote_tok } } <0> { @@ -562,7 +566,14 @@ data Token | ITidEscape FastString -- $x | ITparenEscape -- $( | ITtyQuote -- '' - | ITquasiQuote (FastString,FastString,RealSrcSpan) -- [:...|...|] + | ITquasiQuote (FastString,FastString,RealSrcSpan) + -- ITquasiQuote(quoter, quote, loc) + -- represents a quasi-quote of the form + -- [quoter| quote |] + | ITqQuasiQuote (FastString,FastString,FastString,RealSrcSpan) + -- ITqQuasiQuote(Qual, quoter, quote, loc) + -- represents a qualified quasi-quote of the form + -- [Qual.quoter| quote |] -- Arrow notation extension | ITproc @@ -1423,6 +1434,18 @@ getCharOrFail i = do -- ----------------------------------------------------------------------------- -- QuasiQuote +lex_qquasiquote_tok :: Action +lex_qquasiquote_tok span buf len = do + let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False + quoteStart <- getSrcLoc + quote <- lex_quasiquote quoteStart "" + end <- getSrcLoc + return (L (mkRealSrcSpan (realSrcSpanStart span) end) + (ITqQuasiQuote (qual, + quoter, + mkFastString (reverse quote), + mkRealSrcSpan quoteStart end))) + lex_quasiquote_tok :: Action lex_quasiquote_tok span buf len = do let quoter = tail (lexemeToString buf (len - 1)) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 6424dea79f..9774c245e7 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -350,6 +350,7 @@ TH_ID_SPLICE { L _ (ITidEscape _) } -- $x '$(' { L _ ITparenEscape } -- $( exp ) TH_TY_QUOTE { L _ ITtyQuote } -- ''T TH_QUASIQUOTE { L _ (ITquasiQuote _) } +TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } %monad { P } { >>= } { return } %lexer { lexer } { L _ ITeof } @@ -1360,6 +1361,10 @@ quasiquote :: { Located (HsQuasiQuote RdrName) } ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 ; quoterId = mkUnqual varName quoter } in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } + | TH_QQUASIQUOTE { let { loc = getLoc $1 + ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1 + ; quoterId = mkQual varName (qual, quoter) } + in sL (getLoc $1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } exp :: { LHsExpr RdrName } : infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 } diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 27ae036d61..fabe0305cb 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -431,8 +431,12 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds , cid_sigs = uprags, cid_fam_insts = ats }) -- Used for both source and interface file decls = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty - ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty' - (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags + ; case splitLHsInstDeclTy_maybe inst_ty' of { + Nothing -> return (ClsInstD { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds + , cid_sigs = [], cid_fam_insts = [] }, inst_fvs) ; + Just (inst_tyvars, _, L _ cls,_) -> + + do { let (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags tv_names = hsLTyVarNames inst_tyvars -- Rename the associated types, and type signatures @@ -467,7 +471,7 @@ rnSrcInstDecl (ClsInstD { cid_poly_ty = inst_ty, cid_binds = mbinds , cid_sigs = uprags', cid_fam_insts = ats' }, meth_fvs `plusFV` more_fvs `plusFV` spec_inst_fvs - `plusFV` inst_fvs) } + `plusFV` inst_fvs) } } } -- We return the renamed associated data type declarations so -- that they can be entered into the list of type declarations -- for the binding group, but we also keep a copy in the instance. diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 8056c0eceb..56525b97fa 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -79,6 +79,14 @@ occurAnalysePgm this_mod active_rule imp_rules vects binds (rulesFreeVars imp_rules `unionVarSet` vectsFreeVars vects) -- The RULES and VECTORISE declarations keep things alive! + -- Note [Preventing loops due to imported functions rules] + imp_rules_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv + [ mapVarEnv (const maps_to) (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule) + | imp_rule <- imp_rules + , let maps_to = exprFreeIds (ru_rhs imp_rule) + `delVarSetList` ru_bndrs imp_rule + , arg <- ru_args imp_rule ] + go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) go _ [] = (initial_uds, []) @@ -86,7 +94,7 @@ occurAnalysePgm this_mod active_rule imp_rules vects binds = (final_usage, bind' ++ binds') where (bs_usage, binds') = go env binds - (final_usage, bind') = occAnalBind env env bind bs_usage + (final_usage, bind') = occAnalBind env env imp_rules_edges bind bs_usage occurAnalyseExpr :: CoreExpr -> CoreExpr -- Do occurrence analysis, and discard occurence info returned @@ -110,12 +118,13 @@ Bindings \begin{code} occAnalBind :: OccEnv -- The incoming OccEnv -> OccEnv -- Same, but trimmed by (binderOf bind) + -> IdEnv IdSet -- Mapping from FVs of imported RULE LHSs to RHS FVs -> CoreBind -> UsageDetails -- Usage details of scope -> (UsageDetails, -- Of the whole let(rec) [CoreBind]) -occAnalBind env _ (NonRec binder rhs) body_usage +occAnalBind env _ imp_rules_edges (NonRec binder rhs) body_usage | isTyVar binder -- A type let; we don't gather usage info = (body_usage, [NonRec binder rhs]) @@ -123,15 +132,17 @@ occAnalBind env _ (NonRec binder rhs) body_usage = (body_usage, []) | otherwise -- It's mentioned in the body - = (body_usage' +++ rhs_usage3, [NonRec tagged_binder rhs']) + = (body_usage' +++ rhs_usage4, [NonRec tagged_binder rhs']) where (body_usage', tagged_binder) = tagBinder body_usage binder (rhs_usage1, rhs') = occAnalRhs env (Just tagged_binder) rhs rhs_usage2 = addIdOccs rhs_usage1 (idUnfoldingVars binder) rhs_usage3 = addIdOccs rhs_usage2 (idRuleVars binder) -- See Note [Rules are extra RHSs] and Note [Rule dependency info] + rhs_usage4 = maybe rhs_usage3 (addIdOccs rhs_usage3) $ lookupVarEnv imp_rules_edges binder + -- See Note [Preventing loops due to imported functions rules] -occAnalBind _ env (Rec pairs) body_usage +occAnalBind _ env imp_rules_edges (Rec pairs) body_usage = foldr occAnalRec (body_usage, []) sccs -- For a recursive group, we -- * occ-analyse all the RHSs @@ -144,7 +155,7 @@ occAnalBind _ env (Rec pairs) body_usage sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR nodes nodes :: [Node Details] - nodes = {-# SCC "occAnalBind.assoc" #-} map (makeNode env bndr_set) pairs + nodes = {-# SCC "occAnalBind.assoc" #-} map (makeNode env imp_rules_edges bndr_set) pairs \end{code} Note [Dead code] @@ -404,6 +415,86 @@ It's up the programmer not to write silly rules like RULE f x = f x and the example above is just a more complicated version. +Note [Preventing loops due to imported functions rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + import GHC.Base (foldr) + + {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-} + filter p xs = build (\c n -> foldr (filterFB c p) n xs) + filterFB c p = ... + + f = filter p xs + +Note that filter is not a loop-breaker, so what happens is: + f = filter p xs + = {inline} build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +We are in an infinite loop. + +A more elaborate example (that I actually saw in practice when I went to +mark GHC.List.filter as INLINABLE) is as follows. Say I have this module: + {-# LANGUAGE Rank2Types #-} + module GHCList where + + import Prelude hiding (filter) + import GHC.Base (build) + + {-# INLINABLE filter #-} + filter :: (a -> Bool) -> [a] -> [a] + filter p [] = [] + filter p (x:xs) = if p x then x : filter p xs else filter p xs + + {-# NOINLINE [0] filterFB #-} + filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b + filterFB c p x r | p x = x `c` r + | otherwise = r + + {-# RULES + "filter" [~1] forall p xs. filter p xs = build (\c n -> foldr + (filterFB c p) n xs) + "filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p + #-} + +Then (because RULES are applied inside INLINABLE unfoldings, but inlinings +are not), the unfolding given to "filter" in the interface file will be: + filter p [] = [] + filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs + +Note that because this unfolding does not mention "filter", filter is not +marked as a strong loop breaker. Therefore at a use site in another module: + filter p xs + = {inline} + case xs of [] -> [] + (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs) + + build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +And we are in an infinite loop again, except that this time the loop is producing an +infinitely large *term* (an unrolling of filter) and so the simplifier finally +dies with "ticks exhausted" + +Because of this problem, we make a small change in the occurrence analyser +designed to mark functions like "filter" as strong loop breakers on the basis that: + 1. The RHS of filter mentions the local function "filterFB" + 2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS + +So for each RULE for an *imported* function we are going to add dependency edges between +the FVS of the rule LHS and the FVS of the rule RHS. We don't do anything special for +RULES on local functions because the standard occurrence analysis stuff is pretty good +at getting loop-breakerness correct there. + +It is important to note that even with this extra hack we aren't always going to get +things right. For example, it might be that the rule LHS mentions an imported Id, +and another module has a RULE that can rewrite that imported Id to one of our local +Ids. + Note [Specialising imported functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ BUT for *automatically-generated* rules, the programmer can't be @@ -566,8 +657,8 @@ instance Outputable Details where , ptext (sLit "rule =") <+> ppr (nd_active_rule_fvs nd) ]) -makeNode :: OccEnv -> VarSet -> (Var, CoreExpr) -> Node Details -makeNode env bndr_set (bndr, rhs) +makeNode :: OccEnv -> IdEnv IdSet -> VarSet -> (Var, CoreExpr) -> Node Details +makeNode env imp_rules_edges bndr_set (bndr, rhs) = (details, varUnique bndr, keysUFM node_fvs) where details = ND { nd_bndr = bndr @@ -591,7 +682,9 @@ makeNode env bndr_set (bndr, rhs) is_active = occ_rule_act env :: Activation -> Bool rules = filterOut isBuiltinRule (idCoreRules bndr) rules_w_fvs :: [(Activation, VarSet)] -- Find the RHS fvs - rules_w_fvs = [ (ru_act rule, fvs) + rules_w_fvs = maybe id (\ids -> ((AlwaysActive, ids):)) (lookupVarEnv imp_rules_edges bndr) + -- See Note [Preventing loops due to imported functions rules] + [ (ru_act rule, fvs) | rule <- rules , let fvs = exprFreeVars (ru_rhs rule) `delVarSetList` ru_bndrs rule @@ -1191,7 +1284,7 @@ occAnal env (Case scrut bndr ty alts) occAnal env (Let bind body) = case occAnal env_body body of { (body_usage, body') -> - case occAnalBind env env_body bind body_usage of { (final_usage, new_binds) -> + case occAnalBind env env_body emptyVarEnv bind body_usage of { (final_usage, new_binds) -> (final_usage, mkLets new_binds body') }} where env_body = trimOccEnv env (bindersOf bind) diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index 59ebeea1bc..0af0b7fe73 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -1494,6 +1494,7 @@ of the inner case y, which give us nowhere to go! \begin{code} prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt]) +-- The returned alternatives can be empty, none are possible prepareAlts scrut case_bndr' alts = do us <- getUniquesM -- Case binder is needed just for its type. Note that as an diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index ab195e87b1..335f86a549 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -1946,6 +1946,7 @@ simplAlts :: SimplEnv -> SimplM (OutExpr, OutId, [OutAlt]) -- Includes the continuation -- Like simplExpr, this just returns the simplified alternatives; -- it does not return an environment +-- The returned alternatives can be empty, none are possible simplAlts env scrut case_bndr alts cont' = -- pprTrace "simplAlts" (ppr alts $$ ppr (seTvSubst env)) $ diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 0833a7c7cf..ffaeac8af8 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -85,7 +85,7 @@ emitWanteds origin theta = mapM (emitWanted origin) theta emitWanted :: CtOrigin -> TcPredType -> TcM EvVar emitWanted origin pred = do { loc <- getCtLoc origin ; ev <- newWantedEvVar pred - ; emitFlat (mkNonCanonical ev (Wanted loc)) + ; emitFlat (mkNonCanonical (Wanted loc ev)) ; return ev } newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId) @@ -527,7 +527,7 @@ tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys) tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys tyVarsOfCt (CIPCan { cc_ip_ty = ty }) = tyVarsOfType ty tyVarsOfCt (CIrredEvCan { cc_ty = ty }) = tyVarsOfType ty -tyVarsOfCt (CNonCanonical { cc_id = ev }) = tyVarsOfEvVar ev +tyVarsOfCt (CNonCanonical { cc_flavor = fl }) = tyVarsOfType (ctFlavPred fl) tyVarsOfCDict :: Ct -> TcTyVarSet tyVarsOfCDict (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys @@ -563,19 +563,29 @@ tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet tidyCt :: TidyEnv -> Ct -> Ct -- Also converts it to non-canonical tidyCt env ct - = CNonCanonical { cc_id = tidyEvVar env (cc_id ct) - , cc_flavor = tidyFlavor env (cc_flavor ct) + = CNonCanonical { cc_flavor = tidy_flavor env (cc_flavor ct) , cc_depth = cc_depth ct } + where tidy_flavor :: TidyEnv -> CtFlavor -> CtFlavor + tidy_flavor env (Given { flav_gloc = gloc, flav_evar = evar }) + = Given { flav_gloc = tidyGivenLoc env gloc + , flav_evar = tidyEvVar env evar } + tidy_flavor env (Solved { flav_gloc = gloc + , flav_evar = evar }) + = Solved { flav_gloc = tidyGivenLoc env gloc + , flav_evar = tidyEvVar env evar } + tidy_flavor env (Wanted { flav_wloc = wloc + , flav_evar = evar }) + = Wanted { flav_wloc = wloc -- Interesting: no tidying needed? + , flav_evar = tidyEvVar env evar } + tidy_flavor env (Derived { flav_wloc = wloc, flav_der_pty = pty }) + = Derived { flav_wloc = wloc, flav_der_pty = tidyType env pty } tidyEvVar :: TidyEnv -> EvVar -> EvVar tidyEvVar env var = setVarType var (tidyType env (varType var)) -tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor -tidyFlavor env (Given loc gk) = Given (tidyGivenLoc env loc) gk -tidyFlavor _ fl = fl - tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc -tidyGivenLoc env (CtLoc skol span ctxt) = CtLoc (tidySkolemInfo env skol) span ctxt +tidyGivenLoc env (CtLoc skol span ctxt) + = CtLoc (tidySkolemInfo env skol) span ctxt tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty) @@ -595,13 +605,12 @@ substCt :: TvSubst -> Ct -> Ct -- Conservatively converts it to non-canonical: -- Postcondition: if the constraint does not get rewritten substCt subst ct - | ev <- cc_id ct, pty <- evVarPred (cc_id ct) + | pty <- ctPred ct , sty <- substTy subst pty = if sty `eqType` pty then ct { cc_flavor = substFlavor subst (cc_flavor ct) } else - CNonCanonical { cc_id = setVarType ev sty - , cc_flavor = substFlavor subst (cc_flavor ct) + CNonCanonical { cc_flavor = substFlavor subst (cc_flavor ct) , cc_depth = cc_depth ct } substWC :: TvSubst -> WantedConstraints -> WantedConstraints @@ -626,11 +635,24 @@ substEvVar :: TvSubst -> EvVar -> EvVar substEvVar subst var = setVarType var (substTy subst (varType var)) substFlavor :: TvSubst -> CtFlavor -> CtFlavor -substFlavor subst (Given loc gk) = Given (substGivenLoc subst loc) gk -substFlavor _ fl = fl +substFlavor subst (Given { flav_gloc = gloc, flav_evar = evar }) + = Given { flav_gloc = substGivenLoc subst gloc + , flav_evar = substEvVar subst evar } +substFlavor subst (Solved { flav_gloc = gloc, flav_evar = evar }) + = Solved { flav_gloc = substGivenLoc subst gloc + , flav_evar = substEvVar subst evar } + +substFlavor subst (Wanted { flav_wloc = wloc, flav_evar = evar }) + = Wanted { flav_wloc = wloc + , flav_evar = substEvVar subst evar } + +substFlavor subst (Derived { flav_wloc = wloc, flav_der_pty = pty }) + = Derived { flav_wloc = wloc + , flav_der_pty = substTy subst pty } substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc -substGivenLoc subst (CtLoc skol span ctxt) = CtLoc (substSkolemInfo subst skol) span ctxt +substGivenLoc subst (CtLoc skol span ctxt) + = CtLoc (substSkolemInfo subst skol) span ctxt substSkolemInfo :: TvSubst -> SkolemInfo -> SkolemInfo substSkolemInfo subst (SigSkol cx ty) = SigSkol cx (substTy subst ty) diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs index 5dfa05d60a..b24f76ce40 100644 --- a/compiler/typecheck/TcCanonical.lhs +++ b/compiler/typecheck/TcCanonical.lhs @@ -7,7 +7,7 @@ -- for details module TcCanonical( - canonicalize, + canonicalize, flatten, flattenMany, StopOrContinue (..) ) where @@ -26,9 +26,9 @@ import TypeRep import Name ( Name ) import Var import VarEnv -import Util( equalLength ) +-- import Util( equalLength ) import Outputable -import Control.Monad ( when, unless, zipWithM ) +import Control.Monad ( when, unless ) import MonadUtils import Control.Applicative ( (<|>) ) @@ -37,8 +37,10 @@ import VarSet import TcSMonad import FastString -import Data.Maybe ( isNothing ) -import Data.List ( zip4 ) +import TysWiredIn ( eqTyCon ) + +import Data.Maybe ( isJust, fromMaybe ) +-- import Data.List ( zip4 ) \end{code} @@ -169,53 +171,55 @@ EvBinds, so we are again good. -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ canonicalize :: Ct -> TcS StopOrContinue -canonicalize ct@(CNonCanonical { cc_id = ev, cc_flavor = fl, cc_depth = d }) +canonicalize ct@(CNonCanonical { cc_flavor = fl, cc_depth = d }) = do { traceTcS "canonicalize (non-canonical)" (ppr ct) ; {-# SCC "canEvVar" #-} - canEvVar ev (classifyPredType (evVarPred ev)) d fl } + canEvVar d fl (classifyPredType (ctPred ct)) } -canonicalize (CDictCan { cc_id = ev, cc_depth = d +canonicalize (CDictCan { cc_depth = d , cc_flavor = fl , cc_class = cls , cc_tyargs = xis }) = {-# SCC "canClass" #-} - canClass d fl ev cls xis -- Do not add any superclasses -canonicalize (CTyEqCan { cc_id = ev, cc_depth = d + canClass d fl cls xis -- Do not add any superclasses +canonicalize (CTyEqCan { cc_depth = d , cc_flavor = fl , cc_tyvar = tv , cc_rhs = xi }) = {-# SCC "canEqLeafTyVarLeftRec" #-} - canEqLeafTyVarLeftRec d fl ev tv xi + canEqLeafTyVarLeftRec d fl tv xi -canonicalize (CFunEqCan { cc_id = ev, cc_depth = d +canonicalize (CFunEqCan { cc_depth = d , cc_flavor = fl , cc_fun = fn , cc_tyargs = xis1 , cc_rhs = xi2 }) = {-# SCC "canEqLeafFunEqLeftRec" #-} - canEqLeafFunEqLeftRec d fl ev (fn,xis1) xi2 + canEqLeafFunEqLeftRec d fl (fn,xis1) xi2 -canonicalize (CIPCan { cc_id = ev, cc_depth = d +canonicalize (CIPCan { cc_depth = d , cc_flavor = fl , cc_ip_nm = nm , cc_ip_ty = xi }) - = canIP d fl ev nm xi -canonicalize (CIrredEvCan { cc_id = ev, cc_flavor = fl + = canIP d fl nm xi +canonicalize (CIrredEvCan { cc_flavor = fl , cc_depth = d , cc_ty = xi }) - = canIrred d fl ev xi + = canIrred d fl xi -canEvVar :: EvVar -> PredTree - -> SubGoalDepth -> CtFlavor -> TcS StopOrContinue +canEvVar :: SubGoalDepth + -> CtFlavor + -> PredTree + -> TcS StopOrContinue -- Called only for non-canonical EvVars -canEvVar ev pred_classifier d fl +canEvVar d fl pred_classifier = case pred_classifier of - ClassPred cls tys -> canClassNC d fl ev cls tys - EqPred ty1 ty2 -> canEqNC d fl ev ty1 ty2 - IPPred nm ty -> canIP d fl ev nm ty - IrredPred ev_ty -> canIrred d fl ev ev_ty - TuplePred tys -> canTuple d fl ev tys + ClassPred cls tys -> canClassNC d fl cls tys + EqPred ty1 ty2 -> canEqNC d fl ty1 ty2 + IPPred nm ty -> canIP d fl nm ty + IrredPred ev_ty -> canIrred d fl ev_ty + TuplePred tys -> canTuple d fl tys \end{code} @@ -227,24 +231,15 @@ canEvVar ev pred_classifier d fl \begin{code} canTuple :: SubGoalDepth -- Depth - -> CtFlavor -> EvVar -> [PredType] -> TcS StopOrContinue -canTuple d fl ev tys - = do { traceTcS "can_pred" (text "TuplePred!") - ; evs <- zipWithM can_pred_tup_one tys [0..] - ; if (isWanted fl) then - do {_unused_fl <- setEvBind ev (EvTupleMk evs) fl - ; return Stop } - else return Stop } - where - can_pred_tup_one ty n - = do { evc <- newEvVar fl ty - ; let ev' = evc_the_evvar evc - ; fl' <- if isGivenOrSolved fl then - setEvBind ev' (EvTupleSel ev n) fl - else return fl - ; when (isNewEvVar evc) $ - addToWork (canEvVar ev' (classifyPredType (evVarPred ev')) d fl') - ; return ev' } + -> CtFlavor -> [PredType] -> TcS StopOrContinue +canTuple d fl tys + = do { traceTcS "can_pred" (text "TuplePred!") + ; let xcomp = EvTupleMk + xdecomp x = zipWith (\_ i -> EvTupleSel x i) tys [0..] + ; xCtFlavor fl tys (XEvTerm xcomp xdecomp) what_next } + where what_next fls = mapM_ add_to_work fls >> return Stop + add_to_work fl = addToWork $ canEvVar d fl (classifyPredType (ctFlavPred fl)) + \end{code} @@ -256,33 +251,22 @@ canTuple d fl ev tys \begin{code} canIP :: SubGoalDepth -- Depth - -> CtFlavor -> EvVar + -> CtFlavor -> IPName Name -> Type -> TcS StopOrContinue -- Precondition: EvVar is implicit parameter evidence -canIP d fl v nm ty +canIP d fl nm ty = -- Note [Canonical implicit parameter constraints] explains why it's -- possible in principle to not flatten, but since flattening applies -- the inert substitution we choose to flatten anyway. do { (xi,co) <- flatten d fl (mkIPPred nm ty) - ; let no_flattening = isTcReflCo co - ; if no_flattening then - let IPPred _ xi_in = classifyPredType xi - in continueWith $ CIPCan { cc_id = v, cc_flavor = fl - , cc_ip_nm = nm, cc_ip_ty = xi_in - , cc_depth = d } - else do { evc <- newEvVar fl xi - ; let v_new = evc_the_evvar evc - IPPred _ ip_xi = classifyPredType xi - ; fl_new <- case fl of - Wanted {} -> setEvBind v (EvCast v_new co) fl - Given {} -> setEvBind v_new (EvCast v (mkTcSymCo co)) fl - Derived {} -> return fl - ; if isNewEvVar evc then - continueWith $ CIPCan { cc_id = v_new - , cc_flavor = fl_new, cc_ip_nm = nm - , cc_ip_ty = ip_xi - , cc_depth = d } - else return Stop } } + ; mb <- rewriteCtFlavor fl xi co + ; case mb of + Just new_fl -> let IPPred _ xi_in = classifyPredType xi + in continueWith $ CIPCan { cc_flavor = new_fl + , cc_ip_nm = nm, cc_ip_ty = xi_in + , cc_depth = d } + Nothing -> return Stop } + \end{code} Note [Canonical implicit parameter constraints] @@ -305,7 +289,7 @@ flattened in the first place to facilitate comparing them.) \begin{code} canClass, canClassNC :: SubGoalDepth -- Depth - -> CtFlavor -> EvVar + -> CtFlavor -> Class -> [Type] -> TcS StopOrContinue -- Precondition: EvVar is class evidence @@ -314,44 +298,34 @@ canClass, canClassNC -- for already-canonical class constraints (but which might have -- been subsituted or somthing), and hence do not need superclasses -canClassNC d fl ev cls tys - = canClass d fl ev cls tys +canClassNC d fl cls tys + = canClass d fl cls tys `andWhenContinue` emitSuperclasses -canClass d fl v cls tys +canClass d fl cls tys = do { -- sctx <- getTcSContext ; (xis, cos) <- flattenMany d fl tys ; let co = mkTcTyConAppCo (classTyCon cls) cos xi = mkClassPred cls xis + + ; mb <- rewriteCtFlavor fl xi co - ; let no_flattening = all isTcReflCo cos - -- No flattening, continue with canonical - ; if no_flattening then - continueWith $ CDictCan { cc_id = v, cc_flavor = fl - , cc_tyargs = xis, cc_class = cls - , cc_depth = d } - -- Flattening happened - else do { evc <- newEvVar fl xi - ; let v_new = evc_the_evvar evc - ; fl_new <- case fl of - Wanted {} -> setEvBind v (EvCast v_new co) fl - Given {} -> setEvBind v_new (EvCast v (mkTcSymCo co)) fl - Derived {} -> return fl - -- Continue only if flat constraint is new - ; if isNewEvVar evc then - continueWith $ CDictCan { cc_id = v_new, cc_flavor = fl_new - , cc_tyargs = xis, cc_class = cls - , cc_depth = d } - else return Stop } } + ; case mb of + Just new_fl -> + let (ClassPred cls xis_for_dict) = classifyPredType (ctFlavPred new_fl) + in continueWith $ + CDictCan { cc_flavor = new_fl + , cc_tyargs = xis_for_dict, cc_class = cls, cc_depth = d } + Nothing -> return Stop } emitSuperclasses :: Ct -> TcS StopOrContinue -emitSuperclasses ct@(CDictCan { cc_id = v_new, cc_depth = d, cc_flavor = fl +emitSuperclasses ct@(CDictCan { cc_depth = d, cc_flavor = fl , cc_tyargs = xis_new, cc_class = cls }) -- Add superclasses of this one here, See Note [Adding superclasses]. -- But only if we are not simplifying the LHS of a rule. = do { sctxt <- getTcSContext ; unless (simplEqsOnly sctxt) $ - newSCWorkFromFlavored d v_new fl cls xis_new + newSCWorkFromFlavored d fl cls xis_new -- Arguably we should "seq" the coercions if they are derived, -- as we do below for emit_kind_constraint, to allow errors in -- superclasses to be executed if deferred to runtime! @@ -425,52 +399,38 @@ happen. \begin{code} newSCWorkFromFlavored :: SubGoalDepth -- Depth - -> EvVar -> CtFlavor -> Class -> [Xi] -> TcS () + -> CtFlavor -> Class -> [Xi] -> TcS () -- Returns superclasses, see Note [Adding superclasses] -newSCWorkFromFlavored d ev flavor cls xis +newSCWorkFromFlavored d flavor cls xis | isDerived flavor = return () -- Deriveds don't yield more superclasses because we will -- add them transitively in the case of wanteds. - - | Just gk <- isGiven_maybe flavor - = case gk of - GivenOrig -> do { let sc_theta = immSuperClasses cls xis - ; sc_vars <- mapM (newEvVar flavor) sc_theta - ; sc_cts <- zipWithM (\scv ev_trm -> - do { let sc_evvar = evc_the_evvar scv - ; _unused_fl <- setEvBind sc_evvar ev_trm flavor - -- unused because it's the same - ; return $ - CNonCanonical { cc_id = sc_evvar - , cc_flavor = flavor - , cc_depth = d }}) - sc_vars [EvSuperClass ev n | n <- [0..]] - -- Emit now, canonicalize later in a lazier fashion - ; traceTcS "newSCWorkFromFlavored" $ - text "Emitting superclass work:" <+> ppr sc_cts - ; updWorkListTcS $ appendWorkListCt sc_cts } - GivenSolved {} -> return () - -- Seems very dangerous to add the superclasses for dictionaries that may be - -- partially solved because we may end up with evidence loops. + | isSolved flavor + = return () + + | isGiven flavor + = do { let sc_theta = immSuperClasses cls xis + xev = XEvTerm { ev_comp = panic "Can't compose for given!" + , ev_decomp = \x->zipWith (\_ i->EvSuperClass x i) sc_theta [0..] } + ; xCtFlavor flavor sc_theta xev (emit_sc_flavs d) } | isEmptyVarSet (tyVarsOfTypes xis) - = return () -- Wanteds with no variables yield no deriveds. + = return () -- Wanteds/Derived with no variables yield no deriveds. -- See Note [Improvement from Ground Wanteds] - | otherwise -- Wanted case, just add those SC that can lead to improvement. + | otherwise -- Wanted/Derived case, just add those SC that can lead to improvement. = do { let sc_rec_theta = transSuperClasses cls xis - impr_theta = filter is_improvement_pty sc_rec_theta - Wanted wloc = flavor - ; sc_cts <- mapM (\pty -> do { scv <- newEvVar (Derived wloc) pty - ; if isNewEvVar scv then - return [ CNonCanonical { cc_id = evc_the_evvar scv - , cc_flavor = Derived wloc - , cc_depth = d } ] - else return [] } - ) impr_theta - ; let sc_cts_flat = concat sc_cts - ; traceTcS "newSCWorkFromFlavored" (text "Emitting superclass work:" <+> ppr sc_cts_flat) - ; updWorkListTcS $ appendWorkListCt sc_cts_flat } + impr_theta = filter is_improvement_pty sc_rec_theta + xev = panic "Derived's are not supposed to transform evidence!" + ; xCtFlavor (Derived (flav_wloc flavor) (ctFlavPred flavor)) impr_theta xev $ + emit_sc_flavs d } + +emit_sc_flavs :: SubGoalDepth -> [CtFlavor] -> TcS () +emit_sc_flavs d fls + = do { traceTcS "newSCWorkFromFlavored" $ + text "Emitting superclass work:" <+> ppr sc_cts + ; updWorkListTcS $ appendWorkListCt sc_cts } + where sc_cts = map (\fl -> CNonCanonical { cc_flavor = fl, cc_depth = d }) fls is_improvement_pty :: PredType -> Bool -- Either it's an equality, or has some functional dependency @@ -494,34 +454,24 @@ is_improvement_pty ty = go (classifyPredType ty) \begin{code} canIrred :: SubGoalDepth -- Depth - -> CtFlavor -> EvVar -> TcType -> TcS StopOrContinue + -> CtFlavor -> TcType -> TcS StopOrContinue -- Precondition: ty not a tuple and no other evidence form -canIrred d fl v ty +canIrred d fl ty = do { traceTcS "can_pred" (text "IrredPred = " <+> ppr ty) ; (xi,co) <- flatten d fl ty -- co :: xi ~ ty ; let no_flattening = xi `eqType` ty -- In this particular case it is not safe to -- say 'isTcReflCo' because the new constraint may -- be reducible! - ; if no_flattening then - continueWith $ CIrredEvCan { cc_id = v, cc_flavor = fl - , cc_ty = xi, cc_depth = d } - else do - { -- Flattening consults and applies family equations from the - -- inerts, so 'xi' may become reducible. So just recursively - -- canonicalise the resulting evidence variable - evc <- newEvVar fl xi - ; let v' = evc_the_evvar evc - ; fl' <- case fl of - Wanted {} -> setEvBind v (EvCast v' co) fl - Given {} -> setEvBind v' (EvCast v (mkTcSymCo co)) fl - Derived {} -> return fl - - ; if isNewEvVar evc then - canEvVar v' (classifyPredType (evVarPred v')) d fl' - else - return Stop } - } + ; mb <- rewriteCtFlavor fl xi co + ; case mb of + Just new_fl + | no_flattening + -> continueWith $ + CIrredEvCan { cc_flavor = new_fl, cc_ty = xi, cc_depth = d } + | otherwise + -> canEvVar d new_fl (classifyPredType (ctFlavPred new_fl)) + Nothing -> return Stop } \end{code} @@ -577,6 +527,7 @@ flattenMany :: SubGoalDepth -- Depth -> CtFlavor -> [Type] -> TcS ([Xi], [TcCoercion]) -- Coercions :: Xi ~ Type -- Returns True iff (no flattening happened) +-- NB: The EvVar inside the flavor is unused, we merely want Given/Solved/Derived/Wanted info flattenMany d ctxt tys = -- pprTrace "flattenMany" empty $ go tys @@ -629,53 +580,69 @@ flatten d fl (TyConApp tc tys) -- in which case the remaining arguments should -- be dealt with by AppTys fam_ty = mkTyConApp tc xi_args + ; (ret_co, rhs_xi, ct) <- - do { is_cached <- getCachedFlatEq tc xi_args fl Any - ; case is_cached of - Just (rhs_xi,ret_eq) -> - do { traceTcS "is_cached!" $ ppr ret_eq - ; return (ret_eq, rhs_xi, []) } - Nothing - | isGivenOrSolved fl -> - do { rhs_xi_var <- newFlattenSkolemTy fam_ty - ; (fl',eqv) - <- newGivenEqVar fl fam_ty rhs_xi_var (mkTcReflCo fam_ty) - ; let ct = CFunEqCan { cc_id = eqv - , cc_flavor = fl' -- Given - , cc_fun = tc - , cc_tyargs = xi_args - , cc_rhs = rhs_xi_var - , cc_depth = d } - -- Update the flat cache: just an optimisation! - ; updateFlatCache eqv fl' tc xi_args rhs_xi_var WhileFlattening - ; return (mkTcCoVarCo eqv, rhs_xi_var, [ct]) } - | otherwise -> - -- Derived or Wanted: make a new /unification/ flatten variable - do { rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty) - ; let wanted_flavor = mkWantedFlavor fl - ; evc <- newEqVar wanted_flavor fam_ty rhs_xi_var - ; let eqv = evc_the_evvar evc -- Not going to be cached - ct = CFunEqCan { cc_id = eqv - , cc_flavor = wanted_flavor - -- Always Wanted, not Derived - , cc_fun = tc - , cc_tyargs = xi_args - , cc_rhs = rhs_xi_var - , cc_depth = d } + do { flat_cache <- getFlatCache + ; case lookupTM fam_ty flat_cache of + Just ct + | cc_flavor ct `canRewrite` fl + -> -- You may think that we can just return (cc_rhs ct) but not so. + -- return (mkTcCoVarCo (ctId ct), cc_rhs ct, []) + -- The cached constraint resides in the cache so we have to flatten + -- the rhs to make sure we have applied any inert substitution to it. + -- Alternatively we could be applying the inert substitution to the + -- cache as well when we interact an equality with the inert. + -- The design choice is: do we keep the flat cache rewritten or not? + -- For now I say we don't keep it fully rewritten. + do { traceTcS "flatten/flat-cache hit" $ ppr ct + ; let rhs_xi = cc_rhs ct + ; (flat_rhs_xi,co) <- flatten (cc_depth ct) (cc_flavor ct) rhs_xi + ; let final_co = mkTcCoVarCo (ctId ct) `mkTcTransCo` (mkTcSymCo co) + ; return (final_co, flat_rhs_xi,[]) } + + _ | isGivenOrSolved fl -- Given or Solved: make new flatten skolem + -> do { traceTcS "flatten/flat-cache miss" $ empty + ; rhs_xi_var <- newFlattenSkolemTy fam_ty + ; mg <- newGivenEvVar (mkTcEqPred fam_ty rhs_xi_var) + (EvCoercion (mkTcReflCo fam_ty)) + ; case mg of + Fresh eqv -> + do { let new_fl = Given (flav_gloc fl) eqv + ct = CFunEqCan { cc_flavor = new_fl + , cc_fun = tc + , cc_tyargs = xi_args + , cc_rhs = rhs_xi_var + , cc_depth = d } + -- Update the flat cache + ; updFlatCache ct + ; return (mkTcCoVarCo eqv, rhs_xi_var, [ct]) } + Cached {} -> panic "flatten TyConApp, var must be fresh!" } + | otherwise -- Wanted or Derived: make new unification variable + -> do { traceTcS "flatten/flat-cache miss" $ empty + ; rhs_xi_var <- newFlexiTcSTy (typeKind fam_ty) + ; mw <- newWantedEvVar (mkTcEqPred fam_ty rhs_xi_var) + ; case mw of + Fresh eqv -> + do { let new_fl = Wanted (flav_wloc fl) eqv + ct = CFunEqCan { cc_flavor = new_fl + , cc_fun = tc + , cc_tyargs = xi_args + , cc_rhs = rhs_xi_var + , cc_depth = d } -- Update the flat cache: just an optimisation! - ; updateFlatCache eqv fl tc xi_args rhs_xi_var WhileFlattening - ; return (mkTcCoVarCo eqv, rhs_xi_var, [ct]) } } - - -- Emit the flat constraints + ; updFlatCache ct + ; return (mkTcCoVarCo eqv, rhs_xi_var, [ct]) } + Cached {} -> panic "flatten TyConApp, var must be fresh!" } + } + -- Emit the flat constraints ; updWorkListTcS $ appendWorkListEqs ct - ; let (cos_args, cos_rest) = splitAt (tyConArity tc) cos - ; return ( mkAppTys rhs_xi xi_rest -- NB mkAppTys: rhs_xi might not be a type variable - -- cf Trac #5655 - , mkTcAppCos (mkTcSymCo ret_co `mkTcTransCo` mkTcTyConAppCo tc cos_args) - cos_rest - ) } - + ; return ( mkAppTys rhs_xi xi_rest -- NB mkAppTys: rhs_xi might not be a type variable + -- cf Trac #5655 + , mkTcAppCos (mkTcSymCo ret_co `mkTcTransCo` mkTcTyConAppCo tc cos_args) $ + cos_rest + ) + } flatten d ctxt ty@(ForAllTy {}) -- We allow for-alls when, but only when, no type function @@ -685,6 +652,12 @@ flatten d ctxt ty@(ForAllTy {}) ; (rho', co) <- flatten d ctxt rho ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) } +-- DV: Simon and I have a better plan here related to #T5934 and that plan is to +-- first normalize completely the rho type with respect to the top-level instances, +-- and then flatten out only the family equations that do not mention the quantified +-- variable. Keep the rest as they are. There is no worry that we don't normalize with +-- the givens because the givens can't possibly mention the quantified variable anyway! + where under_families tvs rho = go (mkVarSet tvs) rho where go _bound (TyVarTy _tv) = False @@ -712,15 +685,18 @@ flattenTyVar d ctxt tv ; let ty = mkTyVarTy (setVarType tv new_knd) ; return (ty, mkTcReflCo ty) } -- NB recursive call. - -- Why? See Note [Non-idempotent inert substitution] - -- Actually, I think applying the substition just twice will suffice + -- Why? Because inert subst. non-idempotent, Note [Detailed InertCans Invariants] + -- In fact, because of flavors, it couldn't possibly be idempotent, + -- this is explained in Note [Non-idempotent inert substitution] Just (co,ty) -> do { (ty_final,co') <- flatten d ctxt ty ; return (ty_final, co' `mkTcTransCo` mkTcSymCo co) } } where tv_eq_subst subst tv - | Just (ct,co) <- lookupVarEnv subst tv + | Just ct <- lookupVarEnv subst tv , cc_flavor ct `canRewrite` ctxt - = Just (co,cc_rhs ct) + = Just (mkTcCoVarCo (ctId ct),cc_rhs ct) + -- NB: even if ct is Derived we are not going to + -- touch the actual coercion so we are fine. | otherwise = Nothing \end{code} @@ -731,7 +707,7 @@ The inert substitution is not idempotent in the broad sense. It is only idempote that it cannot rewrite the RHS of other inert equalities any further. An example of such an inert substitution is: - [Ś] g1 : ta8 ~ ta4 + [G] g1 : ta8 ~ ta4 [W] g2 : ta4 ~ a5Fj Observe that the wanted cannot rewrite the solved goal, despite the fact that ta4 appears on @@ -750,36 +726,9 @@ should). For this reason, when we reach to flatten a type variable, we flatten it recursively, so that we can make sure that the inert substitution /is/ fully applied. -This insufficient rewriting was the reason for #5668. +Insufficient (non-recursive) rewriting was the reason for #5668. \begin{code} -getCachedFlatEq :: TyCon -> [Xi] -> CtFlavor - -> FlatEqOrigin - -> TcS (Maybe (Xi, TcCoercion)) --- Returns a coercion between (TyConApp tc xi_args ~ xi) if such an inert item exists --- But also applies the substitution to the item via calling flatten recursively -getCachedFlatEq tc xi_args fl feq_origin - = do { let pty = mkTyConApp tc xi_args - ; traceTcS "getCachedFlatEq" $ ppr (mkTyConApp tc xi_args) - ; flat_cache <- getTcSEvVarFlatCache - ; inerts <- getTcSInerts - ; case lookupFunEq pty fl (inert_funeqs inerts) of - Nothing - -> lookup_in_flat_cache pty flat_cache - res -> return res } - where lookup_in_flat_cache pty flat_cache - = case lookupTM pty flat_cache of - Just (co',(xi',fl',when_generated)) -- ev' :: (TyConApp tc xi_args) ~ xi' - | fl' `canRewrite` fl - , feq_origin `origin_matches` when_generated - -> do { traceTcS "getCachedFlatEq" $ text "success!" - ; (xi'',co) <- flatten 0 fl' xi' -- co :: xi'' ~ xi' - -- The only purpose of this flattening is to apply the - -- inert substitution (since everything in the flat cache - -- by construction will have a family-free RHS. - ; return $ Just (xi'', co' `mkTcTransCo` (mkTcSymCo co)) } - _ -> do { traceTcS "getCachedFlatEq" $ text "failure!" <+> pprEvVarCache flat_cache - ; return Nothing } ----------------- addToWork :: TcS StopOrContinue -> TcS () @@ -797,108 +746,96 @@ addToWork tcs_action = tcs_action >>= stop_or_emit %************************************************************************ \begin{code} -canEqEvVarsCreated :: SubGoalDepth - -> [CtFlavor] -> [EvVarCreated] -> [Type] -> [Type] - -> TcS StopOrContinue -canEqEvVarsCreated d fls evcs tys1 tys2 - = ASSERT( equalLength fls evcs && equalLength fls tys1 && equalLength fls tys2 ) - case filter is_new (zip4 fls evcs tys1 tys2) of - [] -> return Stop - (quad : quads) -> do { mapM_ (addToWork . do_quad) quads - ; do_quad quad } - -- For the new EvVars, add all but one to the work list - -- and return the first (if any) for futher processing - where - is_new (_, evc, _, _) = isNewEvVar evc - do_quad (fl, evc, ty1, ty2) = canEqNC d fl (evc_the_evvar evc) ty1 ty2 - -- Note the "NC": these are fresh equalities so we must be - -- careful to add their kind constraints +canEqEvVarsCreated :: SubGoalDepth + -> [CtFlavor] -> TcS StopOrContinue +canEqEvVarsCreated _d [] = return Stop +canEqEvVarsCreated d (quad:quads) + = mapM_ (addToWork . do_quad) quads >> do_quad quad + -- Add all but one to the work list + -- and return the first (if any) for futher processing + where do_quad fl = let EqPred ty1 ty2 = classifyPredType $ ctFlavPred fl + in canEqNC d fl ty1 ty2 + -- Note the "NC": these are fresh equalities so we must be + -- careful to add their kind constraints ------------------------- canEqNC, canEq :: SubGoalDepth - -> CtFlavor -> EqVar + -> CtFlavor -> Type -> Type -> TcS StopOrContinue -canEqNC d fl ev ty1 ty2 - = canEq d fl ev ty1 ty2 +canEqNC d fl ty1 ty2 + = canEq d fl ty1 ty2 `andWhenContinue` emitKindConstraint -canEq _d fl eqv ty1 ty2 +canEq _d fl ty1 ty2 | eqType ty1 ty2 -- Dealing with equality here avoids -- later spurious occurs checks for a~a - = do { when (isWanted fl) $ - do { _ <- setEqBind eqv (mkTcReflCo ty1) fl; return () } - ; return Stop } + = if isWanted fl then + setEvBind (flav_evar fl) (EvCoercion (mkTcReflCo ty1)) >> return Stop + else + return Stop -- If one side is a variable, orient and flatten, -- WITHOUT expanding type synonyms, so that we tend to -- substitute a ~ Age rather than a ~ Int when @type Age = Int@ -canEq d fl eqv ty1@(TyVarTy {}) ty2 - = canEqLeaf d fl eqv ty1 ty2 -canEq d fl eqv ty1 ty2@(TyVarTy {}) - = canEqLeaf d fl eqv ty1 ty2 +canEq d fl ty1@(TyVarTy {}) ty2 + = canEqLeaf d fl ty1 ty2 +canEq d fl ty1 ty2@(TyVarTy {}) + = canEqLeaf d fl ty1 ty2 -- See Note [Naked given applications] -canEq d fl eqv ty1 ty2 - | Just ty1' <- tcView ty1 = canEq d fl eqv ty1' ty2 - | Just ty2' <- tcView ty2 = canEq d fl eqv ty1 ty2' +canEq d fl ty1 ty2 + | Just ty1' <- tcView ty1 = canEq d fl ty1' ty2 + | Just ty2' <- tcView ty2 = canEq d fl ty1 ty2' -canEq d fl eqv ty1@(TyConApp fn tys) ty2 +canEq d fl ty1@(TyConApp fn tys) ty2 | isSynFamilyTyCon fn, length tys == tyConArity fn - = canEqLeaf d fl eqv ty1 ty2 -canEq d fl eqv ty1 ty2@(TyConApp fn tys) + = canEqLeaf d fl ty1 ty2 +canEq d fl ty1 ty2@(TyConApp fn tys) | isSynFamilyTyCon fn, length tys == tyConArity fn - = canEqLeaf d fl eqv ty1 ty2 + = canEqLeaf d fl ty1 ty2 -canEq d fl eqv ty1 ty2 +canEq d fl ty1 ty2 | Just (tc1,tys1) <- tcSplitTyConApp_maybe ty1 , Just (tc2,tys2) <- tcSplitTyConApp_maybe ty2 , isDecomposableTyCon tc1 && isDecomposableTyCon tc2 = -- Generate equalities for each of the corresponding arguments if (tc1 /= tc2 || length tys1 /= length tys2) -- Fail straight away for better error messages - then canEqFailure d fl eqv - else do - { argeqvs <- zipWithM (newEqVar fl) tys1 tys2 - - ; fls <- case fl of - Wanted {} -> - do { _ <- setEqBind eqv - (mkTcTyConAppCo tc1 (map (mkTcCoVarCo . evc_the_evvar) argeqvs)) fl - ; return (map (\_ -> fl) argeqvs) } - Given {} -> - let do_one argeqv n = setEqBind (evc_the_evvar argeqv) - (mkTcNthCo n (mkTcCoVarCo eqv)) fl - in zipWithM do_one argeqvs [0..] - Derived {} -> return (map (\_ -> fl) argeqvs) - - ; canEqEvVarsCreated d fls argeqvs tys1 tys2 } + then canEqFailure d fl + else + let xcomp xs = EvCoercion (mkTcTyConAppCo tc1 (map mkTcCoVarCo xs)) + xdecomp x = zipWith (\_ i -> EvCoercion $ mkTcNthCo i (mkTcCoVarCo x)) tys1 [0..] + xev = XEvTerm xcomp xdecomp + in xCtFlavor fl (zipWith mkTcEqPred tys1 tys2) xev (canEqEvVarsCreated d) + -- See Note [Equality between type applications] -- Note [Care with type applications] in TcUnify -canEq d fl eqv ty1 ty2 -- e.g. F a b ~ Maybe c +canEq d fl ty1 ty2 -- e.g. F a b ~ Maybe c -- where F has arity 1 | Just (s1,t1) <- tcSplitAppTy_maybe ty1 , Just (s2,t2) <- tcSplitAppTy_maybe ty2 - = canEqAppTy d fl eqv s1 t1 s2 t2 + = canEqAppTy d fl s1 t1 s2 t2 -canEq d fl eqv s1@(ForAllTy {}) s2@(ForAllTy {}) +canEq d fl s1@(ForAllTy {}) s2@(ForAllTy {}) | tcIsForAllTy s1, tcIsForAllTy s2, Wanted {} <- fl - = canEqFailure d fl eqv + = canEqFailure d fl | otherwise = do { traceTcS "Ommitting decomposition of given polytype equality" (pprEq s1 s2) ; return Stop } -canEq d fl eqv _ _ = canEqFailure d fl eqv +canEq d fl _ _ = canEqFailure d fl ------------------------ -- Type application canEqAppTy :: SubGoalDepth - -> CtFlavor -> EqVar -> Type -> Type -> Type -> Type + -> CtFlavor + -> Type -> Type -> Type -> Type -> TcS StopOrContinue -canEqAppTy d fl eqv s1 t1 s2 t2 +canEqAppTy d fl s1 t1 s2 t2 = ASSERT( not (isKind t1) && not (isKind t2) ) if isGivenOrSolved fl then do { traceTcS "canEq (app case)" $ @@ -907,84 +844,76 @@ canEqAppTy d fl eqv s1 t1 s2 t2 -- We cannot decompose given applications -- because we no longer have 'left' and 'right' ; return Stop } - else - do { evc1 <- newEqVar fl s1 s2 - ; evc2 <- newEqVar fl t1 t2 - ; let eqv1 = evc_the_evvar evc1 - eqv2 = evc_the_evvar evc2 - - ; when (isWanted fl) $ - do { _ <- setEqBind eqv (mkTcAppCo (mkTcCoVarCo eqv1) (mkTcCoVarCo eqv2)) fl - ; return () } - - ; canEqEvVarsCreated d [fl,fl] [evc1,evc2] [s1,t1] [s2,t2] } + else + let xevcomp [x,y] = EvCoercion (mkTcAppCo (mkTcCoVarCo x) (mkTcCoVarCo y)) + xevcomp _ = error "canEqAppTy: can't happen" -- Can't happen + xev = XEvTerm { ev_comp = xevcomp + , ev_decomp = error "canEqAppTy: can't happen" } + in xCtFlavor fl [mkTcEqPred s1 s2, mkTcEqPred t1 t2] xev $ + canEqEvVarsCreated d ------------------------- -canEqFailure :: SubGoalDepth - -> CtFlavor -> EvVar -> TcS StopOrContinue -canEqFailure d fl eqv - = do { when (isWanted fl) (delCachedEvVar eqv fl) - -- See Note [Combining insoluble constraints] - ; emitFrozenError fl eqv d - ; return Stop } +canEqFailure :: SubGoalDepth -> CtFlavor -> TcS StopOrContinue +canEqFailure d fl = emitFrozenError fl d >> return Stop ------------------------ emitKindConstraint :: Ct -> TcS StopOrContinue emitKindConstraint ct = case ct of - CTyEqCan { cc_id = ev, cc_depth = d + CTyEqCan { cc_depth = d , cc_flavor = fl, cc_tyvar = tv , cc_rhs = ty } - -> emit_kind_constraint ev d fl (mkTyVarTy tv) ty + -> emit_kind_constraint d fl (mkTyVarTy tv) ty - CFunEqCan { cc_id = ev, cc_depth = d + CFunEqCan { cc_depth = d , cc_flavor = fl , cc_fun = fn, cc_tyargs = xis1 , cc_rhs = xi2 } - -> emit_kind_constraint ev d fl (mkTyConApp fn xis1) xi2 + -> emit_kind_constraint d fl (mkTyConApp fn xis1) xi2 - _ -> continueWith ct + _ -> continueWith ct where - emit_kind_constraint eqv d fl ty1 ty2 + emit_kind_constraint d fl ty1 ty2 | compatKind k1 k2 -- True when ty1,ty2 are themselves kinds, = continueWith ct -- because then k1, k2 are BOX | otherwise = ASSERT( isKind k1 && isKind k2 ) - do { keqv <- forceNewEvVar kind_co_fl (mkNakedEqPred superKind k1 k2) - ; eqv' <- forceNewEvVar fl (mkTcEqPred ty1 ty2) - ; _fl <- case fl of - Wanted {}-> setEvBind eqv - (mkEvKindCast eqv' (mkTcCoVarCo keqv)) fl - Given {} -> setEvBind eqv' - (mkEvKindCast eqv (mkTcCoVarCo keqv)) fl - Derived {} -> return fl - - ; traceTcS "Emitting kind constraint" $ - vcat [ ppr keqv <+> dcolon <+> ppr (mkEqPred k1 k2) - , ppr eqv, ppr eqv' ] - ; addToWork (canEq d kind_co_fl keqv k1 k2) -- Emit kind equality - ; continueWith (ct { cc_id = eqv' }) } + do { kev <- + do { mw <- newWantedEvVar (mkNakedEqPred superKind k1 k2) + ; case mw of + Cached x -> return x + Fresh x -> addToWork (canEq d (kind_co_fl x) k1 k2) >> return x } + ; let xcomp [x] = mkEvKindCast x (mkTcCoVarCo kev) + xcomp _ = panic "emit_kind_constraint:can't happen" + xdecomp x = [mkEvKindCast x (mkTcCoVarCo kev)] + xev = XEvTerm xcomp xdecomp + in xCtFlavor_cache False fl [mkTcEqPred ty1 ty2] xev what_next } + -- Important: Do not cache original as Solved since we are supposed to + -- solve /exactly/ the same constraint later! Example: + -- (alpha :: kappa0) + -- (T :: *) + -- Equality is: (alpha ~ T), so we will emitConstraint (kappa0 ~ *) but + -- we don't want to say that (alpha ~ T) is now Solved! where + what_next [new_fl] = continueWith (ct { cc_flavor = new_fl }) + what_next _ = return Stop + k1 = typeKind ty1 k2 = typeKind ty2 ctxt = mkKindErrorCtxtTcS ty1 k1 ty2 k2 -- Always create a Wanted kind equality even if -- you are decomposing a given constraint. - -- NB: DV finds this reasonable for now. Maybe we - -- have to revisit. - kind_co_fl - | Given (CtLoc _sk_info src_span err_ctxt) _ <- fl - = let orig = TypeEqOrigin (UnifyOrigin ty1 ty2) + -- NB: DV finds this reasonable for now. Maybe we have to revisit. + kind_co_fl x + | isGivenOrSolved fl + = let (CtLoc _sk_info src_span err_ctxt) = flav_gloc fl + orig = TypeEqOrigin (UnifyOrigin ty1 ty2) ctloc = pushErrCtxtSameOrigin ctxt $ CtLoc orig src_span err_ctxt - in Wanted ctloc - | Wanted ctloc <- fl - = Wanted (pushErrCtxtSameOrigin ctxt ctloc) - | Derived ctloc <- fl - = Derived (pushErrCtxtSameOrigin ctxt ctloc) + in Wanted ctloc x | otherwise - = panic "do_emit_kind_constraint: non-CtLoc inside!" + = Wanted (pushErrCtxtSameOrigin ctxt (flav_wloc fl)) x + \end{code} Note [Combining insoluble constraints] @@ -1134,13 +1063,6 @@ data TypeClassifier | FunCls TyCon [Type] -- ^ Type function, exactly saturated | OtherCls TcType -- ^ Neither of the above -{- Useless these days! -unClassify :: TypeClassifier -> TcType -unClassify (VarCls tv) = TyVarTy tv -unClassify (FskCls tv) = TyVarTy tv -unClassify (FunCls fn tys) = TyConApp fn tys -unClassify (OtherCls ty) = ty --} classify :: TcType -> TypeClassifier @@ -1196,7 +1118,7 @@ reOrient _fl (FskCls {}) (OtherCls {}) = False ------------------ canEqLeaf :: SubGoalDepth -- Depth - -> CtFlavor -> EqVar + -> CtFlavor -> Type -> Type -> TcS StopOrContinue -- Canonicalizing "leaf" equality constraints which cannot be @@ -1206,245 +1128,150 @@ canEqLeaf :: SubGoalDepth -- Depth -- Preconditions: -- * one of the two arguments is variable or family applications -- * the two types are not equal (looking through synonyms) -canEqLeaf d fl eqv s1 s2 +canEqLeaf d fl s1 s2 | cls1 `re_orient` cls2 - = do { traceTcS "canEqLeaf (reorienting)" $ ppr eqv <+> dcolon <+> pprEq s1 s2 - ; delCachedEvVar eqv fl - ; evc <- newEqVar fl s2 s1 - ; let eqv' = evc_the_evvar evc - ; fl' <- case fl of - Wanted {} -> setEqBind eqv (mkTcSymCo (mkTcCoVarCo eqv')) fl - Given {} -> setEqBind eqv' (mkTcSymCo (mkTcCoVarCo eqv)) fl - Derived {} -> return fl - ; if isNewEvVar evc then - do { canEqLeafOriented d fl' eqv' s2 s1 } - else return Stop - } + = do { traceTcS "canEqLeaf (reorienting)" $ ppr fl <+> dcolon <+> pprEq s1 s2 + ; let xcomp [x] = EvCoercion (mkTcSymCo (mkTcCoVarCo x)) + xcomp _ = panic "canEqLeaf: can't happen" + xdecomp x = [EvCoercion (mkTcSymCo (mkTcCoVarCo x))] + xev = XEvTerm xcomp xdecomp + what_next [fl] = canEqLeafOriented d fl s2 s1 + what_next _ = return Stop + ; xCtFlavor fl [mkTcEqPred s2 s1] xev what_next } | otherwise - = do { traceTcS "canEqLeaf" $ ppr (mkEqPred s1 s2) - ; canEqLeafOriented d fl eqv s1 s2 } + = do { traceTcS "canEqLeaf" $ ppr (mkTcEqPred s1 s2) + ; canEqLeafOriented d fl s1 s2 } where re_orient = reOrient fl cls1 = classify s1 cls2 = classify s2 canEqLeafOriented :: SubGoalDepth -- Depth - -> CtFlavor -> EqVar + -> CtFlavor -> TcType -> TcType -> TcS StopOrContinue -- By now s1 will either be a variable or a type family application -canEqLeafOriented d fl eqv s1 s2 - = can_eq_split_lhs d fl eqv s1 s2 - where can_eq_split_lhs d fl eqv s1 s2 +canEqLeafOriented d fl s1 s2 + = can_eq_split_lhs d fl s1 s2 + where can_eq_split_lhs d fl s1 s2 | Just (fn,tys1) <- splitTyConApp_maybe s1 - = canEqLeafFunEqLeftRec d fl eqv (fn,tys1) s2 + = canEqLeafFunEqLeftRec d fl (fn,tys1) s2 | Just tv <- getTyVar_maybe s1 - = canEqLeafTyVarLeftRec d fl eqv tv s2 + = canEqLeafTyVarLeftRec d fl tv s2 | otherwise = pprPanic "canEqLeafOriented" $ - text "Non-variable or non-family equality LHS" <+> - ppr eqv <+> dcolon <+> ppr (evVarPred eqv) + text "Non-variable or non-family equality LHS" <+> ppr (ctFlavPred fl) canEqLeafFunEqLeftRec :: SubGoalDepth - -> CtFlavor - -> EqVar + -> CtFlavor -> (TyCon,[TcType]) -> TcType -> TcS StopOrContinue -canEqLeafFunEqLeftRec d fl eqv (fn,tys1) ty2 -- eqv :: F tys1 ~ ty2 +canEqLeafFunEqLeftRec d fl (fn,tys1) ty2 -- fl :: F tys1 ~ ty2 = do { traceTcS "canEqLeafFunEqLeftRec" $ pprEq (mkTyConApp fn tys1) ty2 ; (xis1,cos1) <- {-# SCC "flattenMany" #-} flattenMany d fl tys1 -- Flatten type function arguments -- cos1 :: xis1 ~ tys1 + + ; let fam_head = mkTyConApp fn xis1 + -- Fancy higher-dimensional coercion between equalities! + ; let co = mkTcTyConAppCo eqTyCon $ + [mkTcReflCo (defaultKind $ typeKind ty2), mkTcTyConAppCo fn cos1, mkTcReflCo ty2] + -- Why defaultKind? Same reason as the comment on TcType/mkTcEqPred. I trully hate this (DV) + -- co :: (F xis1 ~ ty2) ~ (F tys1 ~ ty2) + + ; mb <- rewriteCtFlavor fl (mkTcEqPred fam_head ty2) co + ; case mb of + Nothing -> return Stop + Just new_fl -> canEqLeafFunEqLeft d new_fl (fn,xis1) ty2 } --- ; inerts <- getTcSInerts --- ; let fam_eqs = inert_funeqs inerts - - ; let flat_ty = mkTyConApp fn xis1 - - ; is_cached <- getCachedFlatEq fn xis1 fl WhenSolved - -- Lookup if we have solved this goal already -{- - ; let is_cached = {-# SCC "lookupFunEq" #-} - lookupFunEq flat_ty fl fam_eqs --} - ; let no_flattening = all isTcReflCo cos1 - - ; if no_flattening && isNothing is_cached then - canEqLeafFunEqLeft d fl eqv (fn,xis1) ty2 - else do - { let (final_co, final_ty) - | no_flattening -- Just in inerts - , Just (rhs_ty, ret_eq) <- is_cached - = (mkTcSymCo ret_eq, rhs_ty) - | Nothing <- is_cached -- Just flattening - = (mkTcTyConAppCo fn cos1, flat_ty) - | Just (rhs_ty, ret_eq) <- is_cached -- Both - = (mkTcSymCo ret_eq `mkTcTransCo` mkTcTyConAppCo fn cos1, rhs_ty) - | otherwise = panic "No flattening and not cached!" - ; delCachedEvVar eqv fl - ; evc <- newEqVar fl final_ty ty2 - ; let new_eqv = evc_the_evvar evc - ; fl' <- case fl of - Wanted {} -> setEqBind eqv - (mkTcSymCo final_co `mkTcTransCo` (mkTcCoVarCo new_eqv)) fl - Given {} -> setEqBind new_eqv (final_co `mkTcTransCo` (mkTcCoVarCo eqv)) fl - Derived {} -> return fl - ; if isNewEvVar evc then - if isNothing is_cached then - {-# SCC "canEqLeafFunEqLeft" #-} - canEqLeafFunEqLeft d fl' new_eqv (fn,xis1) ty2 - else - canEq (d+1) fl' new_eqv final_ty ty2 - else return Stop - } - } - -lookupFunEq :: PredType -> CtFlavor -> TypeMap Ct -> Maybe (TcType, TcCoercion) -lookupFunEq pty fl fam_eqs = lookup_funeq pty fam_eqs - where lookup_funeq pty fam_eqs - | Just ct <- lookupTM pty fam_eqs - , cc_flavor ct `canRewrite` fl - = Just (cc_rhs ct, mkTcCoVarCo (cc_id ct)) - | otherwise - = Nothing canEqLeafFunEqLeft :: SubGoalDepth -- Depth - -> CtFlavor -> EqVar -> (TyCon,[Xi]) + -> CtFlavor + -> (TyCon,[Xi]) -> TcType -> TcS StopOrContinue -- Precondition: No more flattening is needed for the LHS -canEqLeafFunEqLeft d fl eqv (fn,xis1) s2 +canEqLeafFunEqLeft d fl (fn,xis1) s2 = {-# SCC "canEqLeafFunEqLeft" #-} do { traceTcS "canEqLeafFunEqLeft" $ pprEq (mkTyConApp fn xis1) s2 ; (xi2,co2) <- {-# SCC "flatten" #-} flatten d fl s2 -- co2 :: xi2 ~ s2 - ; let no_flattening_happened = isTcReflCo co2 - ; if no_flattening_happened then - continueWith $ CFunEqCan { cc_id = eqv - , cc_flavor = fl - , cc_fun = fn - , cc_tyargs = xis1 - , cc_rhs = xi2 - , cc_depth = d } - else do { delCachedEvVar eqv fl - ; evc <- - {-# SCC "newEqVar" #-} - newEqVar fl (mkTyConApp fn xis1) xi2 - ; let new_eqv = evc_the_evvar evc -- F xis1 ~ xi2 - new_cv = mkTcCoVarCo new_eqv - cv = mkTcCoVarCo eqv -- F xis1 ~ s2 - ; fl' <- case fl of - Wanted {} -> setEqBind eqv (new_cv `mkTcTransCo` co2) fl - Given {} -> setEqBind new_eqv (cv `mkTcTransCo` mkTcSymCo co2) fl - Derived {} -> return fl - ; if isNewEvVar evc then - do { continueWith $ - CFunEqCan { cc_id = new_eqv - , cc_flavor = fl' - , cc_fun = fn - , cc_tyargs = xis1 - , cc_rhs = xi2 - , cc_depth = d } } - else return Stop } } + + ; let fam_head = mkTyConApp fn xis1 + -- Fancy coercion between equalities! But it should just work! + ; let co = mkTcTyConAppCo eqTyCon $ [ mkTcReflCo (defaultKind $ typeKind s2) + , mkTcReflCo fam_head, co2 ] + -- Why defaultKind? Same reason as the comment at TcType/mkTcEqPred + -- co :: (F xis1 ~ xi2) ~ (F xis1 ~ s2) + -- new pred old pred + ; mb <- rewriteCtFlavor fl (mkTcEqPred fam_head xi2) co + ; case mb of + Nothing -> return Stop + Just new_fl -> continueWith $ + CFunEqCan { cc_flavor = new_fl, cc_depth = d + , cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 } } canEqLeafTyVarLeftRec :: SubGoalDepth - -> CtFlavor -> EqVar + -> CtFlavor -> TcTyVar -> TcType -> TcS StopOrContinue -canEqLeafTyVarLeftRec d fl eqv tv s2 -- eqv :: tv ~ s2 +canEqLeafTyVarLeftRec d fl tv s2 -- fl :: tv ~ s2 = do { traceTcS "canEqLeafTyVarLeftRec" $ pprEq (mkTyVarTy tv) s2 - ; (xi1,co1) <- flattenTyVar d fl tv -- co1 :: xi1 ~ tv - ; case isTcReflCo co1 of - True -> case getTyVar_maybe xi1 of - Just tv' -> canEqLeafTyVarLeft d fl eqv tv' s2 - Nothing -> canEq d fl eqv xi1 s2 - - False -> -- If not refl co, must rewrite and go on - do { traceTcS "celtlr: rewrite" (ppr xi1 $$ ppr co1) - ; delCachedEvVar eqv fl - ; evc <- newEqVar fl xi1 s2 -- new_ev :: xi1 ~ s2 - ; let new_ev = evc_the_evvar evc - ; fl' <- case fl of - Wanted {} -> setEqBind eqv - (mkTcSymCo co1 `mkTcTransCo` mkTcCoVarCo new_ev) fl - Given {} -> setEqBind new_ev - (co1 `mkTcTransCo` mkTcCoVarCo eqv) fl - Derived {} -> return fl - ; if isNewEvVar evc then - do { canEq d fl' new_ev xi1 s2 } - else return Stop - } - } - + ; (xi1,co1) <- flattenTyVar d fl tv -- co1 :: xi1 ~ tv + ; let is_still_var = isJust (getTyVar_maybe xi1) + + ; traceTcS "canEqLeafTyVarLeftRec2" $ empty + + ; let co = mkTcTyConAppCo eqTyCon $ [ mkTcReflCo (defaultKind $ typeKind s2) + , co1, mkTcReflCo s2] + -- co :: (xi1 ~ s2) ~ (tv ~ s2) + ; mb <- rewriteCtFlavor_cache (if is_still_var then False else True) fl (mkTcEqPred xi1 s2) co + -- See Note [Caching loops] + + ; traceTcS "canEqLeafTyVarLeftRec3" $ empty + + ; case mb of + Nothing -> return Stop + Just new_fl -> + case getTyVar_maybe xi1 of + Just tv' -> canEqLeafTyVarLeft d new_fl tv' s2 + Nothing -> canEq d new_fl xi1 s2 } + canEqLeafTyVarLeft :: SubGoalDepth -- Depth - -> CtFlavor -> EqVar + -> CtFlavor -> TcTyVar -> TcType -> TcS StopOrContinue -- Precondition LHS is fully rewritten from inerts (but not RHS) -canEqLeafTyVarLeft d fl eqv tv s2 -- eqv : tv ~ s2 - = do { traceTcS "canEqLeafTyVarLeft" (pprEq (mkTyVarTy tv) s2) - ; (xi2, co) <- flatten d fl s2 -- Flatten RHS co : xi2 ~ s2 - - ; let no_flattening_happened = isTcReflCo co - +canEqLeafTyVarLeft d fl tv s2 -- eqv : tv ~ s2 + = do { let tv_ty = mkTyVarTy tv + ; traceTcS "canEqLeafTyVarLeft" (pprEq tv_ty s2) + ; (xi2, co2) <- flatten d fl s2 -- Flatten RHS co : xi2 ~ s2 + ; traceTcS "canEqLeafTyVarLeft" (nest 2 (vcat [ text "tv =" <+> ppr tv , text "s2 =" <+> ppr s2 , text "xi2 =" <+> ppr xi2])) - -- Flattening the RHS may reveal an identity coercion, which should - -- not be reported as occurs check error! - ; let is_same_tv - | Just tv' <- getTyVar_maybe xi2, tv' == tv - = True - | otherwise = False - ; if is_same_tv then - do { delCachedEvVar eqv fl - ; when (isWanted fl) $ - do { _ <- setEqBind eqv co fl; return () } - ; return Stop } - else - do { -- Do an occurs check, and return a possibly - -- unfolded version of the RHS, if we had to - -- unfold any type synonyms to get rid of tv. - occ_check_result <- canOccursCheck fl tv xi2 - - ; let xi2' - | Just xi2_unfolded <- occ_check_result - = xi2_unfolded - | otherwise = xi2 - - - ; if no_flattening_happened then - if isNothing occ_check_result then - canEqFailure d fl (setVarType eqv $ - mkTcEqPred (mkTyVarTy tv) xi2') - else - continueWith $ CTyEqCan { cc_id = eqv - , cc_flavor = fl - , cc_tyvar = tv - , cc_rhs = xi2' - , cc_depth = d } - else -- Flattening happened, in any case we have to create new variable - -- even if we report an occurs check error - do { delCachedEvVar eqv fl - ; evc <- newEqVar fl (mkTyVarTy tv) xi2' - ; let eqv' = evc_the_evvar evc -- eqv' : tv ~ xi2' - cv = mkTcCoVarCo eqv -- cv : tv ~ s2 - cv' = mkTcCoVarCo eqv' -- cv': tv ~ xi2' - ; fl' <- case fl of - Wanted {} -> setEqBind eqv (cv' `mkTcTransCo` co) fl -- tv ~ xi2' ~ s2 - Given {} -> setEqBind eqv' (cv `mkTcTransCo` mkTcSymCo co) fl -- tv ~ s2 ~ xi2' - Derived {} -> return fl - - ; if isNewEvVar evc then - if isNothing occ_check_result then - canEqFailure d fl eqv' - else continueWith CTyEqCan { cc_id = eqv' - , cc_flavor = fl' - , cc_tyvar = tv - , cc_rhs = xi2' - , cc_depth = d } - else - return Stop } } } - + -- Reflexivity exposed through flattening + ; if tv_ty `eqType` xi2 then + when (isWanted fl) (setEvBind (flav_evar fl) (EvCoercion co2)) >> + return Stop + else do + -- Not reflexivity but maybe an occurs error + { occ_check_result <- canOccursCheck fl tv xi2 + ; let xi2' = fromMaybe xi2 occ_check_result + + not_occ_err = isJust occ_check_result + -- Delicate: don't want to cache as solved a constraint with occurs error! + co = mkTcTyConAppCo eqTyCon $ + [mkTcReflCo (defaultKind $ typeKind s2), mkTcReflCo tv_ty, co2] + ; mb <- rewriteCtFlavor_cache not_occ_err fl (mkTcEqPred tv_ty xi2') co + ; case mb of + Just new_fl -> if not_occ_err then + continueWith $ + CTyEqCan { cc_flavor = new_fl, cc_depth = d + , cc_tyvar = tv, cc_rhs = xi2' } + else + canEqFailure d new_fl + Nothing -> return Stop + } } -- See Note [Type synonyms and canonicalization]. -- Check whether the given variable occurs in the given type. We may diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 0cf05802e2..1967976856 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -309,9 +309,9 @@ tcLookupId name = do tcLookupLocalIds :: [Name] -> TcM [TcId] -- We expect the variables to all be bound, and all at -- the same level as the lookup. Only used in one place... -tcLookupLocalIds ns = do - env <- getLclEnv - return (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns) +tcLookupLocalIds ns + = do { env <- getLclEnv + ; return (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns) } where lookup lenv lvl name = case lookupNameEnv lenv name of @@ -328,17 +328,11 @@ getInLocalScope = do { lcl_env <- getLclTypeEnv \begin{code} tcExtendTcTyThingEnv :: [(Name, TcTyThing)] -> TcM r -> TcM r tcExtendTcTyThingEnv things thing_inside - = updLclEnv upd thing_inside - where - upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } - extend env = extendNameEnvList env things + = updLclEnv (extend_local_env things) thing_inside tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r -tcExtendKindEnv things thing_inside - = updLclEnv upd thing_inside - where - upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } - extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things] +tcExtendKindEnv name_kind_prs + = tcExtendTcTyThingEnv [(n, AThing k) | (n,k) <- name_kind_prs] ----------------------- -- Scoped type and kind variables @@ -432,9 +426,7 @@ tc_extend_local_env :: [(Name, TcTyThing)] -> TcM a -> TcM a tc_extend_local_env extra_env thing_inside = do { traceTc "env2" (ppr extra_env) ; env1 <- getLclEnv - ; let le' = extendNameEnvList (tcl_env env1) extra_env - rdr_env' = extendLocalRdrEnvList (tcl_rdr env1) (map fst extra_env) - env2 = env1 {tcl_env = le', tcl_rdr = rdr_env'} + ; let env2 = extend_local_env extra_env env1 ; env3 <- extend_gtvs env2 ; setLclEnv env3 thing_inside } where @@ -469,6 +461,12 @@ tc_extend_local_env extra_env thing_inside -- -- Nor must we generalise g over any kind variables free in r's kind +extend_local_env :: [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv +-- Extend the local TcTypeEnv *and* the local LocalRdrEnv simultaneously +extend_local_env pairs env@(TcLclEnv { tcl_rdr = rdr_env, tcl_env = type_env }) + = env { tcl_rdr = extendLocalRdrEnvList rdr_env (map fst pairs) + , tcl_env = extendNameEnvList type_env pairs } + tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet) tcExtendGlobalTyVars gtv_var extra_global_tvs = do { global_tvs <- readMutVar gtv_var diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs index 16e3fb546c..0fcd0d4ea2 100644 --- a/compiler/typecheck/TcErrors.lhs +++ b/compiler/typecheck/TcErrors.lhs @@ -159,10 +159,11 @@ reportTidyWanteds ctxt insols flats implics deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg) -> Ct -> TcM () deferToRuntime ev_binds_var ctxt mk_err_msg ct - | Wanted loc <- cc_flavor ct + | fl <- cc_flavor ct + , Wanted loc _ <- fl = do { err <- setCtLoc loc $ mk_err_msg ctxt ct - ; let ev_id = cc_id ct + ; let ev_id = ctId ct -- Prec satisfied: Wanted err_msg = pprLocErrMsg err err_fs = mkFastString $ showSDoc $ err_msg $$ text "(deferred type error)" @@ -323,8 +324,8 @@ groupErrs mk_err (ct1 : rest) same_group :: CtFlavor -> CtFlavor -> Bool same_group (Given l1 _) (Given l2 _) = same_loc l1 l2 - same_group (Derived l1) (Derived l2) = same_loc l1 l2 - same_group (Wanted l1) (Wanted l2) = same_loc l1 l2 + same_group (Derived l1 _) (Derived l2 _) = same_loc l1 l2 + same_group (Wanted l1 _) (Wanted l2 _) = same_loc l1 l2 same_group _ _ = False same_loc :: CtLoc o -> CtLoc o -> Bool @@ -345,7 +346,7 @@ pprWithArising [] pprWithArising (ct:cts) | null cts = (loc, addArising (ctLocOrigin (ctWantedLoc ct)) - (pprEvVarTheta [cc_id ct])) + (pprTheta [ctPred ct])) | otherwise = (loc, vcat (map ppr_one (ct:cts))) where @@ -425,22 +426,23 @@ mkEqErr _ [] = panic "mkEqErr" mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg -- Wanted constraints only! mkEqErr1 ctxt ct - = case cc_flavor ct of - Given gl gk -> mkEqErr_help ctxt2 ct False ty1 ty2 - where - ctxt2 = ctxt { cec_extra = cec_extra ctxt $$ - inaccessible_msg gl gk } - - flav -> do { let orig = ctLocOrigin (getWantedLoc flav) - ; (ctxt1, orig') <- zonkTidyOrigin ctxt orig - ; mk_err ctxt1 orig' } + = if isGivenOrSolved flav then + let ctx2 = ctxt { cec_extra = cec_extra ctxt $$ inaccessible_msg flav } + in mkEqErr_help ctx2 ct False ty1 ty2 + else + do { let orig = ctLocOrigin (getWantedLoc flav) + ; (ctxt1, orig') <- zonkTidyOrigin ctxt orig + ; mk_err ctxt1 orig' } where - -- If a GivenSolved then we should not report inaccessible code - inaccessible_msg loc GivenOrig = hang (ptext (sLit "Inaccessible code in")) + + flav = cc_flavor ct + + inaccessible_msg (Given loc _) = hang (ptext (sLit "Inaccessible code in")) 2 (ppr (ctLocOrigin loc)) - inaccessible_msg _ _ = empty + -- If a Solved then we should not report inaccessible code + inaccessible_msg _ = empty - (ty1, ty2) = getEqPredTys (evVarPred (cc_id ct)) + (ty1, ty2) = getEqPredTys (ctPred ct) -- If the types in the error message are the same as the types -- we are unifying, don't add the extra expected/actual message @@ -1072,6 +1074,19 @@ solverDepthErrorTcS depth stack = failWith msg | otherwise = setCtFlavorLoc (cc_flavor top_item) $ + do { zstack <- mapM zonkCt stack + ; env0 <- tcInitTidyEnv + ; let zstack_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet zstack + tidy_env = tidyFreeTyVars env0 zstack_tvs + tidy_cts = map (tidyCt tidy_env) zstack + ; failWithTcM (tidy_env, hang msg 2 (vcat (map (ppr . ctPred) tidy_cts))) } + where + top_item = head stack + msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth + , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ] + +{- DV: Changing this because Derived's no longer have ids ... Kind of a corner case ... + = setCtFlavorLoc (cc_flavor top_item) $ do { ev_vars <- mapM (zonkEvVar . cc_id) stack ; env0 <- tcInitTidyEnv ; let tidy_env = tidyFreeTyVars env0 (tyVarsOfEvVars ev_vars) @@ -1081,6 +1096,8 @@ solverDepthErrorTcS depth stack top_item = head stack msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ] +-} + flattenForAllErrorTcS :: CtFlavor -> TcType -> TcM a flattenForAllErrorTcS fl ty @@ -1100,9 +1117,10 @@ flattenForAllErrorTcS fl ty \begin{code} setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a -setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing -setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing -setCtFlavorLoc (Given loc _gk) thing = setCtLoc loc thing +setCtFlavorLoc (Wanted loc _) thing = setCtLoc loc thing +setCtFlavorLoc (Derived loc _) thing = setCtLoc loc thing +setCtFlavorLoc (Given loc _) thing = setCtLoc loc thing +setCtFlavorLoc (Solved loc _) thing = setCtLoc loc thing \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 7bda323f5b..ae8ac26918 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -210,17 +210,15 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ (CLabel _)) tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh CWrapper) = do -- Foreign wrapper (former f.e.d.) - -- The type must be of the form ft -> IO (FunPtr ft), where ft is a - -- valid foreign type. For legacy reasons ft -> IO (Ptr ft) as well - -- as ft -> IO Addr is accepted, too. The use of the latter two forms - -- is DEPRECATED, though. + -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid + -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too. + -- The use of the latter form is DEPRECATED, though. checkCg checkCOrAsmOrLlvmOrInterp cconv' <- checkCConv cconv case arg_tys of [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty - checkForeignRes mustBeIO checkSafe isFFIDynResultTy res_ty - -- ToDo: Why are res1_ty and res_ty not equal? + checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty _ -> addErrTc (illegalForeignTyErr empty sig_ty) @@ -230,12 +228,13 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction ta | isDynamicTarget target = do -- Foreign import dynamic checkCg checkCOrAsmOrLlvmOrInterp cconv' <- checkCConv cconv - case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr + case arg_tys of -- The first arg must be Ptr or FunPtr [] -> do check False (illegalForeignTyErr empty sig_ty) (arg1_ty:arg_tys) -> do dflags <- getDynFlags - check (isFFIDynArgumentTy arg1_ty) + let curried_res_ty = foldr FunTy res_ty arg_tys + check (isFFIDynTy curried_res_ty arg1_ty) (illegalForeignTyErr argument arg1_ty) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs index c084f7d676..42b4f747f8 100644 --- a/compiler/typecheck/TcInteract.lhs +++ b/compiler/typecheck/TcInteract.lhs @@ -33,6 +33,7 @@ import TyCon import Name import IParam +import TysWiredIn ( eqTyCon ) import FunDeps import TcEvidence @@ -51,9 +52,10 @@ import TrieMap import VarEnv import qualified Data.Traversable as Traversable +import Data.Maybe ( isJust ) -import Control.Monad( when ) -import Pair ( pSnd ) +import Control.Monad( when, unless ) +import Pair () import UniqFM import FastString ( sLit ) import DynFlags @@ -91,58 +93,13 @@ depth and will simply fail. solveInteractCts :: [Ct] -> TcS () solveInteractCts cts - = do { evvar_cache <- getTcSEvVarCacheMap - ; (cts_thinner, new_evvar_cache) <- add_cts_in_cache evvar_cache cts - ; traceTcS "solveInteractCts" (vcat [ text "cts_original =" <+> ppr cts, - text "cts_thinner =" <+> ppr cts_thinner - ]) - ; setTcSEvVarCacheMap new_evvar_cache - ; updWorkListTcS (appendWorkListCt cts_thinner) >> solveInteract } - - where - add_cts_in_cache evvar_cache cts - = do { ctxt <- getTcSContext - ; foldM (solve_or_cache (simplEqsOnly ctxt)) ([],evvar_cache) cts } - - solve_or_cache :: Bool -- Solve equalities only, not classes etc - -> ([Ct],TypeMap (EvVar,CtFlavor)) - -> Ct - -> TcS ([Ct],TypeMap (EvVar,CtFlavor)) - solve_or_cache eqs_only (acc_cts,acc_cache) ct - | dont_cache eqs_only (classifyPredType pred_ty) - = return (ct:acc_cts,acc_cache) - - | Just (ev',fl') <- lookupTM pred_ty acc_cache - , fl' `canSolve` fl - , isWanted fl - = do { _ <- setEvBind ev (EvId ev') fl - ; return (acc_cts,acc_cache) } - - | otherwise -- If it's a given keep it in the work list, even if it exists in the cache! - = return (ct:acc_cts, alterTM pred_ty (\_ -> Just (ev,fl)) acc_cache) - where fl = cc_flavor ct - ev = cc_id ct - pred_ty = ctPred ct - - dont_cache :: Bool -> PredTree -> Bool - -- Do not use the cache, not update it, if this is true - dont_cache _ (IPPred {}) = True -- IPPreds have subtle shadowing - dont_cache _ (EqPred ty1 ty2) -- Report Int ~ Bool errors separately - | Just tc1 <- tyConAppTyCon_maybe ty1 - , Just tc2 <- tyConAppTyCon_maybe ty2 - , tc1 /= tc2 - = isDecomposableTyCon tc1 && isDecomposableTyCon tc2 - | otherwise = False - dont_cache eqs_only _ = eqs_only - -- If we are simplifying equalities only, - -- do not cache non-equalities - -- See Note [Simplifying RULE lhs constraints] in TcSimplify + = do { traceTcS "solveInteractCtS" (vcat [ text "cts =" <+> ppr cts ]) + ; updWorkListTcS (appendWorkListCt cts) >> solveInteract } solveInteractGiven :: GivenLoc -> [EvVar] -> TcS () solveInteractGiven gloc evs = solveInteractCts (map mk_noncan evs) - where mk_noncan ev = CNonCanonical { cc_id = ev - , cc_flavor = Given gloc GivenOrig + where mk_noncan ev = CNonCanonical { cc_flavor = Given gloc ev , cc_depth = 0 } -- The main solver loop implements Note [Basic Simplifier Plan] @@ -251,7 +208,8 @@ React with (F Int ~ b) ==> IR Stop True [] -- after substituting we re-canoni \begin{code} thePipeline :: [(String,SimplifierStage)] -thePipeline = [ ("canonicalization", canonicalizationStage) +thePipeline = [ ("lookup-in-inerts", lookupInInertsStage) + , ("canonicalization", canonicalizationStage) , ("spontaneous solve", spontaneousSolveStage) , ("interact with inerts", interactWithInertsStage) , ("top-level reactions", topReactionsStage) ] @@ -260,6 +218,26 @@ thePipeline = [ ("canonicalization", canonicalizationStage) \begin{code} +-- A quick lookup everywhere to see if we know about this constraint +-------------------------------------------------------------------- +lookupInInertsStage :: SimplifierStage +lookupInInertsStage ct + | isWantedCt ct + = do { is <- getTcSInerts + ; ctxt <- getTcSContext + ; case lookupInInerts is (ctPred ct) of + Just ct_cached + | (not $ isDerivedCt ct) && (not $ simplEqsOnly ctxt) + -- Don't share if we are simplifying a RULE + -- see Note [Simplifying RULE lhs constraints] + -> setEvBind (ctId ct) (EvId (ctId ct_cached)) >> + return Stop + _ -> continueWith ct } + | otherwise -- I could do something like that for givens + -- as well I suppose but it is not a big deal + = continueWith ct + + -- The canonicalization stage, see TcCanonical for details ---------------------------------------------------------- canonicalizationStage :: SimplifierStage @@ -290,8 +268,6 @@ Case 1: In Rewriting Equalities (function rewriteEqLHS) canonicalize (xi1 ~ xi2) if (b) comes from the inert set, or (xi2 ~ xi1) if (a) comes from the inert set. - This choice is implemented using the WhichComesFromInert flag. - Case 2: Functional Dependencies Again, we should prefer, if possible, the inert variables on the RHS @@ -312,8 +288,7 @@ spontaneousSolveStage workItem spont_solve (SPSolved workItem') -- Post: workItem' must be equality = do { bumpStepCountTcS ; traceFireTcS (cc_depth workItem) $ - ptext (sLit "Spontaneous") - <+> parens (ppr (cc_flavor workItem)) <+> ppr workItem + ptext (sLit "Spontaneous:") <+> ppr workItem -- NB: will add the item in the inerts ; kickOutRewritableInerts workItem' @@ -327,118 +302,107 @@ kickOutRewritableInerts :: Ct -> TcS () -- The rewritable end up in the worklist kickOutRewritableInerts ct = {-# SCC "kickOutRewritableInerts" #-} - do { (wl,ieqs) <- {-# SCC "kick_out_rewritable" #-} + do { traceTcS "kickOutRewritableInerts" $ text "workitem = " <+> ppr ct + ; (wl,ieqs) <- {-# SCC "kick_out_rewritable" #-} modifyInertTcS (kick_out_rewritable ct) + ; traceTcS "Kicked out the following constraints" $ ppr wl + ; is <- getTcSInerts + ; traceTcS "Remaining inerts are" $ ppr is - -- Step 1: Rewrite as many of the inert_eqs on the spot! - -- NB: if it is a solved constraint just use the cached evidence - - ; let ct_coercion = getCtCoercion ct + -- Step 1: Rewrite as many of the inert_eqs on the spot! + -- NB: if it is a given constraint just use the cached evidence + -- to optimize e.g. mkRefl coercions from spontaneously solved cts. + ; bnds <- getTcEvBindsMap + ; let ct_coercion = getCtCoercion bnds ct ; new_ieqs <- {-# SCC "rewriteInertEqsFromInertEq" #-} - rewriteInertEqsFromInertEq (cc_tyvar ct,ct_coercion, cc_flavor ct) ieqs - ; modifyInertTcS (\is -> ((), is { inert_eqs = new_ieqs })) - - -- Step 2: Add the new guy in + rewriteInertEqsFromInertEq (cc_tyvar ct, + ct_coercion,cc_flavor ct) ieqs + ; let upd_eqs is = is { inert_cans = new_ics } + where ics = inert_cans is + new_ics = ics { inert_eqs = new_ieqs } + ; modifyInertTcS (\is -> ((), upd_eqs is)) + + ; is <- getTcSInerts + ; traceTcS "Final inerts are" $ ppr is + + -- Step 2: Add the new guy in ; updInertSetTcS ct ; traceTcS "Kick out" (ppr ct $$ ppr wl) ; updWorkListTcS (unionWorkList wl) } rewriteInertEqsFromInertEq :: (TcTyVar, TcCoercion, CtFlavor) -- A new substitution - -> TyVarEnv (Ct, TcCoercion) -- All inert equalities - -> TcS (TyVarEnv (Ct,TcCoercion)) -- The new inert equalities -rewriteInertEqsFromInertEq (subst_tv, subst_co, subst_fl) ieqs --- The goal: traverse the inert equalities and rewrite some of them, dropping some others --- back to the worklist. This is delicate, see Note [Delicate equality kick-out] + -> TyVarEnv Ct -- All the inert equalities + -> TcS (TyVarEnv Ct) -- The new inert equalities +rewriteInertEqsFromInertEq (subst_tv, _subst_co, subst_fl) ieqs +-- The goal: traverse the inert equalities and throw some of them back to the worklist +-- if you have to rewrite and recheck them for occurs check errors. +-- To see which ones we must throw out see Note [Delicate equality kick-out] = do { mieqs <- Traversable.mapM do_one ieqs ; traceTcS "Original inert equalities:" (ppr ieqs) ; let flatten_justs elem venv - | Just (act,aco) <- elem = extendVarEnv venv (cc_tyvar act) (act,aco) + | Just act <- elem = extendVarEnv venv (cc_tyvar act) act | otherwise = venv final_ieqs = foldVarEnv flatten_justs emptyVarEnv mieqs ; traceTcS "Remaining inert equalities:" (ppr final_ieqs) ; return final_ieqs } - where do_one (ct,inert_co) + where do_one ct | subst_fl `canRewrite` fl && (subst_tv `elemVarSet` tyVarsOfCt ct) - -- Annoyingly inefficient, but we can't simply check - -- that isReflCo co because of cached solved ReflCo evidence. - = if fl `canRewrite` subst_fl then - -- If also the inert can rewrite the subst it's totally safe - -- to rewrite on the spot - do { (ct',inert_co') <- rewrite_on_the_spot (ct,inert_co) - ; return $ Just (ct',inert_co') } + = if fl `canRewrite` subst_fl then + -- If also the inert can rewrite the subst then there is no danger of + -- occurs check errors sor keep it there. No need to rewrite the inert equality + -- (as we did in the past) because of point (8) of + -- Note [Detailed InertCans Invariants] and + return (Just ct) + -- used to be: rewrite_on_the_spot ct >>= ( return . Just ) else -- We have to throw inert back to worklist for occurs checks - do { updWorkListTcS (extendWorkListEq ct) - ; return Nothing } + updWorkListTcS (extendWorkListEq ct) >> return Nothing | otherwise -- Just keep it there - = return $ Just (ct,inert_co) + = return (Just ct) where - -- We have new guy co : tv ~ something - -- and old inert {wanted} cv : tv' ~ rhs[tv] - -- We want to rewrite to - -- {wanted} cv' : tv' ~ rhs[something] - -- cv = cv' ; rhs[Sym co] - -- - rewrite_on_the_spot (ct,_inert_co) - = do { let rhs' = pSnd (tcCoercionKind co) - ; delCachedEvVar ev fl - ; evc <- newEqVar fl (mkTyVarTy tv) rhs' - ; let ev' = evc_the_evvar evc - ; let evco' = mkTcCoVarCo ev' - ; fl' <- if isNewEvVar evc then - do { case fl of - Wanted {} - -> setEqBind ev (evco' `mkTcTransCo` mkTcSymCo co) fl - Given {} - -> setEqBind ev' (mkTcCoVarCo ev `mkTcTransCo` co) fl - Derived {} - -> return fl } - else - if isWanted fl then - setEqBind ev (evco' `mkTcTransCo` mkTcSymCo co) fl - else return fl - ; let ct' = ct { cc_id = ev', cc_flavor = fl', cc_rhs = rhs' } - ; return (ct',evco') } - ev = cc_id ct fl = cc_flavor ct - tv = cc_tyvar ct - rhs = cc_rhs ct - co = liftTcCoSubstWith [subst_tv] [subst_co] rhs - -kick_out_rewritable :: Ct -> InertSet -> ((WorkList,TyVarEnv (Ct,TcCoercion)), InertSet) --- Returns ALL equalities, to be dealt with later -kick_out_rewritable ct (IS { inert_eqs = eqmap - , inert_eq_tvs = inscope - , inert_dicts = dictmap - , inert_ips = ipmap - , inert_funeqs = funeqmap - , inert_irreds = irreds - , inert_frozen = frozen - } ) - = ((kicked_out, eqmap), remaining) + +kick_out_rewritable :: Ct + -> InertSet + -> ((WorkList, TyVarEnv Ct),InertSet) +-- Post: returns ALL inert equalities, to be dealt with later +-- +kick_out_rewritable ct is@(IS { inert_cans = + IC { inert_eqs = eqmap + , inert_eq_tvs = inscope + , inert_dicts = dictmap + , inert_ips = ipmap + , inert_funeqs = funeqmap + , inert_irreds = irreds } + , inert_frozen = frozen }) + = ((kicked_out,eqmap), remaining) where + rest_out = fro_out `andCts` dicts_out + `andCts` ips_out `andCts` irs_out kicked_out = WorkList { wl_eqs = [] , wl_funeqs = bagToList feqs_out - , wl_rest = bagToList (fro_out `andCts` dicts_out - `andCts` ips_out `andCts` irs_out) } + , wl_rest = bagToList rest_out } - remaining = IS { inert_eqs = emptyVarEnv - , inert_eq_tvs = inscope -- keep the same, safe and cheap - , inert_dicts = dicts_in - , inert_ips = ips_in - , inert_funeqs = feqs_in - , inert_irreds = irs_in - , inert_frozen = fro_in - } - + remaining = is { inert_cans = IC { inert_eqs = emptyVarEnv + , inert_eq_tvs = inscope + -- keep the same, safe and cheap + , inert_dicts = dicts_in + , inert_ips = ips_in + , inert_funeqs = feqs_in + , inert_irreds = irs_in } + , inert_frozen = fro_in } + -- NB: Notice that don't rewrite + -- inert_solved, inert_flat_cache and inert_solved_funeqs + -- optimistically. But when we lookup we have to take the + -- subsitution into account fl = cc_flavor ct tv = cc_tyvar ct (ips_out, ips_in) = partitionCCanMap rewritable ipmap - (feqs_out, feqs_in) = partitionCtTypeMap rewritable funeqmap + (feqs_out, feqs_in) = partCtFamHeadMap rewritable funeqmap (dicts_out, dicts_in) = partitionCCanMap rewritable dictmap (irs_out, irs_in) = partitionBag rewritable irreds @@ -463,25 +427,24 @@ Note [Delicate equality kick-out] Delicate: When kicking out rewritable constraints, it would be safe to simply kick out all rewritable equalities, but instead we only kick out those -that, when rewritten, may result in occur-check errors. We rewrite the -rest on the spot. Example: +that, when rewritten, may result in occur-check errors. Example: - WorkItem = [S] a ~ b + WorkItem = [G] a ~ b Inerts = { [W] b ~ [a] } Now at this point the work item cannot be further rewritten by the -inert (due to the weaker inert flavor), so we are examining if we can -instead rewrite the inert from the workitem. But if we rewrite it on -the spot we have to recanonicalize because of the danger of occurs -errors. On the other hand if the inert flavor was just as powerful or -more powerful than the workitem flavor, the work-item could not have -reached this stage (because it would have already been rewritten by -the inert). +inert (due to the weaker inert flavor). Instead the workitem can +rewrite the inert leading to potential occur check errors. So we must +kick the inert out. On the other hand, if the inert flavor was as +powerful or more powerful than the workitem flavor, the work-item could +not have reached this stage (because it would have already been +rewritten by the inert). The coclusion is: we kick out the 'dangerous' equalities that may -require recanonicalization (occurs checks) and the rest we rewrite -unconditionally without further checks, on-the-spot with function -rewriteInertEqsFromInertEq. +require recanonicalization (occurs checks) and the rest we keep +there in the inerts without further checks. +In the past we used to rewrite-on-the-spot those equalities that we keep in, +but this is no longer necessary see Note [Non-idempotent inert substitution]. \begin{code} data SPSolveResult = SPCantSolve @@ -494,7 +457,7 @@ data SPSolveResult = SPCantSolve -- touchable unification variable. -- See Note [Touchables and givens] trySpontaneousSolve :: WorkItem -> TcS SPSolveResult -trySpontaneousSolve workItem@(CTyEqCan { cc_id = eqv, cc_flavor = gw +trySpontaneousSolve workItem@(CTyEqCan { cc_flavor = gw , cc_tyvar = tv1, cc_rhs = xi, cc_depth = d }) | isGivenOrSolved gw = return SPCantSolve @@ -502,13 +465,13 @@ trySpontaneousSolve workItem@(CTyEqCan { cc_id = eqv, cc_flavor = gw = do { tch1 <- isTouchableMetaTyVar tv1 ; tch2 <- isTouchableMetaTyVar tv2 ; case (tch1, tch2) of - (True, True) -> trySpontaneousEqTwoWay d eqv gw tv1 tv2 - (True, False) -> trySpontaneousEqOneWay d eqv gw tv1 xi - (False, True) -> trySpontaneousEqOneWay d eqv gw tv2 (mkTyVarTy tv1) + (True, True) -> trySpontaneousEqTwoWay d gw tv1 tv2 + (True, False) -> trySpontaneousEqOneWay d gw tv1 xi + (False, True) -> trySpontaneousEqOneWay d gw tv2 (mkTyVarTy tv1) _ -> return SPCantSolve } | otherwise = do { tch1 <- isTouchableMetaTyVar tv1 - ; if tch1 then trySpontaneousEqOneWay d eqv gw tv1 xi + ; if tch1 then trySpontaneousEqOneWay d gw tv1 xi else do { traceTcS "Untouchable LHS, can't spontaneously solve workitem:" $ ppr workItem ; return SPCantSolve } @@ -521,24 +484,24 @@ trySpontaneousSolve _ = return SPCantSolve ---------------- trySpontaneousEqOneWay :: SubGoalDepth - -> EqVar -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult + -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult -- tv is a MetaTyVar, not untouchable -trySpontaneousEqOneWay d eqv gw tv xi +trySpontaneousEqOneWay d gw tv xi | not (isSigTyVar tv) || isTyVarTy xi - = solveWithIdentity d eqv gw tv xi + = solveWithIdentity d gw tv xi | otherwise -- Still can't solve, sig tyvar and non-variable rhs = return SPCantSolve ---------------- trySpontaneousEqTwoWay :: SubGoalDepth - -> EqVar -> CtFlavor -> TcTyVar -> TcTyVar -> TcS SPSolveResult + -> CtFlavor -> TcTyVar -> TcTyVar -> TcS SPSolveResult -- Both tyvars are *touchable* MetaTyvars so there is only a chance for kind error here -trySpontaneousEqTwoWay d eqv gw tv1 tv2 +trySpontaneousEqTwoWay d gw tv1 tv2 = do { let k1_sub_k2 = k1 `tcIsSubKind` k2 ; if k1_sub_k2 && nicer_to_update_tv2 - then solveWithIdentity d eqv gw tv2 (mkTyVarTy tv1) - else solveWithIdentity d eqv gw tv1 (mkTyVarTy tv2) } + then solveWithIdentity d gw tv2 (mkTyVarTy tv1) + else solveWithIdentity d gw tv1 (mkTyVarTy tv2) } where k1 = tyVarKind tv1 k2 = tyVarKind tv2 @@ -618,7 +581,7 @@ unification variables as RHS of type family equations: F xis ~ alpha. ---------------- solveWithIdentity :: SubGoalDepth - -> EqVar -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult + -> CtFlavor -> TcTyVar -> Xi -> TcS SPSolveResult -- Solve with the identity coercion -- Precondition: kind(xi) is a sub-kind of kind(tv) -- Precondition: CtFlavor is Wanted or Derived @@ -626,13 +589,13 @@ solveWithIdentity :: SubGoalDepth -- must work for Derived as well as Wanted -- Returns: workItem where -- workItem = the new Given constraint -solveWithIdentity d eqv wd tv xi - = do { traceTcS "Sneaky unification:" $ - vcat [text "Coercion variable: " <+> ppr eqv <+> ppr wd, - text "Coercion: " <+> pprEq (mkTyVarTy tv) xi, - text "Left Kind is : " <+> ppr (typeKind (mkTyVarTy tv)), - text "Right Kind is : " <+> ppr (typeKind xi) - ] +solveWithIdentity d wd tv xi + = do { let tv_ty = mkTyVarTy tv + ; traceTcS "Sneaky unification:" $ + vcat [text "Constraint:" <+> ppr wd, + text "Coercion:" <+> pprEq tv_ty xi, + text "Left Kind is:" <+> ppr (typeKind tv_ty), + text "Right Kind is:" <+> ppr (typeKind xi) ] ; let xi' = defaultKind xi -- We only instantiate kind unification variables @@ -642,14 +605,16 @@ solveWithIdentity d eqv wd tv xi ; setWantedTyBind tv xi' ; let refl_xi = mkTcReflCo xi' - ; let solved_fl = mkSolvedFlavor wd UnkSkol (EvCoercion refl_xi) - ; (_,eqv_given) <- newGivenEqVar solved_fl (mkTyVarTy tv) xi' refl_xi + ; when (isWanted wd) $ + setEvBind (flav_evar wd) (EvCoercion refl_xi) - ; when (isWanted wd) $ do { _ <- setEqBind eqv refl_xi wd; return () } - -- We don't want to do this for Derived, that's why we use 'when (isWanted wd)' - ; return $ SPSolved (CTyEqCan { cc_id = eqv_given - , cc_flavor = solved_fl - , cc_tyvar = tv, cc_rhs = xi', cc_depth = d }) } + ; ev_given <- newGivenEvVar (mkTcEqPred tv_ty xi') + (EvCoercion refl_xi) >>= (return . mn_thing) + ; let given_fl = Given (mkGivenLoc (flav_wloc wd) UnkSkol) ev_given + + ; return $ + SPSolved (CTyEqCan { cc_flavor = given_fl + , cc_tyvar = tv, cc_rhs = xi', cc_depth = d }) } \end{code} @@ -709,20 +674,23 @@ interactWithInertsStage :: WorkItem -> TcS StopOrContinue -- react with anything at this stage. interactWithInertsStage wi = do { ctxt <- getTcSContext - ; if simplEqsOnly ctxt then + ; if simplEqsOnly ctxt && not (isCFunEqCan wi) then + -- Why not just "simplEqsOnly"? See Note [SimplEqsOnly and InteractWithInerts] return (ContinueWith wi) else - extractRelevantInerts wi >>= - foldlBagM interact_next (ContinueWith wi) } + do { traceTcS "interactWithInerts" $ text "workitem = " <+> ppr wi + ; rels <- extractRelevantInerts wi + ; traceTcS "relevant inerts are:" $ ppr rels + ; foldlBagM interact_next (ContinueWith wi) rels } } where interact_next Stop atomic_inert = updInertSetTcS atomic_inert >> return Stop interact_next (ContinueWith wi) atomic_inert = do { ir <- doInteractWithInert atomic_inert wi ; let mk_msg rule keep_doc - = text rule <+> keep_doc - <+> vcat [ ptext (sLit "Inert =") <+> ppr atomic_inert - , ptext (sLit "Work =") <+> ppr wi ] + = vcat [ text rule <+> keep_doc + , ptext (sLit "InertItem =") <+> ppr atomic_inert + , ptext (sLit "WorkItem =") <+> ppr wi ] ; case ir of IRWorkItemConsumed { ir_fire = rule } -> do { bumpStepCountTcS @@ -739,15 +707,44 @@ interactWithInertsStage wi -> do { updInertSetTcS atomic_inert ; return (ContinueWith wi) } } - + +\end{code} + +Note [SimplEqsOnly and InteractWithInerts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It may be possible when we are simplifying a RULE that we have two wanted constraints +of the form: + [W] c1 : F Int ~ Bool + [W] c2 : F Int ~ alpha + +When we simplify RULES we only do equality reactions (simplEqsOnly). So the question is: +are we allowed to do type family interactions? We definitely do not want to apply top-level +family and dictionary instances but what should we do with the constraint set above? + +Suppose that c1 gets processed first and enters the inert. Remember that he will enter a +CtFamHead map with (F Int) as the index. Now c2 comes along, we can't add him to the inert +set since it has exactly the same key, so we'd better react him with the inert c1. In fact +one might think that we should react him anyway to learn that (alpha ~ Bool). This is why +we allow CFunEqCan's to perform reactions with the inerts. + +If we don't allow this, we will try to add both elements to the inert set and will panic! +The relevant example that fails when we don't allow such family reactions is: + + indexed_types/should_compile/T2291.hs + +NB: In previous versions of TcInteract the extra guard (not (isCFunEqCan wi)) was not there +but family reactions were actually happening earlier, during canonicalization. So the behaviour +has not changed -- previously this tricky point was completely lost and worked by accident. + +\begin{code} -------------------------------------------- -data WhichComesFromInert = LeftComesFromInert | RightComesFromInert doInteractWithInert :: Ct -> Ct -> TcS InteractResult -- Identical class constraints. doInteractWithInert - inertItem@(CDictCan { cc_id = d1, cc_flavor = fl1, cc_class = cls1, cc_tyargs = tys1 }) - workItem@(CDictCan { cc_id = _d2, cc_flavor = fl2, cc_class = cls2, cc_tyargs = tys2 }) + inertItem@(CDictCan { cc_flavor = fl1, cc_class = cls1, cc_tyargs = tys1 }) + workItem@(CDictCan { cc_flavor = fl2, cc_class = cls2, cc_tyargs = tys2 }) | cls1 == cls2 = do { let pty1 = mkClassPred cls1 tys1 @@ -772,7 +769,7 @@ doInteractWithInert ; case any_fundeps of -- No Functional Dependencies Nothing - | eqTypes tys1 tys2 -> solveOneFromTheOther "Cls/Cls" (EvId d1,fl1) workItem + | eqTypes tys1 tys2 -> solveOneFromTheOther "Cls/Cls" fl1 workItem | otherwise -> irKeepGoing "NOP" -- Actual Functional Dependencies @@ -782,27 +779,27 @@ doInteractWithInert -> do { emitFDWorkAsDerived fd_work (cc_depth workItem) ; irKeepGoing "Cls/Cls (new fundeps)" } -- Just keep going without droping the inert } - where get_workitem_wloc (Wanted wl) = return wl - get_workitem_wloc (Derived wl) = return wl - get_workitem_wloc (Given {}) = pprPanic "Unexpected given workitem!" $ - vcat [ text "Work item =" <+> ppr workItem - , text "Inert item=" <+> ppr inertItem - ] - --- Two pieces of irreducible evidence: if their types are *exactly identical* we can --- rewrite them. We can never improve using this: if we want ty1 :: Constraint and have --- ty2 :: Constraint it clearly does not mean that (ty1 ~ ty2) -doInteractWithInert (CIrredEvCan { cc_id = id1, cc_flavor = ifl, cc_ty = ty1 }) + where get_workitem_wloc (Wanted wl _) = return wl + get_workitem_wloc (Derived wl _) = return wl + get_workitem_wloc _ = pprPanic "Unexpected given workitem!" $ + vcat [ text "Work item =" <+> ppr workItem + , text "Inert item=" <+> ppr inertItem] + +-- Two pieces of irreducible evidence: if their types are *exactly identical* +-- we can rewrite them. We can never improve using this: +-- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not +-- mean that (ty1 ~ ty2) +doInteractWithInert (CIrredEvCan { cc_flavor = ifl, cc_ty = ty1 }) workItem@(CIrredEvCan { cc_ty = ty2 }) | ty1 `eqType` ty2 - = solveOneFromTheOther "Irred/Irred" (EvId id1,ifl) workItem + = solveOneFromTheOther "Irred/Irred" ifl workItem -- Two implicit parameter constraints. If the names are the same, -- but their types are not, we generate a wanted type equality -- that equates the type (this is "improvement"). -- However, we don't actually need the coercion evidence, -- so we just generate a fresh coercion variable that isn't used anywhere. -doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 }) +doInteractWithInert (CIPCan { cc_flavor = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 }) workItem@(CIPCan { cc_flavor = wfl, cc_ip_nm = nm2, cc_ip_ty = ty2 }) | nm1 == nm2 && isGivenOrSolved wfl && isGivenOrSolved ifl = -- See Note [Overriding implicit parameters] @@ -813,106 +810,136 @@ doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_i irInertConsumed "IP/IP (override inert)" | nm1 == nm2 && ty1 `eqType` ty2 - = solveOneFromTheOther "IP/IP" (EvId id1,ifl) workItem + = solveOneFromTheOther "IP/IP" ifl workItem | nm1 == nm2 = -- See Note [When improvement happens] - do { let flav = Wanted (combineCtLoc ifl wfl) - ; eqv <- newEqVar flav ty2 ty1 -- See Note [Efficient Orientation] - ; when (isNewEvVar eqv) $ - (let ct = CNonCanonical { cc_id = evc_the_evvar eqv - , cc_flavor = flav - , cc_depth = cc_depth workItem } - in updWorkListTcS (extendWorkListEq ct)) - + do { mb_eqv <- newWantedEvVar (mkEqPred ty2 ty1) + -- co :: ty2 ~ ty1, see Note [Efficient orientation] + ; cv <- case mb_eqv of + Fresh eqv -> + do { updWorkListTcS $ extendWorkListEq $ + CNonCanonical { cc_flavor = Wanted new_wloc eqv + , cc_depth = cc_depth workItem } + ; return eqv } + Cached eqv -> return eqv ; case wfl of - Given {} -> pprPanic "Unexpected given IP" (ppr workItem) - Derived {} -> pprPanic "Unexpected derived IP" (ppr workItem) - Wanted {} -> - do { _ <- setEvBind (cc_id workItem) - (mkEvCast id1 (mkTcSymCo (mkTcTyConAppCo (ipTyCon nm1) [mkTcCoVarCo (evc_the_evvar eqv)]))) wfl - ; irWorkItemConsumed "IP/IP (solved by rewriting)" } } - -doInteractWithInert (CFunEqCan { cc_id = eqv1, cc_flavor = fl1, cc_fun = tc1 - , cc_tyargs = args1, cc_rhs = xi1, cc_depth = d1 }) - (CFunEqCan { cc_id = eqv2, cc_flavor = fl2, cc_fun = tc2 - , cc_tyargs = args2, cc_rhs = xi2, cc_depth = d2 }) + Wanted {} -> + let ip_co = mkTcTyConAppCo (ipTyCon nm1) [mkTcCoVarCo cv] + in do { setEvBind (ctId workItem) $ + mkEvCast (flav_evar ifl) (mkTcSymCo ip_co) + ; irWorkItemConsumed "IP/IP (solved by rewriting)" } + _ -> pprPanic "Unexpected IP constraint" (ppr workItem) } + where new_wloc + | Wanted wl _ <- wfl = wl + | Derived wl _ <- wfl = wl + | Wanted wl _ <- ifl = wl + | Derived wl _ <- ifl = wl + | otherwise = panic "Solve IP: no WantedLoc!" + + +doInteractWithInert ii@(CFunEqCan { cc_flavor = fl1, cc_fun = tc1 + , cc_tyargs = args1, cc_rhs = xi1, cc_depth = d1 }) + wi@(CFunEqCan { cc_flavor = fl2, cc_fun = tc2 + , cc_tyargs = args2, cc_rhs = xi2, cc_depth = d2 }) | lhss_match - , Just (GivenSolved {}) <- isGiven_maybe fl1 -- Inert is solved and we can simply ignore it - -- when workitem is given/solved + , isSolved fl1 -- Inert is solved and we can simply ignore it + -- when workitem is given/solved , isGivenOrSolved fl2 = irInertConsumed "FunEq/FunEq" - | lhss_match - , Just (GivenSolved {}) <- isGiven_maybe fl2 -- Workitem is solved and we can ignore it when - -- the inert is given/solved + | lhss_match + , isSolved fl2 -- Workitem is solved and we can ignore it when + -- the inert is given/solved , isGivenOrSolved fl1 = irWorkItemConsumed "FunEq/FunEq" | fl1 `canSolve` fl2 && lhss_match - = do { rewriteEqLHS LeftComesFromInert (eqv1,xi1) (eqv2,d2,fl2,xi2) + = do { traceTcS "interact with inerts: FunEq/FunEq" $ + vcat [ text "workItem =" <+> ppr wi + , text "inertItem=" <+> ppr ii ] + + ; let xev = XEvTerm xcomp xdecomp + -- xcomp : [(xi2 ~ xi1)] -> (F args ~ xi2) + xcomp [x] = EvCoercion (co1 `mkTcTransCo` mk_sym_co x) + xcomp _ = panic "No more goals!" + -- xdecomp : (F args ~ xi2) -> [(xi2 ~ xi1)] + xdecomp x = [EvCoercion (mk_sym_co x `mkTcTransCo` co1)] + + ; xCtFlavor_cache False fl2 [mkTcEqPred xi2 xi1] xev $ what_next d2 + -- Why not simply xCtFlavor? See Note [Cache-caused loops] + -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation] ; irWorkItemConsumed "FunEq/FunEq" } - | fl2 `canSolve` fl1 && lhss_match - = do { rewriteEqLHS RightComesFromInert (eqv2,xi2) (eqv1,d1,fl1,xi1) + = do { traceTcS "interact with inerts: FunEq/FunEq" $ + vcat [ text "workItem =" <+> ppr wi + , text "inertItem=" <+> ppr ii ] + + ; let xev = XEvTerm xcomp xdecomp + -- xcomp : [(xi2 ~ xi1)] -> [(F args ~ xi1)] + xcomp [x] = EvCoercion (co2 `mkTcTransCo` mkTcCoVarCo x) + xcomp _ = panic "No more goals!" + -- xdecomp : (F args ~ xi1) -> [(xi2 ~ xi1)] + xdecomp x = [EvCoercion (mkTcSymCo co2 `mkTcTransCo` mkTcCoVarCo x)] + + ; xCtFlavor_cache False fl1 [mkTcEqPred xi2 xi1] xev $ what_next d1 + -- Why not simply xCtFlavor? See Note [Cache-caused loops] + -- Why not (mkTcEqPred xi1 xi2)? See Note [Efficient orientation] + ; irInertConsumed "FunEq/FunEq"} where lhss_match = tc1 == tc2 && eqTypes args1 args2 + what_next d [new_fl] + = updWorkListTcS $ + extendWorkListEq (CNonCanonical {cc_flavor=new_fl,cc_depth = d}) + what_next _ _ = return () + co1 = mkTcCoVarCo $ flav_evar fl1 + co2 = mkTcCoVarCo $ flav_evar fl2 + mk_sym_co x = mkTcSymCo (mkTcCoVarCo x) + +doInteractWithInert _ _ = irKeepGoing "NOP" +\end{code} -doInteractWithInert _ _ = irKeepGoing "NOP" +Note [Cache-caused loops] +~~~~~~~~~~~~~~~~~~~~~~~~~ +It is very dangerous to cache a rewritten wanted family equation as 'solved' in our +solved cache (which is the default behaviour or xCtFlavor), because the interaction +may not be contributing towards a solution. Here is an example: + +Initial inert set: + [W] g1 : F a ~ beta1 +Work item: + [W] g2 : F a ~ beta2 +The work item will react with the inert yielding the _same_ inert set plus: + i) Will set g2 := g1 `cast` g3 + ii) Will add to our solved cache that [S] g2 : F a ~ beta2 + iii) Will emit [W] g3 : beta1 ~ beta2 +Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2 +and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it +will set + g1 := g ; sym g3 +and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but +remember that we have this in our solved cache, and it is ... g2! In short we +created the evidence loop: + + g2 := g1 ; g3 + g3 := refl + g1 := g2 ; sym g3 + +To avoid this situation we do not cache as solved any workitems (or inert) +which did not really made a 'step' towards proving some goal. Solved's are +just an optimization so we don't lose anything in terms of completeness of +solving. +\begin{code} -rewriteEqLHS :: WhichComesFromInert -> (EqVar,Xi) -> (EqVar,SubGoalDepth,CtFlavor,Xi) -> TcS () --- Used to ineract two equalities of the following form: --- First Equality: co1: (XXX ~ xi1) --- Second Equality: cv2: (XXX ~ xi2) --- Where the cv1 `canRewrite` cv2 equality --- We have an option of creating new work (xi1 ~ xi2) OR (xi2 ~ xi1), --- See Note [Efficient Orientation] for that -rewriteEqLHS LeftComesFromInert (eqv1,xi1) (eqv2,d,gw,xi2) - = do { delCachedEvVar eqv2 gw -- Similarly to canonicalization! - ; evc <- newEqVar gw xi2 xi1 - ; let eqv2' = evc_the_evvar evc - ; gw' <- case gw of - Wanted {} - -> setEqBind eqv2 - (mkTcCoVarCo eqv1 `mkTcTransCo` mkTcSymCo (mkTcCoVarCo eqv2')) gw - Given {} - -> setEqBind eqv2' - (mkTcSymCo (mkTcCoVarCo eqv2) `mkTcTransCo` mkTcCoVarCo eqv1) gw - Derived {} - -> return gw - ; when (isNewEvVar evc) $ - updWorkListTcS (extendWorkListEq (CNonCanonical { cc_id = eqv2' - , cc_flavor = gw' - , cc_depth = d } ) ) } - -rewriteEqLHS RightComesFromInert (eqv1,xi1) (eqv2,d,gw,xi2) - = do { delCachedEvVar eqv2 gw -- Similarly to canonicalization! - ; evc <- newEqVar gw xi1 xi2 - ; let eqv2' = evc_the_evvar evc - ; gw' <- case gw of - Wanted {} - -> setEqBind eqv2 - (mkTcCoVarCo eqv1 `mkTcTransCo` mkTcCoVarCo eqv2') gw - Given {} - -> setEqBind eqv2' - (mkTcSymCo (mkTcCoVarCo eqv1) `mkTcTransCo` mkTcCoVarCo eqv2) gw - Derived {} - -> return gw - - ; when (isNewEvVar evc) $ - updWorkListTcS (extendWorkListEq (CNonCanonical { cc_id = eqv2' - , cc_flavor = gw' - , cc_depth = d } ) ) } - -solveOneFromTheOther :: String -- Info - -> (EvTerm, CtFlavor) -- Inert +solveOneFromTheOther :: String -- Info + -> CtFlavor -- Inert -> Ct -- WorkItem -> TcS InteractResult -- Preconditions: -- 1) inert and work item represent evidence for the /same/ predicate -- 2) ip/class/irred evidence (no coercions) only -solveOneFromTheOther info (ev_term,ifl) workItem +solveOneFromTheOther info ifl workItem | isDerived wfl = irWorkItemConsumed ("Solved[DW] " ++ info) @@ -921,20 +948,21 @@ solveOneFromTheOther info (ev_term,ifl) workItem -- so it's safe to continue on from this point = irInertConsumed ("Solved[DI] " ++ info) - | Just (GivenSolved {}) <- isGiven_maybe ifl, isGivenOrSolved wfl + | isSolved ifl, isGivenOrSolved wfl -- Same if the inert is a GivenSolved -- just get rid of it = irInertConsumed ("Solved[SI] " ++ info) | otherwise = ASSERT( ifl `canSolve` wfl ) -- Because of Note [The Solver Invariant], plus Derived dealt with - do { when (isWanted wfl) $ do { _ <- setEvBind wid ev_term wfl; return () } + do { when (isWanted wfl) $ setEvBind wid (EvId iid) -- Overwrite the binding, if one exists -- If both are Given, we already have evidence; no need to duplicate ; irWorkItemConsumed ("Solved " ++ info) } where wfl = cc_flavor workItem - wid = cc_id workItem + wid = ctId workItem + iid = flav_evar ifl \end{code} @@ -1332,18 +1360,17 @@ instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs = let sty1 = Type.substTy subst ty1 sty2 = Type.substTy subst ty2 in if eqType sty1 sty2 then return ievs -- Return no trivial equalities - else do { eqv <- newEqVar (Derived wl) sty1 sty2 -- Create derived or cached by deriveds - ; let wl' = push_ctx wl - ; if isNewEvVar eqv then - return $ (i,(evc_the_evvar eqv,wl')):ievs - else -- We are eventually going to emit FD work back in the work list so + else do { mb_eqv <- newWantedEvVar (mkTcEqPred sty1 sty2) + ; case mb_eqv of + Fresh eqv -> return $ (i,(eqv, push_ctx wl)):ievs + Cached {} -> return ievs } + -- We are eventually going to emit FD work back in the work list so -- it is important that we only return the /freshly created/ and not -- some existing equality! - return ievs } - push_ctx :: WantedLoc -> WantedLoc push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc + mkEqnMsg :: (TcPredType, SDoc) -> (TcPredType, SDoc) -> TidyEnv -> TcM (TidyEnv, SDoc) mkEqnMsg (pred1,from1) (pred2,from2) tidy_env @@ -1379,9 +1406,9 @@ emitFDWorkAsDerived :: [(EvVar,WantedLoc)] emitFDWorkAsDerived evlocs d = updWorkListTcS $ appendWorkListEqs fd_cts where fd_cts = map mk_fd_ct evlocs - mk_fd_ct (v,wl) = CNonCanonical { cc_id = v - , cc_flavor = Derived wl - , cc_depth = d } + mk_fd_ct (v,wl) + = CNonCanonical { cc_flavor = Derived wl (evVarPred v) + , cc_depth = d } \end{code} @@ -1406,18 +1433,20 @@ tryTopReact :: WorkItem -> TcS StopOrContinue tryTopReact wi = do { inerts <- getTcSInerts ; ctxt <- getTcSContext - ; if simplEqsOnly ctxt then return (ContinueWith wi) -- or Stop? + ; if simplEqsOnly ctxt then + return (ContinueWith wi) else - do { tir <- doTopReact inerts wi - ; case tir of - NoTopInt - -> return (ContinueWith wi) - SomeTopInt rule what_next - -> do { bumpStepCountTcS - ; traceFireTcS (cc_depth wi) $ - ptext (sLit "Top react:") <+> text rule - ; return what_next } - } } + do { tir <- doTopReact inerts wi + ; case tir of + NoTopInt + -> return (ContinueWith wi) + SomeTopInt rule what_next + -> do { bumpStepCountTcS + ; traceFireTcS (cc_depth wi) $ + vcat [ ptext (sLit "Top react:") <+> text rule + , text "WorkItem =" <+> ppr wi ] + ; return what_next } + } } data TopInteractResult = NoTopInt @@ -1439,7 +1468,7 @@ doTopReact _inerts (CDictCan { cc_flavor = Given {} }) = return NoTopInt -- NB: Superclasses already added since it's canonical -- Derived dictionary: just look for functional dependencies -doTopReact _inerts workItem@(CDictCan { cc_flavor = Derived loc +doTopReact _inerts workItem@(CDictCan { cc_flavor = Derived loc _pty , cc_class = cls, cc_tyargs = xis }) = do { instEnvs <- getInstEnvs ; let fd_eqns = improveFromInstEnv instEnvs @@ -1449,7 +1478,7 @@ doTopReact _inerts workItem@(CDictCan { cc_flavor = Derived loc Nothing -> return NoTopInt Just (xis',_,fd_work) -> let workItem' = workItem { cc_tyargs = xis' } - -- Deriveds are not supposed to have identity (cc_id is unused!) + -- Deriveds are not supposed to have identity in do { emitFDWorkAsDerived fd_work (cc_depth workItem) ; return $ SomeTopInt { tir_rule = "Derived Cls fundeps" @@ -1457,8 +1486,7 @@ doTopReact _inerts workItem@(CDictCan { cc_flavor = Derived loc } -- Wanted dictionary -doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc) - , cc_id = dict_id +doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc dict_id) , cc_class = cls, cc_tyargs = xis , cc_depth = depth }) -- See Note [MATCHING-SYNONYMS] @@ -1474,7 +1502,9 @@ doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc) do { lkup_inst_res <- matchClassInst inerts cls xis loc ; case lkup_inst_res of GenInst wtvs ev_term - -> doSolveFromInstance wtvs ev_term + -> let sfl = Solved (mkSolvedLoc loc UnkSkol) dict_id + in addToSolved (workItem { cc_flavor = sfl }) >> + doSolveFromInstance wtvs ev_term NoInstance -> return NoTopInt } @@ -1485,94 +1515,144 @@ doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc) , tir_new_item = ContinueWith workItem } } } where doSolveFromInstance :: [EvVar] -> EvTerm -> TcS TopInteractResult - -- Precondition: evidence term matches the predicate of cc_id of workItem + -- Precondition: evidence term matches the predicate workItem doSolveFromInstance evs ev_term | null evs - = do { traceTcS "doTopReact/found nullary instance for" (ppr dict_id) - ; _ <- setEvBind dict_id ev_term fl + = do { traceTcS "doTopReact/found nullary instance for" $ + ppr dict_id + ; setEvBind dict_id ev_term ; return $ SomeTopInt { tir_rule = "Dict/Top (solved, no new work)" - , tir_new_item = Stop } } -- Don't put him in the inerts + , tir_new_item = Stop } } | otherwise - = do { traceTcS "doTopReact/found non-nullary instance for" (ppr dict_id) - ; _ <- setEvBind dict_id ev_term fl - -- Solved and new wanted work produced, you may cache the - -- (tentatively solved) dictionary as Solved given. --- ; let _solved = workItem { cc_flavor = solved_fl } --- solved_fl = mkSolvedFlavor fl UnkSkol + = do { traceTcS "doTopReact/found non-nullary instance for" $ + ppr dict_id + ; setEvBind dict_id ev_term ; let mk_new_wanted ev - = CNonCanonical { cc_id = ev, cc_flavor = fl + = CNonCanonical { cc_flavor = fl { flav_evar = ev } , cc_depth = depth + 1 } ; updWorkListTcS (appendWorkListCt (map mk_new_wanted evs)) ; return $ SomeTopInt { tir_rule = "Dict/Top (solved, more work)" , tir_new_item = Stop } } --- , tir_new_item = ContinueWith solved } } -- Cache in inerts the Solved item -- Type functions doTopReact _inerts (CFunEqCan { cc_flavor = fl }) - | Just (GivenSolved {}) <- isGiven_maybe fl + | isSolved fl = return NoTopInt -- If Solved, no more interactions should happen -- Otherwise, it's a Given, Derived, or Wanted -doTopReact _inerts workItem@(CFunEqCan { cc_id = eqv, cc_flavor = fl +doTopReact _inerts workItem@(CFunEqCan { cc_flavor = fl, cc_depth = d , cc_fun = tc, cc_tyargs = args, cc_rhs = xi }) - = ASSERT (isSynFamilyTyCon tc) -- No associated data families have reached that far + = ASSERT (isSynFamilyTyCon tc) -- No associated data families have reached that far do { match_res <- matchFam tc args -- See Note [MATCHING-SYNONYMS] ; case match_res of Nothing -> return NoTopInt Just (famInst, rep_tys) - -> do { let coe_ax = famInstAxiom famInst - rhs_ty = mkAxInstRHS coe_ax rep_tys - coe = mkTcAxInstCo coe_ax rep_tys - ; case fl of - Wanted {} -> do { evc <- newEqVar fl rhs_ty xi -- Wanted version - ; let eqv' = evc_the_evvar evc - ; let coercion = coe `mkTcTransCo` mkTcCoVarCo eqv' - ; _ <- setEqBind eqv coercion fl - ; when (isNewEvVar evc) $ - (let ct = CNonCanonical { cc_id = eqv' - , cc_flavor = fl - , cc_depth = cc_depth workItem + 1} - in updWorkListTcS (extendWorkListEq ct)) - - ; let _solved = workItem { cc_flavor = solved_fl } - solved_fl = mkSolvedFlavor fl UnkSkol (EvCoercion coercion) - - ; updateFlatCache eqv solved_fl tc args xi WhenSolved - - ; return $ - SomeTopInt { tir_rule = "Fun/Top (solved, more work)" - , tir_new_item = Stop } } - -- , tir_new_item = ContinueWith solved } } - -- Cache in inerts the Solved item - - Given {} -> do { (fl',eqv') <- newGivenEqVar fl xi rhs_ty $ - mkTcSymCo (mkTcCoVarCo eqv) `mkTcTransCo` coe - ; let ct = CNonCanonical { cc_id = eqv' - , cc_flavor = fl' - , cc_depth = cc_depth workItem + 1} - ; updWorkListTcS (extendWorkListEq ct) - ; return $ - SomeTopInt { tir_rule = "Fun/Top (given)" - , tir_new_item = ContinueWith workItem } } - Derived {} -> do { evc <- newEvVar fl (mkTcEqPred xi rhs_ty) - ; let eqv' = evc_the_evvar evc - ; when (isNewEvVar evc) $ - (let ct = CNonCanonical { cc_id = eqv' - , cc_flavor = fl - , cc_depth = cc_depth workItem + 1 } - in updWorkListTcS (extendWorkListEq ct)) - ; return $ - SomeTopInt { tir_rule = "Fun/Top (derived)" - , tir_new_item = Stop } } - } - } - - + -> do { mb_already_solved <- lkpFunEqCache (mkTyConApp tc args) + ; traceTcS "doTopReact: Family instance matches" $ + vcat [ text "solved-fun-cache" <+> if isJust mb_already_solved then text "hit" else text "miss" + , text "workItem =" <+> ppr workItem ] + ; let (coe,rhs_ty) + | Just cached_ct <- mb_already_solved + = (mkTcCoVarCo (ctId cached_ct), + cc_rhs cached_ct) + | otherwise + = let coe_ax = famInstAxiom famInst + in (mkTcAxInstCo coe_ax rep_tys, + mkAxInstRHS coe_ax rep_tys) + + xdecomp x = [EvCoercion (mkTcSymCo coe `mkTcTransCo` mkTcCoVarCo x)] + xcomp [x] = EvCoercion (coe `mkTcTransCo` mkTcCoVarCo x) + xcomp _ = panic "No more goals!" + + xev = XEvTerm xcomp xdecomp + ; xCtFlavor fl [mkTcEqPred rhs_ty xi] xev what_next } } + where what_next [ct_flav] + = do { updWorkListTcS $ + extendWorkListEq (CNonCanonical { cc_flavor = ct_flav + , cc_depth = d+1 }) + ; cache_in_solved fl + ; return $ SomeTopInt { tir_rule = "Fun/Top" + , tir_new_item = Stop } } + what_next _ -- No subgoal (because it's cached) + = do { cache_in_solved fl + ; return $ SomeTopInt { tir_rule = "Fun/Top" + , tir_new_item = Stop } } + + cache_in_solved (Derived {}) = return () + cache_in_solved (Wanted wl ev) = + let sfl = Solved (mkSolvedLoc wl UnkSkol) ev + solved = workItem { cc_flavor = sfl } + in updFunEqCache solved >> addToSolved solved + cache_in_solved fl = + let sfl = Solved (flav_gloc fl) (flav_evar fl) + solved = workItem { cc_flavor = sfl } + in updFunEqCache solved >> addToSolved solved + -- Any other work item does not react with any top-level equations doTopReact _inerts _workItem = return NoTopInt + + +lkpFunEqCache :: TcType -> TcS (Maybe Ct) +lkpFunEqCache fam_head + = do { (subst,_inscope) <- getInertEqs + ; fun_cache <- getTcSInerts >>= (return . inert_solved_funeqs) + ; traceTcS "lkpFunEqCache" $ vcat [ text "fam_head =" <+> ppr fam_head + , text "funeq cache =" <+> pprCtTypeMap (unCtFamHeadMap fun_cache) ] + ; rewrite_cached $ + lookupTypeMap_mod subst cc_rhs fam_head (unCtFamHeadMap fun_cache) } + where rewrite_cached Nothing = return Nothing + rewrite_cached (Just ct@(CFunEqCan { cc_flavor = fl, cc_depth = d + , cc_fun = tc, cc_tyargs = xis + , cc_rhs = xi})) + = ASSERT (isSolved fl) + do { (xis_subst,cos) <- flattenMany d fl xis + -- cos :: xis_subst ~ xis + ; (xi_subst,co) <- flatten d fl xi + -- co :: xi_subst ~ xi + ; let flat_fam_head = mkTyConApp tc xis_subst + + ; unless (flat_fam_head `eqType` fam_head) $ + pprPanic "lkpFunEqCache" (vcat [ text "Cached (solved) constraint =" <+> ppr ct + , text "Flattened constr. head =" <+> ppr flat_fam_head ]) + ; traceTcS "lkpFunEqCache" $ text "Flattened constr. rhs = " <+> ppr xi_subst + + + ; let new_pty = mkTcEqPred (mkTyConApp tc xis_subst) xi_subst + new_co = mkTcTyConAppCo eqTyCon [ mkTcReflCo (defaultKind $ typeKind xi_subst) + , mkTcTyConAppCo tc cos + , co ] + -- new_co :: (F xis_subst ~ xi_subst) ~ (F xis ~ xi) + -- new_co = (~) <k> (F cos) co + ; new_fl <- rewriteCtFlavor fl new_pty new_co + ; case new_fl of + Nothing + -> return Nothing -- Strange: cached? + Just fl' + -> return $ + Just (CFunEqCan { cc_flavor = fl' + , cc_depth = d + , cc_fun = tc + , cc_tyargs = xis_subst + , cc_rhs = xi_subst }) } + rewrite_cached (Just other_ct) + = pprPanic "lkpFunEqCache:not family equation!" $ ppr other_ct + +updFunEqCache :: Ct -> TcS () +updFunEqCache fun_eq@(CFunEqCan { cc_fun = tc, cc_tyargs = xis }) + = modifyInertTcS $ \inert -> ((), upd_inert inert) + where upd_inert inert + = let slvd = unCtFamHeadMap (inert_solved_funeqs inert) + in inert { inert_solved_funeqs = + CtFamHeadMap (alterTM key upd_funeqs slvd) } + upd_funeqs Nothing = Just fun_eq + upd_funeqs (Just _ct) = Just fun_eq + -- Or _ct? depends on which caches more steps of computation + key = mkTyConApp tc xis +updFunEqCache other = pprPanic "updFunEqCache:Non family equation" $ ppr other + \end{code} @@ -1791,6 +1871,9 @@ matchClassInst inerts clas tys loc = do { let pred = mkClassPred clas tys ; mb_result <- matchClass clas tys ; untch <- getUntouchables + ; traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr pred + , text "inerts=" <+> ppr inerts + , text "untouchables=" <+> ppr untch ] ; case mb_result of MatchInstNo -> return NoInstance MatchInstMany -> return NoInstance -- defer any reactions of a multitude until @@ -1817,23 +1900,25 @@ matchClassInst inerts clas tys loc ; if null theta then return (GenInst [] (EvDFunApp dfun_id tys [])) else do - { evc_vars <- instDFunConstraints theta (Wanted loc) - ; let ev_vars = map evc_the_evvar evc_vars - new_ev_vars = [evc_the_evvar evc | evc <- evc_vars, isNewEvVar evc] + { evc_vars <- instDFunConstraints theta + ; let ev_vars = map mn_thing evc_vars + new_ev_vars = [mn_thing evc | evc <- evc_vars + , isFresh evc ] -- new_ev_vars are only the real new variables that can be emitted - ; return $ GenInst new_ev_vars (EvDFunApp dfun_id tys ev_vars) } - } + ; return $ GenInst new_ev_vars (EvDFunApp dfun_id tys ev_vars) } } } where givens_for_this_clas :: Cts givens_for_this_clas - = lookupUFM (cts_given (inert_dicts inerts)) clas `orElse` emptyCts + = lookupUFM (cts_given (inert_dicts $ inert_cans inerts)) clas + `orElse` emptyCts given_overlap :: TcsUntouchables -> Bool given_overlap untch = anyBag (matchable untch) givens_for_this_clas - matchable untch (CDictCan { cc_class = clas_g, cc_tyargs = sys, cc_flavor = fl }) - | Just GivenOrig <- isGiven_maybe fl + matchable untch (CDictCan { cc_class = clas_g, cc_tyargs = sys + , cc_flavor = fl }) + | isGiven fl = ASSERT( clas_g == clas ) case tcUnifyTys (\tv -> if isTouchableMetaTyVar_InRange untch tv && tv `elemVarSet` tyVarsOfTypes tys diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 82c465c6e0..a8460afef1 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -686,18 +686,29 @@ zonkWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol }) zonkCt :: Ct -> TcM Ct -- Zonking a Ct conservatively gives back a CNonCanonical zonkCt ct - = do { v' <- zonkEvVar (cc_id ct) - ; fl' <- zonkFlavor (cc_flavor ct) + = do { fl' <- zonkFlavor (cc_flavor ct) ; return $ - CNonCanonical { cc_id = v' - , cc_flavor = fl' + CNonCanonical { cc_flavor = fl' , cc_depth = cc_depth ct } } zonkCts :: Cts -> TcM Cts zonkCts = mapBagM zonkCt zonkFlavor :: CtFlavor -> TcM CtFlavor -zonkFlavor (Given loc gk) = do { loc' <- zonkGivenLoc loc; return (Given loc' gk) } -zonkFlavor fl = return fl +zonkFlavor (Given loc evar) + = do { loc' <- zonkGivenLoc loc + ; evar' <- zonkEvVar evar + ; return (Given loc' evar') } +zonkFlavor (Solved loc evar) + = do { loc' <- zonkGivenLoc loc + ; evar' <- zonkEvVar evar + ; return (Solved loc' evar') } +zonkFlavor (Wanted loc evar) + = do { evar' <- zonkEvVar evar + ; return (Wanted loc evar') } +zonkFlavor (Derived loc pty) + = do { pty' <- zonkTcType pty + ; return (Derived loc pty') } + zonkGivenLoc :: GivenLoc -> TcM GivenLoc -- GivenLocs may have unification variables inside them! @@ -897,32 +908,42 @@ checkValidType :: UserTypeCtxt -> Type -> TcM () checkValidType ctxt ty = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (typeKind ty)) ; unboxed <- xoptM Opt_UnboxedTuples - ; rank2 <- xoptM Opt_Rank2Types - ; rankn <- xoptM Opt_RankNTypes + ; rank2_flag <- xoptM Opt_Rank2Types + ; rankn_flag <- xoptM Opt_RankNTypes ; polycomp <- xoptM Opt_PolymorphicComponents ; constraintKinds <- xoptM Opt_ConstraintKinds - ; let gen_rank n | rankn = ArbitraryRank - | rank2 = Rank 2 - | otherwise = Rank n - rank + ; let gen_rank :: Rank -> Rank + gen_rank r | rankn_flag = ArbitraryRank + | rank2_flag = r2 + | otherwise = r + + rank2 = gen_rank r2 + rank1 = gen_rank r1 + rank0 = gen_rank r0 + + r0 = rankZeroMonoType + r1 = LimitedRank True r0 + r2 = LimitedRank True r1 + + rank = case ctxt of DefaultDeclCtxt-> MustBeMonoType ResSigCtxt -> MustBeMonoType - LamPatSigCtxt -> gen_rank 0 - BindPatSigCtxt -> gen_rank 0 - TySynCtxt _ -> gen_rank 0 + LamPatSigCtxt -> rank0 + BindPatSigCtxt -> rank0 + TySynCtxt _ -> rank0 - ExprSigCtxt -> gen_rank 1 - FunSigCtxt _ -> gen_rank 1 + ExprSigCtxt -> rank1 + FunSigCtxt _ -> rank1 InfSigCtxt _ -> ArbitraryRank -- Inferred type - ConArgCtxt _ | polycomp -> gen_rank 2 + ConArgCtxt _ | polycomp -> rank2 -- We are given the type of the entire -- constructor, hence rank 1 - | otherwise -> gen_rank 1 + | otherwise -> rank1 - ForSigCtxt _ -> gen_rank 1 - SpecInstCtxt -> gen_rank 1 - ThBrackCtxt -> gen_rank 1 + ForSigCtxt _ -> rank1 + SpecInstCtxt -> rank1 + ThBrackCtxt -> rank1 GhciCtxt -> ArbitraryRank _ -> panic "checkValidType" -- Can't happen; not used for *user* sigs @@ -960,23 +981,38 @@ checkValidMonoType :: Type -> TcM () checkValidMonoType ty = check_mono_type MustBeMonoType ty \end{code} +Note [Higher rank types] +~~~~~~~~~~~~~~~~~~~~~~~~ +Technically + Int -> forall a. a->a +is still a rank-1 type, but it's not Haskell 98 (Trac #5957). So the +validity checker allow a forall after an arrow only if we allow it +before -- that is, with Rank2Types or RankNTypes \begin{code} data Rank = ArbitraryRank -- Any rank ok - | MustBeMonoType -- Monotype regardless of flags - | TyConArgMonoType -- Monotype but could be poly if -XImpredicativeTypes - | SynArgMonoType -- Monotype but could be poly if -XLiberalTypeSynonyms - | Rank Int -- Rank n, but could be more with -XRankNTypes -decRank :: Rank -> Rank -- Function arguments -decRank (Rank 0) = Rank 0 -decRank (Rank n) = Rank (n-1) -decRank other_rank = other_rank + | LimitedRank -- Note [Higher rank types] + Bool -- Forall ok at top + Rank -- Use for function arguments -nonZeroRank :: Rank -> Bool -nonZeroRank ArbitraryRank = True -nonZeroRank (Rank n) = n>0 -nonZeroRank _ = False + | MonoType SDoc -- Monotype, with a suggestion of how it could be a polytype + + | MustBeMonoType -- Monotype regardless of flags + +rankZeroMonoType, tyConArgMonoType, synArgMonoType :: Rank +rankZeroMonoType = MonoType (ptext (sLit "Perhaps you intended to use -XRankNTypes or -XRank2Types")) +tyConArgMonoType = MonoType (ptext (sLit "Perhaps you intended to use -XImpredicativeTypes")) +synArgMonoType = MonoType (ptext (sLit "Perhaps you intended to use -XLiberalTypeSynonyms")) + +funArgResRank :: Rank -> (Rank, Rank) -- Function argument and result +funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) +funArgResRank other_rank = (other_rank, other_rank) + +forAllAllowed :: Rank -> Bool +forAllAllowed ArbitraryRank = True +forAllAllowed (LimitedRank forall_ok _) = forall_ok +forAllAllowed _ = False ---------------------------------------- data UbxTupFlag = UT_Ok | UT_NotOk @@ -1000,7 +1036,7 @@ check_type :: Rank -> UbxTupFlag -> Type -> TcM () check_type rank ubx_tup ty | not (null tvs && null theta) - = do { checkTc (nonZeroRank rank) (forAllTyErr rank ty) + = do { checkTc (forAllAllowed rank) (forAllTyErr rank ty) -- Reject e.g. (Maybe (?x::Int => Int)), -- with a decent error message ; check_valid_theta SigmaCtxt theta @@ -1012,8 +1048,10 @@ check_type rank ubx_tup ty check_type _ _ (TyVarTy _) = return () check_type rank _ (FunTy arg_ty res_ty) - = do { check_type (decRank rank) UT_NotOk arg_ty - ; check_type rank UT_Ok res_ty } + = do { check_type arg_rank UT_NotOk arg_ty + ; check_type res_rank UT_Ok res_ty } + where + (arg_rank, res_rank) = funArgResRank rank check_type rank _ (AppTy ty1 ty2) = do { check_arg_type rank ty1 @@ -1033,7 +1071,7 @@ check_type rank ubx_tup ty@(TyConApp tc tys) ; liberal <- xoptM Opt_LiberalTypeSynonyms ; if not liberal || isSynFamilyTyCon tc then -- For H98 and synonym families, do check the type args - mapM_ (check_mono_type SynArgMonoType) tys + mapM_ (check_mono_type synArgMonoType) tys else -- In the liberal case (only for closed syns), expand then check case tcView ty of @@ -1046,7 +1084,7 @@ check_type rank ubx_tup ty@(TyConApp tc tys) ; checkTc (ubx_tup_ok ub_tuples_allowed) ubx_tup_msg ; impred <- xoptM Opt_ImpredicativeTypes - ; let rank' = if impred then ArbitraryRank else TyConArgMonoType + ; let rank' = if impred then ArbitraryRank else tyConArgMonoType -- c.f. check_arg_type -- However, args are allowed to be unlifted, or -- more unboxed tuples, so can't use check_arg_ty @@ -1097,7 +1135,7 @@ check_arg_type rank ty ; let rank' = case rank of -- Predictive => must be monotype MustBeMonoType -> MustBeMonoType -- Monotype, regardless _other | impred -> ArbitraryRank - | otherwise -> TyConArgMonoType + | otherwise -> tyConArgMonoType -- Make sure that MustBeMonoType is propagated, -- so that we don't suggest -XImpredicativeTypes in -- (Ord (forall a.a)) => a -> a @@ -1117,10 +1155,9 @@ forAllTyErr rank ty , suggestion ] where suggestion = case rank of - Rank _ -> ptext (sLit "Perhaps you intended to use -XRankNTypes or -XRank2Types") - TyConArgMonoType -> ptext (sLit "Perhaps you intended to use -XImpredicativeTypes") - SynArgMonoType -> ptext (sLit "Perhaps you intended to use -XLiberalTypeSynonyms") - _ -> empty -- Polytype is always illegal + LimitedRank {} -> ptext (sLit "Perhaps you intended to use -XRankNTypes or -XRank2Types") + MonoType d -> d + _ -> empty -- Polytype is always illegal unliftedArgErr, ubxArgTyErr :: Type -> SDoc unliftedArgErr ty = sep [ptext (sLit "Illegal unlifted type:"), ppr ty] diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 3816984dc2..0128f1809e 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -339,6 +339,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Just discard the auxiliary bindings; they are generated -- only for Haskell source code, and should already be in Core tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ; + safe_mode <- liftIO $ finalSafeMode (hsc_dflags hsc_env) tcg_env ; dep_files <- liftIO $ readIORef (tcg_dependent_files tcg_env) ; setGblEnv tcg_env $ do { @@ -366,20 +367,21 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) 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, + 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, + 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_safe_haskell = safe_mode, + mg_trust_pkg = False, mg_dependent_files = dep_files } } ; diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 1d8bdd763f..0d20be2949 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -1112,8 +1112,17 @@ setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s }) %************************************************************************ \begin{code} +-- | Mark that safe inference has failed recordUnsafeInfer :: TcM () recordUnsafeInfer = getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) False + +-- | Figure out the final correct safe haskell mode +finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode +finalSafeMode dflags tcg_env = do + safeInf <- readIORef (tcg_safeInfer tcg_env) + return $ if safeInferOn dflags && not safeInf + then Sf_None + else safeHaskell dflags \end{code} diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index e19ca3574d..f480bab3fa 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -52,12 +52,12 @@ module TcRnTypes( -- Canonical constraints Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, - singleCt, extendCts, isEmptyCts, isCTyEqCan, + singleCt, extendCts, isEmptyCts, isCTyEqCan, isCFunEqCan, isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe, isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt, - isGivenCt_maybe, isGivenOrSolvedCt, + isGivenCt, isGivenOrSolvedCt, ctWantedLoc, - SubGoalDepth, mkNonCanonical, ctPred, + SubGoalDepth, mkNonCanonical, ctPred, ctFlavPred, ctId, ctFlavId, WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, andWC, addFlats, addImplics, mkFlatWC, @@ -65,16 +65,15 @@ module TcRnTypes( Implication(..), CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin, CtOrigin(..), EqOrigin(..), - WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt, + WantedLoc, GivenLoc, pushErrCtxt, pushErrCtxtSameOrigin, SkolemInfo(..), - CtFlavor(..), pprFlavorArising, - mkSolvedFlavor, mkGivenFlavor, mkWantedFlavor, - isWanted, isGivenOrSolved, isGiven_maybe, isSolved, - isDerived, getWantedLoc, canSolve, canRewrite, - combineCtLoc, + CtFlavor(..), pprFlavorArising, + mkSolvedLoc, mkGivenLoc, + isWanted, isGivenOrSolved, isGiven, isSolved, + isDerived, getWantedLoc, getGivenLoc, canSolve, canRewrite, -- Pretty printing pprEvVarTheta, pprWantedsWithLocs, @@ -90,7 +89,7 @@ module TcRnTypes( import HsSyn import HscTypes -import TcEvidence( EvBind, EvBindsVar, EvTerm ) +import TcEvidence( EvBind, EvBindsVar ) import Type import Class ( Class ) import TyCon ( TyCon ) @@ -846,7 +845,6 @@ type SubGoalDepth = Int -- An ever increasing number used to restrict data Ct -- Atomic canonical constraints = CDictCan { -- e.g. Num xi - cc_id :: EvVar, cc_flavor :: CtFlavor, cc_class :: Class, cc_tyargs :: [Xi], @@ -857,7 +855,6 @@ data Ct | CIPCan { -- ?x::tau -- See note [Canonical implicit parameter constraints]. - cc_id :: EvVar, cc_flavor :: CtFlavor, cc_ip_nm :: IPName Name, cc_ip_ty :: TcTauType, -- Not a Xi! See same not as above @@ -865,7 +862,6 @@ data Ct } | CIrredEvCan { -- These stand for yet-unknown predicates - cc_id :: EvVar, cc_flavor :: CtFlavor, cc_ty :: Xi, -- cc_ty is flat hence it may only be of the form (tv xi1 xi2 ... xin) -- Since, if it were a type constructor application, that'd make the @@ -880,7 +876,6 @@ data Ct -- * typeKind xi `compatKind` typeKind tv -- See Note [Spontaneous solving and kind compatibility] -- * We prefer unification variables on the left *JUST* for efficiency - cc_id :: EvVar, cc_flavor :: CtFlavor, cc_tyvar :: TcTyVar, cc_rhs :: Xi, @@ -891,7 +886,6 @@ data Ct | CFunEqCan { -- F xis ~ xi -- Invariant: * isSynFamilyTyCon cc_fun -- * typeKind (F xis) `compatKind` typeKind xi - cc_id :: EvVar, cc_flavor :: CtFlavor, cc_fun :: TyCon, -- A type function cc_tyargs :: [Xi], -- Either under-saturated or exactly saturated @@ -903,7 +897,6 @@ data Ct } | CNonCanonical { -- See Note [NonCanonical Semantics] - cc_id :: EvVar, cc_flavor :: CtFlavor, cc_depth :: SubGoalDepth } @@ -911,11 +904,11 @@ data Ct \end{code} \begin{code} -mkNonCanonical :: EvVar -> CtFlavor -> Ct -mkNonCanonical ev flav = CNonCanonical { cc_id = ev, cc_flavor = flav, cc_depth = 0} +mkNonCanonical :: CtFlavor -> Ct +mkNonCanonical flav = CNonCanonical { cc_flavor = flav, cc_depth = 0} ctPred :: Ct -> PredType -ctPred (CNonCanonical { cc_id = v }) = evVarPred v +ctPred (CNonCanonical { cc_flavor = fl }) = ctFlavPred fl ctPred (CDictCan { cc_class = cls, cc_tyargs = xis }) = mkClassPred cls xis ctPred (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) @@ -925,6 +918,12 @@ ctPred (CFunEqCan { cc_fun = fn, cc_tyargs = xis1, cc_rhs = xi2 }) ctPred (CIPCan { cc_ip_nm = nm, cc_ip_ty = xi }) = mkIPPred nm xi ctPred (CIrredEvCan { cc_ty = xi }) = xi + + +ctId :: Ct -> EvVar +-- Precondition: not a derived! +ctId ct = ctFlavId (cc_flavor ct) + \end{code} @@ -942,16 +941,16 @@ ctWantedLoc ct = ASSERT2( not (isGivenOrSolved (cc_flavor ct)), ppr ct ) getWantedLoc (cc_flavor ct) isWantedCt :: Ct -> Bool -isWantedCt ct = isWanted (cc_flavor ct) +isWantedCt = isWanted . cc_flavor -isDerivedCt :: Ct -> Bool -isDerivedCt ct = isDerived (cc_flavor ct) +isGivenCt :: Ct -> Bool +isGivenCt = isGiven . cc_flavor -isGivenCt_maybe :: Ct -> Maybe GivenKind -isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct) +isDerivedCt :: Ct -> Bool +isDerivedCt = isDerived . cc_flavor isGivenOrSolvedCt :: Ct -> Bool -isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct) +isGivenOrSolvedCt = isGivenOrSolved . cc_flavor isCTyEqCan :: Ct -> Bool isCTyEqCan (CTyEqCan {}) = True @@ -974,6 +973,10 @@ isCFunEqCan_Maybe :: Ct -> Maybe TyCon isCFunEqCan_Maybe (CFunEqCan { cc_fun = tc }) = Just tc isCFunEqCan_Maybe _ = Nothing +isCFunEqCan :: Ct -> Bool +isCFunEqCan (CFunEqCan {}) = True +isCFunEqCan _ = False + isCNonCanonical :: Ct -> Bool isCNonCanonical (CNonCanonical {}) = True isCNonCanonical _ = False @@ -981,11 +984,9 @@ isCNonCanonical _ = False \begin{code} instance Outputable Ct where - ppr ct = ppr (cc_flavor ct) <> braces (ppr (cc_depth ct)) - <+> ppr ev_var <+> dcolon <+> ppr (ctPred ct) - <+> parens (text ct_sort) - where ev_var = cc_id ct - ct_sort = case ct of + ppr ct = ppr (cc_flavor ct) <+> + braces (ppr (cc_depth ct)) <+> parens (text ct_sort) + where ct_sort = case ct of CTyEqCan {} -> "CTyEqCan" CFunEqCan {} -> "CFunEqCan" CNonCanonical {} -> "CNonCanonical" @@ -1225,55 +1226,84 @@ pprWantedsWithLocs wcs \begin{code} data CtFlavor - = Given GivenLoc GivenKind -- We have evidence for this constraint in TcEvBinds - | Derived WantedLoc -- Derived's are just hints for unifications - | Wanted WantedLoc -- We have no evidence bindings for this constraint. - -data GivenKind - = GivenOrig -- Originates in some given, such as signature or pattern match - | GivenSolved (Maybe EvTerm) - -- Is given as result of being solved, maybe provisionally on - -- some other wanted constraints. We cache the evidence term - -- sometimes here as well /as well as/ in the EvBinds, - -- see Note [Optimizing Spontaneously Solved Coercions] + = Given { flav_gloc :: GivenLoc, flav_evar :: EvVar } + -- Trully given, not depending on subgoals + -- NB: Spontaneous unifications belong here + -- DV TODOs: (i) Consider caching actual evidence _term_ + -- (ii) Revisit Note [Optimizing Spontaneously Solved Coercions] + + | Solved { flav_gloc :: GivenLoc, flav_evar :: EvVar } + -- Originally wanted, but now we've produced and + -- bound some partial evidence for this constraint. + -- NB: Evidence may rely on yet-wanted constraints or other solved or given + + | Wanted { flav_wloc :: WantedLoc, flav_evar :: EvVar } + -- Wanted goal + + | Derived { flav_wloc :: WantedLoc, flav_der_pty :: TcPredType } + -- A goal that we don't really have to solve and can't immediately + -- rewrite anything other than a derived (there's no evidence variable!) + -- but if we do manage to solve it may help in solving other goals. + +ctFlavPred :: CtFlavor -> TcPredType +-- The predicate of a flavor +ctFlavPred (Given _ evar) = evVarPred evar +ctFlavPred (Solved _ evar) = evVarPred evar +ctFlavPred (Wanted _ evar) = evVarPred evar +ctFlavPred (Derived { flav_der_pty = pty }) = pty + +ctFlavId :: CtFlavor -> EvVar +-- Precondition: can't be derived +ctFlavId (Derived _ pty) + = pprPanic "ctFlavId: derived constraint cannot have id" $ + text "pty =" <+> ppr pty +ctFlavId fl = flav_evar fl instance Outputable CtFlavor where - ppr (Given _ GivenOrig) = ptext (sLit "[G]") - ppr (Given _ (GivenSolved {})) = ptext (sLit "[S]") -- Print [S] for Given/Solved's - ppr (Wanted {}) = ptext (sLit "[W]") - ppr (Derived {}) = ptext (sLit "[D]") + ppr fl = case fl of + (Given _ evar) -> ptext (sLit "[G]") <+> ppr evar <+> ppr_pty + (Solved _ evar) -> ptext (sLit "[S]") <+> ppr evar <+> ppr_pty + (Wanted _ evar) -> ptext (sLit "[W]") <+> ppr evar <+> ppr_pty + (Derived {}) -> ptext (sLit "[D]") <+> text "_" <+> ppr_pty + where ppr_pty = dcolon <+> ppr (ctFlavPred fl) getWantedLoc :: CtFlavor -> WantedLoc -getWantedLoc (Wanted wl) = wl -getWantedLoc (Derived wl) = wl -getWantedLoc flav@(Given {}) = pprPanic "getWantedLoc" (ppr flav) +-- Precondition: Wanted or Derived +getWantedLoc fl = flav_wloc fl + +getGivenLoc :: CtFlavor -> GivenLoc +-- Precondition: Given or Solved +getGivenLoc fl = flav_gloc fl pprFlavorArising :: CtFlavor -> SDoc -pprFlavorArising (Derived wl) = pprArisingAt wl -pprFlavorArising (Wanted wl) = pprArisingAt wl pprFlavorArising (Given gl _) = pprArisingAt gl +pprFlavorArising (Solved gl _) = pprArisingAt gl +pprFlavorArising (Wanted wl _) = pprArisingAt wl +pprFlavorArising (Derived wl _) = pprArisingAt wl + isWanted :: CtFlavor -> Bool isWanted (Wanted {}) = True -isWanted _ = False +isWanted _ = False isGivenOrSolved :: CtFlavor -> Bool -isGivenOrSolved (Given {}) = True +isGivenOrSolved (Given {}) = True +isGivenOrSolved (Solved {}) = True isGivenOrSolved _ = False isSolved :: CtFlavor -> Bool -isSolved (Given _ (GivenSolved {})) = True +isSolved (Solved {}) = True isSolved _ = False -isGiven_maybe :: CtFlavor -> Maybe GivenKind -isGiven_maybe (Given _ gk) = Just gk -isGiven_maybe _ = Nothing +isGiven :: CtFlavor -> Bool +isGiven (Given {}) = True +isGiven _ = False -isDerived :: CtFlavor -> Bool +isDerived :: CtFlavor -> Bool isDerived (Derived {}) = True -isDerived _ = False +isDerived _ = False -canSolve :: CtFlavor -> CtFlavor -> Bool +canSolve :: CtFlavor -> CtFlavor -> Bool -- canSolve ctid1 ctid2 -- The constraint ctid1 can be used to solve ctid2 -- "to solve" means a reaction where the active parts of the two constraints match. @@ -1287,37 +1317,21 @@ canSolve :: CtFlavor -> CtFlavor -> Bool canSolve (Given {}) _ = True canSolve (Wanted {}) (Derived {}) = True canSolve (Wanted {}) (Wanted {}) = True -canSolve (Derived {}) (Derived {}) = True -- Important: derived can't solve wanted/given -canSolve _ _ = False -- (There is no *evidence* for a derived.) +canSolve (Derived {}) (Derived {}) = True -- Derived can't solve wanted/given +canSolve _ _ = False -- No evidence for a derived, anyway canRewrite :: CtFlavor -> CtFlavor -> Bool --- canRewrite ctid1 ctid2 --- The *equality_constraint* ctid1 can be used to rewrite inside ctid2 +-- canRewrite ct1 ct2 +-- The equality constraint ct1 can be used to rewrite inside ct2 canRewrite = canSolve -combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc --- Precondition: At least one of them should be wanted -combineCtLoc (Wanted loc) _ = loc -combineCtLoc _ (Wanted loc) = loc -combineCtLoc (Derived loc ) _ = loc -combineCtLoc _ (Derived loc ) = loc -combineCtLoc _ _ = panic "combineCtLoc: both given" - -mkSolvedFlavor :: CtFlavor -> SkolemInfo -> EvTerm -> CtFlavor --- To be called when we actually solve a wanted/derived (perhaps leaving residual goals) -mkSolvedFlavor (Wanted loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm)) -mkSolvedFlavor (Derived loc) sk evterm = Given (setCtLocOrigin loc sk) (GivenSolved (Just evterm)) -mkSolvedFlavor fl@(Given {}) _sk _evterm = pprPanic "Solving a given constraint!" $ ppr fl - -mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor -mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenOrig -mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenOrig -mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl - -mkWantedFlavor :: CtFlavor -> CtFlavor -mkWantedFlavor (Wanted loc) = Wanted loc -mkWantedFlavor (Derived loc) = Wanted loc -mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl) + +mkGivenLoc :: WantedLoc -> SkolemInfo -> GivenLoc +mkGivenLoc wl sk = setCtLocOrigin wl sk + +mkSolvedLoc :: WantedLoc -> SkolemInfo -> GivenLoc +mkSolvedLoc wl sk = setCtLocOrigin wl sk + \end{code} %************************************************************************ diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs index 5f87205dfb..4c53dc4454 100644 --- a/compiler/typecheck/TcSMonad.lhs +++ b/compiler/typecheck/TcSMonad.lhs @@ -17,19 +17,19 @@ module TcSMonad ( appendWorkListCt, appendWorkListEqs, unionWorkList, selectWorkItem, getTcSWorkList, updWorkListTcS, updWorkListTcS_return, keepWanted, + getTcSWorkListTvs, Ct(..), Xi, tyVarsOfCt, tyVarsOfCts, tyVarsOfCDicts, emitFrozenError, isWanted, isGivenOrSolved, isDerived, - isGivenOrSolvedCt, isGivenCt_maybe, + isGivenOrSolvedCt, isGivenCt, isWantedCt, isDerivedCt, pprFlavorArising, isFlexiTcsTv, canRewrite, canSolve, - combineCtLoc, mkSolvedFlavor, mkGivenFlavor, - mkWantedFlavor, + mkSolvedLoc, mkGivenLoc, ctWantedLoc, TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality @@ -39,37 +39,42 @@ module TcSMonad ( SimplContext(..), isInteractive, simplEqsOnly, performDefaulting, - -- Creation of evidence variables - newEvVar, forceNewEvVar, delCachedEvVar, updateFlatCache, flushFlatCache, - newGivenEqVar, - newEqVar, newKindConstraint, - EvVarCreated (..), isNewEvVar, FlatEqOrigin ( .. ), origin_matches, - - -- Setting evidence variables - setEqBind, + -- Getting and setting the flattening cache + getFlatCache, updFlatCache, addToSolved, + + setEvBind, - + XEvTerm(..), + MaybeNew (..), isFresh, + xCtFlavor, -- Transform a CtFlavor during a step + rewriteCtFlavor, -- Specialized version of xCtFlavor for coercions + newWantedEvVar, newGivenEvVar, instDFunConstraints, newKindConstraint, + newDerived, + xCtFlavor_cache, rewriteCtFlavor_cache, + + -- Creation of evidence variables setWantedTyBind, getInstEnvs, getFamInstEnvs, -- Getting the environments getTopEnv, getGblEnv, getTcEvBinds, getUntouchables, getTcEvBindsMap, getTcSContext, getTcSTyBinds, getTcSTyBindsMap, - getTcSEvVarCacheMap, getTcSEvVarFlatCache, setTcSEvVarCacheMap, pprEvVarCache, + newFlattenSkolemTy, -- Flatten skolems -- Inerts - InertSet(..), + InertSet(..), InertCans(..), getInertEqs, getCtCoercion, - emptyInert, getTcSInerts, updInertSet, extractUnsolved, + emptyInert, getTcSInerts, lookupInInerts, updInertSet, extractUnsolved, extractUnsolvedTcS, modifyInertTcS, updInertSetTcS, partitionCCanMap, partitionEqMap, getRelevantCts, extractRelevantInerts, - CCanMap (..), CtTypeMap, pprCtTypeMap, mkPredKeyForTypeMap, partitionCtTypeMap, + CCanMap (..), CtTypeMap, CtFamHeadMap(..), CtPredMap(..), + pprCtTypeMap, partCtFamHeadMap, instDFunTypes, -- Instantiation - instDFunConstraints, + -- instDFunConstraints, newFlexiTcSTy, instFlexiTcS, compatKind, mkKindErrorCtxtTcS, @@ -134,7 +139,8 @@ import Maybes ( orElse ) import Control.Monad( when ) import StaticFlags( opt_PprStyle_Debug ) import Data.IORef - +import Data.List ( find ) +import Control.Monad ( zipWithM ) import TrieMap \end{code} @@ -191,7 +197,10 @@ better rewrite it as much as possible before reporting it as an error to the use \begin{code} -- See Note [WorkList] -data WorkList = WorkList { wl_eqs :: [Ct], wl_funeqs :: [Ct], wl_rest :: [Ct] } +data WorkList = WorkList { wl_eqs :: [Ct] + , wl_funeqs :: [Ct] + , wl_rest :: [Ct] + } unionWorkList :: WorkList -> WorkList -> WorkList @@ -200,6 +209,7 @@ unionWorkList new_wl orig_wl = , wl_funeqs = wl_funeqs new_wl ++ wl_funeqs orig_wl , wl_rest = wl_rest new_wl ++ wl_rest orig_wl } + extendWorkListEq :: Ct -> WorkList -> WorkList -- Extension by equality extendWorkListEq ct wl @@ -210,12 +220,13 @@ extendWorkListEq ct wl extendWorkListNonEq :: Ct -> WorkList -> WorkList -- Extension by non equality -extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl } +extendWorkListNonEq ct wl + = wl { wl_rest = ct : wl_rest wl } extendWorkListCt :: Ct -> WorkList -> WorkList -- Agnostic extendWorkListCt ct wl - | isEqVar (cc_id ct) = extendWorkListEq ct wl + | isEqPred (ctPred ct) = extendWorkListEq ct wl | otherwise = extendWorkListNonEq ct wl appendWorkListCt :: [Ct] -> WorkList -> WorkList @@ -231,7 +242,7 @@ isEmptyWorkList wl = null (wl_eqs wl) && null (wl_rest wl) && null (wl_funeqs wl) emptyWorkList :: WorkList -emptyWorkList = WorkList { wl_eqs = [], wl_rest = [], wl_funeqs = []} +emptyWorkList = WorkList { wl_eqs = [], wl_rest = [], wl_funeqs = [] } workListFromEq :: Ct -> WorkList workListFromEq ct = extendWorkListEq ct emptyWorkList @@ -241,8 +252,8 @@ workListFromNonEq ct = extendWorkListNonEq ct emptyWorkList workListFromCt :: Ct -> WorkList -- Agnostic -workListFromCt ct | isEqVar (cc_id ct) = workListFromEq ct - | otherwise = workListFromNonEq ct +workListFromCt ct | isEqPred (ctPred ct) = workListFromEq ct + | otherwise = workListFromNonEq ct selectWorkItem :: WorkList -> (Maybe Ct, WorkList) @@ -266,62 +277,7 @@ keepWanted = filterBag isWantedCt -- ``Important: use fold*r*Bag to preserve the order of the evidence variables'' -- DV: Is this still relevant? -\end{code} - -%************************************************************************ -%* * -%* Inert sets * -%* * -%* * -%************************************************************************ - - -Note [InertSet invariants] -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -An InertSet is a bag of canonical constraints, with the following invariants: - - 1 No two constraints react with each other. - - A tricky case is when there exists a given (solved) dictionary - constraint and a wanted identical constraint in the inert set, but do - not react because reaction would create loopy dictionary evidence for - the wanted. See note [Recursive dictionaries] - - 2 Given equalities form an idempotent substitution [none of the - given LHS's occur in any of the given RHS's or reactant parts] - - 3 Wanted equalities also form an idempotent substitution - - 4 The entire set of equalities is acyclic. - - 5 Wanted dictionaries are inert with the top-level axiom set - - 6 Equalities of the form tv1 ~ tv2 always have a touchable variable - on the left (if possible). - - 7 No wanted constraints tv1 ~ tv2 with tv1 touchable. Such constraints - will be marked as solved right before being pushed into the inert set. - See note [Touchables and givens]. - - 8 No Given constraint mentions a touchable unification variable, but - Given/Solved may do so. - - 9 Given constraints will also have their superclasses in the inert set, - but Given/Solved will not. - -Note that 6 and 7 are /not/ enforced by canonicalization but rather by -insertion in the inert list, ie by TcInteract. - -During the process of solving, the inert set will contain some -previously given constraints, some wanted constraints, and some given -constraints which have arisen from solving wanted constraints. For -now we do not distinguish between given and solved constraints. - -Note that we must switch wanted inert items to given when going under an -implication constraint (when in top-level inference mode). - -\begin{code} - +-- Canonical constraint maps data CCanMap a = CCanMap { cts_given :: UniqFM Cts -- Invariant: all Given , cts_derived :: UniqFM Cts @@ -343,6 +299,7 @@ updCCanMap (a,ct) cmap Wanted {} -> cmap { cts_wanted = insert_into (cts_wanted cmap) } Given {} -> cmap { cts_given = insert_into (cts_given cmap) } Derived {} -> cmap { cts_derived = insert_into (cts_derived cmap) } + Solved {} -> panic "updCCanMap update with solved!" where insert_into m = addToUFM_C unionBags m a (singleCt ct) @@ -359,10 +316,12 @@ getRelevantCts a cmap where lookup map = lookupUFM map a `orElse` emptyCts - -getCtTypeMapRelevants :: PredType -> TypeMap Ct -> (Cts, TypeMap Ct) -getCtTypeMapRelevants key_pty tmap - = partitionCtTypeMap (\ct -> mkPredKeyForTypeMap ct `eqType` key_pty) tmap +lookupCCanMap :: Uniquable a => a -> (Ct -> Bool) -> CCanMap a -> Maybe Ct +lookupCCanMap a p map + = let possible_cts = lookupUFM (cts_given map) a `orElse` + lookupUFM (cts_wanted map) a `orElse` + lookupUFM (cts_derived map) a `orElse` emptyCts + in find p (bagToList possible_cts) partitionCCanMap :: (Ct -> Bool) -> CCanMap a -> (Cts,CCanMap a) @@ -396,29 +355,13 @@ extractUnsolvedCMap cmap = in (wntd `unionBags` derd, cmap { cts_wanted = emptyUFM, cts_derived = emptyUFM }) --- See Note [InertSet invariants] -data InertSet - = IS { inert_eqs :: TyVarEnv (Ct,TcCoercion) - -- Must all be CTyEqCans! If an entry exists of the form: - -- a |-> ct,co - -- Then ct = CTyEqCan { cc_tyvar = a, cc_rhs = xi } - -- And co : a ~ xi - , inert_eq_tvs :: InScopeSet -- Invariant: superset of inert_eqs tvs - - , inert_dicts :: CCanMap Class -- Dictionaries only, index is the class - , inert_ips :: CCanMap (IPName Name) -- Implicit parameters - -- NB: We do not want to use TypeMaps here because functional dependencies - -- will only match on the class but not the type. Similarly IPs match on the - -- name but not on the whole datatype - - , inert_funeqs :: CtTypeMap -- Map from family heads to CFunEqCan constraints - - , inert_irreds :: Cts -- Irreducible predicates - , inert_frozen :: Cts -- All non-canonicals are kept here (as frozen errors) - } - +-- Maps from PredTypes to Constraints type CtTypeMap = TypeMap Ct +newtype CtPredMap = + CtPredMap { unCtPredMap :: CtTypeMap } -- Indexed by TcPredType +newtype CtFamHeadMap = + CtFamHeadMap { unCtFamHeadMap :: CtTypeMap } -- Indexed by family head pprCtTypeMap :: TypeMap Ct -> SDoc pprCtTypeMap ctmap = ppr (foldTM (:) ctmap []) @@ -426,87 +369,218 @@ pprCtTypeMap ctmap = ppr (foldTM (:) ctmap []) ctTypeMapCts :: TypeMap Ct -> Cts ctTypeMapCts ctmap = foldTM (\ct cts -> extendCts cts ct) ctmap emptyCts -mkPredKeyForTypeMap :: Ct -> PredType --- Create a key from a constraint to use in the inert CtTypeMap. --- The only interesting case is for family applications, where the --- key is not the whole PredType of cc_id, but rather the family --- equality left hand side (head) -mkPredKeyForTypeMap (CFunEqCan { cc_fun = fn, cc_tyargs = xis }) - = mkTyConApp fn xis -mkPredKeyForTypeMap ct - = evVarPred (cc_id ct) - -partitionCtTypeMap :: (Ct -> Bool) - -> TypeMap Ct -> (Cts, TypeMap Ct) --- Kick out the ones that match the predicate and keep the rest in the typemap -partitionCtTypeMap f ctmap - = foldTM upd_acc ctmap (emptyBag,ctmap) - where upd_acc ct (cts,acc_map) + +partCtFamHeadMap :: (Ct -> Bool) + -> CtFamHeadMap + -> (Cts, CtFamHeadMap) +partCtFamHeadMap f ctmap + = let (cts,tymap_final) = foldTM upd_acc tymap_inside (emptyBag, tymap_inside) + in (cts, CtFamHeadMap tymap_final) + where + tymap_inside = unCtFamHeadMap ctmap + upd_acc ct (cts,acc_map) | f ct = (extendCts cts ct, alterTM ct_key (\_ -> Nothing) acc_map) | otherwise = (cts,acc_map) - where ct_key = mkPredKeyForTypeMap ct + where ct_key | EqPred ty1 _ <- classifyPredType (ctPred ct) + = ty1 + | otherwise + = panic "partCtFamHeadMap, encountered non equality!" -instance Outputable InertSet where - ppr is = vcat [ vcat (map ppr (varEnvElts (inert_eqs is))) - , vcat (map ppr (Bag.bagToList $ inert_irreds is)) - , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts is))) - , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_ips is))) - , vcat (map ppr (Bag.bagToList $ ctTypeMapCts (inert_funeqs is))) +\end{code} + +%************************************************************************ +%* * +%* Inert Sets * +%* * +%* * +%************************************************************************ + +\begin{code} + + +-- All Given (fully known) or Wanted or Derived, never Solved +-- See Note [Detailed InertCans Invariants] for more +data InertCans + = IC { inert_eqs :: TyVarEnv Ct + -- Must all be CTyEqCans! If an entry exists of the form: + -- a |-> ct,co + -- Then ct = CTyEqCan { cc_tyvar = a, cc_rhs = xi } + -- And co : a ~ xi + , inert_eq_tvs :: InScopeSet + -- Superset of the type variables of inert_eqs + , inert_dicts :: CCanMap Class + -- Dictionaries only, index is the class + -- NB: index is /not/ the whole type because FD reactions + -- need to match the class but not necessarily the whole type. + , inert_ips :: CCanMap (IPName Name) + -- Implicit parameters, index is the name + -- NB: index is /not/ the whole type because IP reactions need + -- to match the ip name but not necessarily the whole type. + , inert_funeqs :: CtFamHeadMap + -- Family equations, index is the whole family head type. + , inert_irreds :: Cts + -- Irreducible predicates + } + + +\end{code} + +Note [Detailed InertCans Invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The InertCans represents a collection of constraints with the following properties: + 1 All canonical + 2 All Given or Wanted or Derived. No (partially) Solved + 3 No two dictionaries with the same head + 4 No two family equations with the same head + NB: This is enforced by construction since we use a CtFamHeadMap for inert_funeqs + 5 Family equations inert wrt top-level family axioms + 6 Dictionaries have no matching top-level instance + + 7 Non-equality constraints are fully rewritten with respect to the equalities (CTyEqCan) + + 8 Equalities _do_not_ form an idempotent substitution but they are guarranteed to not have + any occurs errors. Additional notes: + + - The lack of idempotence of the inert substitution implies that we must make sure + that when we rewrite a constraint we apply the substitution /recursively/ to the + types involved. Currently the one AND ONLY way in the whole constraint solver + that we rewrite types and constraints wrt to the inert substitution is + TcCanonical/flattenTyVar. + + - In the past we did try to have the inert substituion as idempotent as possible but + this would only be true for constraints of the same flavor, so in total the inert + substitution could not be idempotent, due to flavor-related issued. + Note [Non-idempotent inert substitution] explains what is going on. + + - Whenever a constraint ends up in the worklist we do recursively apply exhaustively + the inert substitution to it to check for occurs errors but if an equality is already + in the inert set and we can guarantee that adding a new equality will not cause the + first equality to have an occurs check then we do not rewrite the inert equality. + This happens in TcInteract, rewriteInertEqsFromInertEq. + + See Note [Delicate equality kick-out] to see which inert equalities can safely stay + in the inert set and which must be kicked out to be rewritten and re-checked for + occurs errors. + + 9 Given family or dictionary constraints don't mention touchable unification variables +\begin{code} + + +-- The Inert Set +data InertSet + = IS { inert_cans :: InertCans + -- Canonical Given,Wanted,Solved + , inert_frozen :: Cts + -- Frozen errors (as non-canonicals) + + , inert_solved :: CtPredMap + -- Solved constraints (for caching): + -- (i) key is by predicate type + -- (ii) all of 'Solved' flavor, may or may not be canonicals + -- (iii) we use this field for avoiding creating newEvVars + , inert_flat_cache :: CtFamHeadMap + -- All ``flattening equations'' are kept here. + -- Always canonical CTyFunEqs (Given or Wanted only!) + -- Key is by family head. We used this field during flattening only + , inert_solved_funeqs :: CtFamHeadMap + -- Memoized Solved family equations co :: F xis ~ xi + -- Stored not necessarily as fully rewritten; we'll do that lazily + -- when we lookup + } + + +instance Outputable InertCans where + ppr ics = vcat [ vcat (map ppr (varEnvElts (inert_eqs ics))) + , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts ics))) + , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_ips ics))) + , vcat (map ppr (Bag.bagToList $ + ctTypeMapCts (unCtFamHeadMap $ inert_funeqs ics))) + , vcat (map ppr (Bag.bagToList $ inert_irreds ics)) + ] + +instance Outputable InertSet where + ppr is = vcat [ ppr $ inert_cans is , text "Frozen errors =" <+> -- Clearly print frozen errors braces (vcat (map ppr (Bag.bagToList $ inert_frozen is))) - , text "Warning: Not displaying cached (solved) constraints" - ] - -emptyInert :: InertSet -emptyInert = IS { inert_eqs = emptyVarEnv - , inert_eq_tvs = emptyInScopeSet - , inert_frozen = emptyCts - , inert_irreds = emptyCts - , inert_dicts = emptyCCanMap - , inert_ips = emptyCCanMap - , inert_funeqs = emptyTM - } + , text "Solved and cached" <+> + int (foldTypeMap (\_ x -> x+1) 0 + (unCtPredMap $ inert_solved is)) <+> + text "more constraints" ] +emptyInert :: InertSet +emptyInert + = IS { inert_cans = IC { inert_eqs = emptyVarEnv + , inert_eq_tvs = emptyInScopeSet + , inert_dicts = emptyCCanMap + , inert_ips = emptyCCanMap + , inert_funeqs = CtFamHeadMap emptyTM + , inert_irreds = emptyCts } + , inert_frozen = emptyCts + , inert_flat_cache = CtFamHeadMap emptyTM + , inert_solved = CtPredMap emptyTM + , inert_solved_funeqs = CtFamHeadMap emptyTM } type AtomicInert = Ct updInertSet :: InertSet -> AtomicInert -> InertSet -- Add a new inert element to the inert set. updInertSet is item - | isCTyEqCan item - = let upd_err a b = pprPanic "updInertSet" $ - vcat [ text "Multiple inert equalities:" - , text "Old (already inert):" <+> ppr a - , text "Trying to insert :" <+> ppr b - ] - - -- If evidence is cached, pick it up from the flavor! - coercion = getCtCoercion item - - eqs' = extendVarEnv_C upd_err (inert_eqs is) - (cc_tyvar item) - (item, coercion) - inscope' = extendInScopeSetSet (inert_eq_tvs is) (tyVarsOfCt item) - in is { inert_eqs = eqs', inert_eq_tvs = inscope' } - - | Just x <- isCIPCan_Maybe item -- IP - = is { inert_ips = updCCanMap (x,item) (inert_ips is) } - | isCIrredEvCan item -- Presently-irreducible evidence - = is { inert_irreds = inert_irreds is `Bag.snocBag` item } - - - | Just cls <- isCDictCan_Maybe item -- Dictionary - = is { inert_dicts = updCCanMap (cls,item) (inert_dicts is) } - - | Just _tc <- isCFunEqCan_Maybe item -- Function equality - = let pty = mkPredKeyForTypeMap item - upd_funeqs Nothing = Just item - upd_funeqs (Just _alredy_there) = panic "updInertSet: item already there!" - in is { inert_funeqs = alterTM pty upd_funeqs (inert_funeqs is) } - - | otherwise + | isSolved (cc_flavor item) + -- Solved items go in their special place + = let pty = ctPred item + upd_solved Nothing = Just item + upd_solved (Just _existing_solved) = Just item + -- .. or Just existing_solved? Is this even possible to happen? + in is { inert_solved = + CtPredMap $ + alterTM pty upd_solved (unCtPredMap $ inert_solved is) } + + | isCNonCanonical item + -- NB: this may happen if we decide to kick some frozen error + -- out to rewrite him. Frozen errors are just NonCanonicals = is { inert_frozen = inert_frozen is `Bag.snocBag` item } + + | otherwise + -- A canonical Given, Wanted, or Derived + = is { inert_cans = upd_inert_cans (inert_cans is) item } + + where upd_inert_cans :: InertCans -> AtomicInert -> InertCans + -- Precondition: item /is/ canonical + upd_inert_cans ics item + | isCTyEqCan item + = let upd_err a b = pprPanic "updInertSet" $ + vcat [ text "Multiple inert equalities:" + , text "Old (already inert):" <+> ppr a + , text "Trying to insert :" <+> ppr b ] + + eqs' = extendVarEnv_C upd_err (inert_eqs ics) + (cc_tyvar item) item + inscope' = extendInScopeSetSet (inert_eq_tvs ics) + (tyVarsOfCt item) + + in ics { inert_eqs = eqs', inert_eq_tvs = inscope' } + + | Just x <- isCIPCan_Maybe item -- IP + = ics { inert_ips = updCCanMap (x,item) (inert_ips ics) } + + | isCIrredEvCan item -- Presently-irreducible evidence + = ics { inert_irreds = inert_irreds ics `Bag.snocBag` item } + + | Just cls <- isCDictCan_Maybe item -- Dictionary + = ics { inert_dicts = updCCanMap (cls,item) (inert_dicts ics) } + + | Just _tc <- isCFunEqCan_Maybe item -- Function equality + = let fam_head = mkTyConApp (cc_fun item) (cc_tyargs item) + upd_funeqs Nothing = Just item + upd_funeqs (Just _already_there) + = panic "updInertSet: item already there!" + in ics { inert_funeqs = CtFamHeadMap + (alterTM fam_head upd_funeqs $ + (unCtFamHeadMap $ inert_funeqs ics)) } + | otherwise + = pprPanic "upd_inert set: can't happen! Inserting " $ + ppr item updInertSetTcS :: AtomicInert -> TcS () -- Add a new item in the inerts of the monad @@ -528,6 +602,12 @@ modifyInertTcS upd ; wrapTcS (TcM.writeTcRef is_var new_inert) ; return a } + +addToSolved :: Ct -> TcS () +addToSolved ct + = ASSERT ( isSolved (cc_flavor ct) ) + updInertSetTcS ct + extractUnsolvedTcS :: TcS (Cts,Cts) -- Extracts frozen errors and remaining unsolved and sets the -- inert set to be the remaining! @@ -549,33 +629,51 @@ extractUnsolved :: InertSet -> ((Cts,Cts), InertSet) -- -----------|----------------------------------------------------------------- -- is_solved | Whatever remains from the inert after removing the previous two. -- ----------------------------------------------------------------------------- -extractUnsolved is@(IS {inert_eqs = eqs, inert_irreds = irreds}) - = let is_solved = is { inert_eqs = solved_eqs - , inert_eq_tvs = inert_eq_tvs is - , inert_dicts = solved_dicts - , inert_ips = solved_ips - , inert_irreds = solved_irreds - , inert_frozen = emptyCts - , inert_funeqs = solved_funeqs +extractUnsolved (IS { inert_cans = IC { inert_eqs = eqs + , inert_eq_tvs = eq_tvs + , inert_irreds = irreds + , inert_ips = ips + , inert_funeqs = funeqs + , inert_dicts = dicts + } + , inert_frozen = frozen + , inert_solved = _solved + , inert_flat_cache = _flat_cache }) + + = let is_solved = IS { inert_cans = IC { inert_eqs = solved_eqs + , inert_eq_tvs = eq_tvs + , inert_dicts = solved_dicts + , inert_ips = solved_ips + , inert_irreds = solved_irreds + , inert_funeqs = solved_funeqs } + , inert_frozen = emptyCts -- All out + + -- DV: For solved and the flat cache, I am flushing them here: + -- Solved cts may depend on wanteds which we kick out. But later + -- we may try to re-solve some kicked-out wanteds and I am worried + -- that there is a danger or evidence loops if we keep the solved + -- in for caching purposes. So I am flushing the solved and the + -- flattening cache, quite conservatively. + , inert_solved = CtPredMap emptyTM + , inert_flat_cache = CtFamHeadMap emptyTM + , inert_solved_funeqs = CtFamHeadMap emptyTM } - in ((inert_frozen is, unsolved), is_solved) + in ((frozen, unsolved), is_solved) - where solved_eqs = filterVarEnv_Directly (\_ (ct,_) -> isGivenOrSolvedCt ct) eqs - unsolved_eqs = foldVarEnv (\(ct,_co) cts -> cts `extendCts` ct) emptyCts $ + where solved_eqs = filterVarEnv_Directly (\_ ct -> isGivenOrSolvedCt ct) eqs + unsolved_eqs = foldVarEnv (\ct cts -> cts `extendCts` ct) emptyCts $ eqs `minusVarEnv` solved_eqs (unsolved_irreds, solved_irreds) = Bag.partitionBag (not.isGivenOrSolvedCt) irreds - (unsolved_ips, solved_ips) = extractUnsolvedCMap (inert_ips is) - (unsolved_dicts, solved_dicts) = extractUnsolvedCMap (inert_dicts is) + (unsolved_ips, solved_ips) = extractUnsolvedCMap ips + (unsolved_dicts, solved_dicts) = extractUnsolvedCMap dicts - (unsolved_funeqs, solved_funeqs) = extractUnsolvedCtTypeMap (inert_funeqs is) + (unsolved_funeqs, solved_funeqs) = + partCtFamHeadMap (not . isGivenOrSolved . cc_flavor) funeqs unsolved = unsolved_eqs `unionBags` unsolved_irreds `unionBags` unsolved_ips `unionBags` unsolved_dicts `unionBags` unsolved_funeqs -extractUnsolvedCtTypeMap :: TypeMap Ct -> (Cts,TypeMap Ct) -extractUnsolvedCtTypeMap - = partitionCtTypeMap (not . isGivenOrSolved . cc_flavor) extractRelevantInerts :: Ct -> TcS Cts @@ -583,23 +681,70 @@ extractRelevantInerts :: Ct -> TcS Cts -- this constraint. The monad is left with the 'thinner' inerts. -- NB: This function contains logic specific to the constraint solver, maybe move there? extractRelevantInerts wi - = modifyInertTcS (extract_inert_relevants wi) - where extract_inert_relevants (CDictCan {cc_class = cl}) is = - let (cts,dict_map) = getRelevantCts cl (inert_dicts is) - in (cts, is { inert_dicts = dict_map }) - extract_inert_relevants (CFunEqCan {cc_fun = tc, cc_tyargs = xis}) is = - let (cts,feqs_map) = getCtTypeMapRelevants (mkTyConApp tc xis) (inert_funeqs is) - in (cts, is { inert_funeqs = feqs_map }) - extract_inert_relevants (CIPCan { cc_ip_nm = nm } ) is = - let (cts, ips_map) = getRelevantCts nm (inert_ips is) - in (cts, is { inert_ips = ips_map }) - extract_inert_relevants (CIrredEvCan { }) is = - let cts = inert_irreds is - in (cts, is { inert_irreds = emptyCts }) - extract_inert_relevants _ is = (emptyCts,is) + = modifyInertTcS (extract_relevants wi) + where extract_relevants wi is + = let (cts,ics') = extract_ics_relevants wi (inert_cans is) + in (cts, is { inert_cans = ics' }) + + extract_ics_relevants (CDictCan {cc_class = cl}) ics = + let (cts,dict_map) = getRelevantCts cl (inert_dicts ics) + in (cts, ics { inert_dicts = dict_map }) + extract_ics_relevants ct@(CFunEqCan {}) ics = + let (cts,feqs_map) = + let funeq_map = unCtFamHeadMap $ inert_funeqs ics + fam_head = mkTyConApp (cc_fun ct) (cc_tyargs ct) + lkp = lookupTM fam_head funeq_map + new_funeq_map = alterTM fam_head xtm funeq_map + xtm Nothing = Nothing + xtm (Just _ct) = Nothing + in case lkp of + Nothing -> (emptyCts, funeq_map) + Just ct -> (singleCt ct, new_funeq_map) + in (cts, ics { inert_funeqs = CtFamHeadMap feqs_map }) + extract_ics_relevants (CIPCan { cc_ip_nm = nm } ) ics = + let (cts, ips_map) = getRelevantCts nm (inert_ips ics) + in (cts, ics { inert_ips = ips_map }) + extract_ics_relevants (CIrredEvCan { }) ics = + let cts = inert_irreds ics + in (cts, ics { inert_irreds = emptyCts }) + extract_ics_relevants _ ics = (emptyCts,ics) + + +lookupInInerts :: InertSet -> TcPredType -> Maybe Ct +-- Is this exact predicate type cached in the solved or canonicals of the InertSet +lookupInInerts (IS { inert_solved = solved, inert_cans = ics }) pty + = case lookupInSolved solved pty of + Just ct -> return ct + Nothing -> lookupInInertCans ics pty + +lookupInSolved :: CtPredMap -> TcPredType -> Maybe Ct +-- Returns just if exactly this predicate type exists in the solved. +lookupInSolved tm pty = lookupTM pty $ unCtPredMap tm + +lookupInInertCans :: InertCans -> TcPredType -> Maybe Ct +-- Returns Just if exactly this pred type exists in the inert canonicals +lookupInInertCans ics pty + = lkp_ics (classifyPredType pty) + where lkp_ics (ClassPred cls _) + = lookupCCanMap cls (\ct -> ctPred ct `eqType` pty) (inert_dicts ics) + lkp_ics (EqPred ty1 _ty2) + | Just tv <- getTyVar_maybe ty1 + , Just ct <- lookupVarEnv (inert_eqs ics) tv + , ctPred ct `eqType` pty + = Just ct + lkp_ics (EqPred ty1 _ty2) -- Family equation + | Just _ <- splitTyConApp_maybe ty1 + , Just ct <- lookupTM ty1 (unCtFamHeadMap $ inert_funeqs ics) + , ctPred ct `eqType` pty + = Just ct + lkp_ics (IrredPred {}) + = find (\ct -> ctPred ct `eqType` pty) (bagToList (inert_irreds ics)) + lkp_ics _ = Nothing -- NB: No caching for IPs \end{code} + + %************************************************************************ %* * %* The TcS solver monad * @@ -623,10 +768,7 @@ added. This is initialised from the innermost implication constraint. data TcSEnv = TcSEnv { tcs_ev_binds :: EvBindsVar, - tcs_evvar_cache :: IORef EvVarCache, - -- Evidence bindings and a cache from predicate types to the created evidence - -- variables. The scope of the cache will be the same as the scope of tcs_ev_binds - + tcs_ty_binds :: IORef (TyVarEnv (TcTyVar, TcType)), -- Global type bindings @@ -640,34 +782,8 @@ data TcSEnv tcs_inerts :: IORef InertSet, -- Current inert set tcs_worklist :: IORef WorkList -- Current worklist - - -- TcSEnv invariant: the tcs_evvar_cache is a superset of tcs_inerts, tcs_worklist, tcs_ev_binds which must - -- all be disjoint with each other. } -data EvVarCache - = EvVarCache { evc_cache :: TypeMap (EvVar,CtFlavor) - -- Map from PredTys to Evidence variables - -- used to avoid creating new goals - , evc_flat_cache :: TypeMap (TcCoercion,(Xi,CtFlavor,FlatEqOrigin)) - -- Map from family-free heads (F xi) to family-free types. - -- Useful during flattening to share flatten skolem generation - -- The boolean flag: - -- True <-> This equation was generated originally during flattening - -- False <-> This equation was generated by having solved a goal - } - -data FlatEqOrigin = WhileFlattening -- Was it generated during flattening? - | WhenSolved -- Was it generated when a family equation was solved? - | Any - -origin_matches :: FlatEqOrigin -> FlatEqOrigin -> Bool -origin_matches Any _ = True -origin_matches WhenSolved WhenSolved = True -origin_matches WhileFlattening WhileFlattening = True -origin_matches _ _ = False - - type TcsUntouchables = (Untouchables,TcTyVarSet) -- Like the TcM Untouchables, -- but records extra TcsTv variables generated during simplification @@ -764,8 +880,6 @@ runTcS :: SimplContext -> TcM (a, Bag EvBind) runTcS context untouch is wl tcs = do { ty_binds_var <- TcM.newTcRef emptyVarEnv - ; ev_cache_var <- TcM.newTcRef $ - EvVarCache { evc_cache = emptyTM, evc_flat_cache = emptyTM } ; ev_binds_var <- TcM.newTcEvBinds ; step_count <- TcM.newTcRef 0 @@ -773,7 +887,6 @@ runTcS context untouch is wl tcs ; wl_var <- TcM.newTcRef wl ; let env = TcSEnv { tcs_ev_binds = ev_binds_var - , tcs_evvar_cache = ev_cache_var , tcs_ty_binds = ty_binds_var , tcs_context = context , tcs_untch = (untouch, emptyVarSet) -- No Tcs untouchables yet @@ -804,16 +917,11 @@ runTcS context untouch is wl tcs doWithInert :: InertSet -> TcS a -> TcS a doWithInert inert (TcS action) = TcS $ \env -> do { new_inert_var <- TcM.newTcRef inert - ; orig_cache_var <- TcM.readTcRef (tcs_evvar_cache env) - ; new_cache_var <- TcM.newTcRef orig_cache_var - ; action (env { tcs_inerts = new_inert_var - , tcs_evvar_cache = new_cache_var }) } - + ; action (env { tcs_inerts = new_inert_var }) } nestImplicTcS :: EvBindsVar -> TcsUntouchables -> TcS a -> TcS a nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside) = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds - , tcs_evvar_cache = orig_evvar_cache_var , tcs_untch = (_outer_range, outer_tcs) , tcs_count = count , tcs_ic_depth = idepth @@ -829,13 +937,8 @@ nestImplicTcS ref (inner_range, inner_tcs) (TcS thing_inside) -- Inherit the inerts from the outer scope ; orig_inerts <- TcM.readTcRef inert_var ; new_inert_var <- TcM.newTcRef orig_inerts - - -- Inherit EvVar cache - ; orig_evvar_cache <- TcM.readTcRef orig_evvar_cache_var - ; evvar_cache <- TcM.newTcRef orig_evvar_cache - + ; let nest_env = TcSEnv { tcs_ev_binds = ref - , tcs_evvar_cache = evvar_cache , tcs_ty_binds = ty_binds , tcs_untch = inner_untch , tcs_count = count @@ -871,12 +974,7 @@ tryTcS tcs ; ty_binds_var <- TcM.newTcRef emptyVarEnv ; ev_binds_var <- TcM.newTcEvBinds - ; ev_binds_cache_var <- TcM.newTcRef (EvVarCache emptyTM emptyTM) - -- Empty cache: Don't inherit cache from above, see - -- Note [tryTcS for defaulting] in TcSimplify - ; let env1 = env { tcs_ev_binds = ev_binds_var - , tcs_evvar_cache = ev_binds_cache_var , tcs_ty_binds = ty_binds_var , tcs_inerts = is_var , tcs_worklist = wl_var } @@ -898,6 +996,16 @@ getTcSInerts = getTcSInertsRef >>= wrapTcS . (TcM.readTcRef) getTcSWorkList :: TcS WorkList getTcSWorkList = getTcSWorkListRef >>= wrapTcS . (TcM.readTcRef) + +getTcSWorkListTvs :: TcS TyVarSet +-- Return the variables of the worklist +getTcSWorkListTvs + = do { wl <- getTcSWorkList + ; return $ + cts_tvs (wl_eqs wl) `unionVarSet` cts_tvs (wl_funeqs wl) `unionVarSet` cts_tvs (wl_rest wl) } + where cts_tvs = foldr (unionVarSet . tyVarsOfCt) emptyVarSet + + updWorkListTcS :: (WorkList -> WorkList) -> TcS () updWorkListTcS f = updWorkListTcS_return (\w -> ((),f w)) @@ -910,14 +1018,13 @@ updWorkListTcS_return f ; wrapTcS (TcM.writeTcRef wl_var new_work) ; return res } -emitFrozenError :: CtFlavor -> EvVar -> SubGoalDepth -> TcS () +emitFrozenError :: CtFlavor -> SubGoalDepth -> TcS () -- Emits a non-canonical constraint that will stand for a frozen error in the inerts. -emitFrozenError fl ev depth - = do { traceTcS "Emit frozen error" (ppr ev <+> dcolon <+> ppr (evVarPred ev)) +emitFrozenError fl depth + = do { traceTcS "Emit frozen error" (ppr (ctFlavPred fl)) ; inert_ref <- getTcSInertsRef ; inerts <- wrapTcS (TcM.readTcRef inert_ref) - ; let ct = CNonCanonical { cc_id = ev - , cc_flavor = fl + ; let ct = CNonCanonical { cc_flavor = fl , cc_depth = depth } inerts_new = inerts { inert_frozen = extendCts (inert_frozen inerts) ct } ; wrapTcS (TcM.writeTcRef inert_ref inerts_new) } @@ -931,31 +1038,24 @@ getTcSContext = TcS (return . tcs_context) getTcEvBinds :: TcS EvBindsVar getTcEvBinds = TcS (return . tcs_ev_binds) -getTcSEvVarCache :: TcS (IORef EvVarCache) -getTcSEvVarCache = TcS (return . tcs_evvar_cache) - -flushFlatCache :: TcS () -flushFlatCache - = do { cache_var <- getTcSEvVarCache - ; the_cache <- wrapTcS $ TcM.readTcRef cache_var - ; wrapTcS $ TcM.writeTcRef cache_var (the_cache { evc_flat_cache = emptyTM }) } - - -getTcSEvVarCacheMap :: TcS (TypeMap (EvVar,CtFlavor)) -getTcSEvVarCacheMap = do { cache_var <- getTcSEvVarCache - ; the_cache <- wrapTcS $ TcM.readTcRef cache_var - ; return (evc_cache the_cache) } - -getTcSEvVarFlatCache :: TcS (TypeMap (TcCoercion,(Type,CtFlavor,FlatEqOrigin))) -getTcSEvVarFlatCache = do { cache_var <- getTcSEvVarCache - ; the_cache <- wrapTcS $ TcM.readTcRef cache_var - ; return (evc_flat_cache the_cache) } +getFlatCache :: TcS CtTypeMap +getFlatCache = getTcSInerts >>= (return . unCtFamHeadMap . inert_flat_cache) + +updFlatCache :: Ct -> TcS () +-- Pre: constraint is a flat family equation (equal to a flatten skolem) +updFlatCache flat_eq@(CFunEqCan { cc_flavor = fl, cc_fun = tc, cc_tyargs = xis }) + = modifyInertTcS upd_inert_cache + where upd_inert_cache is = ((), is { inert_flat_cache = CtFamHeadMap new_fc }) + where new_fc = alterTM pred_key upd_cache fc + fc = unCtFamHeadMap $ inert_flat_cache is + pred_key = mkTyConApp tc xis + upd_cache (Just ct) | cc_flavor ct `canSolve` fl = Just ct + upd_cache (Just _ct) = Just flat_eq + upd_cache Nothing = Just flat_eq +updFlatCache other_ct = pprPanic "updFlatCache: non-family constraint" $ + ppr other_ct + -setTcSEvVarCacheMap :: TypeMap (EvVar,CtFlavor) -> TcS () -setTcSEvVarCacheMap cache = do { cache_var <- getTcSEvVarCache - ; orig_cache <- wrapTcS $ TcM.readTcRef cache_var - ; let new_cache = orig_cache { evc_cache = cache } - ; wrapTcS $ TcM.writeTcRef cache_var new_cache } getUntouchables :: TcS TcsUntouchables getUntouchables = TcS (return . tcs_untch) @@ -966,16 +1066,11 @@ getTcSTyBinds = TcS (return . tcs_ty_binds) getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType)) getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef) - getTcEvBindsMap :: TcS EvBindMap getTcEvBindsMap = do { EvBindsVar ev_ref _ <- getTcEvBinds ; wrapTcS $ TcM.readTcRef ev_ref } - -setEqBind :: EqVar -> TcCoercion -> CtFlavor -> TcS CtFlavor -setEqBind eqv co fl = setEvBind eqv (EvCoercion co) fl - setWantedTyBind :: TcTyVar -> TcType -> TcS () -- Add a type binding -- We never do this twice! @@ -991,41 +1086,6 @@ setWantedTyBind tv ty ; TcM.writeTcRef ref (extendVarEnv ty_binds tv (tv,ty)) } } -setEvBind :: EvVar -> EvTerm -> CtFlavor -> TcS CtFlavor --- If the flavor is Solved, we cache the new evidence term inside the returned flavor --- see Note [Optimizing Spontaneously Solved Coercions] -setEvBind ev t fl - = do { tc_evbinds <- getTcEvBinds - ; wrapTcS $ TcM.addTcEvBind tc_evbinds ev t - -#ifdef DEBUG - ; binds <- getTcEvBindsMap - ; let cycle = any (reaches binds) (evVarsOfTerm t) - ; when cycle (fail_if_co_loop binds) -#endif - ; return $ - case fl of - Given gl (GivenSolved _) - -> Given gl (GivenSolved (Just t)) - _ -> fl - } - -#ifdef DEBUG - where fail_if_co_loop binds - = pprTrace "setEvBind" (vcat [ text "Cycle in evidence binds, evvar =" <+> ppr ev - , ppr (evBindMapBinds binds) ]) $ - when (isEqVar ev) (pprPanic "setEvBind" (text "BUG: Coercion loop!")) - - reaches :: EvBindMap -> Var -> Bool - -- Does this evvar reach ev? - reaches ebm ev0 = go ev0 - where go ev0 - | ev0 == ev = True - | Just (EvBind _ evtrm) <- lookupEvBind ebm ev0 - = any go (evVarsOfTerm evtrm) - | otherwise = False -#endif - \end{code} Note [Optimizing Spontaneously Solved Coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1153,11 +1213,12 @@ newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty newFlattenSkolemTyVar :: TcType -> TcS TcTyVar newFlattenSkolemTyVar ty - = do { tv <- wrapTcS $ do { uniq <- TcM.newUnique - ; let name = TcM.mkTcTyVarName uniq (fsLit "f") - ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty) } - ; traceTcS "New Flatten Skolem Born" $ - (ppr tv <+> text "[:= " <+> ppr ty <+> text "]") + = do { tv <- wrapTcS $ + do { uniq <- TcM.newUnique + ; let name = TcM.mkTcTyVarName uniq (fsLit "f") + ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty) } + ; traceTcS "New Flatten Skolem Born" $ + ppr tv <+> text "[:= " <+> ppr ty <+> text "]" ; return tv } -- Instantiations @@ -1171,13 +1232,9 @@ instDFunTypes mb_inst_tys inst_tv (Left tv) = mkTyVarTy <$> instFlexiTcS tv inst_tv (Right ty) = return ty -instDFunConstraints :: TcThetaType -> CtFlavor -> TcS [EvVarCreated] -instDFunConstraints preds fl - = mapM (newEvVar fl) preds - instFlexiTcS :: TyVar -> TcS TcTyVar --- Like TcM.instMetaTyVar but the variable that is created is always --- touchable; we are supposed to guess its instantiation. +-- Like TcM.instMetaTyVar but the variable that is created is +-- always touchable; we are supposed to guess its instantiation. -- See Note [Touchable meta type variables] instFlexiTcS tv = instFlexiTcSHelper (tyVarName tv) (tyVarKind tv) @@ -1195,14 +1252,6 @@ isFlexiTcsTv tv | MetaTv TcsTv _ <- tcTyVarDetails tv = True | otherwise = False -newKindConstraint :: TcTyVar -> Kind -> CtFlavor -> TcS EvVarCreated --- Create new wanted CoVar that constrains the type to have the specified kind. -newKindConstraint tv knd fl - = do { tv_k <- instFlexiTcSHelper (tyVarName tv) knd - ; let ty_k = mkTyVarTy tv_k - ; eqv <- newEqVar fl (mkTyVarTy tv) ty_k - ; return eqv } - instFlexiTcSHelper :: Name -> Kind -> TcS TcTyVar instFlexiTcSHelper tvname tvkind = wrapTcS $ @@ -1212,153 +1261,184 @@ instFlexiTcSHelper tvname tvkind kind = tvkind ; return (mkTcTyVar name kind (MetaTv TcsTv ref)) } --- Superclasses and recursive dictionaries --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -data EvVarCreated - = EvVarCreated { evc_is_new :: Bool -- True iff the variable was just created - , evc_the_evvar :: EvVar } -- The actual evidence variable could be cached or new +-- Creating and setting evidence variables and CtFlavors +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -instance Outputable EvVarCreated where - ppr (EvVarCreated { evc_is_new = is_new, evc_the_evvar = ev }) - = ppr ev <> parens (if is_new then ptext (sLit "new") else ptext (sLit "old")) - -isNewEvVar :: EvVarCreated -> Bool -isNewEvVar = evc_is_new - -newEvVar :: CtFlavor -> TcPredType -> TcS EvVarCreated --- Post: If Given then evc_is_new is True --- Hence it is safe to do a setEvBind right after a newEvVar with a Given flavor --- NB: newEvVar may temporarily break the TcSEnv invariant but it is expected in --- the call sites for this invariant to be quickly restored. -newEvVar fl pty - | isGivenOrSolved fl -- Create new variable and update the cache - = do { -{- We lose a lot of time if we enable this check: - eref <- getTcSEvVarCache - ; ecache <- wrapTcS (TcM.readTcRef eref) - ; case lookupTM pty (evc_cache ecache) of - Just (_,cached_fl) - | cached_fl `canSolve` fl - -> pprTrace "Interesting: given newEvVar, missed caching opportunity!" empty $ - return () - _ -> return () --} - new <- forceNewEvVar fl pty - ; return (EvVarCreated True new) } - - | otherwise -- Otherwise lookup first - = {-# SCC "newEvVarWanted" #-} - do { eref <- getTcSEvVarCache - ; ecache <- wrapTcS (TcM.readTcRef eref) - ; case lookupTM pty (evc_cache ecache) of - Just (cached_evvar, cached_flavor) - | cached_flavor `canSolve` fl -- NB: - -- We want to use the cache /only/ if he can solve - -- the workitem. If cached_flavor is Derived - -- but we have a real Wanted, we want to create - -- new evidence, otherwise we are in danger to - -- have unsolved goals in the end. - -- (Remember: Derived's are just unification hints - -- but they don't come with guarantees - -- that they can be solved and we don't - -- quantify over them. - -> do { traceTcS "newEvVar: already cached, doing nothing" - (ppr (evc_cache ecache)) - ; return (EvVarCreated False cached_evvar) } - _ -- Not cached or cached with worse flavor - -> do { new <- force_new_ev_var eref ecache fl pty - ; return (EvVarCreated True new) } } - -forceNewEvVar :: CtFlavor -> TcPredType -> TcS EvVar --- Create a new EvVar, regardless of whether or not the --- cache already contains one like it, and update the cache -forceNewEvVar fl pty - = do { eref <- getTcSEvVarCache - ; ecache <- wrapTcS (TcM.readTcRef eref) - ; force_new_ev_var eref ecache fl pty } - -force_new_ev_var :: IORef EvVarCache -> EvVarCache -> CtFlavor -> TcPredType -> TcS EvVar --- Create a new EvVar, and update the cache with it -force_new_ev_var eref ecache fl pty - = wrapTcS $ - do { TcM.traceTc "newEvVar" $ text "updating cache" +data XEvTerm = + XEvTerm { ev_comp :: [EvVar] -> EvTerm + -- How to compose evidence + , ev_decomp :: EvVar -> [EvTerm] + -- How to decompose evidence + } - ; new_evvar <-TcM.newEvVar pty - -- This is THE PLACE where we finally call TcM.newEvVar +data MaybeNew a = Fresh { mn_thing :: a } + | Cached { mn_thing :: a } + +isFresh :: MaybeNew a -> Bool +isFresh (Fresh {}) = True +isFresh _ = False + +setEvBind :: EvVar -> EvTerm -> TcS () +setEvBind ev t + = do { tc_evbinds <- getTcEvBinds + ; wrapTcS $ TcM.addTcEvBind tc_evbinds ev t + + ; traceTcS "setEvBind" $ vcat [ text "ev =" <+> ppr ev + , text "t =" <+> ppr t ] + +#ifdef DEBUG + ; binds <- getTcEvBindsMap + ; let cycle = any (reaches binds) (evVarsOfTerm t) + ; when cycle (fail_if_co_loop binds) +#endif + ; return () } + +#ifdef DEBUG + where fail_if_co_loop binds + = pprTrace "setEvBind" (vcat [ text "Cycle in evidence binds, evvar =" <+> ppr ev + , ppr (evBindMapBinds binds) ]) $ + when (isEqVar ev) (pprPanic "setEvBind" (text "BUG: Coercion loop!")) + + reaches :: EvBindMap -> Var -> Bool + -- Does this evvar reach ev? + reaches ebm ev0 = go ev0 + where go ev0 + | ev0 == ev = True + | Just (EvBind _ evtrm) <- lookupEvBind ebm ev0 + = any go (evVarsOfTerm evtrm) + | otherwise = False +#endif + +newGivenEvVar :: TcPredType -> EvTerm -> TcS (MaybeNew EvVar) +newGivenEvVar pty evterm + = do { is <- getTcSInerts + ; case lookupInInerts is pty of + Just ct | isGivenOrSolvedCt ct + -> return (Cached (ctId ct)) + _ -> do { new_ev <- wrapTcS $ TcM.newEvVar pty + ; setEvBind new_ev evterm + ; return (Fresh new_ev) } } + +newWantedEvVar :: TcPredType -> TcS (MaybeNew EvVar) +newWantedEvVar pty + = do { is <- getTcSInerts + ; case lookupInInerts is pty of + Just ct | not (isDerivedCt ct) + -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ct + ; return (Cached (ctId ct)) } + _ -> do { new_ev <- wrapTcS $ TcM.newEvVar pty + ; traceTcS "newWantedEvVar/cache miss" $ ppr new_ev + ; return (Fresh new_ev) } } + +newDerived :: TcPredType -> TcS (MaybeNew TcPredType) +newDerived pty + = do { is <- getTcSInerts + ; case lookupInInerts is pty of + Just {} -> return (Cached pty) + _ -> return (Fresh pty) } + +newKindConstraint :: TcTyVar -> Kind -> TcS (MaybeNew EvVar) +-- Create new wanted CoVar that constrains the type to have the specified kind. +newKindConstraint tv knd + = do { tv_k <- instFlexiTcSHelper (tyVarName tv) knd + ; let ty_k = mkTyVarTy tv_k + ; newWantedEvVar (mkTcEqPred (mkTyVarTy tv) ty_k) } + +instDFunConstraints :: TcThetaType -> TcS [MaybeNew EvVar] +instDFunConstraints = mapM newWantedEvVar + + +xCtFlavor :: CtFlavor -- Original flavor + -> [TcPredType] -- New predicate types + -> XEvTerm -- Instructions about how to manipulate evidence + -> ([CtFlavor] -> TcS a) -- What to do with any remaining /fresh/ goals! + -> TcS a +xCtFlavor = xCtFlavor_cache True + + +xCtFlavor_cache :: Bool -- True = if wanted add to the solved bag! + -> CtFlavor -- Original flavor + -> [TcPredType] -- New predicate types + -> XEvTerm -- Instructions about how to manipulate evidence + -> ([CtFlavor] -> TcS a) -- What to do with any remaining /fresh/ goals! + -> TcS a +xCtFlavor_cache _ (Given { flav_gloc = gl, flav_evar = evar }) ptys xev cont_with + = do { let ev_trms = ev_decomp xev evar + ; new_evars <- zipWithM newGivenEvVar ptys ev_trms + ; cont_with $ + map (\x -> Given gl (mn_thing x)) (filter isFresh new_evars) } + +xCtFlavor_cache cache (Wanted { flav_wloc = wl, flav_evar = evar }) ptys xev cont_with + = do { new_evars <- mapM newWantedEvVar ptys + ; let evars = map mn_thing new_evars + evterm = ev_comp xev evars + ; setEvBind evar evterm + ; let solved_flav = Solved { flav_gloc = mkSolvedLoc wl UnkSkol + , flav_evar = evar } + ; when cache $ addToSolved (mkNonCanonical solved_flav) + ; cont_with $ + map (\x -> Wanted wl (mn_thing x)) (filter isFresh new_evars) } + +xCtFlavor_cache _ (Derived { flav_wloc = wl }) ptys _xev cont_with + = do { ders <- mapM newDerived ptys + ; cont_with $ + map (\x -> Derived wl (mn_thing x)) (filter isFresh ders) } + + -- I am not sure I actually want to do this (e.g. from recanonicalizing a solved?) + -- but if we plan to use xCtFlavor for rewriting as well then I might as well add a case +xCtFlavor_cache _ (Solved { flav_gloc = gl, flav_evar = evar }) ptys xev cont_with + = do { let ev_trms = ev_decomp xev evar + ; new_evars <- zipWithM newGivenEvVar ptys ev_trms + ; cont_with $ + map (\x -> Solved gl (mn_thing x)) (filter isFresh new_evars) } + +rewriteCtFlavor :: CtFlavor + -> TcPredType -- new predicate + -> TcCoercion -- new ~ old + -> TcS (Maybe CtFlavor) +rewriteCtFlavor = rewriteCtFlavor_cache True +-- Returns Nothing only if rewriting has happened and the rewritten constraint is cached +-- Returns Just if either (i) we rewrite by reflexivity or +-- (ii) we rewrite and original not cached + +rewriteCtFlavor_cache :: Bool + -> CtFlavor + -> TcPredType -- new predicate + -> TcCoercion -- new ~ old + -> TcS (Maybe CtFlavor) +-- If derived, don't even look at the coercion +-- NB: this allows us to sneak away with ``error'' thunks for +-- coercions that come from derived ids (which don't exist!) +rewriteCtFlavor_cache _cache (Derived wl _pty_orig) pty_new _co + = newDerived pty_new >>= from_mn + where from_mn (Cached {}) = return Nothing + from_mn (Fresh {}) = return $ Just (Derived wl pty_new) + +rewriteCtFlavor_cache cache fl pty co + | isTcReflCo co + -- If just reflexivity then you may re-use the same variable as optimization + = if ctFlavPred fl `eqType` pty then + -- E.g. for type synonyms we want to use the original type + -- since it's not flattened to report better error messages. + return $ Just fl + else + -- E.g. because we rewrite with a spontaneously solved one + return (Just $ case fl of + Derived wl _pty_orig -> Derived wl pty + Given gl ev -> Given gl (setVarType ev pty) + Wanted wl ev -> Wanted wl (setVarType ev pty) + Solved gl ev -> Solved gl (setVarType ev pty)) + | otherwise + = xCtFlavor_cache cache fl [pty] (XEvTerm ev_comp ev_decomp) cont + where ev_comp [x] = mkEvCast x co + ev_comp _ = panic "Coercion can only have one subgoal" + ev_decomp x = [mkEvCast x (mkTcSymCo co)] + cont [] = return Nothing + cont [fl] = return $ Just fl + cont _ = panic "At most one constraint can be subgoal of coercion!" - ; let new_cache = updateCache ecache (new_evvar,fl,pty) - ; TcM.writeTcRef eref new_cache - ; return new_evvar } -updateCache :: EvVarCache -> (EvVar,CtFlavor,Type) -> EvVarCache -updateCache ecache (ev,fl,pty) - | IPPred {} <- classifier - = ecache - | otherwise - = ecache { evc_cache = ecache' } - where classifier = classifyPredType pty - ecache' = alterTM pty (\_ -> Just (ev,fl)) $ - evc_cache ecache - -delCachedEvVar :: EvVar -> CtFlavor -> TcS () -delCachedEvVar ev _fl - = {-# SCC "delCachedEvVarOther" #-} - do { eref <- getTcSEvVarCache - ; ecache <- wrapTcS (TcM.readTcRef eref) - ; wrapTcS $ TcM.writeTcRef eref (delFromCache ecache ev) } - -delFromCache :: EvVarCache -> EvVar -> EvVarCache -delFromCache (EvVarCache { evc_cache = ecache - , evc_flat_cache = flat_cache }) ev - = EvVarCache { evc_cache = ecache', evc_flat_cache = flat_cache } - where ecache' = alterTM pty x_del ecache - x_del Nothing = Nothing - x_del r@(Just (ev0,_)) - | ev0 == ev = Nothing - | otherwise = r - pty = evVarPred ev - - - -updateFlatCache :: EvVar -> CtFlavor - -> TyCon -> [Xi] -> TcType - -> FlatEqOrigin - -> TcS () -updateFlatCache ev fl fn xis rhs_ty feq_origin - = do { eref <- getTcSEvVarCache - ; ecache <- wrapTcS (TcM.readTcRef eref) - ; let flat_cache = evc_flat_cache ecache - new_flat_cache = alterTM fun_ty x_flat_cache flat_cache - new_evc = ecache { evc_flat_cache = new_flat_cache } - ; wrapTcS $ TcM.writeTcRef eref new_evc } - where x_flat_cache _ = Just (mkTcCoVarCo ev,(rhs_ty,fl,feq_origin)) - fun_ty = mkTyConApp fn xis - - -pprEvVarCache :: TypeMap (TcCoercion,a) -> SDoc -pprEvVarCache tm = ppr (foldTM mk_pair tm []) - where mk_pair (co,_) cos = (co, tcCoercionKind co) : cos - - -newGivenEqVar :: CtFlavor -> TcType -> TcType -> TcCoercion -> TcS (CtFlavor,EvVar) --- Pre: fl is Given -newGivenEqVar fl ty1 ty2 co - = do { ecv <- newEqVar fl ty1 ty2 - ; let v = evc_the_evvar ecv -- Will be a new EvVar by post of newEvVar - ; fl' <- setEvBind v (EvCoercion co) fl - ; return (fl',v) } - -newEqVar :: CtFlavor -> TcType -> TcType -> TcS EvVarCreated -newEqVar fl ty1 ty2 - = do { let pred = mkTcEqPred ty1 ty2 - ; v <- newEvVar fl pred - ; traceTcS "newEqVar" (ppr v <+> dcolon <+> ppr pred) - ; return v } -\end{code} - - -\begin{code} -- Matching and looking up classes and family instances -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1373,6 +1453,7 @@ matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Either TyVar TcT matchClass clas tys = do { let pred = mkClassPred clas tys ; instEnvs <- getInstEnvs + ; traceTcS "matchClass" $ text "instEnvs=" <+> ppr instEnvs ; case lookupInstEnv instEnvs clas tys of { ([], unifs, _) -- Nothing matches -> do { traceTcS "matchClass not matching" @@ -1408,19 +1489,28 @@ matchFam tycon args = wrapTcS $ tcLookupFamInst tycon args -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -getInertEqs :: TcS (TyVarEnv (Ct,TcCoercion), InScopeSet) +getInertEqs :: TcS (TyVarEnv Ct, InScopeSet) getInertEqs = do { inert <- getTcSInerts - ; return (inert_eqs inert, inert_eq_tvs inert) } + ; let ics = inert_cans inert + ; return (inert_eqs ics, inert_eq_tvs ics) } + +getCtCoercion :: EvBindMap -> Ct -> TcCoercion +-- Precondition: A CTyEqCan which is either Wanted or Given, never Derived or Solved! +getCtCoercion bs ct + = case lookupEvBind bs cc_id of + -- Given and bound to a coercion term + Just (EvBind _ (EvCoercion co)) -> co + -- NB: The constraint could have been rewritten due to spontaneous + -- unifications but because we are optimizing away mkRefls the evidence + -- variable may still have type (alpha ~ [beta]). The constraint may + -- however have a more accurate type (alpha ~ [Int]) (where beta ~ Int has + -- been previously solved by spontaneous unification). So if we are going + -- to use the evidence variable for rewriting other constraints, we'd better + -- make sure it's of the right type! + -- Always the ctPred type is more accurate, so we just pick that type + + _ -> mkTcCoVarCo (setVarType cc_id (ctPred ct)) + + where cc_id = ctId ct -getCtCoercion :: Ct -> TcCoercion --- Precondition: A CTyEqCan. -getCtCoercion ct - | Just (GivenSolved (Just (EvCoercion co))) <- maybe_given - = co - | otherwise - = mkTcCoVarCo (setVarType (cc_id ct) (ctPred ct)) - -- NB: The variable could be rewritten by a spontaneously - -- solved, so it is not safe to simply do a mkTcCoVarCo (cc_id ct) - -- Instead we use the most accurate type, given by ctPred c - where maybe_given = isGiven_maybe (cc_flavor ct) \end{code} diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 390c70e1fa..3c3c7f7299 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -39,7 +39,7 @@ import BasicTypes ( RuleName ) import Control.Monad ( when ) import Outputable import FastString -import TrieMap +import TrieMap () -- DV: for now import DynFlags \end{code} @@ -597,13 +597,22 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted -- We allow ourselves to unify environment -- variables; hence *no untouchables* +-- DV: SPJ and I discussed a new plan here: +-- Step 1: Simplify everything in the same bag +-- Step 2: zonk away the lhs constraints and get only the non-trivial ones +-- Step 3: do the implications with these constraints +-- This will have the advantage that (i) we no longer need simplEqsOnly flag +-- and (ii) will fix problems appearing from touchable unification variables +-- in the givens, manifested by #5853 +-- TODO ... + ; (lhs_results, lhs_binds) <- runTcS (SimplRuleLhs name) untch emptyInert emptyWorkList $ solveWanteds zonked_lhs ; traceTc "simplifyRule" $ vcat [ text "zonked_lhs" <+> ppr zonked_lhs - , text "lhs_results" <+> ppr lhs_results + , text "lhs_results" <+> ppr lhs_results , text "lhs_binds" <+> ppr lhs_binds , text "rhs_wanted" <+> ppr rhs_wanted ] @@ -611,8 +620,11 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted -- Don't quantify over equalities (judgement call here) ; let (eqs, dicts) = partitionBag (isEqPred . ctPred) (wc_flat lhs_results) - lhs_dicts = map cc_id (bagToList dicts) + lhs_dicts = map ctId (bagToList dicts) -- Dicts and implicit parameters + -- NB: dicts come from lhs_results which + -- are all Wanted, hence have ids, hence + -- it's fine to call ctId on them -- Fail if we have not got down to unsolved flats ; ev_binds_var <- newTcEvBinds @@ -695,10 +707,12 @@ simplifyCheck ctxt wanteds ; traceTc "simplifyCheck }" $ ptext (sLit "unsolved =") <+> ppr unsolved + ; traceTc "reportUnsolved {" empty -- See Note [Deferring coercion errors to runtime] ; runtimeCoercionErrors <- doptM Opt_DeferTypeErrors ; eb2 <- reportUnsolved runtimeCoercionErrors unsolved - + ; traceTc "reportUnsolved }" empty + ; return (eb1 `unionBags` eb2) } \end{code} @@ -807,19 +821,11 @@ simpl_loop n implics ; inerts <- getTcSInerts ; let ((_,unsolved_flats),_) = extractUnsolved inerts - - ; ecache_pre <- getTcSEvVarCacheMap - ; let pr = ppr ((\k z m -> foldTM k m z) (:) [] ecache_pre) - ; traceTcS "ecache_pre" $ pr - + ; improve_eqs <- if not (isEmptyBag implic_eqs) then return implic_eqs else applyDefaultingRules unsolved_flats - ; ecache_post <- getTcSEvVarCacheMap - ; let po = ppr ((\k z m -> foldTM k m z) (:) [] ecache_post) - ; traceTcS "ecache_po" $ po - ; traceTcS "solveWanteds: simpl_loop end" $ vcat [ text "improve_eqs =" <+> ppr improve_eqs , text "unsolved_flats =" <+> ppr unsolved_flats @@ -865,7 +871,10 @@ solveNestedImplications implics where givens_from_wanteds = foldrBag get_wanted [] get_wanted cc rest_givens | pushable_wanted cc - = let this_given = cc { cc_flavor = mkGivenFlavor (cc_flavor cc) UnkSkol } + = let fl = cc_flavor cc + wloc = flav_wloc fl + gfl = Given (mkGivenLoc wloc UnkSkol) (flav_evar fl) + this_given = cc { cc_flavor = gfl } in this_given : rest_givens | otherwise = rest_givens @@ -932,7 +941,10 @@ floatEqualities skols can_given wantders | hasEqualities can_given = (emptyBag, wantders) -- Note [Float Equalities out of Implications] | otherwise = partitionBag is_floatable wantders - + +-- TODO: Maybe we should try out /not/ floating constraints that contain touchables only, +-- since they are inert and not going to interact with anything more in a more global scope. + where skol_set = mkVarSet skols is_floatable :: Ct -> Bool is_floatable ct @@ -1078,6 +1090,8 @@ Note [Float Equalities out of Implications] We want to float equalities out of vanilla existentials, but *not* out of GADT pattern matches. +---> TODO Expand in accordance to our discussion + \begin{code} @@ -1097,23 +1111,22 @@ solveCTyFunEqs cts ; return (niFixTvSubst ni_subst, unsolved_can_cts) } where - solve_one (cv,tv,ty) = do { setWantedTyBind tv ty - ; _ <- setEqBind cv (mkTcReflCo ty) $ - (Wanted $ panic "Met an already solved function equality!") - ; return () -- Don't care about flavors etc this is - -- the last thing happening - } - + solve_one (Wanted _ cv,tv,ty) + = setWantedTyBind tv ty >> setEvBind cv (EvCoercion (mkTcReflCo ty)) + solve_one (Derived {}, tv, ty) + = setWantedTyBind tv ty + solve_one arg + = pprPanic "solveCTyFunEqs: can't solve a /given/ family equation!" $ ppr arg ------------ -type FunEqBinds = (TvSubstEnv, [(CoVar, TcTyVar, TcType)]) +type FunEqBinds = (TvSubstEnv, [(CtFlavor, TcTyVar, TcType)]) -- The TvSubstEnv is not idempotent, but is loop-free -- See Note [Non-idempotent substitution] in Unify emptyFunEqBinds :: FunEqBinds emptyFunEqBinds = (emptyVarEnv, []) -extendFunEqBinds :: FunEqBinds -> CoVar -> TcTyVar -> TcType -> FunEqBinds -extendFunEqBinds (tv_subst, cv_binds) cv tv ty - = (extendVarEnv tv_subst tv ty, (cv, tv, ty):cv_binds) +extendFunEqBinds :: FunEqBinds -> CtFlavor -> TcTyVar -> TcType -> FunEqBinds +extendFunEqBinds (tv_subst, cv_binds) fl tv ty + = (extendVarEnv tv_subst tv ty, (fl, tv, ty):cv_binds) ------------ getSolvableCTyFunEqs :: TcsUntouchables @@ -1125,8 +1138,7 @@ getSolvableCTyFunEqs untch cts dflt_funeq :: (Cts, FunEqBinds) -> Ct -> (Cts, FunEqBinds) dflt_funeq (cts_in, feb@(tv_subst, _)) - (CFunEqCan { cc_id = cv - , cc_flavor = fl + (CFunEqCan { cc_flavor = fl , cc_fun = tc , cc_tyargs = xis , cc_rhs = xi }) @@ -1146,7 +1158,7 @@ getSolvableCTyFunEqs untch cts , not (tv `elemVarSet` niSubstTvSet tv_subst (tyVarsOfTypes xis)) -- Occurs check: see Note [Solving Family Equations], Point 2 = ASSERT ( not (isGivenOrSolved fl) ) - (cts_in, extendFunEqBinds feb cv tv (mkTyConApp tc xis)) + (cts_in, extendFunEqBinds feb fl tv (mkTyConApp tc xis)) dflt_funeq (cts_in, fun_eq_binds) ct = (cts_in `extendCts` ct, fun_eq_binds) @@ -1284,12 +1296,19 @@ defaultTyVar untch the_tv , not (k `eqKind` default_k) = tryTcS $ -- Why tryTcS? See Note [tryTcS in defaulting] do { let loc = CtLoc DefaultOrigin (getSrcSpan the_tv) [] -- Yuk - fl = Wanted loc - ; eqv <- TcSMonad.newKindConstraint the_tv default_k fl - ; if isNewEvVar eqv then + ; eqv <- TcSMonad.newKindConstraint the_tv default_k + ; case eqv of + Fresh x -> + return $ unitBag $ + CNonCanonical { cc_flavor = Wanted loc x, cc_depth = 0 } + Cached _ -> return emptyBag } +{- DELETEME + if isNewEvVar eqv then return $ unitBag (CNonCanonical { cc_id = evc_the_evvar eqv , cc_flavor = fl, cc_depth = 0 }) else return emptyBag } +-} + | otherwise = return emptyBag -- The common case where @@ -1365,12 +1384,16 @@ disambigGroup [] _grp disambigGroup (default_ty:default_tys) group = do { traceTcS "disambigGroup" (ppr group $$ ppr default_ty) ; success <- tryTcS $ -- Why tryTcS? See Note [tryTcS in defaulting] - do { let der_flav = mk_derived_flavor (cc_flavor the_ct) - ; derived_eq <- tryTcS $ + do { derived_eq <- tryTcS $ -- I need a new tryTcS because we will call solveInteractCts below! - do { eqv <- TcSMonad.newEqVar der_flav (mkTyVarTy the_tv) default_ty - ; return [ CNonCanonical { cc_id = evc_the_evvar eqv - , cc_flavor = der_flav, cc_depth = 0 } ] } + do { md <- newDerived (mkTcEqPred (mkTyVarTy the_tv) default_ty) + ; case md of + Cached _ -> return [] + Fresh pty -> + -- flav_wloc because constraint is not Given/Solved! + let dfl = Derived (flav_wloc the_fl) pty + in return [ CNonCanonical { cc_flavor = dfl, cc_depth = 0 } ] } + ; traceTcS "disambigGroup (solving) {" (text "trying to solve constraints along with default equations ...") ; solveInteractCts (derived_eq ++ wanteds) @@ -1393,10 +1416,8 @@ disambigGroup (default_ty:default_tys) group ; disambigGroup default_tys group } } where ((the_ct,the_tv):_) = group + the_fl = cc_flavor the_ct wanteds = map fst group - mk_derived_flavor :: CtFlavor -> CtFlavor - mk_derived_flavor (Wanted loc) = Derived loc - mk_derived_flavor _ = panic "Asked to disambiguate given or derived!" \end{code} Note [Avoiding spurious errors] @@ -1426,9 +1447,8 @@ newFlatWanteds orig theta = do { loc <- getCtLoc orig ; mapM (inst_to_wanted loc) theta } where inst_to_wanted loc pty - = do { v <- newWantedEvVar pty + = do { v <- TcMType.newWantedEvVar pty ; return $ - CNonCanonical { cc_id = v - , cc_flavor = Wanted loc + CNonCanonical { cc_flavor = Wanted loc v , cc_depth = 0 } } \end{code} diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 1ff9dc12e6..e535f24d59 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -390,7 +390,9 @@ tc_bracket _ (ExpBr expr) -- Result type is ExpQ (= Q Exp) tc_bracket _ (TypBr typ) - = do { _ <- tcHsSigTypeNC ThBrackCtxt typ + = do { _ <- tcLHsType typ -- Do not check type validity; we can have a bracket + -- inside a "knot" where things are not yet settled + -- eg data T a = MkT $(foo [t| a |]) ; tcMetaTy typeQTyConName } -- Result type is Type (= Q Typ) @@ -829,7 +831,7 @@ runMeta show_code run_and_convert expr ; either_hval <- tryM $ liftIO $ HscMain.hscCompileCoreExpr hsc_env src_span ds_expr ; case either_hval of { - Left exn -> failWithTc (mk_msg "compile and link" exn) ; + Left exn -> fail_with_exn "compile and link" exn ; Right hval -> do { -- Coerce it to Q t, and run it @@ -857,12 +859,16 @@ runMeta show_code run_and_convert expr Right v -> return v Left se -> case fromException se of Just IOEnvFailure -> failM -- Error already in Tc monad - _ -> failWithTc (mk_msg "run" se) -- Exception + _ -> fail_with_exn "run" se -- Exception }}} where - mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:", - nest 2 (text (Panic.showException exn)), - if show_code then nest 2 (text "Code:" <+> ppr expr) else empty] + -- see Note [Concealed TH exceptions] + fail_with_exn phase exn = do + exn_msg <- liftIO $ Panic.safeShowException exn + let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:", + nest 2 (text exn_msg), + if show_code then nest 2 (text "Code:" <+> ppr expr) else empty] + failWithTc msg \end{code} Note [Exceptions in TH] @@ -894,6 +900,21 @@ like that. Here's how it's processed: - other errors, we add an error to the bag and then fail +Note [Concealed TH exceptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When displaying the error message contained in an exception originated from TH +code, we need to make sure that the error message itself does not contain an +exception. For example, when executing the following splice: + + $( error ("foo " ++ error "bar") ) + +the message for the outer exception is a thunk which will throw the inner +exception when evaluated. + +For this reason, we display the message of a TH exception using the +'safeShowException' function, which recursively catches any exception thrown +when showing an error message. + To call runQ in the Tc monad, we need to make TcM an instance of Quasi: diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index e9af2015ba..fc08bad1d1 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -102,8 +102,7 @@ module TcType ( isFFIImportResultTy, -- :: DynFlags -> Type -> Bool isFFIExportResultTy, -- :: Type -> Bool isFFIExternalTy, -- :: Type -> Bool - isFFIDynArgumentTy, -- :: Type -> Bool - isFFIDynResultTy, -- :: Type -> Bool + isFFIDynTy, -- :: Type -> Type -> Bool isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool isFFILabelTy, -- :: Type -> Bool @@ -1338,19 +1337,24 @@ isFFIImportResultTy dflags ty isFFIExportResultTy :: Type -> Bool isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty -isFFIDynArgumentTy :: Type -> Bool --- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr, --- or a newtype of either. -isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] - -isFFIDynResultTy :: Type -> Bool --- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr, --- or a newtype of either. -isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] +isFFIDynTy :: Type -> Type -> Bool +-- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of +-- either, and the wrapped function type must be equal to the given type. +-- We assume that all types have been run through normalizeFfiType, so we don't +-- need to worry about expanding newtypes here. +isFFIDynTy expected ty + -- Note [Foreign import dynamic] + -- In the example below, expected would be 'CInt -> IO ()', while ty would + -- be 'FunPtr (CDouble -> IO ())'. + | Just (tc, [ty']) <- splitTyConApp_maybe ty + , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey] + , eqType ty' expected + = True + | otherwise + = False isFFILabelTy :: Type -> Bool --- The type of a foreign label must be Ptr, FunPtr, Addr, --- or a newtype of either. +-- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] isFFIPrimArgumentTy :: DynFlags -> Type -> Bool @@ -1401,6 +1405,21 @@ checkRepTyConKey keys = checkRepTyCon (\tc -> tyConUnique tc `elem` keys) \end{code} +Note [Foreign import dynamic] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign +type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'. + +We use isFFIDynTy to check whether a signature is well-formed. For example, +given a (illegal) declaration like: + +foreign import ccall "dynamic" + foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO () + +isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried +result type 'CInt -> IO ()', and return False, as they are not equal. + + ---------------------------------------------- These chaps do the work; they are not exported ---------------------------------------------- diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index a54d420b98..d22fbdaca1 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -535,7 +535,7 @@ uType_defer items ty1 ty2 = ASSERT( not (null items) ) do { eqv <- newEq ty1 ty2 ; loc <- getCtLoc (TypeEqOrigin (last items)) - ; emitFlat (mkNonCanonical eqv (Wanted loc)) + ; emitFlat $ mkNonCanonical (Wanted loc eqv) -- Error trace only -- NB. do *not* call mkErrInfo unless tracing is on, because diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 68a61fd860..50a0fcf39a 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -199,6 +199,8 @@ match menv subst (AppTy ty1a ty1b) ty2 = do { subst' <- match menv subst ty1a ty2a ; match menv subst' ty1b ty2b } +match _ subst (LitTy x) (LitTy y) | x == y = return subst + match _ _ _ _ = Nothing @@ -339,6 +341,8 @@ typesCantMatch prs = any (\(s,t) -> cant_match s t) prs | Just (f1, a1) <- repSplitAppTy_maybe ty1 = cant_match f1 f2 || cant_match a1 a2 + cant_match (LitTy x) (LitTy y) = x /= y + cant_match _ _ = False -- Safe! -- Things we could add; @@ -453,6 +457,8 @@ unify subst ty1 (AppTy ty2a ty2b) = do { subst' <- unify subst ty1a ty2a ; unify subst' ty1b ty2b } +unify subst (LitTy x) (LitTy y) | x == y = return subst + unify _ ty1 ty2 = failWith (misMatch ty1 ty2) -- ForAlls?? diff --git a/compiler/utils/Panic.lhs b/compiler/utils/Panic.lhs index cc3603baeb..0fb206ca77 100644 --- a/compiler/utils/Panic.lhs +++ b/compiler/utils/Panic.lhs @@ -22,7 +22,7 @@ module Panic ( panic, sorry, panicFastInt, assertPanic, trace, - Exception.Exception(..), showException, try, tryMost, throwTo, + Exception.Exception(..), showException, safeShowException, try, tryMost, throwTo, installSignalHandlers, interruptTargetThread ) where @@ -113,6 +113,18 @@ short_usage = "Usage: For basic information, try the `--help' option." showException :: Exception e => e -> String showException = show +-- | Show an exception which can possibly throw other exceptions. +-- Used when displaying exception thrown within TH code. +safeShowException :: Exception e => e -> IO String +safeShowException e = do + -- ensure the whole error message is evaluated inside try + r <- try (return $! forceList (showException e)) + case r of + Right msg -> return msg + Left e' -> safeShowException (e' :: SomeException) + where + forceList [] = [] + forceList xs@(x : xt) = x `seq` forceList xt `seq` xs -- | Append a description of the given exception to this string. showGhcException :: GhcException -> String -> String |