From: simonpj@microsoft.com Date: Wed, 7 Jul 2010 12:31:25 +0000 (+0000) Subject: Fix Trac #4127 (and hence #4173) X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=f87cc9cfccf83b21a66501f9654d3e6f1fa7adb4 Fix Trac #4127 (and hence #4173) The change involves a little refactoring, so that the default method Ids are brought into scope earlier, before the value declarations are compiled. (Since a value decl may contain an instance decl in a quote.) See Note [Default method Ids and Template Haskell] in TcTyClsDcls. --- diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index d0725bf..6e7b0c0 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -12,13 +12,6 @@ have a standard form, namely: - primitive operations \begin{code} -{-# OPTIONS -fno-warn-missing-signatures #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- --- for details - module MkId ( mkDictFunId, mkDefaultMethodId, mkDictSelId, @@ -399,6 +392,7 @@ mAX_CPR_SIZE = 10 -- by the caller. So doing CPR for them may in fact make -- things worse. +mkLocals :: Int -> [Type] -> ([Id], Int) mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n) where n = length tys @@ -806,6 +800,7 @@ mkBreakPointOpId :: Unique -> Module -> TickBoxId -> Id mkBreakPointOpId uniq mod ix = mkTickBox' uniq mod ix ty where ty = mkSigmaTy [openAlphaTyVar] [] openAlphaTy +mkTickBox' :: Unique -> Module -> TickBoxId -> Type -> Id mkTickBox' uniq mod ix ty = mkGlobalId (TickBoxOpId tickbox) name ty info where tickbox = TickBox mod ix @@ -846,7 +841,10 @@ BUT make sure they are *exported* LocalIds (mkExportedLocalId) so that they aren't discarded by the occurrence analyser. \begin{code} -mkDefaultMethodId dm_name ty = mkExportedLocalId dm_name ty +mkDefaultMethodId :: Id -- Selector Id + -> Name -- Default method name + -> Id -- Default method Id +mkDefaultMethodId sel_id dm_name = mkExportedLocalId dm_name (idType sel_id) mkDictFunId :: Name -- Name to use for the dict fun; -> [TyVar] @@ -885,9 +883,14 @@ they can unify with both unlifted and lifted types. Hence we provide another gun with which to shoot yourself in the foot. \begin{code} +mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name mkWiredInIdName mod fs uniq id = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax +unsafeCoerceName, nullAddrName, seqName, realWorldName :: Name +lazyIdName, errorName, recSelErrorName, runtimeErrorName :: Name +irrefutPatErrorName, recConErrorName, patErrorName :: Name +nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId @@ -910,6 +913,7 @@ nonExhaustiveGuardsErrorName \begin{code} ------------------------------------------------ -- unsafeCoerce# :: forall a b. a -> b +unsafeCoerceId :: Id unsafeCoerceId = pcMiscPrelId unsafeCoerceName ty info where @@ -1051,6 +1055,7 @@ E.g. This comes up in strictness analysis \begin{code} +realWorldPrimId :: Id realWorldPrimId -- :: State# RealWorld = pcMiscPrelId realWorldName realWorldStatePrimTy (noCafIdInfo `setUnfoldingInfo` evaldUnfolding) @@ -1103,6 +1108,8 @@ mkImpossibleExpr :: Type -> CoreExpr mkImpossibleExpr res_ty = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative" +rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id +pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName @@ -1121,6 +1128,7 @@ runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) \end{code} \begin{code} +eRROR_ID :: Id eRROR_ID = pc_bottoming_Id errorName errorTy errorTy :: Type diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 2f7f6bc..13b6300 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -149,12 +149,12 @@ tcClassSig _ s = pprPanic "tcClassSig" (ppr s) \begin{code} tcClassDecl2 :: LTyClDecl Name -- The class declaration - -> TcM ([Id], LHsBinds Id) + -> TcM (LHsBinds Id) tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcdMeths = default_binds})) - = recoverM (return ([], emptyLHsBinds)) $ - setSrcSpan loc $ + = recoverM (return emptyLHsBinds) $ + setSrcSpan loc $ do { clas <- tcLookupLocatedClass class_name -- We make a separate binding for each default method. @@ -179,17 +179,16 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, this_dict default_binds sig_fn prag_fn - ; dm_stuff <- tcExtendTyVarEnv clas_tyvars $ + ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ mapM tc_dm op_items - ; let (dm_ids, defm_binds) = unzip (catMaybes dm_stuff) - ; return (dm_ids, listToBag defm_binds) } + ; return (listToBag (catMaybes dm_binds)) } tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) tcDefMeth :: Class -> [TyVar] -> Inst -> LHsBinds Name -> TcSigFun -> TcPragFun -> ClassOpItem - -> TcM (Maybe (Id, LHsBind Id)) + -> TcM (Maybe (LHsBind Id)) -- Generate code for polymorphic default methods only (hence DefMeth) -- (Generic default methods have turned into instance decls by now.) -- This is incompatible with Hugs, which expects a polymorphic @@ -213,9 +212,8 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) `orElse` pprPanic "tcDefMeth" (ppr sel_id) -- dm_info = DefMeth dm_name only if there is a binding in binds_in - dm_sig_fn _ = sig_fn sel_name - dm_ty = idType sel_id - dm_id = mkDefaultMethodId dm_name dm_ty + dm_sig_fn _ = sig_fn sel_name + dm_id = mkDefaultMethodId sel_id dm_name local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars) local_dm_id = mkLocalId local_dm_name local_dm_type @@ -237,7 +235,7 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) tcInstanceMethodBody :: InstLoc -> [TcTyVar] -> [Inst] -> ([Inst], LHsBinds Id) -> Id -> Id -> TcSigFun -> TcSpecPrags -> LHsBind Name - -> TcM (Id, LHsBind Id) + -> TcM (LHsBind Id) tcInstanceMethodBody inst_loc tyvars dfun_dicts (this_dict, this_bind) meth_id local_meth_id meth_sig_fn spec_prags bind@(L loc _) @@ -264,7 +262,7 @@ tcInstanceMethodBody inst_loc tyvars dfun_dicts dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities - ; return (meth_id, L loc full_bind) } + ; return (L loc full_bind) } where no_prag_fn _ = [] -- No pragmas for local_meth_id; -- they are all for meth_id diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 374fb6d..a6f2b80 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -323,7 +323,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ; at_idx_tycons = concat at_tycons_s ++ idx_tycons ; clas_decls = filter (isClassDecl.unLoc) tycl_decls ; implicit_things = concatMap implicitTyThings at_idx_tycons - ; aux_binds = mkAuxBinds at_idx_tycons + ; aux_binds = mkRecSelBinds at_idx_tycons } -- (2) Add the tycons of indexed types and their implicit @@ -541,7 +541,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) \begin{code} tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name] - -> TcM (LHsBinds Id, TcLclEnv) + -> TcM (LHsBinds Id) -- (a) From each class declaration, -- generate any default-method bindings -- (b) From each instance decl @@ -550,18 +550,14 @@ tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name] tcInstDecls2 tycl_decls inst_decls = do { -- (a) Default methods from class decls let class_decls = filter (isClassDecl . unLoc) tycl_decls - ; (dm_ids_s, dm_binds_s) <- mapAndUnzipM tcClassDecl2 class_decls + ; dm_binds_s <- mapM tcClassDecl2 class_decls - ; tcExtendIdEnv (concat dm_ids_s) $ do - -- (b) instance declarations - { inst_binds_s <- mapM tcInstDecl2 inst_decls + ; inst_binds_s <- mapM tcInstDecl2 inst_decls -- Done - ; let binds = unionManyBags dm_binds_s `unionBags` - unionManyBags inst_binds_s - ; tcl_env <- getLclEnv -- Default method Ids in here - ; return (binds, tcl_env) } } + ; return (unionManyBags dm_binds_s `unionBags` + unionManyBags inst_binds_s) } tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) @@ -1005,13 +1001,14 @@ tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys = add_meth_ctxt rn_bind $ do { (meth_id1, spec_prags) <- tcPrags NonRecursive False True meth_id (prag_fn sel_name) - ; tcInstanceMethodBody (instLoc this_dict) + ; bind <- tcInstanceMethodBody (instLoc this_dict) tyvars dfun_dicts ([this_dict], this_dict_bind) meth_id1 local_meth_id meth_sig_fn (SpecPrags (spec_inst_prags ++ spec_prags)) - rn_bind } + rn_bind + ; return (meth_id1, bind) } -------------- tc_default :: DefMeth -> TcM (Id, LHsBind Id) diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 069446f..8638d9f 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -297,7 +297,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- any mutually recursive types are done right -- Just discard the auxiliary bindings; they are generated -- only for Haskell source code, and should already be in Core - (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ; + (tcg_env, _aux_binds, _dm_ids) <- tcTyAndClassDecls emptyModDetails rn_decls ; setGblEnv tcg_env $ do { -- Make the new type env available to stuff slurped from interface files @@ -485,8 +485,10 @@ tcRnHsBootDecls decls -- Typecheck type/class decls ; traceTc (text "Tc2") - ; (tcg_env, aux_binds) <- tcTyAndClassDecls emptyModDetails tycl_decls - ; setGblEnv tcg_env $ do { + ; (tcg_env, aux_binds, dm_ids) + <- tcTyAndClassDecls emptyModDetails tycl_decls + ; setGblEnv tcg_env $ + tcExtendIdEnv dm_ids $ do { -- Typecheck instance decls -- Family instance declarations are rejected here @@ -821,10 +823,12 @@ tcTopSrcDecls boot_details -- The latter come in via tycl_decls traceTc (text "Tc2") ; - (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ; + (tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ; -- If there are any errors, tcTyAndClassDecls fails here - setGblEnv tcg_env $ do { + setGblEnv tcg_env $ + tcExtendIdEnv dm_ids $ do { + -- Source-language instances, including derivings, -- and import the supporting declarations traceTc (text "Tc3") ; @@ -854,13 +858,12 @@ tcTopSrcDecls boot_details (tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $ tcTopBinds val_binds; + setLclTypeEnv tcl_env $ do { -- Environment doesn't change now + -- Second pass over class and instance declarations, traceTc (text "Tc6") ; - (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $ - tcInstDecls2 tycl_decls inst_infos ; - showLIE (text "after instDecls2") ; - - setLclTypeEnv tcl_env $ do { -- Environment doesn't change now + inst_binds <- tcInstDecls2 tycl_decls inst_infos ; + showLIE (text "after instDecls2") ; -- Foreign exports traceTc (text "Tc7") ; diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 47b8c31..83f05da 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -7,7 +7,7 @@ TcTyClsDecls: Typecheck type and class declarations \begin{code} module TcTyClsDecls ( - tcTyAndClassDecls, tcFamInstDecl, mkAuxBinds + tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds ) where #include "HsVersions.h" @@ -30,7 +30,7 @@ import Class import TyCon import DataCon import Id -import MkId ( rEC_SEL_ERROR_ID ) +import MkId ( rEC_SEL_ERROR_ID, mkDefaultMethodId ) import IdInfo import Var import VarSet @@ -136,7 +136,9 @@ indeed type families). I think. tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name] -> TcM (TcGblEnv, -- Input env extended by types and classes -- and their implicit Ids,DataCons - HsValBinds Name) -- Renamed bindings for record selectors + HsValBinds Name, -- Renamed bindings for record selectors + [Id]) -- Default method ids + -- Fails if there are any errors tcTyAndClassDecls boot_details allDecls @@ -202,11 +204,12 @@ tcTyAndClassDecls boot_details allDecls -- second time here. This doesn't matter as the definitions are -- the same. ; let { implicit_things = concatMap implicitTyThings alg_tyclss - ; aux_binds = mkAuxBinds alg_tyclss } + ; rec_sel_binds = mkRecSelBinds alg_tyclss + ; dm_ids = mkDefaultMethodIds alg_tyclss } ; traceTc ((text "Adding" <+> ppr alg_tyclss) $$ (text "and" <+> ppr implicit_things)) ; env <- tcExtendGlobalEnv implicit_things getGblEnv - ; return (env, aux_binds) } + ; return (env, rec_sel_binds, dm_ids) } } where -- Pull associated types out of class declarations, to tie them into the @@ -1228,11 +1231,36 @@ checkValidClass cls %************************************************************************ \begin{code} -mkAuxBinds :: [TyThing] -> HsValBinds Name +mkDefaultMethodIds :: [TyThing] -> [Id] +-- See Note [Default method Ids and Template Haskell] +mkDefaultMethodIds things + = [ mkDefaultMethodId sel_id dm_name + | AClass cls <- things + , (sel_id, DefMeth dm_name) <- classOpItems cls ] +\end{code} + +Note [Default method Ids and Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (Trac #4169): + class Numeric a where + fromIntegerNum :: a + fromIntegerNum = ... + + ast :: Q [Dec] + ast = [d| instance Numeric Int |] + +When we typecheck 'ast' we have done the first pass over the class decl +(in tcTyClDecls), but we have not yet typechecked the default-method +declarations (becuase they can mention value declarations). So we +must bring the default method Ids into scope first (so they can be seen +when typechecking the [d| .. |] quote, and typecheck them later. + +\begin{code} +mkRecSelBinds :: [TyThing] -> HsValBinds Name -- NB We produce *un-typechecked* bindings, rather like 'deriving' -- This makes life easier, because the later type checking will add -- all necessary type abstractions and applications -mkAuxBinds ty_things +mkRecSelBinds ty_things = ValBindsOut [(NonRecursive, b) | b <- binds] sigs where (sigs, binds) = unzip rec_sels diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs index 27ec5c1..dc7cd91 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -14,7 +14,7 @@ module Class ( mkClass, classTyVars, classArity, classKey, className, classATs, classSelIds, classTyCon, classMethods, - classBigSig, classExtraBigSig, classTvsFds, classSCTheta + classOpItems,classBigSig, classExtraBigSig, classTvsFds, classSCTheta ) where #include "Typeable.h" @@ -121,6 +121,9 @@ classMethods :: Class -> [Id] classMethods (Class {classOpStuff = op_stuff}) = [op_sel | (op_sel, _) <- op_stuff] +classOpItems :: Class -> [ClassOpItem] +classOpItems (Class {classOpStuff = op_stuff}) = op_stuff + classTvsFds :: Class -> ([TyVar], [FunDep TyVar]) classTvsFds c = (classTyVars c, classFunDeps c)