[project @ 2003-02-04 12:28:22 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcInstDcls.lhs

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 427ec92..cf705ae 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -31,8 +31,7 @@ import TcType         ( mkClassPred, mkTyVarTy, tcSplitForAllTys, tyVarsOfType,
                          tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys,
                          TyVarDetails(..)
                        )
-import Inst            ( InstOrigin(..), newMethod, tcInstClassOp, 
-                         newDicts, instToId, showLIE )
+import Inst            ( InstOrigin(..), tcInstClassOp, newDicts, instToId, showLIE )
 import TcDeriv         ( tcDeriving )
 import TcEnv           ( tcExtendGlobalValEnv, 
                          tcLookupClass, tcExtendTyVarEnv2,
@@ -546,9 +545,6 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
 
        -- Create the result bindings
     let
-       local_dfun_id = setIdLocalExported dfun_id
-               -- Reason for setIdLocalExported: see notes with MkId.mkDictFunId
-
         dict_constr   = classDataCon clas
        scs_and_meths = map instToId sc_dicts ++ meth_ids
        this_dict_id  = instToId this_dict
@@ -594,7 +590,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds })
        main_bind = AbsBinds
                         zonked_inst_tyvars
                         (map instToId dfun_arg_dicts)
-                        [(inst_tyvars', local_dfun_id, this_dict_id)] 
+                        [(inst_tyvars', dfun_id, this_dict_id)] 
                         inlines all_binds
     in
     showLIE "instance"                 `thenM_`
@@ -611,29 +607,48 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
     mappM (addErrTc . badMethodErr clas) bad_bndrs     `thenM_`
 
        -- Make the method bindings
-    mapAndUnzipM do_one op_items                       `thenM` \ (meth_ids, meth_binds_s) ->
+    let
+       mk_method_bind = mkMethodBind InstanceDeclOrigin clas inst_tys' monobinds
+    in
+    mapAndUnzipM mk_method_bind op_items       `thenM` \ (meth_insts, meth_infos) ->
+
+       -- And type check them
+       -- It's really worth making meth_insts available to the tcMethodBind
+       -- Consider     instance Monad (ST s) where
+       --                {-# INLINE (>>) #-}
+       --                (>>) = ...(>>=)...
+       -- If we don't include meth_insts, we end up with bindings like this:
+       --      rec { dict = MkD then bind ...
+       --            then = inline_me (... (GHC.Base.>>= dict) ...)
+       --            bind = ... }
+       -- The trouble is that (a) 'then' and 'dict' are mutually recursive, 
+       -- and (b) the inline_me prevents us inlining the >>= selector, which
+       -- would unravel the loop.  Result: (>>) ends up as a loop breaker, and
+       -- is not inlined across modules. Rather ironic since this does not
+       -- happen without the INLINE pragma!  
+       --
+       -- Solution: make meth_insts available, so that 'then' refers directly
+       --           to the local 'bind' rather than going via the dictionary.
+    let
+       all_insts      = avail_insts ++ catMaybes meth_insts
+       xtve           = inst_tyvars `zip` inst_tyvars'
+       tc_method_bind = tcMethodBind xtve inst_tyvars' dfun_theta' all_insts uprags 
+    in
+    mapM tc_method_bind meth_infos             `thenM` \ meth_binds_s ->
    
-    returnM (meth_ids, andMonoBindList meth_binds_s)
+    returnM ([meth_id | (_,meth_id,_) <- meth_infos], 
+            andMonoBindList meth_binds_s)
 
-  where
-    xtve = inst_tyvars `zip` inst_tyvars'
-    do_one op_item 
-       = mkMethodBind InstanceDeclOrigin clas 
-                      inst_tys' monobinds op_item      `thenM` \ (meth_inst, meth_info) ->
-         tcMethodBind xtve inst_tyvars' dfun_theta' 
-                      avail_insts uprags meth_info     `thenM` \ meth_bind ->
-               -- Could add meth_insts to avail_insts, but not worth the bother
-         returnM (instToId meth_inst, meth_bind)
 
 -- Derived newtype instances
 tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' 
          avail_insts op_items (NewTypeDerived rep_tys)
-  = getInstLoc InstanceDeclOrigin                      `thenM` \ inst_loc ->
-    getLIE (mapAndUnzipM (do_one inst_loc) op_items)   `thenM` \ ((meth_ids, meth_binds), lie) ->
+  = getInstLoc InstanceDeclOrigin              `thenM` \ inst_loc ->
+    mapAndUnzip3M (do_one inst_loc) op_items   `thenM` \ (meth_ids, meth_binds, rhs_insts) ->
     
     tcSimplifyCheck
         (ptext SLIT("newtype derived instance"))
-        inst_tyvars' avail_insts lie                   `thenM` \ lie_binds ->
+        inst_tyvars' avail_insts rhs_insts     `thenM` \ lie_binds ->
 
        -- I don't think we have to do the checkSigTyVars thing
 
@@ -646,11 +661,11 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys'
          tcInstClassOp inst_loc sel_id inst_tys'       `thenM` \ meth_inst ->
 
                -- Make the *occurrence on the rhs*
-         newMethod InstanceDeclOrigin sel_id rep_tys'  `thenM` \ rhs_id ->
+         tcInstClassOp inst_loc sel_id rep_tys'        `thenM` \ rhs_inst ->
          let
             meth_id = instToId meth_inst
          in
-         return (meth_id, VarMonoBind meth_id (HsVar rhs_id))
+         return (meth_id, VarMonoBind meth_id (HsVar (instToId rhs_inst)), rhs_inst)
 
        -- Instantiate rep_tys with the relevant type variables
     rep_tys' = map (substTy subst) rep_tys