[project @ 2000-01-28 20:52:37 by lewie]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcBinds.lhs
index 51b7301..ec5a592 100644 (file)
@@ -1,76 +1,71 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[TcBinds]{TcBinds}
 
 \begin{code}
-#include "HsVersions.h"
+module TcBinds ( tcBindsAndThen, tcTopBindsAndThen,
+                tcSpecSigs, tcBindWithSigs ) where
 
-module TcBinds (
-       tcTopBindsAndThen, tcLocalBindsAndThen,
-       tcSigs, doSpecPragma
-    ) where
+#include "HsVersions.h"
 
---IMPORT_Trace         -- ToDo:rm (debugging)
+import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun )
+import {-# SOURCE #-} TcExpr  ( tcExpr )
 
-import TcMonad         -- typechecking monad machinery
-import TcMonadFns      ( newLocalsWithOpenTyVarTys,
-                         newLocalsWithPolyTyVarTys,
-                         newSpecPragmaId, newSpecId,
-                         applyTcSubstAndCollectTyVars
+import HsSyn           ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), InPat(..), StmtCtxt(..),
+                         collectMonoBinders, andMonoBindList, andMonoBinds
                        )
-import AbsSyn          -- the stuff being typechecked
+import RnHsSyn         ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
+import TcHsSyn         ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet )
 
-import AbsUniType      ( isTyVarTy, isGroundTy, isUnboxedDataType,
-                         isGroundOrTyVarTy, extractTyVarsFromTy,
-                         UniType
+import TcMonad
+import Inst            ( Inst, LIE, emptyLIE, mkLIE, plusLIE, plusLIEs, InstOrigin(..),
+                         newDicts, tyVarsOfInst, instToId,
+                         getAllFunDepsOfLIE, getIPsOfLIE, zonkFunDeps
                        )
-import BackSubst       ( applyTcSubstToBinds )
-import E
-import Errors          ( topLevelUnboxedDeclErr, specGroundnessErr,
-                         specCtxtGroundnessErr, Error(..), UnifyErrContext(..)
+import TcEnv           ( tcExtendLocalValEnv,
+                         newSpecPragmaId, newLocalId,
+                         tcLookupTyCon, 
+                         tcGetGlobalTyVars, tcExtendGlobalTyVars
                        )
-import GenSpecEtc      ( checkSigTyVars, genBinds, SignatureInfo(..) )
-import Id              ( getIdUniType, mkInstId )
-import IdInfo          ( SpecInfo(..) )
-import Inst
-import LIE             ( nullLIE, mkLIE, plusLIE, LIE )
-import Maybes          ( assocMaybe, catMaybes, Maybe(..) )
-import Spec            ( specTy )
-import TVE             ( nullTVE, TVE(..), UniqFM )
-import TcMonoBnds      ( tcMonoBinds )
-import TcPolyType      ( tcPolyType )
+import TcSimplify      ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
+import TcImprove       ( tcImprove )
+import TcMonoType      ( tcHsType, checkSigTyVars,
+                         TcSigInfo(..), tcTySig, maybeSig, sigCtxt
+                       )
+import TcPat           ( tcPat )
 import TcSimplify      ( bindInstsOfLocalFuns )
-import Unify           ( unifyTauTy )
-import UniqFM          ( emptyUFM ) -- profiling, pragmas only
-import Util
+import TcType          ( TcType, TcThetaType,
+                         TcTyVar,
+                         newTyVarTy, newTyVar, newTyVarTy_OpenKind, tcInstTcType,
+                         zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcTyVarToTyVar
+                       )
+import TcUnify         ( unifyTauTy, unifyTauTyLists )
+
+import PrelInfo                ( main_NAME, ioTyCon_NAME )
+
+import Id              ( Id, mkVanillaId, setInlinePragma )
+import Var             ( idType, idName )
+import IdInfo          ( setInlinePragInfo, InlinePragInfo(..) )
+import Name            ( Name, getName, getOccName, getSrcLoc )
+import NameSet
+import Type            ( mkTyVarTy, tyVarsOfTypes, mkTyConApp,
+                         splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, 
+                         mkPredTy, splitRhoTy, mkForAllTy, isUnLiftedType, 
+                         isUnboxedType, unboxedTypeKind, boxedTypeKind
+                       )
+import FunDeps         ( tyVarFunDep, oclose )
+import Var             ( TyVar, tyVarKind )
+import VarSet
+import Bag
+import Util            ( isIn )
+import Maybes          ( maybeToBool )
+import BasicTypes      ( TopLevelFlag(..), RecFlag(..), isNotTopLevel )
+import FiniteMap       ( listToFM, lookupFM )
+import SrcLoc           ( SrcLoc )
+import Outputable
 \end{code}
 
-%************************************************************************
-%*                                                                     *
-\subsection{Type-checking top-level bindings}
-%*                                                                     *
-%************************************************************************
-
-@tcBindsAndThen@ takes a boolean which indicates whether the binding
-group is at top level or not.  The difference from inner bindings is
-that
-\begin{enumerate}
-\item
-we zero the substitution before each group
-\item
-we back-substitute after each group.
-\end{enumerate}
-We still return an LIE, but it is sure to contain nothing but constant
-dictionaries, which we resolve at the module level.
-
-@tcTopBinds@ returns an LVE, not, as you might expect, a GVE.  Why?
-Because the monomorphism restriction means that is might return some
-monomorphic things, with free type variables.  Hence it must be an LVE.
-
-The LIE returned by @tcTopBinds@ may constrain some type variables,
-but they are guaranteed to be a subset of those free in the
-corresponding returned LVE.
 
 %************************************************************************
 %*                                                                     *
@@ -78,7 +73,7 @@ corresponding returned LVE.
 %*                                                                     *
 %************************************************************************
 
-@tcBindsAndThen@ typechecks a @Binds@.  The "and then" part is because
+@tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
 it needs to know something about the {\em usage} of the things bound,
 so that it can create specialisations of them.  So @tcBindsAndThen@
 takes a function which, given an extended environment, E, typechecks
@@ -89,7 +84,7 @@ specialising the things bound.
 @tcBindsAndThen@ also takes a "combiner" which glues together the
 bindings and the "thing" to make a new "thing".
 
-The real work is done by @tcBindAndThen@.
+The real work is done by @tcBindWithSigsAndThen@.
 
 Recursive and non-recursive binds are handled in essentially the same
 way: because of uniques there are no scoping issues left.  The only
@@ -100,55 +95,86 @@ to the LVE for the following reason.  When each individual binding is
 checked the type of its LHS is unified with that of its RHS; and
 type-checking the LHS of course requires that the binder is in scope.
 
-\begin{code}
-tcBindsAndThen 
-       :: Bool
-       -> E 
-       -> (TypecheckedBinds -> thing -> thing)         -- Combinator
-       -> RenamedBinds
-       -> (E -> TcM (thing, LIE, thing_ty))
-       -> TcM (thing, LIE, thing_ty)
-
-tcBindsAndThen top_level e combiner EmptyBinds do_next
-  = do_next e          `thenTc` \ (thing, lie, thing_ty) ->
-    returnTc (combiner EmptyBinds thing, lie, thing_ty)
-
-tcBindsAndThen top_level e combiner (SingleBind bind) do_next
-  = tcBindAndThen top_level e combiner bind [] do_next
-
-tcBindsAndThen top_level e combiner (BindWith bind sigs) do_next
-  = tcBindAndThen top_level e combiner bind sigs do_next
-
-tcBindsAndThen top_level e combiner (ThenBinds binds1 binds2) do_next
-  = tcBindsAndThen top_level e combiner binds1 new_after
-  where
-    -- new_after :: E -> TcM (thing, LIE, thing_ty)
-    -- Can't write this signature, cos it's monomorphic in thing and
-    -- thing_ty.
-    new_after e = tcBindsAndThen top_level e combiner binds2 do_next
-\end{code}
+At the top-level the LIE is sure to contain nothing but constant
+dictionaries, which we resolve at the module level.
 
-Simple wrappers for export:
 \begin{code}
-tcTopBindsAndThen
-       :: E
-       -> (TypecheckedBinds -> thing -> thing)         -- Combinator
-       -> RenamedBinds 
-       -> (E -> TcM (thing, LIE, anything))
-       -> TcM (thing, LIE, anything)
-
-tcTopBindsAndThen e combiner binds do_next
-  = tcBindsAndThen True e combiner binds do_next
-
-tcLocalBindsAndThen
-       :: E 
-       -> (TypecheckedBinds -> thing -> thing)         -- Combinator
-       -> RenamedBinds 
-       -> (E -> TcM (thing, LIE, thing_ty))
-       -> TcM (thing, LIE, thing_ty)
-
-tcLocalBindsAndThen e combiner binds do_next
-  = tcBindsAndThen False e combiner  binds do_next
+tcTopBindsAndThen, tcBindsAndThen
+       :: (RecFlag -> TcMonoBinds -> thing -> thing)           -- Combinator
+       -> RenamedHsBinds
+       -> TcM s (thing, LIE)
+       -> TcM s (thing, LIE)
+
+tcTopBindsAndThen = tc_binds_and_then TopLevel
+tcBindsAndThen    = tc_binds_and_then NotTopLevel
+
+tc_binds_and_then top_lvl combiner EmptyBinds do_next
+  = do_next
+tc_binds_and_then top_lvl combiner (MonoBind EmptyMonoBinds sigs is_rec) do_next
+  = do_next
+
+tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next
+  = tc_binds_and_then top_lvl combiner b1      $
+    tc_binds_and_then top_lvl combiner b2      $
+    do_next
+
+tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
+  =    -- TYPECHECK THE SIGNATURES
+      mapTc tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenTc` \ tc_ty_sigs ->
+  
+      tcBindWithSigs top_lvl bind tc_ty_sigs
+                    sigs is_rec                        `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
+  
+         -- Extend the environment to bind the new polymorphic Ids
+      tcExtendLocalValEnv [(idName poly_id, poly_id) | poly_id <- poly_ids] $
+  
+         -- Build bindings and IdInfos corresponding to user pragmas
+      tcSpecSigs sigs          `thenTc` \ (prag_binds, prag_lie) ->
+
+       -- Now do whatever happens next, in the augmented envt
+      do_next                  `thenTc` \ (thing, thing_lie) ->
+
+       -- Create specialisations of functions bound here
+       -- We want to keep non-recursive things non-recursive
+       -- so that we desugar unboxed bindings correctly
+      case (top_lvl, is_rec) of
+
+               -- For the top level don't bother will all this bindInstsOfLocalFuns stuff
+               -- All the top level things are rec'd together anyway, so it's fine to
+               -- leave them to the tcSimplifyTop, and quite a bit faster too
+       (TopLevel, _)
+               -> returnTc (combiner Recursive (poly_binds `andMonoBinds` prag_binds) thing,
+                            thing_lie `plusLIE` prag_lie `plusLIE` poly_lie)
+
+       (NotTopLevel, NonRecursive) 
+               -> bindInstsOfLocalFuns 
+                               (thing_lie `plusLIE` prag_lie)
+                               poly_ids                        `thenTc` \ (thing_lie', lie_binds) ->
+
+                  returnTc (
+                       combiner NonRecursive poly_binds $
+                       combiner NonRecursive prag_binds $
+                       combiner Recursive lie_binds  $
+                               -- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns
+                               -- aren't guaranteed in dependency order (though we could change
+                               -- that); hence the Recursive marker.
+                       thing,
+
+                       thing_lie' `plusLIE` poly_lie
+                  )
+
+       (NotTopLevel, Recursive)
+               -> bindInstsOfLocalFuns 
+                               (thing_lie `plusLIE` poly_lie `plusLIE` prag_lie) 
+                               poly_ids                        `thenTc` \ (final_lie, lie_binds) ->
+
+                  returnTc (
+                       combiner Recursive (
+                               poly_binds `andMonoBinds`
+                               lie_binds  `andMonoBinds`
+                               prag_binds) thing,
+                       final_lie
+                  )
 \end{code}
 
 An aside.  The original version of @tcBindsAndThen@ which lacks a
@@ -158,386 +184,770 @@ at a different type to the definition itself.  There aren't too many
 examples of this, which is why I thought it worth preserving! [SLPJ]
 
 \begin{pseudocode}
-tcBindsAndThen 
-       :: Bool -> E -> RenamedBinds
-       -> (E -> TcM (thing, LIE, thing_ty))
-       -> TcM ((TypecheckedBinds, thing), LIE, thing_ty)
-
-tcBindsAndThen top_level e EmptyBinds do_next
-  = do_next e          `thenTc` \ (thing, lie, thing_ty) ->
-    returnTc ((EmptyBinds, thing), lie, thing_ty)
-
-tcBindsAndThen top_level e (SingleBind bind) do_next
-  = tcBindAndThen top_level e bind [] do_next
-
-tcBindsAndThen top_level e (BindWith bind sigs) do_next
-  = tcBindAndThen top_level e bind sigs do_next
-
-tcBindsAndThen top_level e (ThenBinds binds1 binds2) do_next
-  = tcBindsAndThen top_level e binds1 new_after
-       `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
-
-    returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
-
-  where
-    -- new_after :: E -> TcM ((TypecheckedBinds, thing), LIE, thing_ty)
-    -- Can't write this signature, cos it's monomorphic in thing and thing_ty
-    new_after e = tcBindsAndThen top_level e binds2 do_next
+% tcBindsAndThen
+%      :: RenamedHsBinds
+%      -> TcM s (thing, LIE, thing_ty))
+%      -> TcM s ((TcHsBinds, thing), LIE, thing_ty)
+% 
+% tcBindsAndThen EmptyBinds do_next
+%   = do_next          `thenTc` \ (thing, lie, thing_ty) ->
+%     returnTc ((EmptyBinds, thing), lie, thing_ty)
+% 
+% tcBindsAndThen (ThenBinds binds1 binds2) do_next
+%   = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next)
+%      `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
+% 
+%     returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
+% 
+% tcBindsAndThen (MonoBind bind sigs is_rec) do_next
+%   = tcBindAndThen bind sigs do_next
 \end{pseudocode}
 
+
 %************************************************************************
 %*                                                                     *
-\subsection{Bind}
+\subsection{tcBindWithSigs}
 %*                                                                     *
 %************************************************************************
 
+@tcBindWithSigs@ deals with a single binding group.  It does generalisation,
+so all the clever stuff is in here.
+
+* binder_names and mbind must define the same set of Names
+
+* The Names in tc_ty_sigs must be a subset of binder_names
+
+* The Ids in tc_ty_sigs don't necessarily have to have the same name
+  as the Name in the tc_ty_sig
+
 \begin{code}
-tcBindAndThen
-       :: Bool                                           -- At top level
-       -> E 
-       -> (TypecheckedBinds -> thing -> thing)           -- Combinator
-       -> RenamedBind                                    -- The Bind to typecheck
-       -> [RenamedSig]                                   -- ...and its signatures
-       -> (E -> TcM (thing, LIE, thing_ty))              -- Thing to type check in
-                                                         -- augmented envt
-       -> TcM (thing, LIE, thing_ty)                     -- Results, incl the 
-
-tcBindAndThen top_level e combiner bind sigs do_next
-  =    -- Deal with the bind
-    tcBind top_level e bind sigs    `thenTc` \ (poly_binds, poly_lie, poly_lve) ->
+tcBindWithSigs 
+       :: TopLevelFlag
+       -> RenamedMonoBinds
+       -> [TcSigInfo]
+       -> [RenamedSig]         -- Used solely to get INLINE, NOINLINE sigs
+       -> RecFlag
+       -> TcM s (TcMonoBinds, LIE, [TcId])
+
+tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
+  = recoverTc (
+       -- If typechecking the binds fails, then return with each
+       -- signature-less binder given type (forall a.a), to minimise subsequent
+       -- error messages
+       newTyVar boxedTypeKind          `thenNF_Tc` \ alpha_tv ->
+       let
+         forall_a_a    = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
+          binder_names  = map fst (bagToList (collectMonoBinders mbind))
+         poly_ids      = map mk_dummy binder_names
+         mk_dummy name = case maybeSig tc_ty_sigs name of
+                           Just (TySigInfo _ poly_id _ _ _ _ _ _) -> poly_id   -- Signature
+                           Nothing -> mkVanillaId name forall_a_a              -- No signature
+       in
+       returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
+    ) $
+
+       -- TYPECHECK THE BINDINGS
+    tcMonoBinds mbind tc_ty_sigs is_rec                `thenTc` \ (mbind', lie_req, binder_names, mono_ids) ->
+
+       -- CHECK THAT THE SIGNATURES MATCH
+       -- (must do this before getTyVarsToGen)
+    checkSigMatch top_lvl binder_names mono_ids tc_ty_sigs     `thenTc` \ maybe_sig_theta ->   
+
+       -- IMPROVE the LIE
+       -- Force any unifications dictated by functional dependencies.
+       -- Because unification may happen, it's important that this step
+       -- come before:
+       --   - computing vars over which to quantify
+       --   - zonking the generalized type vars
+    tcImprove lie_req `thenTc_`
+
+       -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
+       -- The tyvars_not_to_gen are free in the environment, and hence
+       -- candidates for generalisation, but sometimes the monomorphism
+       -- restriction means we can't generalise them nevertheless
+    let
+       mono_id_tys = map idType mono_ids
+    in
+    getTyVarsToGen is_unrestricted mono_id_tys lie_req `thenNF_Tc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
+
+       -- Finally, zonk the generalised type variables to real TyVars
+       -- This commits any unbound kind variables to boxed kind
+       -- I'm a little worried that such a kind variable might be
+       -- free in the environment, but I don't think it's possible for
+       -- this to happen when the type variable is not free in the envt
+       -- (which it isn't).            SLPJ Nov 98
+    mapTc zonkTcTyVarToTyVar (varSetElems tyvars_to_gen)       `thenTc` \ real_tyvars_to_gen_list ->
+    let
+       real_tyvars_to_gen = mkVarSet real_tyvars_to_gen_list
+               -- It's important that the final list 
+               -- (real_tyvars_to_gen and real_tyvars_to_gen_list) is fully
+               -- zonked, *including boxity*, because they'll be included in the forall types of
+               -- the polymorphic Ids, and instances of these Ids will be generated from them.
+               -- 
+               -- Also NB that tcSimplify takes zonked tyvars as its arg, hence we pass
+               -- real_tyvars_to_gen
+    in
 
-       -- Now do whatever happens next, in the augmented envt
-    do_next (growE_LVE e poly_lve)  `thenTc` \ (thing, thing_lie, thing_ty) ->
+       -- SIMPLIFY THE LIE
+    tcExtendGlobalTyVars tyvars_not_to_gen (
+       let ips = getIPsOfLIE lie_req in
+       if null real_tyvars_to_gen_list && null ips then
+               -- No polymorphism, and no IPs, so no need to simplify context
+           returnTc (lie_req, EmptyMonoBinds, [])
+       else
+       case maybe_sig_theta of
+         Nothing ->
+               -- No signatures, so just simplify the lie
+               -- NB: no signatures => no polymorphic recursion, so no
+               -- need to use lie_avail (which will be empty anyway)
+           tcSimplify (text "tcBinds1" <+> ppr binder_names)
+                      real_tyvars_to_gen lie_req       `thenTc` \ (lie_free, dict_binds, lie_bound) ->
+           returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
+
+         Just (sig_theta, lie_avail) ->
+               -- There are signatures, and their context is sig_theta
+               -- Furthermore, lie_avail is an LIE containing the 'method insts'
+               -- for the things bound here
+
+           zonkTcThetaType sig_theta                   `thenNF_Tc` \ sig_theta' ->
+           newDicts SignatureOrigin sig_theta'         `thenNF_Tc` \ (dicts_sig, dict_ids) ->
+               -- It's important that sig_theta is zonked, because
+               -- dict_id is later used to form the type of the polymorphic thing,
+               -- and forall-types must be zonked so far as their bound variables
+               -- are concerned
+
+           let
+               -- The "givens" is the stuff available.  We get that from
+               -- the context of the type signature, BUT ALSO the lie_avail
+               -- so that polymorphic recursion works right (see comments at end of fn)
+               givens = dicts_sig `plusLIE` lie_avail
+           in
+
+               -- Check that the needed dicts can be expressed in
+               -- terms of the signature ones
+           tcAddErrCtxt  (bindSigsCtxt tysig_names) $
+           tcSimplifyAndCheck
+               (ptext SLIT("type signature for") <+> pprQuotedList binder_names)
+               real_tyvars_to_gen givens lie_req       `thenTc` \ (lie_free, dict_binds) ->
+
+           returnTc (lie_free, dict_binds, dict_ids)
+
+    )                                          `thenTc` \ (lie_free, dict_binds, dicts_bound) ->
+
+       -- GET THE FINAL MONO_ID_TYS
+    zonkTcTypes mono_id_tys                    `thenNF_Tc` \ zonked_mono_id_types ->
+
+
+       -- CHECK FOR BOGUS UNPOINTED BINDINGS
+    (if any isUnLiftedType zonked_mono_id_types then
+               -- Unlifted bindings must be non-recursive,
+               -- not top level, and non-polymorphic
+       checkTc (isNotTopLevel top_lvl)
+               (unliftedBindErr "Top-level" mbind)             `thenTc_`
+       checkTc (case is_rec of {Recursive -> False; NonRecursive -> True})
+               (unliftedBindErr "Recursive" mbind)             `thenTc_`
+       checkTc (null real_tyvars_to_gen_list)
+               (unliftedBindErr "Polymorphic" mbind)
+     else
+       returnTc ()
+    )                                                  `thenTc_`
+
+    ASSERT( not (any ((== unboxedTypeKind) . tyVarKind) real_tyvars_to_gen_list) )
+               -- The instCantBeGeneralised stuff in tcSimplify should have
+               -- already raised an error if we're trying to generalise an 
+               -- unboxed tyvar (NB: unboxed tyvars are always introduced 
+               -- along with a class constraint) and it's better done there 
+               -- because we have more precise origin information.
+               -- That's why we just use an ASSERT here.
+
+
+        -- BUILD THE POLYMORPHIC RESULT IDs
+    mapNF_Tc zonkId mono_ids           `thenNF_Tc` \ zonked_mono_ids ->
     let
-       bound_ids = map snd poly_lve
+       exports  = zipWith mk_export binder_names zonked_mono_ids
+       dict_tys = map idType dicts_bound
+
+       inlines    = mkNameSet [name | InlineSig name _ loc <- inline_sigs]
+        no_inlines = listToFM ([(name, IMustNotBeINLINEd False phase) | NoInlineSig name phase loc <- inline_sigs] ++
+                              [(name, IMustNotBeINLINEd True  phase) | InlineSig   name phase loc <- inline_sigs, maybeToBool phase])
+               -- "INLINE n foo" means inline foo, but not until at least phase n
+               -- "NOINLINE n foo" means don't inline foo until at least phase n, and even 
+               --                  then only if it is small enough etc.
+               -- "NOINLINE foo" means don't inline foo ever, which we signal with a (IMustNotBeINLINEd Nothing)
+               -- See comments in CoreUnfold.blackListed for the Authorised Version
+
+       mk_export binder_name zonked_mono_id
+         = (tyvars, 
+            attachNoInlinePrag no_inlines poly_id,
+            zonked_mono_id)
+         where
+           (tyvars, poly_id) = 
+               case maybeSig tc_ty_sigs binder_name of
+                 Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _ _ _) -> 
+                       (sig_tyvars, sig_poly_id)
+                 Nothing -> (real_tyvars_to_gen_list, new_poly_id)
+
+           new_poly_id = mkVanillaId binder_name poly_ty
+           poly_ty = mkForAllTys real_tyvars_to_gen_list 
+                       $ mkFunTys dict_tys 
+                       $ idType (zonked_mono_id)
+               -- It's important to build a fully-zonked poly_ty, because
+               -- we'll slurp out its free type variables when extending the
+               -- local environment (tcExtendLocalValEnv); if it's not zonked
+               -- it appears to have free tyvars that aren't actually free 
+               -- at all.
+       
+       pat_binders :: [Name]
+       pat_binders = map fst $ bagToList $ collectMonoBinders $ 
+                     (justPatBindings mbind EmptyMonoBinds)
     in
-       -- Create specialisations
-    specialiseBinds bound_ids thing_lie poly_binds poly_lie
-                                   `thenNF_Tc` \ (final_binds, final_lie) ->
-       -- All done
-    returnTc (combiner final_binds thing, final_lie, thing_ty)
+       -- CHECK FOR UNBOXED BINDERS IN PATTERN BINDINGS
+    mapTc (\id -> checkTc (not (idName id `elem` pat_binders
+                               && isUnboxedType (idType id)))
+                         (unboxedPatBindErr id)) zonked_mono_ids
+                               `thenTc_`
+
+        -- BUILD RESULTS
+    returnTc (
+        -- pprTrace "binding.." (ppr ((dicts_bound, dict_binds), exports, [idType poly_id | (_, poly_id, _) <- exports])) $
+        AbsBinds real_tyvars_to_gen_list
+                 dicts_bound
+                 exports
+                 inlines
+                 (dict_binds `andMonoBinds` mbind'),
+        lie_free,
+        [poly_id | (_, poly_id, _) <- exports]
+    )
+  where
+    tysig_names     = [name | (TySigInfo name _ _ _ _ _ _ _) <- tc_ty_sigs]
+    is_unrestricted = isUnRestrictedGroup tysig_names mbind
+
+justPatBindings bind@(PatMonoBind _ _ _) binds = bind `andMonoBinds` binds
+justPatBindings (AndMonoBinds b1 b2) binds = 
+       justPatBindings b1 (justPatBindings b2 binds) 
+justPatBindings other_bind binds = binds
+
+attachNoInlinePrag no_inlines bndr
+  = case lookupFM no_inlines (idName bndr) of
+       Just prag -> bndr `setInlinePragma` prag
+       Nothing   -> bndr
 \end{code}
 
-\begin{code}
-tcBind :: Bool -> E 
-       -> RenamedBind -> [RenamedSig]
-       -> TcM (TypecheckedBinds, LIE, LVE)     -- LIE is a fixed point of substitution
+Polymorphic recursion
+~~~~~~~~~~~~~~~~~~~~~
+The game plan for polymorphic recursion in the code above is 
 
-tcBind False e bind sigs                       -- Not top level
-  = tcBind_help False e bind sigs
+       * Bind any variable for which we have a type signature
+         to an Id with a polymorphic type.  Then when type-checking 
+         the RHSs we'll make a full polymorphic call.
 
-tcBind True  e bind sigs                       -- Top level!
-  = pruneSubstTc (tvOfE e) (
+This fine, but if you aren't a bit careful you end up with a horrendous
+amount of partial application and (worse) a huge space leak. For example:
 
-        -- DO THE WORK
-    tcBind_help True e bind sigs       `thenTc` \ (new_binds, lie, lve) ->
+       f :: Eq a => [a] -> [a]
+       f xs = ...f...
 
-{-  Top-level unboxed values are now allowed
-    They will be lifted by the Desugarer (see CoreLift.lhs)
+If we don't take care, after typechecking we get
 
-       -- CHECK FOR PRIMITIVE TOP-LEVEL BINDS
-       listTc [ checkTc (isUnboxedDataType (getIdUniType id))
-                        (topLevelUnboxedDeclErr id (getSrcLoc id))
-              | (_,id) <- lve ]        `thenTc_`
--}
+       f = /\a -> \d::Eq a -> let f' = f a d
+                              in
+                              \ys:[a] -> ...f'...
 
-    -- Back-substitute over the binds, since we are about to discard
-    -- a good chunk of the substitution.
-    applyTcSubstToBinds new_binds      `thenNF_Tc` \ final_binds ->
+Notice the the stupid construction of (f a d), which is of course
+identical to the function we're executing.  In this case, the
+polymorphic recursion isn't being used (but that's a very common case).
+We'd prefer
 
-    -- The lie is already a fixed point of the substitution; it just turns out
-    -- that almost always this happens automatically, and so we made it part of
-    -- the specification of genBinds.
-    returnTc (final_binds, lie, lve)
-    )
-\end{code}
+       f = /\a -> \d::Eq a -> letrec
+                                fm = \ys:[a] -> ...fm...
+                              in
+                              fm
 
-\begin{code}
-tcBind_help top_level e bind sigs
-  =    -- Create an LVE binding each identifier to an appropriate type variable
-    new_locals binders         `thenNF_Tc` \ bound_ids ->
-    let  lve = binders `zip` bound_ids  in
-
-       -- Now deal with type signatures, if any
-    tcSigs e lve sigs          `thenTc`    \ sig_info ->
-
-       -- Check the bindings: this is the point at which we can use
-       -- error recovery.  If checking the bind fails we just
-       -- return the empty bindings.  The variables will still be in
-       -- scope, but bound to completely free type variables, which
-       -- is just what we want to minimise subsequent error messages.
-    recoverTc (NonRecBind EmptyMonoBinds, nullLIE)
-             (tc_bind (growE_LVE e lve) bind)  `thenNF_Tc` \ (bind', lie) ->
-
-       -- Notice that genBinds gets the old (non-extended) environment
-    genBinds top_level e bind' lie lve sig_info        `thenTc` \ (binds', lie, lve) ->
-
-       -- Add bindings corresponding to SPECIALIZE pragmas in the code
-    mapAndUnzipTc (doSpecPragma e (assoc "doSpecPragma" lve))
-                 (get_spec_pragmas sig_info)
-                       `thenTc` \ (spec_binds_s, spec_lie_s) ->
-
-    returnTc (binds' `ThenBinds` (SingleBind (NonRecBind (
-               foldr AndMonoBinds EmptyMonoBinds spec_binds_s))),
-             lie `plusLIE` (foldr plusLIE nullLIE spec_lie_s),
-             lve)
-  where
-    binders = collectBinders bind
+This can lead to a massive space leak, from the following top-level defn
+(post-typechecking)
 
-    new_locals binders
-      = case bind of
-         NonRecBind _ -> -- Recursive, so no unboxed types
-                         newLocalsWithOpenTyVarTys binders
+       ff :: [Int] -> [Int]
+       ff = f Int dEqInt
 
-         RecBind _    -> -- Non-recursive, so we permit unboxed types
-                         newLocalsWithPolyTyVarTys binders
+Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
+f' is another thunk which evaluates to the same thing... and you end
+up with a chain of identical values all hung onto by the CAF ff.
 
-    get_spec_pragmas sig_info
-      = catMaybes (map get_pragma_maybe sig_info)
-      where
-       get_pragma_maybe s@(ValSpecInfo _ _ _ _) = Just s
-       get_pragma_maybe _                       = Nothing
-\end{code}
+       ff = f Int dEqInt
 
-\begin{verbatim}
-       f :: Ord a => [a] -> b -> b
-       {-# SPECIALIZE f :: [Int] -> b -> b #-}
-\end{verbatim}
-We generate:
-\begin{verbatim}
-       f@Int = /\ b -> let d1 = ...
-                       in f Int b d1
+          = let f' = f Int dEqInt in \ys. ...f'...
 
+          = let f' = let f' = f Int dEqInt in \ys. ...f'...
+                     in \ys. ...f'...
 
-       h :: Ord a => [a] -> b -> b
-       {-# SPECIALIZE h :: [Int] -> b -> b #-}
+Etc.
+Solution: when typechecking the RHSs we always have in hand the
+*monomorphic* Ids for each binding.  So we just need to make sure that
+if (Method f a d) shows up in the constraints emerging from (...f...)
+we just use the monomorphic Id.  We achieve this by adding monomorphic Ids
+to the "givens" when simplifying constraints.  That's what the "lies_avail"
+is doing.
 
-       spec_h = /\b -> h [Int] b dListOfInt
-                       ^^^^^^^^^^^^^^^^^^^^ This bit created by specId
-\end{verbatim}
+
+%************************************************************************
+%*                                                                     *
+\subsection{getTyVarsToGen}
+%*                                                                     *
+%************************************************************************
+
+@getTyVarsToGen@ decides what type variables to generalise over.
+
+For a "restricted group" -- see the monomorphism restriction
+for a definition -- we bind no dictionaries, and
+remove from tyvars_to_gen any constrained type variables
+
+*Don't* simplify dicts at this point, because we aren't going
+to generalise over these dicts.  By the time we do simplify them
+we may well know more.  For example (this actually came up)
+       f :: Array Int Int
+       f x = array ... xs where xs = [1,2,3,4,5]
+We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
+stuff.  If we simplify only at the f-binding (not the xs-binding)
+we'll know that the literals are all Ints, and we can just produce
+Int literals!
+
+Find all the type variables involved in overloading, the
+"constrained_tyvars".  These are the ones we *aren't* going to
+generalise.  We must be careful about doing this:
+
+ (a) If we fail to generalise a tyvar which is not actually
+       constrained, then it will never, ever get bound, and lands
+       up printed out in interface files!  Notorious example:
+               instance Eq a => Eq (Foo a b) where ..
+       Here, b is not constrained, even though it looks as if it is.
+       Another, more common, example is when there's a Method inst in
+       the LIE, whose type might very well involve non-overloaded
+       type variables.
+
+ (b) On the other hand, we mustn't generalise tyvars which are constrained,
+       because we are going to pass on out the unmodified LIE, with those
+       tyvars in it.  They won't be in scope if we've generalised them.
+
+So we are careful, and do a complete simplification just to find the
+constrained tyvars. We don't use any of the results, except to
+find which tyvars are constrained.
 
 \begin{code}
-doSpecPragma :: E
-            -> (Name -> Id)
-            -> SignatureInfo
-            -> TcM (TypecheckedMonoBinds, LIE)
-
-doSpecPragma e name_to_id (ValSpecInfo name spec_ty using src_loc)
-  = let
-       main_id = name_to_id name    -- Get the parent Id
-
-       main_id_ty = getIdUniType main_id
-       main_id_free_tyvars = extractTyVarsFromTy main_id_ty
-       origin = ValSpecOrigin name src_loc
-       err_ctxt = ValSpecSigCtxt name spec_ty src_loc
+getTyVarsToGen is_unrestricted mono_id_tys lie
+  = tcGetGlobalTyVars                  `thenNF_Tc` \ free_tyvars ->
+    zonkTcTypes mono_id_tys            `thenNF_Tc` \ zonked_mono_id_tys ->
+    let
+       body_tyvars = tyVarsOfTypes zonked_mono_id_tys `minusVarSet` free_tyvars
     in
-    addSrcLocTc src_loc                 (
-    specTy origin spec_ty `thenNF_Tc` \ (spec_tyvars, spec_dicts, spec_tau) ->
-
-       -- Check that the SPECIALIZE pragma had an empty context
-    checkTc (not (null spec_dicts))
-           (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
-
-       -- Make an instance of this id
-    specTy origin main_id_ty `thenNF_Tc` \ (main_tyvars, main_dicts, main_tau) ->
-
-       -- Check that the specialised type is indeed an instance of
-       -- the inferred type.
-       -- The unification should leave all type vars which are
-       -- currently free in the environment still free, and likewise
-       -- the signature type vars.
-       -- The only way type vars free in the envt could possibly be affected
-       -- is if main_id_ty has free type variables.  So we just extract them,
-       -- and check that they are not constrained in any way by the unification.
-    applyTcSubstAndCollectTyVars main_id_free_tyvars  `thenNF_Tc` \ free_tyvars' ->
-    unifyTauTy spec_tau main_tau err_ctxt   `thenTc_`
-    checkSigTyVars [] (spec_tyvars ++ free_tyvars')
-                  spec_tau main_tau err_ctxt `thenTc_`
-
-       -- Check that the type variables of the polymorphic function are
-       -- either left polymorphic, or instantiate to ground type.
-       -- Also check that the overloaded type variables are instantiated to
-       -- ground type; or equivalently that all dictionaries have ground type
-    applyTcSubstToTyVars main_tyvars   `thenNF_Tc` \ main_arg_tys ->
-    applyTcSubstToInsts  main_dicts    `thenNF_Tc` \ main_dicts' ->
-
-    checkTc (not (all isGroundOrTyVarTy main_arg_tys))
-           (specGroundnessErr err_ctxt main_arg_tys)
-                                       `thenTc_`
-
-    checkTc (not (and [isGroundTy ty | (_,ty) <- map getDictClassAndType main_dicts']))
-           (specCtxtGroundnessErr err_ctxt main_dicts')
-                                       `thenTc_`
-
-       -- Build a suitable binding; depending on whether we were given
-       -- a value (Maybe Name) to be used as the specialisation.
-    case using of
-      Nothing ->
-
-           -- Make a specPragmaId to which to bind the new call-instance
-       newSpecPragmaId name spec_ty Nothing
-                                       `thenNF_Tc` \ pseudo_spec_id ->
+    if is_unrestricted
+    then
+       let fds = getAllFunDepsOfLIE lie in
+       zonkFunDeps fds         `thenNF_Tc` \ fds' ->
+       let tvFundep = tyVarFunDep fds'
+           extended_tyvars = oclose tvFundep body_tyvars in
+       -- pprTrace "gTVTG" (ppr (lie, body_tyvars, extended_tyvars)) $
+       returnNF_Tc (emptyVarSet, extended_tyvars)
+    else
+       -- This recover and discard-errs is to avoid duplicate error
+       -- messages; this, after all, is an "extra" call to tcSimplify
+       recoverNF_Tc (returnNF_Tc (emptyVarSet, body_tyvars))           $
+       discardErrsTc                                                   $
+
+       tcSimplify (text "getTVG") body_tyvars lie    `thenTc` \ (_, _, constrained_dicts) ->
        let
-           pseudo_bind = VarMonoBind pseudo_spec_id pseudo_rhs
-           pseudo_rhs  = mkTyLam spec_tyvars (mkDictApp (mkTyApp (Var main_id) main_arg_tys)
-                                                        (map mkInstId main_dicts'))
-       in
-       returnTc (pseudo_bind, mkLIE main_dicts')
+         -- ASSERT: dicts_sig is already zonked!
+           constrained_tyvars    = foldrBag (unionVarSet . tyVarsOfInst) emptyVarSet constrained_dicts
+           reduced_tyvars_to_gen = body_tyvars `minusVarSet` constrained_tyvars
+        in
+        returnTc (constrained_tyvars, reduced_tyvars_to_gen)
+\end{code}
 
-      Just spec_name -> -- use spec_name as the specialisation value ...
-       let
-           spec_id      = lookupE_Value e spec_name
-           spec_id_ty   = getIdUniType spec_id
 
-           spec_id_free_tyvars = extractTyVarsFromTy spec_id_ty
-           spec_id_ctxt = ValSpecSpecIdCtxt name spec_ty spec_name src_loc
+\begin{code}
+isUnRestrictedGroup :: [Name]          -- Signatures given for these
+                   -> RenamedMonoBinds
+                   -> Bool
+
+is_elem v vs = isIn "isUnResMono" v vs
+
+isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs
+isUnRestrictedGroup sigs (PatMonoBind other        _ _) = False
+isUnRestrictedGroup sigs (VarMonoBind v _)             = v `is_elem` sigs
+isUnRestrictedGroup sigs (FunMonoBind _ _ _ _)         = True
+isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2)                = isUnRestrictedGroup sigs mb1 &&
+                                                         isUnRestrictedGroup sigs mb2
+isUnRestrictedGroup sigs EmptyMonoBinds                        = True
+\end{code}
+
 
-           spec_tys    = map maybe_ty main_arg_tys
-            maybe_ty ty | isTyVarTy ty = Nothing
-                       | otherwise    = Just ty
+%************************************************************************
+%*                                                                     *
+\subsection{tcMonoBind}
+%*                                                                     *
+%************************************************************************
+
+@tcMonoBinds@ deals with a single @MonoBind@.  
+The signatures have been dealt with already.
+
+\begin{code}
+tcMonoBinds :: RenamedMonoBinds 
+           -> [TcSigInfo]
+           -> RecFlag
+           -> TcM s (TcMonoBinds, 
+                     LIE,              -- LIE required
+                     [Name],           -- Bound names
+                     [TcId])   -- Corresponding monomorphic bound things
+
+tcMonoBinds mbinds tc_ty_sigs is_rec
+  = tc_mb_pats mbinds          `thenTc` \ (complete_it, lie_req_pat, tvs, ids, lie_avail) ->
+    let
+       tv_list           = bagToList tvs
+       id_list           = bagToList ids
+       (names, mono_ids) = unzip id_list
+
+               -- This last defn is the key one:
+               -- extend the val envt with bindings for the 
+               -- things bound in this group, overriding the monomorphic
+               -- ids with the polymorphic ones from the pattern
+       extra_val_env = case is_rec of
+                         Recursive    -> map mk_bind id_list
+                         NonRecursive -> []
+    in
+       -- Don't know how to deal with pattern-bound existentials yet
+    checkTc (isEmptyBag tvs && isEmptyBag lie_avail) 
+           (existentialExplode mbinds)                 `thenTc_` 
+
+       -- *Before* checking the RHSs, but *after* checking *all* the patterns,
+       -- extend the envt with bindings for all the bound ids;
+       --   and *then* override with the polymorphic Ids from the signatures
+       -- That is the whole point of the "complete_it" stuff.
+       --
+       -- There's a further wrinkle: we have to delay extending the environment
+       -- until after we've dealt with any pattern-bound signature type variables
+       -- Consider  f (x::a) = ...f...
+       -- We're going to check that a isn't unified with anything in the envt, 
+       -- so f itself had better not be!  So we pass the envt binding f into
+       -- complete_it, which extends the actual envt in TcMatches.tcMatch, after
+       -- dealing with the signature tyvars
+
+    complete_it extra_val_env                          `thenTc` \ (mbinds', lie_req_rhss) ->
+
+    returnTc (mbinds', lie_req_pat `plusLIE` lie_req_rhss, names, mono_ids)
+  where
+
+       -- This function is used when dealing with a LHS binder; we make a monomorphic
+       -- version of the Id.  We check for type signatures
+    tc_pat_bndr name pat_ty
+       = case maybeSig tc_ty_sigs name of
+           Nothing
+               -> newLocalId (getOccName name) pat_ty (getSrcLoc name)
+
+           Just (TySigInfo _ _ _ _ _ mono_id _ _)
+               -> tcAddSrcLoc (getSrcLoc name)                         $
+                  unifyTauTy (idType mono_id) pat_ty   `thenTc_`
+                  returnTc mono_id
+
+    mk_bind (name, mono_id) = case maybeSig tc_ty_sigs name of
+                               Nothing                                   -> (name, mono_id)
+                               Just (TySigInfo name poly_id _ _ _ _ _ _) -> (name, poly_id)
+
+    tc_mb_pats EmptyMonoBinds
+      = returnTc (\ xve -> returnTc (EmptyMonoBinds, emptyLIE), emptyLIE, emptyBag, emptyBag, emptyLIE)
+
+    tc_mb_pats (AndMonoBinds mb1 mb2)
+      = tc_mb_pats mb1         `thenTc` \ (complete_it1, lie_req1, tvs1, ids1, lie_avail1) ->
+        tc_mb_pats mb2         `thenTc` \ (complete_it2, lie_req2, tvs2, ids2, lie_avail2) ->
+       let
+          complete_it xve = complete_it1 xve   `thenTc` \ (mb1', lie1) ->
+                            complete_it2 xve   `thenTc` \ (mb2', lie2) ->
+                            returnTc (AndMonoBinds mb1' mb2', lie1 `plusLIE` lie2)
        in
-           -- Make an instance of the spec_id
-       specTy origin spec_id_ty `thenNF_Tc` \ (spec_id_tyvars, spec_id_dicts, spec_id_tau) ->
-
-           -- Check that the specialised type is indeed an instance of
-           -- the type inferred for spec_id
-           -- The unification should leave all type vars which are
-           -- currently free in the environment still free, and likewise
-           -- the signature type vars.
-           -- The only way type vars free in the envt could possibly be affected
-           -- is if spec_id_ty has free type variables.  So we just extract them,
-           -- and check that they are not constrained in any way by the unification.
-        applyTcSubstAndCollectTyVars spec_id_free_tyvars  `thenNF_Tc` \ spec_id_free_tyvars' ->
-        unifyTauTy spec_tau spec_id_tau spec_id_ctxt             `thenTc_`
-        checkSigTyVars [] (spec_tyvars ++ spec_id_free_tyvars')
-                      spec_tau spec_id_tau spec_id_ctxt  `thenTc_`
-
-           -- Check that the type variables of the explicit spec_id are
-           -- either left polymorphic, or instantiate to ground type.
-           -- Also check that the overloaded type variables are instantiated to
-           -- ground type; or equivalently that all dictionaries have ground type
-       applyTcSubstToTyVars spec_id_tyvars     `thenNF_Tc` \ spec_id_arg_tys ->
-       applyTcSubstToInsts  spec_id_dicts      `thenNF_Tc` \ spec_id_dicts' ->
-
-       checkTc (not (all isGroundOrTyVarTy spec_id_arg_tys))
-               (specGroundnessErr spec_id_ctxt spec_id_arg_tys)
-                                               `thenTc_`
-
-       checkTc (not (and [isGroundTy ty | (_,ty) <- map getDictClassAndType spec_id_dicts']))
-               (specCtxtGroundnessErr spec_id_ctxt spec_id_dicts')
-                                               `thenTc_`
-
-           -- Make a local SpecId to bind to applied spec_id
-       newSpecId main_id spec_tys spec_ty      `thenNF_Tc` \ local_spec_id ->
-
-           -- Make a specPragmaId id with a spec_info for local_spec_id
-           -- This is bound to local_spec_id
-           -- The SpecInfo will be extracted by the specialiser and
-           -- used to create a call instance for main_id (which is
-           -- extracted from the spec_id)
-           -- NB: the pseudo_local_id must stay in the scope of main_id !!!
+       returnTc (complete_it,
+                 lie_req1 `plusLIE` lie_req2,
+                 tvs1 `unionBags` tvs2,
+                 ids1 `unionBags` ids2,
+                 lie_avail1 `plusLIE` lie_avail2)
+
+    tc_mb_pats (FunMonoBind name inf matches locn)
+      = newTyVarTy boxedTypeKind       `thenNF_Tc` \ bndr_ty ->
+       tc_pat_bndr name bndr_ty        `thenTc` \ bndr_id ->
        let
-           spec_info = SpecInfo spec_tys (length main_dicts') local_spec_id
+          complete_it xve = tcAddSrcLoc locn                           $
+                            tcMatchesFun xve name bndr_ty  matches     `thenTc` \ (matches', lie) ->
+                            returnTc (FunMonoBind bndr_id inf matches' locn, lie)
        in
-       newSpecPragmaId name spec_ty (Just spec_info)   `thenNF_Tc` \ pseudo_spec_id ->
+       returnTc (complete_it, emptyLIE, emptyBag, unitBag (name, bndr_id), emptyLIE)
+
+    tc_mb_pats bind@(PatMonoBind pat grhss locn)
+      = tcAddSrcLoc locn               $
+
+               -- Figure out the appropriate kind for the pattern,
+               -- and generate a suitable type variable 
+       (case is_rec of
+            Recursive    -> newTyVarTy boxedTypeKind   -- Recursive, so no unboxed types
+            NonRecursive -> newTyVarTy_OpenKind        -- Non-recursive, so we permit unboxed types
+       )                                       `thenNF_Tc` \ pat_ty ->
+
+               --      Now typecheck the pattern
+               -- We don't support binding fresh type variables in the
+               -- pattern of a pattern binding.  For example, this is illegal:
+               --      (x::a, y::b) = e
+               -- whereas this is ok
+               --      (x::Int, y::Bool) = e
+               --
+               -- We don't check explicitly for this problem.  Instead, we simply
+               -- type check the pattern with tcPat.  If the pattern mentions any
+               -- fresh tyvars we simply get an out-of-scope type variable error
+       tcPat tc_pat_bndr pat pat_ty            `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
        let
-           spec_bind   = VarMonoBind local_spec_id spec_rhs
-           spec_rhs    = mkTyLam spec_tyvars (mkDictApp (mkTyApp (Var spec_id) spec_id_arg_tys)
-                                                        (map mkInstId spec_id_dicts'))
-           pseudo_bind = VarMonoBind pseudo_spec_id (Var local_spec_id)
+          complete_it xve = tcAddSrcLoc locn                           $
+                            tcAddErrCtxt (patMonoBindsCtxt bind)       $
+                            tcExtendLocalValEnv xve                    $
+                            tcGRHSs grhss pat_ty PatBindRhs            `thenTc` \ (grhss', lie) ->
+                            returnTc (PatMonoBind pat' grhss' locn, lie)
        in
-       returnTc (spec_bind `AndMonoBinds` pseudo_bind, mkLIE spec_id_dicts')
-    )
+       returnTc (complete_it, lie_req, tvs, ids, lie_avail)
 \end{code}
 
-\begin{code}
-tc_bind :: E
-       -> RenamedBind
-       -> TcM (TypecheckedBind, LIE)
+%************************************************************************
+%*                                                                     *
+\subsection{Signatures}
+%*                                                                     *
+%************************************************************************
 
-tc_bind e (NonRecBind mono_binds)
-  = tcMonoBinds e mono_binds   `thenTc` \ (mono_binds2, lie) ->
-    returnTc  (NonRecBind mono_binds2, lie)
+@checkSigMatch@ does the next step in checking signature matching.
+The tau-type part has already been unified.  What we do here is to
+check that this unification has not over-constrained the (polymorphic)
+type variables of the original signature type.
 
-tc_bind e (RecBind mono_binds)
-  = tcMonoBinds e mono_binds   `thenTc` \ (mono_binds2, lie) ->
-    returnTc  (RecBind mono_binds2, lie)
-\end{code}
+The error message here is somewhat unsatisfactory, but it'll do for
+now (ToDo).
 
 \begin{code}
-specialiseBinds
-       :: [Id]                 -- Ids bound in this group
-       -> LIE                  -- LIE of scope of these bindings
-       -> TypecheckedBinds
-       -> LIE
-       -> NF_TcM (TypecheckedBinds, LIE)
-
-specialiseBinds bound_ids lie_of_scope poly_binds poly_lie
-  = bindInstsOfLocalFuns lie_of_scope bound_ids
-                                       `thenNF_Tc` \ (lie2, inst_mbinds) ->
-
-    returnNF_Tc (poly_binds `ThenBinds` (SingleBind (NonRecBind inst_mbinds)),
-                lie2 `plusLIE` poly_lie)
+checkSigMatch top_lvl binder_names mono_ids sigs
+  | main_bound_here
+  =    -- First unify the main_id with IO t, for any old t
+    tcSetErrCtxt mainTyCheckCtxt (
+       tcLookupTyCon ioTyCon_NAME              `thenTc`    \ ioTyCon ->
+       newTyVarTy boxedTypeKind                `thenNF_Tc` \ t_tv ->
+       unifyTauTy ((mkTyConApp ioTyCon [t_tv]))
+                  (idType main_mono_id)
+    )                                          `thenTc_`
+
+       -- Now check the signatures
+       -- Must do this after the unification with IO t, 
+       -- in case of a silly signature like
+       --      main :: forall a. a
+       -- The unification to IO t will bind the type variable 'a',
+       -- which is just waht check_one_sig looks for
+    mapTc check_one_sig sigs                   `thenTc_`
+    mapTc check_main_ctxt sigs                 `thenTc_` 
+
+           returnTc (Just ([], emptyLIE))
+
+  | not (null sigs)
+  = mapTc check_one_sig sigs                   `thenTc_`
+    mapTc check_one_ctxt all_sigs_but_first    `thenTc_`
+    returnTc (Just (theta1, sig_lie))
+
+  | otherwise
+  = returnTc Nothing           -- No constraints from type sigs
+
+  where
+    (TySigInfo _ id1 _ theta1 _ _ _ _ : all_sigs_but_first) = sigs
+
+    sig1_dict_tys      = mk_dict_tys theta1
+    n_sig1_dict_tys    = length sig1_dict_tys
+    sig_lie            = mkLIE [inst | TySigInfo _ _ _ _ _ _ inst _ <- sigs]
+
+    maybe_main        = find_main top_lvl binder_names mono_ids
+    main_bound_here   = maybeToBool maybe_main
+    Just main_mono_id = maybe_main
+                     
+       -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
+       -- Doesn't affect substitution
+    check_one_sig (TySigInfo _ id sig_tyvars _ sig_tau _ _ src_loc)
+      = tcAddSrcLoc src_loc                                    $
+       tcAddErrCtxtM (sigCtxt (sig_msg id) (idType id))        $
+       checkSigTyVars sig_tyvars
+
+
+       -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
+       -- The type signatures on a mutually-recursive group of definitions
+       -- must all have the same context (or none).
+       --
+       -- We unify them because, with polymorphic recursion, their types
+       -- might not otherwise be related.  This is a rather subtle issue.
+       -- ToDo: amplify
+    check_one_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
+       = tcAddSrcLoc src_loc   $
+        tcAddErrCtxt (sigContextsCtxt id1 id) $
+        checkTc (length this_sig_dict_tys == n_sig1_dict_tys)
+                               sigContextsErr          `thenTc_`
+        unifyTauTyLists sig1_dict_tys this_sig_dict_tys
+      where
+        this_sig_dict_tys = mk_dict_tys theta
+
+       -- CHECK THAT FOR A GROUP INVOLVING Main.main, all 
+       -- the signature contexts are empty (what a bore)
+    check_main_ctxt sig@(TySigInfo _ id _ theta _ _ _ src_loc)
+       = tcAddSrcLoc src_loc   $
+         checkTc (null theta) (mainContextsErr id)
+
+    mk_dict_tys theta = map mkPredTy theta
+
+    sig_msg id tidy_ty = sep [ptext SLIT("When checking the type signature"),
+                             nest 4 (ppr id <+> dcolon <+> ppr tidy_ty)]
+
+       -- Search for Main.main in the binder_names, return corresponding mono_id
+    find_main NotTopLevel binder_names mono_ids = Nothing
+    find_main TopLevel    binder_names mono_ids = go binder_names mono_ids
+    go [] [] = Nothing
+    go (n:ns) (m:ms) | n == main_NAME = Just m
+                    | otherwise      = go ns ms
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
-\subsection{Signatures}
+\subsection{SPECIALIZE pragmas}
 %*                                                                     *
 %************************************************************************
 
-@tcSigs@ checks the signatures for validity, and returns a list of
-{\em freshly-instantiated} signatures.  That is, the types are already
-split up, and have fresh type variables (not @TyVarTemplate@s)
-installed.
+@tcSpecSigs@ munches up the specialisation "signatures" that arise through *user*
+pragmas.  It is convenient for them to appear in the @[RenamedSig]@
+part of a binding because then the same machinery can be used for
+moving them into place as is done for type signatures.
 
-\begin{code}
-tcSigs :: E -> LVE
-       -> [RenamedSig] 
-       -> TcM [SignatureInfo]
-
-tcSigs e lve [] = returnTc []
+They look like this:
 
-tcSigs e lve (s:ss)
-  = tc_sig      s      `thenTc` \ sig_info1 ->
-    tcSigs e lve ss    `thenTc` \ sig_info2 ->
-    returnTc (sig_info1 : sig_info2)
-  where
-    tc_sig (Sig v ty _ src_loc)        -- no interesting pragmas on non-iface sigs
-      = addSrcLocTc src_loc (
-
-       babyTcMtoTcM
-         (tcPolyType (getE_CE e) (getE_TCE e) nullTVE ty) `thenTc` \ sigma_ty ->
+\begin{verbatim}
+       f :: Ord a => [a] -> b -> b
+       {-# SPECIALIZE f :: [Int] -> b -> b #-}
+\end{verbatim}
 
-       let  val = assoc "tcSigs" lve v  in
-           -- (The renamer/dependency-analyser should have ensured
-           -- that there are only signatures for which there is a
-           -- corresponding binding.)
+For this we generate:
+\begin{verbatim}
+       f* = /\ b -> let d1 = ...
+                    in f Int b d1
+\end{verbatim}
 
-           -- Instantiate the type, and unify with the type variable
-           -- found in the Id.
-       specTy SignatureOrigin sigma_ty `thenNF_Tc` \ (tyvars, dicts, tau_ty) ->
-       unifyTauTy (getIdUniType val) tau_ty
-                  (panic "ToDo: unifyTauTy(tcSigs)") `thenTc_`
+where f* is a SpecPragmaId.  The **sole** purpose of SpecPragmaIds is to
+retain a right-hand-side that the simplifier will otherwise discard as
+dead code... the simplifier has a flag that tells it not to discard
+SpecPragmaId bindings.
 
-       returnTc (TySigInfo val tyvars dicts tau_ty src_loc)
-       )
+In this case the f* retains a call-instance of the overloaded
+function, f, (including appropriate dictionaries) so that the
+specialiser will subsequently discover that there's a call of @f@ at
+Int, and will create a specialisation for @f@.  After that, the
+binding for @f*@ can be discarded.
 
-    tc_sig (SpecSig v ty using src_loc)
-      = addSrcLocTc src_loc (
+We used to have a form
+       {-# SPECIALISE f :: <type> = g #-}
+which promised that g implemented f at <type>, but we do that with 
+a RULE now:
+       {-# SPECIALISE (f::<type) = g #-}
 
-       babyTcMtoTcM
-         (tcPolyType (getE_CE e) (getE_TCE e) nullTVE ty) `thenTc` \ sigma_ty ->
+\begin{code}
+tcSpecSigs :: [RenamedSig] -> TcM s (TcMonoBinds, LIE)
+tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
+  =    -- SPECIALISE f :: forall b. theta => tau  =  g
+    tcAddSrcLoc src_loc                                $
+    tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
+
+       -- Get and instantiate its alleged specialised type
+    tcHsType poly_ty                           `thenTc` \ sig_ty ->
+
+       -- Check that f has a more general type, and build a RHS for
+       -- the spec-pragma-id at the same time
+    tcExpr (HsVar name) sig_ty                 `thenTc` \ (spec_expr, spec_lie) ->
+
+       -- Squeeze out any Methods (see comments with tcSimplifyToDicts)
+    tcSimplifyToDicts spec_lie                 `thenTc` \ (spec_lie1, spec_binds) ->
+
+       -- Just specialise "f" by building a SpecPragmaId binding
+       -- It is the thing that makes sure we don't prematurely 
+       -- dead-code-eliminate the binding we are really interested in.
+    newSpecPragmaId name sig_ty                `thenNF_Tc` \ spec_id ->
+
+       -- Do the rest and combine
+    tcSpecSigs sigs                    `thenTc` \ (binds_rest, lie_rest) ->
+    returnTc (binds_rest `andMonoBinds` VarMonoBind spec_id (mkHsLet spec_binds spec_expr),
+             lie_rest   `plusLIE`      spec_lie1)
+
+tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
+tcSpecSigs []                = returnTc (EmptyMonoBinds, emptyLIE)
+\end{code}
 
-       returnTc (ValSpecInfo v sigma_ty using src_loc)
-       )
 
-    tc_sig (InlineSig v guide locn)
-      = returnTc (ValInlineInfo v guide locn)
+%************************************************************************
+%*                                                                     *
+\subsection[TcBinds-errors]{Error contexts and messages}
+%*                                                                     *
+%************************************************************************
 
-    tc_sig (DeforestSig v locn)
-      = returnTc (ValDeforestInfo v locn)
 
-    tc_sig (MagicUnfoldingSig v str locn)
-      = returnTc (ValMagicUnfoldingInfo v str locn)
+\begin{code}
+patMonoBindsCtxt bind
+  = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind)
+
+-----------------------------------------------
+valSpecSigCtxt v ty
+  = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
+        nest 4 (ppr v <+> dcolon <+> ppr ty)]
+
+-----------------------------------------------
+notAsPolyAsSigErr sig_tau mono_tyvars
+  = hang (ptext SLIT("A type signature is more polymorphic than the inferred type"))
+       4  (vcat [text "Can't for-all the type variable(s)" <+> 
+                 pprQuotedList mono_tyvars,
+                 text "in the type" <+> quotes (ppr sig_tau)
+          ])
+
+-----------------------------------------------
+badMatchErr sig_ty inferred_ty
+  = hang (ptext SLIT("Type signature doesn't match inferred type"))
+        4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sig_ty),
+                     hang (ptext SLIT("Inferred :")) 4 (ppr inferred_ty)
+          ])
+
+-----------------------------------------------
+unboxedPatBindErr id
+  = ptext SLIT("variable in a lazy pattern binding has unboxed type: ")
+        <+> quotes (ppr id)
+
+-----------------------------------------------
+bindSigsCtxt ids
+  = ptext SLIT("When checking the type signature(s) for") <+> pprQuotedList ids
+
+-----------------------------------------------
+sigContextsErr
+  = ptext SLIT("Mismatched contexts")
+
+sigContextsCtxt s1 s2
+  = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"), 
+               quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)])
+        4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
+
+mainContextsErr id
+  | getName id == main_NAME = ptext SLIT("Main.main cannot be overloaded")
+  | otherwise
+  = quotes (ppr id) <+> ptext SLIT("cannot be overloaded") <> char ',' <> -- sigh; workaround for cpp's inability to deal
+    ptext SLIT("because it is mutually recursive with Main.main")         -- with commas inside SLIT strings.
+
+mainTyCheckCtxt
+  = hsep [ptext SLIT("When checking that"), quotes (ppr main_NAME), 
+         ptext SLIT("has the required type")]
+
+-----------------------------------------------
+unliftedBindErr flavour mbind
+  = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed"))
+        4 (ppr mbind)
+
+existentialExplode mbinds
+  = hang (vcat [text "My brain just exploded.",
+               text "I can't handle pattern bindings for existentially-quantified constructors.",
+               text "In the binding group"])
+       4 (ppr mbinds)
 \end{code}