From: simonpj Date: Thu, 3 May 2001 08:13:25 +0000 (+0000) Subject: [project @ 2001-05-03 08:13:25 by simonpj] X-Git-Tag: Approximately_9120_patches~2027 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=cd7dc9b1d4277ead419f45264fead9ef02b65bcb;p=ghc-hetmet.git [project @ 2001-05-03 08:13:25 by simonpj] **** MERGE WITH 5.00 BRANCH ******** -------------------------------- Fix a bad implicit parameter bug -------------------------------- TcSimplify.tcSimplifyIPs was just completely wrong; it wasn't doing improvement properly nor binding values properly. Sigh. To make this work nicely I added Inst.instName :: Inst -> Name --- diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 4d258ee..c0c5f78 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -26,7 +26,7 @@ module Inst ( instBindingRequired, instCanBeGeneralised, zonkInst, zonkInsts, - instToId, + instToId, instName, InstOrigin(..), InstLoc, pprInstLoc ) where @@ -48,9 +48,9 @@ import TcType ( TcThetaType, ) import CoreFVs ( idFreeTyVars ) import Class ( Class ) -import Id ( Id, idType, mkUserLocal, mkSysLocal, mkLocalId ) +import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId ) import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) -import Name ( mkMethodOcc, getOccName ) +import Name ( Name, mkMethodOcc, getOccName ) import NameSet ( NameSet ) import PprType ( pprPred ) import Type ( Type, PredType(..), ThetaType, @@ -195,6 +195,9 @@ cmpInst (LitInst _ _ _ _) other = GT Selection ~~~~~~~~~ \begin{code} +instName :: Inst -> Name +instName inst = idName (instToId inst) + instToId :: Inst -> TcId instToId (Dict id _ _) = id instToId (Method id _ _ _ _ _) = id @@ -312,6 +315,8 @@ newDictsAtLoc inst_loc@(_,loc,_) theta where mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc +-- For implicit parameters, since there is only one in scope +-- at any time, we use the name of the implicit parameter itself newIPDict orig name ty = tcGetInstLoc orig `thenNF_Tc` \ inst_loc -> returnNF_Tc (Dict (mkLocalId name (mkPredTy pred)) pred inst_loc) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index ebc25af..07c3374 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -629,7 +629,10 @@ Implicit Parameter bindings. tcMonoExpr (HsWith expr binds) res_ty = tcMonoExpr expr res_ty `thenTc` \ (expr', expr_lie) -> mapAndUnzipTc tcIPBind binds `thenTc` \ (pairs, bind_lies) -> - tcSimplifyIPs (map fst binds) expr_lie `thenTc` \ (expr_lie', dict_binds) -> + + -- If the binding binds ?x = E, we must now + -- discharge any ?x constraints in expr_lie + tcSimplifyIPs (map fst pairs) expr_lie `thenTc` \ (expr_lie', dict_binds) -> let binds' = [(instToId ip, rhs) | (ip,rhs) <- pairs] expr'' = HsLet (mkMonoBind dict_binds [] Recursive) expr' diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index d8c3194..5a4867a 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -25,7 +25,7 @@ import TcHsSyn ( TcExpr, TcId, import TcMonad import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..), tyVarsOfInst, predsOfInsts, predsOfInst, - isDict, isClassDict, + isDict, isClassDict, instName, isStdClassTyVarDict, isMethodFor, instToId, tyVarsOfInsts, instBindingRequired, instCanBeGeneralised, @@ -234,7 +234,7 @@ However, we don't *need* to report ambiguity right away. It'll always show up at the call site.... and eventually at main, which needs special treatment. Nevertheless, reporting ambiguity promptly is an excellent thing. -So heres the plan. We WARN about probable ambiguity if +So here's the plan. We WARN about probable ambiguity if fv(Cq) is not a subset of oclose(fv(T) union fv(G), C) @@ -282,7 +282,7 @@ is a "bubble" that's a set of constraints Hence another idea. To decide Q start with fv(T) and grow it by transitive closure in Cq (no functional dependencies involved). Now partition Cq using Q, leaving the definitely-ambiguous and probably-ok. -The definitely-ambigous can then float out, and get smashed at top level +The definitely-ambiguous can then float out, and get smashed at top level (which squashes out the constants, like Eq (T a) above) @@ -685,28 +685,45 @@ When we have let ?x = R in B we must discharge all the ?x constraints from B. We also do an improvement -step; if we have ?x::t1 and ?x::t2 we must unify t1, t2. No need to iterate, though. +step; if we have ?x::t1 and ?x::t2 we must unify t1, t2. + +Actually, the constraints from B might improve the types in ?x. For example + + f :: (?x::Int) => Char -> Char + let ?x = 3 in f 'c' + +then the constraint (?x::Int) arising from the call to f will +force the binding for ?x to be of type Int. \begin{code} -tcSimplifyIPs :: [Name] -- The implicit parameters bound here +tcSimplifyIPs :: [Inst] -- The implicit parameters bound here -> LIE -> TcM (LIE, TcDictBinds) -tcSimplifyIPs ip_names wanted_lie - = simpleReduceLoop doc try_me wanteds `thenTc` \ (frees, binds, irreds) -> - -- The irreducible ones should be a subset of the implicit - -- parameters we provided - ASSERT( all here_ip irreds ) +tcSimplifyIPs given_ips wanted_lie + = simpl_loop given_ips wanteds `thenTc` \ (frees, binds) -> returnTc (mkLIE frees, binds) - where - doc = text "tcSimplifyIPs" <+> ppr ip_names - wanteds = lieToList wanted_lie - ip_set = mkNameSet ip_names - here_ip ip = isDict ip && ip `instMentionsIPs` ip_set - + doc = text "tcSimplifyIPs" <+> ppr ip_names + wanteds = lieToList wanted_lie + ip_names = map instName given_ips + ip_set = mkNameSet ip_names + -- Simplify any methods that mention the implicit parameter try_me inst | inst `instMentionsIPs` ip_set = ReduceMe | otherwise = Free + + simpl_loop givens wanteds + = mapNF_Tc zonkInst givens `thenNF_Tc` \ givens' -> + mapNF_Tc zonkInst wanteds `thenNF_Tc` \ wanteds' -> + + reduceContext doc try_me givens' wanteds' `thenTc` \ (no_improvement, frees, binds, irreds) -> + + if no_improvement then + ASSERT( null irreds ) + returnTc (frees, binds) + else + simpl_loop givens' (irreds ++ frees) `thenTc` \ (frees1, binds1) -> + returnTc (frees1, binds `AndMonoBinds` binds1) \end{code}