From ba013704bfb94aa133fb28f342e0d432698a5d6d Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 8 Jun 1998 11:45:29 +0000 Subject: [PATCH] [project @ 1998-06-08 11:45:09 by simonpj] (a) FloatIn idSpecVars bug [DoCon] (b) Generalise superclasses --- ghc/compiler/coreSyn/FreeVars.lhs | 21 ++++++++-------- ghc/compiler/parser/hsparser.y | 22 ++++++++++------- ghc/compiler/parser/syntax.c | 43 ++++++++++++++++++++++++++++++++- ghc/compiler/simplCore/FloatIn.lhs | 32 +++++++++++------------- ghc/compiler/typecheck/TcBinds.lhs | 11 ++++++--- ghc/compiler/typecheck/TcClassDcl.lhs | 27 ++++++++++++++++++--- ghc/compiler/typecheck/TcSimplify.lhs | 17 ++++++++----- ghc/compiler/typecheck/TcType.lhs | 8 +++++- 8 files changed, 129 insertions(+), 52 deletions(-) diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs index 9619f49..b0b39e3 100644 --- a/ghc/compiler/coreSyn/FreeVars.lhs +++ b/ghc/compiler/coreSyn/FreeVars.lhs @@ -262,8 +262,11 @@ fvExpr id_cands tyvar_cands (Case expr alts) binder_ftvs = munge_id_ty binder -- We need to collect free tyvars from the binder +-- Don't forget to notice that the idSpecVars of the binder +-- are free in the whole expression; albeit not in the RHS or body + fvExpr id_cands tyvar_cands (Let (NonRec binder rhs) body) - = (FVInfo (freeVarsOf rhs' `combine` body_fvs) + = (FVInfo (freeVarsOf rhs' `combine` body_fvs `combine` mkIdSet (idSpecVars binder)) (freeTyVarsOf rhs' `combine` freeTyVarsOf body2 `combine` binder_ftvs) (leakinessOf rhs' `orLeak` leakinessOf body2), AnnLet (AnnNonRec binder rhs') body2) @@ -288,7 +291,12 @@ fvExpr id_cands tyvar_cands (Let (Rec binds) body) FVInfo rhss_fvs rhss_tfvs leakiness_of_rhss = foldr1 combineFVInfo [info | (info,_) <- rhss'] - binds_fvs = rhss_fvs `minusIdSet` binders_set + -- Don't forget to notice that the idSpecVars of the binder + -- are free in the whole expression; albeit not in the RHS or body + binds_fvs = (foldr (unionIdSets . mkIdSet . idSpecVars) rhss_fvs binders) + `minusIdSet` + binders_set + body2 = fvExpr new_id_cands tyvar_cands body body_fvs = freeVarsOf body2 `minusIdSet` binders_set binders_ftvs = foldr (combine . munge_id_ty) noFreeTyVars binders @@ -309,15 +317,8 @@ fvExpr id_cands tyvar_cands (Note other_note expr) where expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr --- fvRhs returns the annotated RHS, but it adds to the --- free vars of the RHS the idSpecVars of the binder, --- since those are, in truth, free in the definition. fvRhs id_cands tyvar_cands (bndr,rhs) - = (FVInfo fvs' ftvs leak, rhs') - where - (FVInfo fvs ftvs leak, rhs') = fvExpr id_cands tyvar_cands rhs - fvs' = fvs `unionIdSets` mkIdSet (idSpecVars bndr) - + = fvExpr id_cands tyvar_cands rhs \end{code} \begin{code} diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y index 05441f9..ab59ce6 100644 --- a/ghc/compiler/parser/hsparser.y +++ b/ghc/compiler/parser/hsparser.y @@ -504,10 +504,14 @@ deriving: /* empty */ { $$ = mknothing(); } | DERIVING dtyclses { $$ = mkjust($2); } ; -classd : classkey simple_context DARROW simple_con_app1 cbody - { $$ = mkcbind($2,$4,$5,startlineno); } - | classkey simple_con_app1 cbody - { $$ = mkcbind(Lnil,$2,$3,startlineno); } +classd : classkey btype DARROW simple_con_app1 cbody + /* Context can now be more than simple_context */ + { $$ = mkcbind(type2context($2),$4,$5,startlineno); } + | classkey btype cbody + /* We have to say btype rather than simple_con_app1, else + we get reduce/reduce errs */ + { check_class_decl_head($3); + $$ = mkcbind(Lnil,$2,$3,startlineno); } ; cbody : /* empty */ { $$ = mknullbind(); } @@ -521,7 +525,7 @@ instd : instkey inst_type rinst { $$ = mkibind($2,$3,startlineno); } /* Compare ctype */ inst_type : type DARROW type { is_context_format( $3, 0 ); /* Check the instance head */ $$ = mkcontext(type2context($1),$3); } - | type { is_context_format( $1, 0 ); /* Check the instance head */ + | btype { is_context_format( $1, 0 ); /* Check the instance head */ $$ = $1; } ; @@ -649,7 +653,7 @@ type_and_maybe_id : /* A sigtype is a rank 2 type; it can have for-alls as function args: f :: All a => (All b => ...) -> Int */ -sigtype : type DARROW sigarrowtype { $$ = mkcontext(type2context($1),$3); } +sigtype : btype DARROW sigarrowtype { $$ = mkcontext(type2context($1),$3); } | sigarrowtype ; @@ -659,11 +663,11 @@ sigarrowtype : bigatype RARROW sigarrowtype { $$ = mktfun($1,$3); } ; /* A "big" atype can be a forall-type in brackets. */ -bigatype: OPAREN type DARROW type CPAREN { $$ = mkcontext(type2context($2),$4); } +bigatype: OPAREN btype DARROW type CPAREN { $$ = mkcontext(type2context($2),$4); } ; /* 1 S/R conflict at DARROW -> shift */ -ctype : type DARROW type { $$ = mkcontext(type2context($1),$3); } +ctype : btype DARROW type { $$ = mkcontext(type2context($1),$3); } | type ; @@ -733,7 +737,7 @@ constrs : constr { $$ = lsing($1); } ; constr : constr_after_context - | type DARROW constr_after_context { $$ = mkconstrcxt ( type2context($1), $3 ); } + | btype DARROW constr_after_context { $$ = mkconstrcxt ( type2context($1), $3 ); } ; constr_after_context : diff --git a/ghc/compiler/parser/syntax.c b/ghc/compiler/parser/syntax.c index 73b39f0..4f8d661 100644 --- a/ghc/compiler/parser/syntax.c +++ b/ghc/compiler/parser/syntax.c @@ -540,9 +540,50 @@ checknobangs(app) hsperror("syntax error: unexpected ! in type"); checknobangs(gtapp((struct Stapp *)app)); - } + } +} + + +/* Check that a type is of the form + C a1 a2 .. an + where n>=1, and the ai are all type variables + This is used to check that a class decl is well formed. +*/ +void +check_class_decl_head_help( app, n ) + ttype app; + int n; /* Number of args so far */ +{ + switch (tttype(app)) { + case tapp: + /* Check the arg is a type variable */ + switch (tttype (gtarg((struct Stapp *) app))) { + case namedtvar: break; + default: hsperror("Class declaration head must use only type variables"); + } + + /* Check the fun part */ + check_class_decl_head_help( gtapp((struct Stapp *) app), n+1 ); + break; + + case tname: + /* Class name; check there is at least one argument */ + if (n==0) { + hsperror("Class must have at least one argument"); + } + break; + + default: + hsperror("Illegal syntax in class declaration head"); + } } +void +check_class_decl_head( app ) + ttype app; +{ check_class_decl_head_help( app, 0 ); } + + /* Splits a tycon application into its constructor and a list of types. diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 877304d..353a3b2 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -362,27 +362,23 @@ sepBindsByDropPoint drop_pts floaters split' drop_pts_fvs [] mult_branch drop_boxes = (drop_boxes, mult_branch, drop_pts_fvs) - -- only in a or unused - split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes) - | all (\b -> {-b `elementOfIdSet` a &&-} - not (b `elementOfIdSet` (unionManyIdSets as))) - (bindersOf (fst bind)) - = split' (a':as) binds mult_branch ((bind:drop_box_a):drop_boxes) - where - a' = a `unionIdSets` fvsOfBind bind + split' drop_pts_fvs (bind:binds) mult_branch drop_boxes + | no_of_branches == 1 -- Exactly one branch + = split' drop_pts_fvs' binds mult_branch drop_boxes' - -- not in a - split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes) - | all (\b -> not (b `elementOfIdSet` a)) (bindersOf (fst bind)) - = split' (a:as') binds mult_branch' (drop_box_a:drop_boxes') - where - (drop_boxes',mult_branch',as') = split' as [bind] mult_branch drop_boxes + | otherwise -- Zero or many branches; drop it here + = split' drop_pts_fvs binds (bind:mult_branch) drop_boxes - -- in a and in as - split' aas@(a:as) (bind:binds) mult_branch drop_boxes - = split' aas' binds (bind : mult_branch) drop_boxes where - aas' = map (unionIdSets (fvsOfBind bind)) aas + binders = bindersOf (fst bind) + no_of_branches = length [() | True <- in_branch_flags] + in_branch_flags = [ any (`elementOfIdSet` branch_fvs) binders + | branch_fvs <- drop_pts_fvs ] + + (drop_pts_fvs', drop_boxes') = unzip (zipWith3 drop in_branch_flags drop_pts_fvs drop_boxes) + drop True drop_fvs box = (drop_fvs `unionIdSets` fvsOfBind bind, bind:box) + drop False drop_fvs box = (drop_fvs, box) + ------------------------- fvsOfBind (_,fvs) = fvs diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index b5765ef..cb56629 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -268,11 +268,11 @@ tcBindWithSigs top_lvl binder_names mbind tc_ty_sigs is_rec prag_info_fn -- The tyvars_not_to_gen are free in the environment, and hence -- candidates for generalisation, but sometimes the monomorphism -- restriction means we can't generalise them nevertheless - getTyVarsToGen is_unrestricted mono_id_tys lie `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen) -> + getTyVarsToGen is_unrestricted mono_id_tys lie `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) -> -- DEAL WITH TYPE VARIABLE KINDS -- **** This step can do unification => keep other zonking after this **** - mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list -> + mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen) `thenTc` \ real_tyvars_to_gen_list -> let real_tyvars_to_gen = mkTyVarSet real_tyvars_to_gen_list -- It's important that the final list @@ -487,8 +487,13 @@ getTyVarsToGen is_unrestricted mono_id_tys lie in if is_unrestricted then - returnTc (emptyTyVarSet, tyvars_to_gen) + returnNF_Tc (emptyTyVarSet, tyvars_to_gen) else + -- This recover and discard-errs is to avoid duplicate error + -- messages; this, after all, is an "extra" call to tcSimplify + recoverNF_Tc (returnNF_Tc (emptyTyVarSet, tyvars_to_gen)) $ + discardErrsTc $ + tcSimplify (text "getTVG") NotTopLevel tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) -> let -- ASSERT: dicts_sig is already zonked! diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index e4dec94..e7b7676 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -10,7 +10,7 @@ module TcClassDcl ( tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) wh import HsSyn ( HsDecl(..), ClassDecl(..), Sig(..), MonoBinds(..), InPat(..), HsBinds(..), GRHSsAndBinds(..), GRHS(..), - HsExpr(..), HsLit(..), + HsExpr(..), HsLit(..), HsType(..), pprClassAssertion, unguardedRHS, andMonoBinds, getTyVarName ) import HsPragmas ( ClassPragmas(..) ) @@ -125,7 +125,7 @@ tcClassDecl1 rec_env rec_inst_mapper unifyKinds class_kinds tyvar_kinds `thenTc_` -- CHECK THE CONTEXT - tcClassContext rec_class rec_tyvars context pragmas + tcClassContext class_name rec_class rec_tyvars context pragmas `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) -> -- CHECK THE CLASS SIGNATURES, @@ -170,18 +170,27 @@ tcClassDecl1 rec_env rec_inst_mapper \begin{code} -tcClassContext :: Class -> [TyVar] +tcClassContext :: Name -> Class -> [TyVar] -> RenamedContext -- class context -> RenamedClassPragmas -- pragmas for superclasses -> TcM s (ThetaType, -- the superclass context [Type], -- types of the superclass dictionaries [Id]) -- superclass selector Ids -tcClassContext rec_class rec_tyvars context pragmas +tcClassContext class_name rec_class rec_tyvars context pragmas = -- Check the context. -- The renamer has already checked that the context mentions -- only the type variable of the class decl. + + -- For std Haskell check that the context constrains only tyvars + (if opt_GlasgowExts then + returnTc [] + else + mapTc check_constraint context + ) `thenTc_` + tcContext context `thenTc` \ sc_theta -> + let sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta] in @@ -210,6 +219,12 @@ tcClassContext rec_class rec_tyvars context pragmas in returnTc (mkSuperDictSelId uniq rec_class index ty) + check_constraint (c, tys) = checkTc (all is_tyvar tys) + (superClassErr class_name (c, tys)) + + is_tyvar (MonoTyVar _) = True + is_tyvar other = False + tcClassSig :: GlobalValueEnv -- Knot tying only! -> Class -- ...ditto... @@ -578,6 +593,10 @@ classArityErr class_name classDeclCtxt class_name = ptext SLIT("In the class declaration for") <+> quotes (ppr class_name) +superClassErr class_name sc + = ptext SLIT("Illegal superclass constraint") <+> quotes (pprClassAssertion sc) + <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name) + methodCtxt sel_id = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id) diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 3f9a9de..e289201 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -139,7 +139,7 @@ import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), Inst, LIE, pprInsts, pprInstsInFull, mkLIE, InstOrigin, pprOrigin ) -import TcEnv ( TcIdOcc(..) ) +import TcEnv ( TcIdOcc(..), tcGetGlobalTyVars ) import TcType ( TcType, TcTyVarSet, TcMaybe, tcInstType, tcInstTheta ) import Unify ( unifyTauTy ) import Id ( mkIdSet ) @@ -155,7 +155,7 @@ import Type ( Type, ThetaType, TauType, mkTyVarTy, getTyVar, import PprType ( pprConstraint ) import TysWiredIn ( unitTy ) import TyVar ( intersectTyVarSets, unionManyTyVarSets, minusTyVarSet, - isEmptyTyVarSet, tyVarSetToList, + isEmptyTyVarSet, tyVarSetToList, unionTyVarSets, zipTyVarEnv, emptyTyVarEnv ) import FiniteMap @@ -208,10 +208,14 @@ tcSimplify str top_lvl local_tvs wanted_lie -- But we can get stuck with -- C a b -- where "a" is one of the local_tvs, but "b" is unconstrained. - -- Then we must yell about the ambiguous b + -- Then we must yell about the ambiguous b. + -- But we must only do so if "b" really is unconstrained; so + -- we must grab the global tyvars to answer that question + tcGetGlobalTyVars `thenNF_Tc` \ global_tvs -> let + avail_tvs = local_tvs `unionTyVarSets` global_tvs (irreds', bad_guys) = partition (isEmptyTyVarSet . ambig_tv_fn) irreds - ambig_tv_fn dict = tyVarsOfInst dict `minusTyVarSet` local_tvs + ambig_tv_fn dict = tyVarsOfInst dict `minusTyVarSet` avail_tvs in addAmbigErrs ambig_tv_fn bad_guys `thenNF_Tc_` @@ -401,7 +405,6 @@ reduceContext str try_me givens wanteds text "----------------------" ]) $ -} - -- Build the Avail mapping from "givens" foldlNF_Tc addGiven emptyFM givens `thenNF_Tc` \ avails -> @@ -432,7 +435,9 @@ reduceContext str try_me givens wanteds text "given" <+> ppr givens, text "wanted" <+> ppr wanteds, text "----", - pprAvails avails, + text "avails" <+> pprAvails avails, + text "free" <+> ppr frees, + text "irreds" <+> ppr irreds, text "----------------------" ]) $ -} diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 1c35bda..1c0c193 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -55,6 +55,7 @@ import Class ( Class ) import TyCon ( isFunTyCon ) import Kind ( Kind ) import TcMonad +import Name ( changeUnique ) import TysPrim ( voidTy ) @@ -181,8 +182,13 @@ inst_sig_tyvar (TyVar _ kind name _) tcNewMutVar UnBound `thenNF_Tc` \ box -> -- Was DontBind, but we've nuked that "optimisation" + let + name' = case name of + Nothing -> Nothing + Just n -> Just (changeUnique n uniq) + in - returnNF_Tc (TyVar uniq kind name box) + returnNF_Tc (TyVar uniq kind name' box) -- We propagate the name of the sigature type variable \end{code} -- 1.7.10.4