X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=ca4f2c5ecd098e9afbd1c105c4faaf1bef78ec94;hp=d4e859be38acb5501a37d7fce1f1dc502204416a;hb=792449f555bb4dfa8e718079f6d42dc9babe938a;hpb=d7fb8d371d3228774331a67db8da805b2d68f1c4 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index d4e859b..ca4f2c5 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -35,6 +35,7 @@ import IdInfo import Var import VarSet import Name +import NameEnv import Outputable import Maybes import Unify @@ -65,9 +66,7 @@ tcTyAndClassDecls :: ModDetails -> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order -> TcM (TcGblEnv, -- Input env extended by types and classes -- and their implicit Ids,DataCons - HsValBinds Name, -- Renamed bindings for record selectors - [Id], -- Default method ids - [LTyClDecl Name]) -- Kind-checked declarations + HsValBinds Name) -- Renamed bindings for record selectors -- Fails if there are any errors tcTyAndClassDecls boot_details decls_s @@ -109,11 +108,10 @@ tcTyAndClassDecls boot_details decls_s ; rec_sel_binds = mkRecSelBinds [tc | ATyCon tc <- tyclss] ; dm_ids = mkDefaultMethodIds tyclss } - ; env <- tcExtendGlobalEnv implicit_things getGblEnv - -- We need the kind-checked declarations later, so we return them - -- from here - ; kc_decls <- kcTyClDecls tyclds_s - ; return (env, rec_sel_binds, dm_ids, kc_decls) } } + ; env <- tcExtendGlobalEnv implicit_things $ + tcExtendGlobalValEnv dm_ids $ + getGblEnv + ; return (env, rec_sel_binds) } } zipRecTyClss :: [[LTyClDecl Name]] -> [TyThing] -- Knot-tied @@ -484,7 +482,6 @@ tcTyClDecl1 _parent calc_isrec { extra_tvs <- tcDataKindSig mb_ksig ; let final_tvs = tvs' ++ extra_tvs ; stupid_theta <- tcHsKindedContext ctxt - ; unbox_strict <- doptM Opt_UnboxStrictFields ; kind_signatures <- xoptM Opt_KindSignatures ; existential_ok <- xoptM Opt_ExistentialQuantification ; gadt_ok <- xoptM Opt_GADTs @@ -498,8 +495,7 @@ tcTyClDecl1 _parent calc_isrec ; tycon <- fixM (\ tycon -> do { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) - ; data_cons <- tcConDecls unbox_strict ex_ok - tycon (final_tvs, res_ty) cons + ; data_cons <- tcConDecls ex_ok tycon (final_tvs, res_ty) cons ; tc_rhs <- if null cons && is_boot -- In a hs-boot file, empty cons means then return AbstractTyCon -- "don't know"; hence Abstract @@ -524,7 +520,7 @@ tcTyClDecl1 _parent calc_isrec tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; fds' <- mapM (addLocM tc_fundep) fundeps - ; sig_stuff <- tcClassSigs class_name sigs meths + ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths ; clas <- fixM $ \ clas -> do { let -- This little knot is just so we can get -- hold of the name of the class TyCon, which we @@ -537,7 +533,18 @@ tcTyClDecl1 _parent calc_isrec ; buildClass False {- Must include unfoldings for selectors -} class_name tvs' ctxt' fds' (concat atss') sig_stuff tc_isrec } - ; return (AClass clas : map ATyCon (classATs clas)) + + ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty) + | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas + , let gen_dm_tau = expectJust "tcTyClDecl1" $ + lookupNameEnv gen_dm_env (idName sel_id) + , let gen_dm_ty = mkSigmaTy tvs' + [mkClassPred clas (mkTyVarTys tvs')] + gen_dm_tau + ] + class_ats = map ATyCon (classATs clas) + + ; return (AClass clas : gen_dm_ids ++ class_ats ) -- NB: Order is important due to the call to `mkGlobalThings' when -- tying the the type and class declaration type checking knot. } @@ -576,19 +583,18 @@ dataDeclChecks tc_name new_or_data stupid_theta cons (emptyConDeclsErr tc_name) } ----------------------------------- -tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type) +tcConDecls :: Bool -> TyCon -> ([TyVar], Type) -> [LConDecl Name] -> TcM [DataCon] -tcConDecls unbox ex_ok rep_tycon res_tmpl cons - = mapM (addLocM (tcConDecl unbox ex_ok rep_tycon res_tmpl)) cons +tcConDecls ex_ok rep_tycon res_tmpl cons + = mapM (addLocM (tcConDecl ex_ok rep_tycon res_tmpl)) cons -tcConDecl :: Bool -- True <=> -funbox-strict_fields - -> Bool -- True <=> -XExistentialQuantificaton or -XGADTs +tcConDecl :: Bool -- True <=> -XExistentialQuantificaton or -XGADTs -> TyCon -- Representation tycon -> ([TyVar], Type) -- Return type template (with its template tyvars) -> ConDecl Name -> TcM DataCon -tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types +tcConDecl existential_ok rep_tycon res_tmpl -- Data types con@(ConDecl {con_name = name, con_qvars = tvs, con_cxt = ctxt , con_details = details, con_res = res_ty }) = addErrCtxt (dataConCtxt name) $ @@ -599,7 +605,7 @@ tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty ; let tc_datacon is_infix field_lbls btys - = do { (arg_tys, stricts) <- mapAndUnzipM (tcConArg unbox_strict) btys + = do { (arg_tys, stricts) <- mapAndUnzipM tcConArg btys ; buildDataCon (unLoc name) is_infix stricts field_lbls univ_tvs ex_tvs eq_preds ctxt' arg_tys @@ -705,13 +711,10 @@ conRepresentibleWithH98Syntax f _ _ = False ------------------- -tcConArg :: Bool -- True <=> -funbox-strict_fields - -> LHsType Name - -> TcM (TcType, HsBang) -tcConArg unbox_strict bty +tcConArg :: LHsType Name -> TcM (TcType, HsBang) +tcConArg bty = do { arg_ty <- tcHsBangType bty - ; let bang = getBangStrictness bty - ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang + ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty) ; return (arg_ty, strict_mark) } -- We attempt to unbox/unpack a strict field when either: @@ -720,13 +723,19 @@ tcConArg unbox_strict bty -- -- We have turned off unboxing of newtypes because coercions make unboxing -- and reboxing more complicated -chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang -chooseBoxingStrategy unbox_strict_fields arg_ty bang +chooseBoxingStrategy :: TcType -> HsBang -> TcM HsBang +chooseBoxingStrategy arg_ty bang = case bang of - HsNoBang -> HsNoBang - HsUnpack -> can_unbox HsUnpackFailed arg_ty - HsStrict | unbox_strict_fields -> can_unbox HsStrict arg_ty - | otherwise -> HsStrict + HsNoBang -> return HsNoBang + HsStrict -> do { unbox_strict <- doptM Opt_UnboxStrictFields + ; if unbox_strict then return (can_unbox HsStrict arg_ty) + else return HsStrict } + HsUnpack -> do { omit_prags <- doptM Opt_OmitInterfacePragmas + -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on + -- See Trac #5252: unpacking means we must not conceal the + -- representation of the argument type + ; if omit_prags then return HsStrict + else return (can_unbox HsUnpackFailed arg_ty) } HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty) -- Source code never has shtes where @@ -802,6 +811,8 @@ checkValidTyCl decl ATyCon tc -> checkValidTyCon tc AClass cl -> do { checkValidClass cl ; mapM_ (addLocM checkValidTyCl) (tcdATs decl) } + AnId _ -> return () -- Generic default methods are checked + -- with their parent class _ -> panic "checkValidTyCl" ; traceTc "Done validity of" (ppr thing) } @@ -964,7 +975,7 @@ checkValidClass cls unary = isSingleton tyvars no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff] - check_op constrained_class_methods (sel_id, _) + check_op constrained_class_methods (sel_id, dm) = addErrCtxt (classOpCtxt sel_id tau) $ do { checkValidTheta SigmaCtxt (tail theta) -- The 'tail' removes the initial (C a) from the @@ -982,6 +993,11 @@ checkValidClass cls ; let grown_tyvars = growThetaTyVars theta (mkVarSet tyvars) ; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars) (noClassTyVarErr cls sel_id) + + ; case dm of + GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name + ; checkValidType (FunSigCtxt op_name) (idType dm_id) } + _ -> return () } where op_name = idName sel_id