Major change in compilation of instance declarations (fix Trac #955, #2328)
authorsimonpj@microsoft.com <unknown>
Wed, 3 Sep 2008 12:02:28 +0000 (12:02 +0000)
committersimonpj@microsoft.com <unknown>
Wed, 3 Sep 2008 12:02:28 +0000 (12:02 +0000)
This patch makes an important change to the way that dictionary
functions are handled.  Before, they were unconditionally marked
INLIINE, but all the code written by the user in the instance
was inside that unconditionally-inlined function.  Result: massive
code bloat in programs that use complicated instances.

This patch make instances behave rather as if all the methods
were written in separate definitions.  That dramatically reduces
bloat.  The new plan is described in TcInstDcls
Note [How instance declarations are translated]

Everything validates.  The major code-bloat bug is squashed: in particular
DoCon is fine now (Trac #2328) and I believe that #955 is also better.

Nofib results:

Binary sizes
        -1 s.d.      +2.5%
        +1 s.d.      +3.1%
        Average      +2.8%

Allocations
        -1 s.d.      -6.4%
        +1 s.d.      +2.5%
        Average      -2.0%

Note that 2% improvement.  Some programs improve by 20% (rewrite)!
Two get slightly worse: pic (2.1%), and gameteb (3.2%), but all others
improve or stay the same.

I am not absolutely 100% certain that all the corners are correct; for
example, when default methods are marked INLINE, are they inlined?  But
overall it's better.

It's nice that the patch also removes a lot of code.  I deleted some
out of date comments, but there's something like 100 fewer lines of
code in the new version!  (In the line counts below, there are a lot
of new comments.)

12 files changed:
compiler/deSugar/DsBinds.lhs
compiler/hsSyn/HsBinds.lhs
compiler/typecheck/TcArrows.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcClassDcl.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcExpr.lhs-boot
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcMType.lhs
compiler/typecheck/TcMatches.lhs
compiler/typecheck/TcType.lhs
compiler/typecheck/TcUnify.lhs

index 3df57d7..764e44b 100644 (file)
@@ -587,8 +587,11 @@ dsCoercion (WpLam id)        thing_inside = do { expr <- thing_inside
                                               ; return (Lam id expr) }
 dsCoercion (WpTyLam tv)      thing_inside = do { expr <- thing_inside
                                               ; return (Lam tv expr) }
-dsCoercion (WpApp id)        thing_inside = do { expr <- thing_inside
-                                              ; return (App expr (Var id)) }
+dsCoercion (WpApp v)         thing_inside   
+          | isTyVar v                    = do { expr <- thing_inside
+               {- Probably a coercion var -}  ; return (App expr (Type (mkTyVarTy v))) }
+          | otherwise                    = do { expr <- thing_inside
+               {- An Id -}                    ; return (App expr (Var v)) }
 dsCoercion (WpTyApp ty)      thing_inside = do { expr <- thing_inside
                                               ; return (App expr (Type ty)) }
 dsCoercion WpInline         thing_inside = do { expr <- thing_inside
index b8501d7..b4dc5b2 100644 (file)
@@ -340,7 +340,7 @@ data HsWrapper
   | WpCast Coercion            -- A cast:  [] `cast` co
                                -- Guaranteed not the identity coercion
 
-  | WpApp Var                  -- [] d         the 'd' is a type-class dictionary
+  | WpApp Var                  -- [] d         the 'd' is a type-class dictionary or coercion variable
   | WpTyApp Type               -- [] t         the 't' is a type or corecion
   | WpLam Var                  -- \d. []       the 'd' is a type-class dictionary or coercion variable
   | WpTyLam TyVar              -- \a. []       the 'a' is a type variable (not coercion var)
index 082f9da..4593482 100644 (file)
@@ -123,8 +123,7 @@ tc_cmd env (HsLet binds (L body_loc body)) res_ty
 
 tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty)
   = addErrCtxt (cmdCtxt in_cmd) $ do
-      (scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut) $
-                              tcInferRho scrut 
+      (scrut', scrut_ty) <- tcInferRho scrut 
       matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
       return (HsCase scrut' matches')
   where
@@ -341,10 +340,6 @@ arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
 cmdCtxt :: HsExpr Name -> SDoc
 cmdCtxt cmd = ptext (sLit "In the command:") <+> ppr cmd
 
-caseScrutCtxt :: LHsExpr Name -> SDoc
-caseScrutCtxt cmd
-  = hang (ptext (sLit "In the scrutinee of a case command:")) 4 (ppr cmd)
-
 nonEmptyCmdStkErr :: HsExpr Name -> SDoc
 nonEmptyCmdStkErr cmd
   = hang (ptext (sLit "Non-empty command stack at command:"))
index aa179b2..ddf066b 100644 (file)
@@ -6,7 +6,7 @@
 
 \begin{code}
 module TcBinds ( tcLocalBinds, tcTopBinds, 
-                 tcHsBootSigs, tcMonoBinds, 
+                 tcHsBootSigs, tcMonoBinds, tcPolyBinds,
                  TcPragFun, tcSpecPrag, tcPrags, mkPragFun, 
                  TcSigInfo(..), TcSigFun, mkTcSigFun,
                  badBootDeclErr ) where
@@ -165,26 +165,29 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
                 -- the Ids declared with type signatures
         ; poly_rec <- doptM Opt_RelaxedPolyRec
         ; (binds', thing) <- tcExtendIdEnv poly_ids $
-                             tc_val_binds poly_rec top_lvl sig_fn prag_fn 
+                             tcBindGroups poly_rec top_lvl sig_fn prag_fn 
                                           binds thing_inside
 
         ; return (ValBindsOut binds' sigs, thing) }
 
 ------------------------
-tc_val_binds :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
+tcBindGroups :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
              -> [(RecFlag, LHsBinds Name)] -> TcM thing
              -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 -- Typecheck a whole lot of value bindings,
 -- one strongly-connected component at a time
+-- Here a "strongly connected component" has the strightforward
+-- meaning of a group of bindings that mention each other, 
+-- ignoring type signatures (that part comes later)
 
-tc_val_binds _ _ _ _ [] thing_inside
+tcBindGroups _ _ _ _ [] thing_inside
   = do  { thing <- thing_inside
         ; return ([], thing) }
 
-tc_val_binds poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside
+tcBindGroups poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside
   = do  { (group', (groups', thing))
                 <- tc_group poly_rec top_lvl sig_fn prag_fn group $ 
-                   tc_val_binds poly_rec top_lvl sig_fn prag_fn groups thing_inside
+                   tcBindGroups poly_rec top_lvl sig_fn prag_fn groups thing_inside
         ; return (group' ++ groups', thing) }
 
 ------------------------
@@ -209,12 +212,12 @@ tc_group poly_rec top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
         ; return ([(Recursive, unionManyBags binds1)], thing) }
 
   | otherwise           -- Recursive group, with gla-exts
-  =     -- To maximise polymorphism (with -fglasgow-exts), we do a new 
+  =     -- To maximise polymorphism (with -XRelaxedPolyRec), we do a new 
         -- strongly-connected-component analysis, this time omitting 
         -- any references to variables with type signatures.
         --
-        -- Notice that the bindInsts thing covers *all* the bindings in the original
-        -- group at once; an earlier one may use a later one!
+        -- Notice that the bindInsts thing covers *all* the bindings in
+        -- the original group at once; an earlier one may use a later one!
     do  { traceTc (text "tc_group rec" <+> pprLHsBinds binds)
         ; (binds1,thing) <- bindLocalInsts top_lvl $
                             go (stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds))
@@ -560,8 +563,14 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
                         -- Note that the scoped_tvs and the (sig_tvs sig) 
                         -- may have different Names. That's quite ok.
 
+       ; traceTc (text "tcMoonBinds" <+> ppr scoped_tvs $$ ppr tc_sig)
         ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $
                                tcMatchesFun mono_name inf matches mono_ty
+            -- Note that "mono_ty" might actually be a polymorphic type,
+            -- if the original function had a signature like
+            --    forall a. Eq a => forall b. Ord b => ....
+            -- But that's ok: tcMatchesFun can deal with that
+            -- It happens, too!  See Note [Polymorphic methods] in TcClassDcl.
 
         ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, 
                                     fun_infix = inf, fun_matches = matches',
@@ -1120,9 +1129,8 @@ tcInstSig :: Bool -> Name -> TcM TcSigInfo
 tcInstSig use_skols name
   = do  { poly_id <- tcLookupId name    -- Cannot fail; the poly ids are put into 
                                         -- scope when starting the binding group
-        ; let skol_info = SigSkol (FunSigCtxt name)
-              inst_tyvars = tcInstSigTyVars use_skols skol_info
-        ; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id)
+       ; let skol_info = SigSkol (FunSigCtxt name)
+        ; (tvs, theta, tau) <- tcInstSigType use_skols skol_info (idType poly_id)
         ; loc <- getInstLoc (SigOrigin skol_info)
         ; return (TcSigInfo { sig_id = poly_id,
                               sig_tvs = tvs, sig_theta = theta, sig_tau = tau, 
index 1fd8706..c3edcc4 100644 (file)
@@ -7,8 +7,8 @@ Typechecking class declarations
 
 \begin{code}
 module TcClassDcl ( tcClassSigs, tcClassDecl2, 
-                   getGenericInstances
-                   MethodSpec, tcMethodBind, mkMethId,
+                   findMethodBind, tcMethodBind
+                   mkGenericDefMethBind, getGenericInstances, mkDefMethRdrName,
                    tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
                  ) where
 
@@ -23,8 +23,6 @@ import InstEnv
 import TcEnv
 import TcBinds
 import TcHsType
-import TcSimplify
-import TcUnify
 import TcMType
 import TcType
 import TcRnMonad
@@ -183,12 +181,13 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
     let
        (tyvars, _, _, op_items) = classBigSig clas
        rigid_info               = ClsSkol clas
-       origin                   = SigOrigin rigid_info
        prag_fn                  = mkPragFun sigs
        sig_fn                   = mkTcSigFun sigs
        clas_tyvars              = tcSkolSigTyVars rigid_info tyvars
-       tc_dm                    = tcDefMeth origin clas clas_tyvars
-                                            default_binds sig_fn prag_fn
+       tc_dm                    = tcDefMeth clas_tyvars default_binds
+                                            sig_fn prag_fn
+               -- tc_dm is called only for a sel_id
+               -- that has a binding in default_binds
 
        dm_sel_ids               = [sel_id | (sel_id, DefMeth) <- op_items]
        -- Generate code for polymorphic default methods only
@@ -198,260 +197,140 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
        -- the programmer supplied an explicit default decl for the class.  
        -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
 
-    (defm_binds, dm_ids_s) <- mapAndUnzipM tc_dm dm_sel_ids
-    return (listToBag defm_binds, concat dm_ids_s)
+    (defm_binds, dm_ids) <- mapAndUnzipM tc_dm dm_sel_ids
+    return (unionManyBags defm_binds, dm_ids)
 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
     
-tcDefMeth :: InstOrigin -> Class -> [TyVar] -> LHsBinds Name
+tcDefMeth :: [TyVar] -> LHsBinds Name
           -> TcSigFun -> TcPragFun -> Id
-          -> TcM (LHsBindLR Id Var, [Id])
-tcDefMeth origin clas tyvars binds_in sig_fn prag_fn sel_id
-  = do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
-       ; let   inst_tys    = mkTyVarTys tyvars
-               dm_ty       = idType sel_id     -- Same as dict selector!
-               cls_pred    = mkClassPred clas inst_tys
-               local_dm_id = mkDefaultMethodId dm_name dm_ty
-
-       ; loc <- getInstLoc origin
-       ; this_dict <- newDictBndr loc cls_pred
-       ; (_, meth_id) <- mkMethId origin clas sel_id inst_tys
-       ; (defm_bind, insts_needed) <- getLIE $
-               tcMethodBind origin tyvars [cls_pred] this_dict []
-                            sig_fn prag_fn binds_in
-                            (sel_id, DefMeth) meth_id
-    
-       ; addErrCtxt (defltMethCtxt clas) $ do
-    
-        -- Check the context
-       { dict_binds <- tcSimplifyCheck
-                               loc
-                               tyvars
-                               [this_dict]
-                               insts_needed
-
-       -- Simplification can do unification
-       ; checkSigTyVars tyvars
-    
-       -- Inline pragmas 
-       -- We'll have an inline pragma on the local binding, made by tcMethodBind
-       -- but that's not enough; we want one on the global default method too
-       -- Specialisations, on the other hand, belong on the thing inside only, I think
-       ; let sel_name         = idName sel_id
-             inline_prags     = filter isInlineLSig (prag_fn sel_name)
-       ; prags <- tcPrags meth_id inline_prags
-
-       ; let full_bind = AbsBinds  tyvars
-                                   [instToId this_dict]
-                                   [(tyvars, local_dm_id, meth_id, prags)]
-                                   (dict_binds `unionBags` defm_bind)
-       ; return (noLoc full_bind, [local_dm_id]) }}
-
-mkDefMethRdrName :: Id -> RdrName
-mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc
-\end{code}
+          -> TcM (LHsBinds Id, Id)
+tcDefMeth tyvars binds_in sig_fn prag_fn sel_id
+  = do { let sel_name = idName sel_id
+       ; dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_name)
+       ; uniq <- newUnique
+       ; let   dm_ty         = idType sel_id   -- Same as dict selector!
+               local_dm_name = setNameUnique sel_name uniq
+               local_dm_id   = mkLocalId local_dm_name dm_ty
+               top_dm_id     = mkDefaultMethodId dm_name dm_ty
+               all_tvs       = map tyVarName tyvars ++ (sig_fn sel_name `orElse` [])
+                           -- Tyvars in scope are *both* the ones from the 
+                           -- class decl *and* ones from the method sig
+
+       ; let meth_bind = findMethodBind sel_name local_dm_name binds_in
+                         `orElse` pprPanic "tcDefMeth" (ppr sel_id)
+               -- We only call tcDefMeth on selectors for which 
+               -- there is a binding in binds_in
+
+       ; tc_meth_bind <- tcMethodBind all_tvs (prag_fn sel_name) 
+                                      local_dm_id meth_bind
+
+               -- See Note [Silly default-method bind]
+        ; let loc = getLoc meth_bind
+             top_bind = L loc $ VarBind top_dm_id $ 
+                        L loc $ HsWrap (WpLet tc_meth_bind) $
+                        HsVar local_dm_id
+
+       ; return (unitBag top_bind, top_dm_id) }
+
+mkDefMethRdrName :: Name -> RdrName
+mkDefMethRdrName sel_name = mkDerivedRdrName sel_name mkDefaultMethodOcc
 
+---------------------------
+-- The renamer just puts the selector ID as the binder in the method binding
+-- but we must use the method name; so we substitute it here.  Crude but simple.
+findMethodBind :: Name -> Name         -- Selector and method name
+               -> LHsBinds Name        -- A group of bindings
+               -> Maybe (LHsBind Name) -- The binding, with meth_name replacing sel_name
+findMethodBind sel_name meth_name binds
+  = foldlBag mplus Nothing (mapBag f binds)
+  where 
+       f (L loc1 bind@(FunBind { fun_id = L loc2 op_name }))
+                | op_name == sel_name
+                = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
+       f _other = Nothing
 
-%************************************************************************
-%*                                                                     *
-\subsection{Typechecking a method}
-%*                                                                     *
-%************************************************************************
-
-@tcMethodBind@ is used to type-check both default-method and
-instance-decl method declarations.  We must type-check methods one at a
-time, because their signatures may have different contexts and
-tyvar sets.
-
-\begin{code}
-type MethodSpec = (Id,                         -- Global selector Id
-                  Id,                  -- Local Id (class tyvars instantiated)
-                  LHsBind Name)        -- Binding for the method
-
-tcMethodBind 
-       :: InstOrigin
-       -> [TcTyVar]            -- Skolemised type variables for the
-                               --      enclosing class/instance decl. 
-                               --      They'll be signature tyvars, and we
-                               --      want to check that they don't get bound
-                               -- Also they are scoped, so we bring them into scope
-                               -- Always equal the range of the type envt
-       -> TcThetaType          -- Available theta; it's just used for the error message
-       -> Inst                 -- Current dictionary (this_dict)
-       -> [Inst]               -- Other stuff available from context, used to simplify 
-                               --   constraints from the method body (exclude this_dict)
-       -> TcSigFun             -- For scoped tyvars, indexed by sel_name
-       -> TcPragFun            -- Pragmas (e.g. inline pragmas), indexed by sel_name
-        -> LHsBinds Name       -- Method binding (pick the right one from in here)
-       -> ClassOpItem
-       -> TcId                 -- The method Id
-       -> TcM (LHsBinds Id)
-
-tcMethodBind origin inst_tyvars inst_theta 
-            this_dict extra_insts 
-            sig_fn prag_fn meth_binds
-            (sel_id, dm_info) meth_id
-  | Just user_bind <- find_bind sel_name meth_name meth_binds
-  =            -- If there is a user-supplied method binding, typecheck it
-    tc_method_bind inst_tyvars inst_theta (this_dict:extra_insts) 
-                  sig_fn prag_fn
-                  sel_id meth_id user_bind
-
-  | otherwise  -- The user didn't supply a method binding, so we have to make 
-               -- up a default binding, in a way depending on the default-method info
-  = case dm_info of
-      NoDefMeth -> do  { warn <- doptM Opt_WarnMissingMethods          
-                        ; warnTc (isInstDecl origin  
-                                  && warn   -- Warn only if -fwarn-missing-methods
-                                  && reportIfUnused (getOccName sel_id))
-                                            -- Don't warn about _foo methods
-                                (omittedMethodWarn sel_id) 
-                       ; return (unitBag $ L loc (VarBind meth_id error_rhs)) }
-
-      DefMeth ->   do  {       -- An polymorphic default method
-                               -- Might not be imported, but will be an OrigName
-                         dm_name <- lookupImportedName (mkDefMethRdrName sel_id)
-                       ; dm_id   <- tcLookupId dm_name
-                               -- Note [Default methods in instances]
-                       ; return (unitBag $ L loc (VarBind meth_id (mk_dm_app dm_id))) }
-
-      GenDefMeth -> ASSERT( isInstDecl origin )        -- We never get here from a class decl
-                   do  { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id meth_name
-                       ; tc_method_bind inst_tyvars inst_theta (this_dict:extra_insts) 
-                                        sig_fn prag_fn
-                                        sel_id meth_id meth_bind }
-
-  where
-    meth_name = idName meth_id
-    sel_name  = idName sel_id
-    loc       = getSrcSpan meth_id
-    (clas, inst_tys) = getDictClassTys this_dict
+---------------------------
+tcMethodBind :: [Name] -> [LSig Name] -> Id
+            -> LHsBind Name -> TcM (LHsBinds Id)
+tcMethodBind tyvars prags meth_id bind 
+  = do  { let sig_fn  _ = Just tyvars
+             prag_fn _ = prags
+
+               -- Typecheck the binding, first extending the envt
+               -- so that when tcInstSig looks up the meth_id to find
+               -- its  signature, we'll find it in the environment
+               --
+               -- If scoped type variables is on, they are brought
+               -- into scope by tcPolyBinds (via sig_fn)
+               --
+               -- See Note [Polymorphic methods]
+       ; traceTc (text "tcMethodBind" <+> ppr meth_id <+> ppr tyvars)
+       ; (tc_binds, ids) <- tcExtendIdEnv [meth_id] $
+                            tcPolyBinds TopLevel sig_fn prag_fn 
+                                   NonRecursive NonRecursive
+                                   (unitBag bind)
+
+       ; ASSERT( ids == [meth_id] )    -- Binding for ONE method
+        return (unionManyBags tc_binds) }
+\end{code}
 
-    this_dict_id = instToId this_dict
-    error_id     = L loc (HsVar nO_METHOD_BINDING_ERROR_ID) 
-    error_id_app = mkLHsWrap (WpTyApp (idType meth_id)) error_id
-    error_rhs    = mkHsApp error_id_app $ L loc $
-                  HsLit (HsStringPrim (mkFastString error_msg))
-    error_msg    = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
+Note [Polymorphic methods]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+    class Foo a where
+       op :: forall b. Ord b => a -> b -> b -> b
+    instance Foo c => Foo [c] where
+        op = e
 
-    mk_dm_app dm_id    -- dm tys inst_dict
-       = mkLHsWrap (WpApp this_dict_id `WpCompose` mkWpTyApps inst_tys) 
-                   (L loc (HsVar dm_id))
+When typechecking the binding 'op = e', we'll have a meth_id for op
+whose type is
+      op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
 
+So tcPolyBinds must be capable of dealing with nested polytypes; 
+and so it is. See TcBinds.tcMonoBinds (with type-sig case).
 
----------------------------
-tc_method_bind :: [TyVar] -> TcThetaType -> [Inst] -> (Name -> Maybe [Name])
-               -> (Name -> [LSig Name]) -> Id -> Id -> LHsBind Name
-               -> TcRn (LHsBindsLR Id Var)
-tc_method_bind inst_tyvars inst_theta avail_insts sig_fn prag_fn
-             sel_id meth_id meth_bind
-  = recoverM (return emptyLHsBinds) $
-       -- If anything fails, recover returning no bindings.
-       -- This is particularly useful when checking the default-method binding of
-       -- a class decl. If we don't recover, we don't add the default method to
-       -- the type enviroment, and we get a tcLookup failure on $dmeth later.
-
-       -- Check the bindings; first adding inst_tyvars to the envt
-       -- so that we don't quantify over them in nested places
-
-    do { let sel_name  = idName sel_id
-              meth_name = idName meth_id
-              meth_sig_fn name = ASSERT( name == meth_name ) sig_fn sel_name
-               -- The meth_bind metions the meth_name, but sig_fn is indexed by sel_name
-
-       ; ((meth_bind, mono_bind_infos), meth_lie)
-              <- tcExtendTyVarEnv inst_tyvars      $
-                 tcExtendIdEnv [meth_id]           $ -- In scope for tcInstSig
-                 addErrCtxt (methodCtxt sel_id)    $
-                 getLIE                            $
-                 tcMonoBinds [meth_bind] meth_sig_fn Recursive
-
-               -- Now do context reduction.   We simplify wrt both the local tyvars
-               -- and the ones of the class/instance decl, so that there is
-               -- no problem with
-               --      class C a where
-               --        op :: Eq a => a -> b -> a
-               --
-               -- We do this for each method independently to localise error messages
+Note [Silly default-method bind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we pass the default method binding to the type checker, it must
+look like    op2 = e
+not         $dmop2 = e
+otherwise the "$dm" stuff comes out in the interface file.  So we
+typecheck the former, and wrap it in a let, thus
+         $dmop2 = let op2 = e in op2
+This makes the error messages right.
 
-       ; let [(_, Just sig, local_meth_id)] = mono_bind_infos
-             loc = sig_loc sig
 
-       ; addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $ do
-       { meth_dicts <- newDictBndrs loc (sig_theta sig)
-       ; let meth_tvs   = sig_tvs sig
-              all_tyvars = meth_tvs ++ inst_tyvars
-              all_insts  = avail_insts ++ meth_dicts
+%************************************************************************
+%*                                                                     *
+       Extracting generic instance declaration from class declarations
+%*                                                                     *
+%************************************************************************
 
-       ; lie_binds <- tcSimplifyCheck loc all_tyvars all_insts meth_lie
+@getGenericInstances@ extracts the generic instance declarations from a class
+declaration.  For exmaple
 
-       ; checkSigTyVars all_tyvars
+       class C a where
+         op :: a -> a
        
-       ; prags <- tcPrags meth_id (prag_fn sel_name)
-       ; let poly_meth_bind = noLoc $ AbsBinds meth_tvs
-                                 (map instToId meth_dicts)
-                                 [(meth_tvs, meth_id, local_meth_id, prags)]
-                                 (lie_binds `unionBags` meth_bind)
+         op{ x+y } (Inl v)   = ...
+         op{ x+y } (Inr v)   = ...
+         op{ x*y } (v :*: w) = ...
+         op{ 1   } Unit      = ...
 
-       ; return (unitBag poly_meth_bind) }}
+gives rise to the instance declarations
 
+       instance C (x+y) where
+         op (Inl v)   = ...
+         op (Inr v)   = ...
+       
+       instance C (x*y) where
+         op (v :*: w) = ...
 
----------------------------
-mkMethId :: InstOrigin -> Class
-        -> Id -> [TcType]      -- Selector, and instance types
-        -> TcM (Maybe Inst, Id)
-            
--- mkMethId instantiates the selector Id at the specified types
-mkMethId origin clas sel_id inst_tys
-  = let
-       (tyvars,rho) = tcSplitForAllTys (idType sel_id)
-       rho_ty       = ASSERT( length tyvars == length inst_tys )
-                      substTyWith tyvars inst_tys rho
-       (preds,tau)  = tcSplitPhiTy rho_ty
-        first_pred   = ASSERT( not (null preds)) head preds
-    in
-       -- The first predicate should be of form (C a b)
-       -- where C is the class in question
-    ASSERT( not (null preds) && 
-           case getClassPredTys_maybe first_pred of
-               { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False }
-    )
-    if isSingleton preds then do
-       -- If it's the only one, make a 'method'
-        inst_loc <- getInstLoc origin
-        meth_inst <- newMethod inst_loc sel_id inst_tys
-        return (Just meth_inst, instToId meth_inst)
-    else do
-       -- If it's not the only one we need to be careful
-       -- For example, given 'op' defined thus:
-       --      class Foo a where
-       --        op :: (?x :: String) => a -> a
-       -- (mkMethId op T) should return an Inst with type
-       --      (?x :: String) => T -> T
-       -- That is, the class-op's context is still there.  
-       -- BUT: it can't be a Method any more, because it breaks
-       --      INVARIANT 2 of methods.  (See the data decl for Inst.)
-       uniq <- newUnique
-       loc <- getSrcSpanM
-       let 
-           real_tau = mkPhiTy (tail preds) tau
-           meth_id  = mkUserLocal (getOccName sel_id) uniq real_tau loc
-
-       return (Nothing, meth_id)
+       instance C 1 where
+         op Unit      = ...
 
----------------------------
--- The renamer just puts the selector ID as the binder in the method binding
--- but we must use the method name; so we substitute it here.  Crude but simple.
-find_bind :: Name -> Name      -- Selector and method name
-          -> LHsBinds Name             -- A group of bindings
-         -> Maybe (LHsBind Name)       -- The binding, with meth_name replacing sel_name
-find_bind sel_name meth_name binds
-  = foldlBag mplus Nothing (mapBag f binds)
-  where 
-       f (L loc1 bind@(FunBind { fun_id = L loc2 op_name })) | op_name == sel_name
-                = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
-       f _other = Nothing
 
----------------------------
+\begin{code}
 mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
 mkGenericDefMethBind clas inst_tys sel_id meth_name
   =    -- A generic default method
@@ -487,113 +366,8 @@ mkGenericDefMethBind clas inst_tys sel_id meth_name
                                  _                                               -> Nothing
                        _ -> Nothing
 
-isInstDecl :: InstOrigin -> Bool
-isInstDecl (SigOrigin InstSkol)    = True
-isInstDecl (SigOrigin (ClsSkol _)) = False
-isInstDecl o                       = pprPanic "isInstDecl" (ppr o)
-\end{code}
-
-
-Note [Default methods]
-~~~~~~~~~~~~~~~~~~~~~~~
-The default methods for a class are each passed a dictionary for the
-class, so that they get access to the other methods at the same type.
-So, given the class decl
-
-    class Foo a where
-       op1 :: a -> Bool
-       op2 :: forall b. Ord b => a -> b -> b -> b
-
-       op1 x = True
-       op2 x y z = if (op1 x) && (y < z) then y else z
-
-we get the default methods:
-
-    $dmop1 :: forall a. Foo a => a -> Bool
-    $dmop1 = /\a -> \dfoo -> \x -> True
-
-    $dmop2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
-    $dmop2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
-                         if (op1 a dfoo x) && (< b dord y z) then y else z
-
-When we come across an instance decl, we may need to use the default methods:
-
-    instance Foo Int where {}
-
-    $dFooInt :: Foo Int
-    $dFooInt = MkFoo ($dmop1 Int $dFooInt) 
-                    ($dmop2 Int $dFooInt)
-
-Notice that, as with method selectors above, we assume that dictionary
-application is curried, so there's no need to mention the Ord dictionary
-in the application of $dmop2.
-
-   instance Foo a => Foo [a] where {}
-
-   $dFooList :: forall a. Foo a -> Foo [a]
-   $dFooList = /\ a -> \ dfoo_a ->
-             let rec
-               op1 = defm.Foo.op1 [a] dfoo_list
-               op2 = defm.Foo.op2 [a] dfoo_list
-               dfoo_list = MkFoo ($dmop1 [a] dfoo_list)
-                                 ($dmop2 [a] dfoo_list)
-             in
-             dfoo_list
-
-Note [Default methods in instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this
-
-   class Baz v x where
-      foo :: x -> x
-      foo y = y
-
-   instance Baz Int Int
-
-From the class decl we get
-
-   $dmfoo :: forall v x. Baz v x => x -> x
-
-Notice that the type is ambiguous.  That's fine, though. The instance decl generates
-
-   $dBazIntInt = MkBaz ($dmfoo Int Int $dBazIntInt)
-
-BUT this does mean we must generate the dictionary translation directly, rather
-than generating source-code and type-checking it.  That was the bug ing
-Trac #1061. In any case it's less work to generate the translated version!
-
-
-%************************************************************************
-%*                                                                     *
-\subsection{Extracting generic instance declaration from class declarations}
-%*                                                                     *
-%************************************************************************
 
-@getGenericInstances@ extracts the generic instance declarations from a class
-declaration.  For exmaple
-
-       class C a where
-         op :: a -> a
-       
-         op{ x+y } (Inl v)   = ...
-         op{ x+y } (Inr v)   = ...
-         op{ x*y } (v :*: w) = ...
-         op{ 1   } Unit      = ...
-
-gives rise to the instance declarations
-
-       instance C (x+y) where
-         op (Inl v)   = ...
-         op (Inr v)   = ...
-       
-       instance C (x*y) where
-         op (v :*: w) = ...
-
-       instance C 1 where
-         op Unit      = ...
-
-
-\begin{code}
+---------------------------
 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name] 
 getGenericInstances class_decls
   = do { gen_inst_infos <- mapM (addLocM get_generics) class_decls
@@ -754,14 +528,6 @@ tcAddDeclCtxt decl thing_inside
      ctxt = hsep [ptext (sLit "In the"), text thing, 
                  ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
 
-defltMethCtxt :: Class -> SDoc
-defltMethCtxt clas
-  = ptext (sLit "When checking the default methods for class") <+> quotes (ppr clas)
-
-methodCtxt :: Var -> SDoc
-methodCtxt sel_id
-  = ptext (sLit "In the definition for method") <+> quotes (ppr sel_id)
-
 badMethodErr :: Outputable a => a -> Name -> SDoc
 badMethodErr clas op
   = hsep [ptext (sLit "Class"), quotes (ppr clas), 
@@ -772,10 +538,6 @@ badATErr clas at
   = hsep [ptext (sLit "Class"), quotes (ppr clas), 
          ptext (sLit "does not have an associated type"), quotes (ppr at)]
 
-omittedMethodWarn :: Id -> SDoc
-omittedMethodWarn sel_id
-  = ptext (sLit "No explicit method nor default method for") <+> quotes (ppr sel_id)
-
 omittedATWarn :: Name -> SDoc
 omittedATWarn at
   = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
index fe1d0cf..d0052d8 100644 (file)
@@ -12,7 +12,7 @@
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
-module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcSyntaxOp ) where
+module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcInferRho, tcInferRhoNC, tcSyntaxOp ) where
 
 #include "HsVersions.h"
 
@@ -79,20 +79,20 @@ tcPolyExpr, tcPolyExprNC
 -- to do so himself.
 
 tcPolyExpr expr res_ty         
-  = addErrCtxt (exprCtxt (unLoc expr)) $
+  = addErrCtxt (exprCtxt expr) $
     (do {traceTc (text "tcPolyExpr") ; tcPolyExprNC expr res_ty })
 
 tcPolyExprNC expr res_ty 
   | isSigmaTy res_ty
   = do { traceTc (text "tcPolyExprNC" <+> ppr res_ty)
-       ; (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr)
+       ; (gen_fn, expr') <- tcGen res_ty emptyVarSet Nothing (tcPolyExprNC expr)
                -- Note the recursive call to tcPolyExpr, because the
                -- type may have multiple layers of for-alls
                -- E.g. forall a. Eq a => forall b. Ord b => ....
        ; return (mkLHsWrap gen_fn expr') }
 
   | otherwise
-  = tcMonoExpr expr res_ty
+  = tcMonoExprNC expr res_ty
 
 ---------------
 tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
@@ -104,21 +104,27 @@ tcPolyExprs (expr:exprs) (ty:tys)
 tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
 
 ---------------
-tcMonoExpr :: LHsExpr Name     -- Expression to type check
-          -> BoxyRhoType       -- Expected type (could be a type variable)
-                               -- Definitely no foralls at the top
-                               -- Can contain boxes, which will be filled in
-          -> TcM (LHsExpr TcId)
-
-tcMonoExpr (L loc expr) res_ty
+tcMonoExpr, tcMonoExprNC 
+    :: LHsExpr Name    -- Expression to type check
+    -> BoxyRhoType     -- Expected type (could be a type variable)
+                       -- Definitely no foralls at the top
+                       -- Can contain boxes, which will be filled in
+    -> TcM (LHsExpr TcId)
+
+tcMonoExpr expr res_ty
+  = addErrCtxt (exprCtxt expr) $
+    tcMonoExprNC expr res_ty
+
+tcMonoExprNC (L loc expr) res_ty
   = ASSERT( not (isSigmaTy res_ty) )
     setSrcSpan loc $
     do { expr' <- tcExpr expr res_ty
        ; return (L loc expr') }
 
 ---------------
-tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
-tcInferRho expr        = tcInfer (tcMonoExpr expr)
+tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
+tcInferRho   expr = tcInfer (tcMonoExpr expr)
+tcInferRhoNC expr = tcInfer (tcMonoExprNC expr)
 \end{code}
 
 
@@ -130,6 +136,9 @@ tcInferRho expr     = tcInfer (tcMonoExpr expr)
 
 \begin{code}
 tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId)
+tcExpr e res_ty | debugIsOn && isSigmaTy res_ty     -- Sanity check
+                       = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
+
 tcExpr (HsVar name)     res_ty = tcId (OccurrenceOf name) name res_ty
 
 tcExpr (HsLit lit)     res_ty = do { let lit_ty = hsLitType lit
@@ -137,7 +146,7 @@ tcExpr (HsLit lit)  res_ty = do { let lit_ty = hsLitType lit
                                    ; return $ mkHsWrapCoI coi (HsLit lit)
                                    }
 
-tcExpr (HsPar expr)     res_ty = do { expr' <- tcMonoExpr expr res_ty
+tcExpr (HsPar expr)     res_ty = do { expr' <- tcMonoExprNC expr res_ty
                                    ; return (HsPar expr') }
 
 tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
@@ -191,9 +200,8 @@ tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
  = do  { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
 
        -- Remember to extend the lexical type-variable environment
-       ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (\ skol_tvs res_ty ->
-                            tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
-                            tcPolyExprNC expr res_ty)
+       ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $
+                            tcMonoExprNC expr
 
        ; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty
        ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
@@ -238,7 +246,7 @@ tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
            then do (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
                    return (SectionL arg1' (L loc op'))
            else do (co_fn, (op', arg1'))
-                       <- subFunTys doc 1 res_ty
+                       <- subFunTys doc 1 res_ty Nothing
                         $ \ [arg2_ty'] res_ty' ->
                               tcApp op 2 (tc_args arg2_ty') res_ty'
                    return (mkHsWrap co_fn (SectionL arg1' (L loc op')))
@@ -256,7 +264,7 @@ tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
 --     \ x -> op x expr
  
 tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
-  = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' ->
+  = do { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] res_ty' ->
                                   tcApp op 2 (tc_args arg1_ty') res_ty'
        ; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) }
   where
@@ -286,8 +294,7 @@ tcExpr (HsCase scrut matches) exp_ty
           --
           -- But now, in the GADT world, we need to typecheck the scrutinee
           -- first, to get type info that may be refined in the case alternatives
-         (scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut)
-                                          (tcInferRho scrut)
+         (scrut', scrut_ty) <- tcInferRho scrut
 
        ; traceTc (text "HsCase" <+> ppr scrut_ty)
        ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
@@ -297,8 +304,7 @@ tcExpr (HsCase scrut matches) exp_ty
                      mc_body = tcBody }
 
 tcExpr (HsIf pred b1 b2) res_ty
-  = do { pred' <- addErrCtxt (predCtxt pred) $
-                  tcMonoExpr pred boolTy
+  = do { pred' <- tcMonoExpr pred boolTy
        ; b1' <- tcMonoExpr b1 res_ty
        ; b2' <- tcMonoExpr b2 res_ty
        ; return (HsIf pred' b1' b2') }
@@ -1169,10 +1175,7 @@ checkMissingFields data_con rbinds
 
 Boring and alphabetical:
 \begin{code}
-caseScrutCtxt expr
-  = hang (ptext (sLit "In the scrutinee of a case expression:")) 4 (ppr expr)
-
-exprCtxt expr
+exprCtxt (L _ expr)
   = hang (ptext (sLit "In the expression:")) 4 (ppr expr)
 
 fieldCtxt field_name
@@ -1183,9 +1186,6 @@ funAppCtxt fun arg arg_no
                    quotes (ppr fun) <> text ", namely"])
         4 (quotes (ppr arg))
 
-predCtxt expr
-  = hang (ptext (sLit "In the predicate expression:")) 4 (ppr expr)
-
 nonVanillaUpd tycon
   = vcat [ptext (sLit "Record update for the non-Haskell-98 data type") 
                <+> quotes (pprSourceTyCon tycon)
index 4ff2c19..ec36034 100644 (file)
@@ -15,7 +15,7 @@ tcMonoExpr ::
        -> BoxyRhoType
        -> TcM (LHsExpr TcId)
 
-tcInferRho :: 
+tcInferRho, tcInferRhoNC :: 
          LHsExpr Name
        -> TcM (LHsExpr TcId, TcRhoType)
 
index 8ff44ad..c8e4b46 100644 (file)
@@ -21,6 +21,7 @@ import FamInst
 import FamInstEnv
 import TcDeriv
 import TcEnv
+import RnEnv   ( lookupImportedName )
 import TcHsType
 import TcUnify
 import TcSimplify
@@ -37,9 +38,9 @@ import Name
 import NameSet
 import DynFlags
 import SrcLoc
-import ListSetOps
 import Util
 import Outputable
+import Maybes
 import Bag
 import BasicTypes
 import HscTypes
@@ -48,6 +49,8 @@ import FastString
 import Data.Maybe
 import Control.Monad
 import Data.List
+
+#include "HsVersions.h"
 \end{code}
 
 Typechecking instance declarations is done in two passes. The first
@@ -60,67 +63,178 @@ pass, when the class-instance envs and GVE contain all the info from
 all the instance and value decls.  Indeed that's the reason we need
 two passes over the instance decls.
 
-Here is the overall algorithm.
-Assume that we have an instance declaration
-
-    instance c => k (t tvs) where b
-
-\begin{enumerate}
-\item
-$LIE_c$ is the LIE for the context of class $c$
-\item
-$betas_bar$ is the free variables in the class method type, excluding the
-   class variable
-\item
-$LIE_cop$ is the LIE constraining a particular class method
-\item
-$tau_cop$ is the tau type of a class method
-\item
-$LIE_i$ is the LIE for the context of instance $i$
-\item
-$X$ is the instance constructor tycon
-\item
-$gammas_bar$ is the set of type variables of the instance
-\item
-$LIE_iop$ is the LIE for a particular class method instance
-\item
-$tau_iop$ is the tau type for this instance of a class method
-\item
-$alpha$ is the class variable
-\item
-$LIE_cop' = LIE_cop [X gammas_bar \/ alpha, fresh betas_bar]$
-\item
-$tau_cop' = tau_cop [X gammas_bar \/ alpha, fresh betas_bar]$
-\end{enumerate}
-
-ToDo: Update the list above with names actually in the code.
-
-\begin{enumerate}
-\item
-First, make the LIEs for the class and instance contexts, which means
-instantiate $thetaC [X inst_tyvars \/ alpha ]$, yielding LIElistC' and LIEC',
-and make LIElistI and LIEI.
-\item
-Then process each method in turn.
-\item
-order the instance methods according to the ordering of the class methods
-\item
-express LIEC' in terms of LIEI, yielding $dbinds_super$ or an error
-\item
-Create final dictionary function from bindings generated already
-\begin{pseudocode}
-df = lambda inst_tyvars
-       lambda LIEI
-         let Bop1
-             Bop2
-             ...
-             Bopn
-         and dbinds_super
-              in <op1,op2,...,opn,sd1,...,sdm>
-\end{pseudocode}
-Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
-and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
-\end{enumerate}
+
+Note [How instance declarations are translated]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Here is how we translation instance declarations into Core
+
+Running example:
+       class C a where
+          op1, op2 :: Ix b => a -> b -> b
+          op2 = <dm-rhs>
+
+       instance C a => C [a]
+          {-# INLINE [2] op1 #-}
+          op1 = <rhs>
+===>
+       -- Method selectors
+       op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
+       op1 = ...
+       op2 = ...
+
+       -- Default methods get the 'self' dictionary as argument
+       -- so they can call other methods at the same type
+       -- Default methods get the same type as their method selector
+       $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
+       $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
+              -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
+              -- Note [Tricky type variable scoping]
+
+       -- A top-level definition for each instance method
+       -- Here op1_i, op2_i are the "instance method Ids"
+       {-# INLINE [2] op1_i #-}  -- From the instance decl bindings
+       op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
+       op1_i = <rhs>   -- Source code; run the type checker on this
+              -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
+              -- Note [Tricky type variable scoping]
+
+       op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) 
+
+       -- The dictionary function itself
+       {-# INLINE df_i #-}     -- Always inline dictionary functions
+       df_i :: forall a. C a -> C [a]
+       df_i = /\a. \d:C a. MkC (op1_i a d) ($dmop2 a d)
+               -- But see Note [Default methods in instances]
+               -- We can't apply the type checker to the default-nmethod call
+
+* The dictionary function itself is inlined as vigorously as we
+  possibly can, so that we expose that dictionary constructor to
+  selectors as much as poss.  That is why the op_i stuff is in 
+  *separate* bindings, so that the df_i binding is small enough
+  to inline.  See Note [Inline dfuns unconditionally].
+
+* Note that df_i may be mutually recursive with both op1_i and op2_i.
+  It's crucial that df_i is not chosen as the loop breaker, even 
+  though op1_i has a (user-specified) INLINE pragma.
+  Not even once!  Else op1_i, op2_i may be inlined into df_i.
+
+* Instead the idea is to inline df_i into op1_i, which may then select
+  methods from the MkC record, and thereby break the recursion with
+  df_i, leaving a *self*-recurisve op1_i.  (If op1_i doesn't call op at
+  the same type, it won't mention df_i, so there won't be recursion in
+  the first place.)  
+
+* If op1_i is marked INLINE by the user there's a danger that we won't
+  inline df_i in it, and that in turn means that (since it'll be a
+  loop-breaker because df_i isn't), op1_i will ironically never be 
+  inlined.  We need to fix this somehow -- perhaps allowing inlining
+  of INLINE funcitons inside other INLINE functions.
+
+Note [Tricky type variable scoping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In our example
+       class C a where
+          op1, op2 :: Ix b => a -> b -> b
+          op2 = <dm-rhs>
+
+       instance C a => C [a]
+          {-# INLINE [2] op1 #-}
+          op1 = <rhs>
+
+note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
+in scope in <rhs>.  In particular, we must make sure that 'b' is in
+scope when typechecking <dm-rhs>.  This is achieved by subFunTys,
+which brings appropriate tyvars into scope. This happens for both
+<dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
+complained if 'b' is mentioned in <rhs>.
+
+Note [Inline dfuns unconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The code above unconditionally inlines dict funs.  Here's why.
+Consider this program:
+
+    test :: Int -> Int -> Bool
+    test x y = (x,y) == (y,x) || test y x
+    -- Recursive to avoid making it inline.
+
+This needs the (Eq (Int,Int)) instance.  If we inline that dfun
+the code we end up with is good:
+
+    Test.$wtest =
+        \r -> case ==# [ww ww1] of wild {
+                PrelBase.False -> Test.$wtest ww1 ww;
+                PrelBase.True ->
+                  case ==# [ww1 ww] of wild1 {
+                    PrelBase.False -> Test.$wtest ww1 ww;
+                    PrelBase.True -> PrelBase.True [];
+                  };
+            };
+    Test.test = \r [w w1]
+            case w of w2 {
+              PrelBase.I# ww ->
+                  case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
+            };
+
+If we don't inline the dfun, the code is not nearly as good:
+
+    (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
+              PrelBase.:DEq tpl1 tpl2 -> tpl2;
+            };
+
+    Test.$wtest =
+        \r [ww ww1]
+            let { y = PrelBase.I#! [ww1]; } in
+            let { x = PrelBase.I#! [ww]; } in
+            let { sat_slx = PrelTup.(,)! [y x]; } in
+            let { sat_sly = PrelTup.(,)! [x y];
+            } in
+              case == sat_sly sat_slx of wild {
+                PrelBase.False -> Test.$wtest ww1 ww;
+                PrelBase.True -> PrelBase.True [];
+              };
+
+    Test.test =
+        \r [w w1]
+            case w of w2 {
+              PrelBase.I# ww ->
+                  case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
+            };
+
+Why didn't GHC inline $fEq in those days?  Because it looked big:
+
+    PrelTup.zdfEqZ1T{-rcX-}
+        = \ @ a{-reT-} :: * @ b{-reS-} :: *
+            zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
+            zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
+            let {
+              zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
+              zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
+            let {
+              zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
+              zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
+            let {
+              zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
+              zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
+                               ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
+                             case ds{-rf5-}
+                             of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
+                             case ds1{-rf4-}
+                             of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
+                             PrelBase.zaza{-r4e-}
+                               (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
+                               (zeze{-rf0-} a2{-reZ-} b2{-reY-})
+                             }
+                             } } in
+            let {
+              a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
+              a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
+                            b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
+                          PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
+            } in
+              PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
+
+and it's not as bad as it seems, because it's further dramatically
+simplified: only zeze2 is extracted and its body is simplified.
 
 
 %************************************************************************
@@ -392,67 +506,6 @@ tcInstDecls2 tycl_decls inst_decls
         ; return (binds, tcl_env) }
 \end{code}
 
-======= New documentation starts here (Sept 92) ==============
-
-The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines
-the dictionary function for this instance declaration. For example
-
-        instance Foo a => Foo [a] where
-                op1 x = ...
-                op2 y = ...
-
-might generate something like
-
-        dfun.Foo.List dFoo_a = let op1 x = ...
-                                   op2 y = ...
-                               in
-                                   Dict [op1, op2]
-
-HOWEVER, if the instance decl has no context, then it returns a
-bigger @HsBinds@ with declarations for each method.  For example
-
-        instance Foo [a] where
-                op1 x = ...
-                op2 y = ...
-
-might produce
-
-        dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
-        const.Foo.op1.List a x = ...
-        const.Foo.op2.List a y = ...
-
-This group may be mutually recursive, because (for example) there may
-be no method supplied for op2 in which case we'll get
-
-        const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)
-
-that is, the default method applied to the dictionary at this type.
-What we actually produce in either case is:
-
-        AbsBinds [a] [dfun_theta_dicts]
-                 [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
-                 { d = (sd1,sd2, ..., op1, op2, ...)
-                   op1 = ...
-                   op2 = ...
-                 }
-
-The "maybe" says that we only ask AbsBinds to make global constant methods
-if the dfun_theta is empty.
-
-For an instance declaration, say,
-
-        instance (C1 a, C2 b) => C (T a b) where
-                ...
-
-where the {\em immediate} superclasses of C are D1, D2, we build a dictionary
-function whose type is
-
-        (C1 a, C2 b, D1 (T a b), D2 (T a b)) => C (T a b)
-
-Notice that we pass it the superclass dictionaries at the instance type; this
-is the ``Mark Jones optimisation''.  The stuff before the "=>" here
-is the @dfun_theta@ below.
-
 
 \begin{code}
 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
@@ -617,15 +670,18 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
 
         -- Typecheck the methods
     let -- These insts are in scope; quite a few, eh?
-        dfun_insts      = dfun_eqs ++ dfun_dicts
-        wanted_sc_insts = wanted_sc_eqs   ++ sc_dicts
-        given_sc_eqs    = map (updateEqInstCoercion (mkGivenCo . TyVarTy . fromWantedCo "tcInstDecl2") ) wanted_sc_eqs
-        given_sc_insts  = given_sc_eqs   ++ sc_dicts
-        avail_insts     = dfun_insts ++ given_sc_insts
-
-    (meth_ids, meth_binds) <- tcMethods origin clas inst_tyvars'
-                                 dfun_theta' inst_tys' this_dict avail_insts
-                                 op_items monobinds uprags
+        dfun_insts      = dfun_eqs      ++ dfun_dicts
+        wanted_sc_insts = wanted_sc_eqs ++ sc_dicts
+        this_dict_id   = instToId this_dict
+        sc_dict_ids    = map instToId sc_dicts
+       dfun_dict_ids   = map instToId dfun_dicts
+       prag_fn         = mkPragFun uprags 
+       tc_meth         = tcInstanceMethod loc clas inst_tyvars'
+                                          (dfun_covars ++ dfun_dict_ids)
+                                          dfun_theta' inst_tys'
+                                          this_dict_id 
+                                          monobinds prag_fn
+    (meth_exprs, meth_binds) <- mapAndUnzipM tc_meth op_items 
 
     -- Figure out bindings for the superclass context
     -- Don't include this_dict in the 'givens', else
@@ -643,8 +699,6 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
     -- Create the result bindings
     let
         dict_constr   = classDataCon clas
-        scs_and_meths = map instToId sc_dicts ++ meth_ids
-        this_dict_id  = instToId this_dict
         inline_prag | null dfun_insts  = []
                     | otherwise        = [L loc (InlinePrag (Inline AlwaysActive True))]
                 -- Always inline the dfun; this is an experimental decision
@@ -659,7 +713,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
                 --      See Note [Inline dfuns] below
 
         dict_rhs = mkHsConApp dict_constr (inst_tys' ++ mkTyVarTys sc_covars)
-                                          (map HsVar scs_and_meths)
+                                          (map HsVar sc_dict_ids ++ meth_exprs)
                 -- We don't produce a binding for the dict_constr; instead we
                 -- rely on the simplifier to unfold this saturated application
                 -- We do this rather than generate an HsCon directly, because
@@ -668,16 +722,15 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
                 -- than needing to be repeated here.
 
         dict_bind  = noLoc (VarBind this_dict_id dict_rhs)
-        all_binds  = dict_bind `consBag` (sc_binds `unionBags` meth_binds)
 
         main_bind = noLoc $ AbsBinds
                             (inst_tyvars' ++ dfun_covars)
-                            (map instToId dfun_dicts)
+                            dfun_dict_ids
                             [(inst_tyvars' ++ dfun_covars, dfun_id, this_dict_id, inline_prag ++ prags)]
-                            all_binds
+                            (dict_bind `consBag` sc_binds)
 
     showLIE (text "instance")
-    return (unitBag main_bind)
+    return (main_bind `consBag` unionManyBags meth_binds)
 
 mkCoVars :: [PredType] -> TcM [TyVar]
 mkCoVars = newCoVars . map unEqPred
@@ -690,159 +743,119 @@ mkMetaCoVars = mapM eqPredToCoVar
   where
     eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2
     eqPredToCoVar _                = panic "TcInstDcls.mkMetaCoVars"
+\end{code}
 
-tcMethods :: InstOrigin -> Class -> [TcTyVar] -> TcThetaType -> [TcType]
-          -> Inst -> [Inst] -> [(Id, DefMeth)] -> LHsBindsLR Name Name
-          -> [LSig Name]
-          -> TcM ([Id], Bag (LHsBind Id))
-tcMethods origin clas inst_tyvars' dfun_theta' inst_tys'
-          this_dict extra_insts op_items monobinds uprags = do
-    -- Check that all the method bindings come from this class
-    let
-        sel_names = [idName sel_id | (sel_id, _) <- op_items]
-        bad_bndrs = collectHsBindBinders monobinds `minusList` sel_names
 
-    mapM (addErrTc . badMethodErr clas) bad_bndrs
 
-    -- Make the method bindings
-    let
-        mk_method_id (sel_id, _) = mkMethId origin clas sel_id inst_tys'
-
-    (meth_insts, meth_ids) <- mapAndUnzipM mk_method_id op_items
-
-        -- 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.
-        --
-        -- BUT WATCH OUT!  If the method type mentions the class variable, then
-        -- this optimisation is not right.  Consider
-        --      class C a where
-        --        op :: Eq a => a
-        --
-        --      instance C Int where
-        --        op = op
-        -- The occurrence of 'op' on the rhs gives rise to a constraint
-        --      op at Int
-        -- The trouble is that the 'meth_inst' for op, which is 'available', also
-        -- looks like 'op at Int'.  But they are not the same.
-    let
-        prag_fn        = mkPragFun uprags
-        all_insts      = extra_insts ++ catMaybes meth_insts
-        sig_fn _       = Just []        -- No scoped type variables, but every method has
-                                        -- a type signature, in effect, so that we check
-                                        -- the method has the right type
-        tc_method_bind = tcMethodBind origin inst_tyvars' dfun_theta' this_dict 
-                                     all_insts sig_fn prag_fn monobinds
-
-    meth_binds_s <- zipWithM tc_method_bind op_items meth_ids
+tcInstanceMethod
+- Make the method bindings, as a [(NonRec, HsBinds)], one per method
+- Remembering to use fresh Name (the instance method Name) as the binder
+- Bring the instance method Ids into scope, for the benefit of tcInstSig
+- Use sig_fn mapping instance method Name -> instance tyvars
+- Ditto prag_fn
+- Use tcValBinds to do the checking
 
-    return (meth_ids, unionManyBags meth_binds_s)
+\begin{code}
+tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Var]
+                -> TcThetaType -> [TcType] -> Id
+                -> LHsBinds Name -> TcPragFun
+                -> (Id, DefMeth)
+                -> TcM (HsExpr Id, LHsBinds Id)
+       -- The returned inst_meth_ids all have types starting
+       --      forall tvs. theta => ...
+
+tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys this_dict_id
+                binds_in prag_fn (sel_id, dm_info)
+  = do { uniq <- newUnique
+       ; let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
+             rho_ty = ASSERT( length sel_tyvars == length inst_tys )
+                      substTyWith sel_tyvars inst_tys sel_rho
+             (first_pred, meth_tau) = tcSplitPredFunTy_maybe rho_ty
+                       `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
+                                      
+                     -- The first predicate should be of form (C a b)
+                     -- where C is the class in question
+             meth_ty   = mkSigmaTy tyvars theta meth_tau
+             meth_name = mkInternalName uniq sel_occ loc       -- Same OccName
+             meth_id   = mkLocalId meth_name meth_ty
+
+       ; MASSERT( case getClassPredTys_maybe first_pred of
+                       { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } )
+
+
+       ; case (findMethodBind sel_name meth_name binds_in, dm_info) of
+               -- There is a user-supplied method binding, so use it
+           (Just user_bind, _) -> typecheck_meth meth_id user_bind
+
+               -- The user didn't supply a method binding, so we have to make 
+               -- up a default binding, in a way depending on the default-method info
+
+           (Nothing, GenDefMeth) -> do         -- Derivable type classes stuff
+                       { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id meth_name
+                       ; typecheck_meth meth_id meth_bind }
+
+           (Nothing, NoDefMeth) -> do          -- No default method in the class
+                       { warn <- doptM Opt_WarnMissingMethods          
+                        ; warnTc (warn  -- Warn only if -fwarn-missing-methods
+                                 && reportIfUnused (getOccName sel_id))
+                                       -- Don't warn about _foo methods
+                                (omittedMethodWarn sel_id) 
+                       ; return (mk_error_rhs meth_tau, emptyBag) }
+
+           (Nothing, DefMeth) -> do    -- An polymorphic default method
+                       {   -- Build the typechecked version directly, 
+                           -- without calling typecheck_method; 
+                           -- see Note [Default methods in instances]
+                         dm_name <- lookupImportedName (mkDefMethRdrName sel_name)
+                                       -- Might not be imported, but will be an OrigName
+                       ; dm_id   <- tcLookupId dm_name
+                       ; return (wrap dm_wrapper dm_id, emptyBag) } }
+  where
+    sel_name = idName sel_id
+    sel_occ  = nameOccName sel_name
+    tv_names = map tyVarName tyvars
+    prags    = prag_fn sel_name
+
+    typecheck_meth :: Id -> LHsBind Name -> TcM (HsExpr Id, LHsBinds Id)
+    typecheck_meth meth_id bind
+       = do { tc_binds <- tcMethodBind tv_names prags meth_id bind
+            ; return (wrap meth_wrapper meth_id, tc_binds) }
+
+    mk_error_rhs tau = HsApp (mkLHsWrap (WpTyApp tau) error_id) error_msg
+    error_id     = L loc (HsVar nO_METHOD_BINDING_ERROR_ID) 
+    error_msg    = L loc (HsLit (HsStringPrim (mkFastString error_string)))
+    error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
+
+    wrap wrapper id = mkHsWrap wrapper (HsVar id)
+    meth_wrapper = mkWpApps dfun_lam_vars `WpCompose` mkWpTyApps (mkTyVarTys tyvars)
+    dm_wrapper   = WpApp this_dict_id `WpCompose` mkWpTyApps inst_tys 
+
+omittedMethodWarn :: Id -> SDoc
+omittedMethodWarn sel_id
+  = ptext (sLit "No explicit method nor default method for") <+> quotes (ppr sel_id)
 \end{code}
 
+Note [Default methods in instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
 
-                ------------------------------
-        [Inline dfuns] Inlining dfuns unconditionally
-                ------------------------------
+   class Baz v x where
+      foo :: x -> x
+      foo y = y
 
-The code above unconditionally inlines dict funs.  Here's why.
-Consider this program:
+   instance Baz Int Int
 
-    test :: Int -> Int -> Bool
-    test x y = (x,y) == (y,x) || test y x
-    -- Recursive to avoid making it inline.
+From the class decl we get
 
-This needs the (Eq (Int,Int)) instance.  If we inline that dfun
-the code we end up with is good:
+   $dmfoo :: forall v x. Baz v x => x -> x
 
-    Test.$wtest =
-        \r -> case ==# [ww ww1] of wild {
-                PrelBase.False -> Test.$wtest ww1 ww;
-                PrelBase.True ->
-                  case ==# [ww1 ww] of wild1 {
-                    PrelBase.False -> Test.$wtest ww1 ww;
-                    PrelBase.True -> PrelBase.True [];
-                  };
-            };
-    Test.test = \r [w w1]
-            case w of w2 {
-              PrelBase.I# ww ->
-                  case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
-            };
-
-If we don't inline the dfun, the code is not nearly as good:
+Notice that the type is ambiguous.  That's fine, though. The instance decl generates
 
-    (==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
-              PrelBase.:DEq tpl1 tpl2 -> tpl2;
-            };
+   $dBazIntInt = MkBaz ($dmfoo Int Int $dBazIntInt)
 
-    Test.$wtest =
-        \r [ww ww1]
-            let { y = PrelBase.I#! [ww1]; } in
-            let { x = PrelBase.I#! [ww]; } in
-            let { sat_slx = PrelTup.(,)! [y x]; } in
-            let { sat_sly = PrelTup.(,)! [x y];
-            } in
-              case == sat_sly sat_slx of wild {
-                PrelBase.False -> Test.$wtest ww1 ww;
-                PrelBase.True -> PrelBase.True [];
-              };
-
-    Test.test =
-        \r [w w1]
-            case w of w2 {
-              PrelBase.I# ww ->
-                  case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
-            };
-
-Why doesn't GHC inline $fEq?  Because it looks big:
-
-    PrelTup.zdfEqZ1T{-rcX-}
-        = \ @ a{-reT-} :: * @ b{-reS-} :: *
-            zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
-            zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
-            let {
-              zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
-              zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
-            let {
-              zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
-              zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
-            let {
-              zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
-              zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
-                               ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
-                             case ds{-rf5-}
-                             of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
-                             case ds1{-rf4-}
-                             of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
-                             PrelBase.zaza{-r4e-}
-                               (zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
-                               (zeze{-rf0-} a2{-reZ-} b2{-reY-})
-                             }
-                             } } in
-            let {
-              a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
-              a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
-                            b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
-                          PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
-            } in
-              PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
-
-and it's not as bad as it seems, because it's further dramatically
-simplified: only zeze2 is extracted and its body is simplified.
+BUT this does mean we must generate the dictionary translation directly, rather
+than generating source-code and type-checking it.  That was the bug ing
+Trac #1061. In any case it's less work to generate the translated version!
 
 
 %************************************************************************
index 5b660df..1addfe4 100644 (file)
@@ -33,8 +33,8 @@ module TcMType (
   --------------------------------
   -- Instantiation
   tcInstTyVar, tcInstType, tcInstTyVars, tcInstBoxyTyVar,
-  tcInstSigTyVars,
-  tcInstSkolTyVar, tcInstSkolTyVars, tcInstSkolType, 
+  tcInstSigType,
+  tcInstSkolTyVars, tcInstSkolType, 
   tcSkolSigType, tcSkolSigTyVars, occurCheckErr,
 
   --------------------------------
@@ -430,17 +430,17 @@ tcSkolSigTyVars :: SkolemInfo -> [TyVar] -> [TcTyVar]
 tcSkolSigTyVars info tyvars = [ mkSkolTyVar (tyVarName tv) (tyVarKind tv) info
                              | tv <- tyvars ]
 
-tcInstSkolTyVar :: SkolemInfo -> Maybe SrcSpan -> TyVar -> TcM TcTyVar
+tcInstSkolTyVar :: SkolemInfo -> (Name -> SrcSpan) -> TyVar -> TcM TcTyVar
 -- Instantiate the tyvar, using 
 --     * the occ-name and kind of the supplied tyvar, 
 --     * the unique from the monad,
 --     * the location either from the tyvar (mb_loc = Nothing)
 --       or from mb_loc (Just loc)
-tcInstSkolTyVar info mb_loc tyvar
+tcInstSkolTyVar info get_loc tyvar
   = do { uniq <- newUnique
        ; let old_name = tyVarName tyvar
              kind     = tyVarKind tyvar
-             loc      = mb_loc `orElse` getSrcSpan old_name
+             loc      = get_loc old_name
              new_name = mkInternalName uniq (nameOccName old_name) loc
        ; return (mkSkolTyVar new_name kind info) }
 
@@ -448,12 +448,21 @@ tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar]
 -- Get the location from the monad
 tcInstSkolTyVars info tyvars 
   = do         { span <- getSrcSpanM
-       ; mapM (tcInstSkolTyVar info (Just span)) tyvars }
+       ; mapM (tcInstSkolTyVar info (const span)) tyvars }
 
 tcInstSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
 -- Instantiate a type with fresh skolem constants
 -- Binding location comes from the monad
 tcInstSkolType info ty = tcInstType (tcInstSkolTyVars info) ty
+
+tcInstSigType :: Bool -> SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcRhoType)
+-- Instantiate with skolems or meta SigTvs; depending on use_skols
+-- Always take location info from the supplied tyvars
+tcInstSigType use_skols skol_info ty
+  = tcInstType (mapM inst_tyvar) ty
+  where
+    inst_tyvar | use_skols = tcInstSkolTyVar skol_info getSrcSpan
+              | otherwise = instMetaTyVar (SigTv skol_info)
 \end{code}
 
 
@@ -563,16 +572,6 @@ tcInstTyVars tyvars
 %************************************************************************
 
 \begin{code}
-tcInstSigTyVars :: Bool -> SkolemInfo -> [TyVar] -> TcM [TcTyVar]
--- Instantiate with skolems or meta SigTvs; depending on use_skols
--- Always take location info from the supplied tyvars
-tcInstSigTyVars use_skols skol_info tyvars 
-  | use_skols
-  = mapM (tcInstSkolTyVar skol_info Nothing) tyvars
-
-  | otherwise
-  = mapM (instMetaTyVar (SigTv skol_info)) tyvars
-
 zonkSigTyVar :: TcTyVar -> TcM TcTyVar
 zonkSigTyVar sig_tv 
   | isSkolemTyVar sig_tv 
index 37fbd19..4748901 100644 (file)
@@ -12,7 +12,7 @@ module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
                   tcDoStmt, tcMDoStmt, tcGuardStmt
        ) where
 
-import {-# SOURCE #-}  TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
+import {-# SOURCE #-}  TcExpr( tcSyntaxOp, tcInferRhoNC, tcMonoExpr, tcPolyExpr )
 
 import HsSyn
 import TcRnMonad
@@ -73,7 +73,7 @@ tcMatchesFun fun_name inf matches exp_ty
                -- This is one of two places places we call subFunTys
                -- The point is that if expected_y is a "hole", we want 
                -- to make pat_tys and rhs_ty as "holes" too.
-       ; subFunTys doc n_pats exp_ty     $ \ pat_tys rhs_ty -> 
+       ; subFunTys doc n_pats exp_ty (Just (FunSigCtxt fun_name)) $ \ pat_tys rhs_ty -> 
          tcMatches match_ctxt pat_tys rhs_ty matches
        }
   where
@@ -105,7 +105,7 @@ tcMatchesCase ctxt scrut_ty matches res_ty
 
 tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
 tcMatchLambda match res_ty 
-  = subFunTys doc n_pats res_ty        $ \ pat_tys rhs_ty ->
+  = subFunTys doc n_pats res_ty Nothing        $ \ pat_tys rhs_ty ->
     tcMatches match_ctxt pat_tys rhs_ty match
   where
     n_pats = matchGroupArity match
@@ -267,7 +267,7 @@ tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
 tcBody :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
 tcBody body res_ty
   = do { traceTc (text "tcBody" <+> ppr res_ty)
-       ; body' <- tcPolyExpr body res_ty
+       ; body' <- tcMonoExpr body res_ty
        ; return body' 
         } 
 \end{code}
@@ -327,7 +327,7 @@ tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
        ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
 
 tcGuardStmt _ (BindStmt pat rhs _ _) res_ty thing_inside
-  = do { (rhs', rhs_ty) <- tcInferRho rhs
+  = do { (rhs', rhs_ty) <- tcInferRhoNC rhs    -- Stmt has a context already
        ; (pat', thing)  <- tcLamPat pat rhs_ty res_ty thing_inside
        ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
@@ -404,7 +404,7 @@ tcLcStmt m_tc ctxt (TransformStmt (stmts, binders) usingExpr maybeByExpr) elt_ty
                         return (usingExpr', Nothing)
                     Just byExpr -> do
                         -- We must infer a type such that e :: t and then check that usingExpr :: forall a. (a -> t) -> [a] -> [a]
-                        (byExpr', tTy) <- tcInferRho byExpr
+                        (byExpr', tTy) <- tcInferRhoNC byExpr
                         usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy)))
                         return (usingExpr', Just byExpr')
             
@@ -428,7 +428,7 @@ tcLcStmt m_tc ctxt (GroupStmt (stmts, bindersMap) groupByClause) elt_ty thing_in
                             tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListListTy)) >>= (return . GroupByNothing)
                         GroupBySomething eitherUsingExpr byExpr -> do
                             -- We must infer a type such that byExpr :: t
-                            (byExpr', tTy) <- tcInferRho byExpr
+                            (byExpr', tTy) <- tcInferRhoNC byExpr
                             
                             -- If it exists, we then check that usingExpr :: forall a. (a -> t) -> [a] -> [[a]]
                             let expectedUsingType = mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListListTy))
@@ -464,7 +464,7 @@ tcLcStmt _ _ stmt _ _
 tcDoStmt :: TcStmtChecker
 
 tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
-  = do { (rhs', rhs_ty) <- tcInferRho rhs
+  = do { (rhs', rhs_ty) <- tcInferRhoNC rhs
                -- We should use type *inference* for the RHS computations, 
                 -- becuase of GADTs. 
                --      do { pat <- rhs; <rest> }
@@ -495,7 +495,7 @@ tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
 
 
 tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
-  = do { (rhs', rhs_ty) <- tcInferRho rhs
+  = do { (rhs', rhs_ty) <- tcInferRhoNC rhs
 
        -- Deal with rebindable syntax; (>>) :: rhs_ty -> new_res_ty -> res_ty
        ; (then_op', new_res_ty) <-
index b1862b7..6ff9732 100644 (file)
@@ -41,7 +41,7 @@ module TcType (
   -- Splitters  
   -- These are important because they do not look through newtypes
   tcView,
-  tcSplitForAllTys, tcSplitPhiTy, 
+  tcSplitForAllTys, tcSplitPhiTy, tcSplitPredFunTy_maybe,
   tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN,
   tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
   tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe,
@@ -660,16 +660,24 @@ tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'
 tcIsForAllTy (ForAllTy tv _) = not (isCoVar tv)
 tcIsForAllTy _               = False
 
+tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type)
+-- Split off the first predicate argument from a type
+tcSplitPredFunTy_maybe ty | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty'
+tcSplitPredFunTy_maybe (ForAllTy tv ty)
+  | isCoVar tv = Just (coVarPred tv, ty)
+tcSplitPredFunTy_maybe (FunTy arg res)
+  | Just p <- tcSplitPredTy_maybe arg = Just (p, res)
+tcSplitPredFunTy_maybe _
+  = Nothing
+
 tcSplitPhiTy :: Type -> (ThetaType, Type)
-tcSplitPhiTy ty = split ty ty []
- where
-  split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
-
-  split _       (ForAllTy tv ty) ts
-        | isCoVar tv = split ty ty (coVarPred tv : ts)
-  split _        (FunTy arg res) ts 
-       | Just p <- tcSplitPredTy_maybe arg = split res res (p:ts)
-  split orig_ty _               ts = (reverse ts, orig_ty)
+tcSplitPhiTy ty
+  = split ty []
+  where
+    split ty ts 
+      = case tcSplitPredFunTy_maybe ty of
+         Just (pred, ty) -> split ty (pred:ts)
+         Nothing         -> (reverse ts, ty)
 
 tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
 tcSplitSigmaTy ty = case tcSplitForAllTys ty of
index ecee5ac..11c0f3f 100644 (file)
@@ -79,7 +79,9 @@ tcInfer tc_infer = withBox openTypeKind tc_infer
 subFunTys :: SDoc  -- Something like "The function f has 3 arguments"
                    -- or "The abstraction (\x.e) takes 1 argument"
           -> Arity              -- Expected # of args
-          -> BoxyRhoType        -- res_ty
+          -> BoxySigmaType      -- res_ty
+         -> Maybe UserTypeCtxt -- Whether res_ty arises from a user signature
+                               -- Only relevant if we encounter a sigma-type
           -> ([BoxySigmaType] -> BoxyRhoType -> TcM a)
           -> TcM (HsWrapper, a)
 -- Attempt to decompse res_ty to have enough top-level arrows to
@@ -108,7 +110,7 @@ subFunTys :: SDoc  -- Something like "The function f has 3 arguments"
 -}
 
 
-subFunTys error_herald n_pats res_ty thing_inside
+subFunTys error_herald n_pats res_ty mb_ctxt thing_inside
   = loop n_pats [] res_ty
   where
         -- In 'loop', the parameter 'arg_tys' accumulates
@@ -121,8 +123,8 @@ subFunTys error_herald n_pats res_ty thing_inside
         | isSigmaTy res_ty      -- Do this before checking n==0, because we
                                 -- guarantee to return a BoxyRhoType, not a
                                 -- BoxySigmaType
-        = do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet $ \ _ res_ty' ->
-                                         loop n args_so_far res_ty'
+        = do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet mb_ctxt $ 
+                                         loop n args_so_far
              ; return (gen_fn <.> co_fn, res) }
 
     loop 0 args_so_far res_ty
@@ -768,7 +770,7 @@ tc_sub1 orig act_sty act_ty exp_ib exp_sty exp_ty
     if exp_ib then      -- SKOL does not apply if exp_ty is inside a box
         defer_to_boxy_matching orig act_sty act_ty exp_ib exp_sty exp_ty
     else do
-        { (gen_fn, co_fn) <- tcGen exp_ty act_tvs $ \ _ body_exp_ty ->
+        { (gen_fn, co_fn) <- tcGen exp_ty act_tvs Nothing $ \ body_exp_ty ->
                              tc_sub orig act_sty act_ty False body_exp_ty body_exp_ty
         ; return (gen_fn <.> co_fn) }
     }
@@ -898,22 +900,17 @@ tcGen :: BoxySigmaType                          -- expected_ty
       -> TcTyVarSet                             -- Extra tyvars that the universally
                                                 --      quantified tyvars of expected_ty
                                                 --      must not be unified
-      -> ([TcTyVar] -> BoxyRhoType -> TcM result)
+      -> Maybe UserTypeCtxt                    -- Just ctxt => this polytype arose directly from
+                                               --              a user type sig; bring tyvars into scope
+                                               -- Nothing => a higher order situation
+      -> (BoxyRhoType -> TcM result)
       -> TcM (HsWrapper, result)
         -- The expression has type: spec_ty -> expected_ty
 
-tcGen expected_ty extra_tvs thing_inside        -- We expect expected_ty to be a forall-type
-                                                -- If not, the call is a no-op
+tcGen expected_ty extra_tvs mb_ctxt thing_inside        -- We expect expected_ty to be a forall-type
+                                                       -- If not, the call is a no-op
   = do  { traceTc (text "tcGen")
-                -- We want the GenSkol info in the skolemised type variables to
-                -- mention the *instantiated* tyvar names, so that we get a
-                -- good error message "Rigid variable 'a' is bound by (forall a. a->a)"
-                -- Hence the tiresome but innocuous fixM
-        ; ((tvs', theta', rho'), skol_info) <- fixM (\ ~(_, skol_info) ->
-                do { (forall_tvs, theta, rho_ty) <- tcInstSkolType skol_info expected_ty
-                        -- Get loation from monad, not from expected_ty
-                   ; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty)
-                   ; return ((forall_tvs, theta, rho_ty), skol_info) })
+        ; ((tvs', theta', rho'), skol_info, scoped_tvs) <- instantiate expected_ty
 
         ; when debugIsOn $
               traceTc (text "tcGen" <+> vcat [
@@ -924,7 +921,11 @@ tcGen expected_ty extra_tvs thing_inside        -- We expect expected_ty to be a
                            text "free_tvs" <+> ppr free_tvs])
 
         -- Type-check the arg and unify with poly type
-        ; (result, lie) <- getLIE (thing_inside tvs' rho')
+        ; (result, lie) <- getLIE $ 
+                          tcExtendTyVarEnv2 (scoped_tvs `zip` mkTyVarTys tvs') $ 
+                               -- Extend the lexical type-variable environment 
+                               -- if we're in a user-type context
+                          thing_inside rho'
 
         -- Check that the "forall_tvs" havn't been constrained
         -- The interesting bit here is that we must include the free variables
@@ -951,6 +952,24 @@ tcGen expected_ty extra_tvs thing_inside        -- We expect expected_ty to be a
         ; return (co_fn, result) }
   where
     free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs
+
+    instantiate :: TcType -> TcM (([TcTyVar],ThetaType,TcRhoType), SkolemInfo, [Name])
+    instantiate expected_ty
+      | Just ctxt <- mb_ctxt
+      = do { let skol_info = SigSkol ctxt
+                tv_names  = map tyVarName (fst (tcSplitForAllTys expected_ty))
+           ; stuff <- tcInstSigType True skol_info expected_ty
+          ; return (stuff, skol_info, tv_names) }
+
+      | otherwise   -- We want the GenSkol info in the skolemised type variables to
+                    -- mention the *instantiated* tyvar names, so that we get a
+                   -- good error message "Rigid variable 'a' is bound by (forall a. a->a)"
+                   -- Hence the tiresome but innocuous fixM
+      = fixM $ \ ~(_, skol_info, _) ->
+        do { stuff@(forall_tvs, theta, rho_ty) <- tcInstSkolType skol_info expected_ty
+                -- Get loation from *monad*, not from expected_ty
+           ; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty)
+           ; return (stuff, skol_info, []) }
 \end{code}