[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 (file)
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -26,7 +26,7 @@ module Inst (
        instBindingRequired, instCanBeGeneralised,
 
        zonkInst, zonkInsts,
        instBindingRequired, instCanBeGeneralised,
 
        zonkInst, zonkInsts,

-       instToId, 
+       instToId, instName,

 
        InstOrigin(..), InstLoc, pprInstLoc
     ) where
 
        InstOrigin(..), InstLoc, pprInstLoc
     ) where

@@ -48,9 +48,9 @@ import TcType ( TcThetaType,
                )
 import CoreFVs ( idFreeTyVars )
 import Class   ( Class )
                )
 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 PrelInfo        ( isStandardClass, isCcallishClass, isNoDictClass )

-import Name    ( mkMethodOcc, getOccName )
+import Name    ( Name, mkMethodOcc, getOccName )

 import NameSet ( NameSet )
 import PprType ( pprPred )     
 import Type    ( Type, PredType(..), ThetaType,
 import NameSet ( NameSet )
 import PprType ( pprPred )     
 import Type    ( Type, PredType(..), ThetaType,

@@ -195,6 +195,9 @@ cmpInst (LitInst _ _ _ _)     other                     = GT
 Selection
 ~~~~~~~~~
 \begin{code}
 Selection
 ~~~~~~~~~
 \begin{code}

+instName :: Inst -> Name
+instName inst = idName (instToId inst)
+

 instToId :: Inst -> TcId
 instToId (Dict id _ _)        = id
 instToId (Method id _ _ _ _ _) = id
 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
 
   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)
 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 (file)
--- 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) ->
 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'
     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 (file)
--- 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,
 import TcMonad
 import Inst            ( lookupInst, lookupSimpleInst, LookupInstResult(..),
                          tyVarsOfInst, predsOfInsts, predsOfInst,

-                         isDict, isClassDict, 
+                         isDict, isClassDict, instName,

                          isStdClassTyVarDict, isMethodFor,
                          instToId, tyVarsOfInsts,
                          instBindingRequired, instCanBeGeneralised,
                          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.
 
 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)
 
 
        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.
 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)
 
 
 (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
        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}
 
 \begin{code}

-tcSimplifyIPs :: [Name]                -- The implicit parameters bound here
+tcSimplifyIPs :: [Inst]                -- The implicit parameters bound here

              -> LIE
              -> TcM (LIE, TcDictBinds)
              -> 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)
     returnTc (mkLIE frees, binds)

-    

   where
   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
        -- 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}
 
 
 \end{code}