Trim imports
[ghc-hetmet.git] / ghc / compiler / typecheck / TcBinds.lhs
index c4e1b92..38f4306 100644 (file)
@@ -4,57 +4,68 @@
 \section[TcBinds]{TcBinds}
 
 \begin{code}
 \section[TcBinds]{TcBinds}
 
 \begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBinds, tcHsBootSigs, tcMonoBinds, tcSpecSigs ) where
+module TcBinds ( tcLocalBinds, tcTopBinds, 
+                tcHsBootSigs, tcMonoBinds, 
+                TcPragFun, tcSpecPrag, tcPrags, mkPragFun,
+                TcSigInfo(..),
+                badBootDeclErr ) where
 
 #include "HsVersions.h"
 
 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
 
 #include "HsVersions.h"
 
 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
-import {-# SOURCE #-} TcExpr  ( tcCheckSigma, tcCheckRho )
-
-import CmdLineOpts     ( DynFlag(Opt_MonomorphismRestriction) )
-import HsSyn           ( HsExpr(..), HsBind(..), LHsBinds, Sig(..),
-                         LSig, Match(..), HsBindGroup(..), IPBind(..), 
-                         HsType(..), hsLTyVarNames, isVanillaLSig,
-                         LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds,
+import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
+
+import DynFlags                ( DynFlag(Opt_MonomorphismRestriction, Opt_GlasgowExts) )
+import HsSyn           ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..),
+                         HsLocalBinds(..), HsValBinds(..), HsIPBinds(..),
+                         LSig, Match(..), IPBind(..), Prag(..),
+                         HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames, 
+                         isVanillaLSig, sigName, placeHolderNames, isPragLSig,
+                         LPat, GRHSs, MatchGroup(..), pprLHsBinds, mkHsCoerce,
                          collectHsBindBinders, collectPatBinders, pprPatBind
                        )
                          collectHsBindBinders, collectPatBinders, pprPatBind
                        )
-import TcHsSyn         ( TcId, TcDictBinds, zonkId, mkHsLet )
+import TcHsSyn         ( zonkId )
 
 import TcRnMonad
 
 import TcRnMonad
-import Inst            ( InstOrigin(..), newDictsAtLoc, newIPDict, instToId )
+import Inst            ( newDictsAtLoc, newIPDict, instToId )
 import TcEnv           ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, 
 import TcEnv           ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, 
-                         newLocalName, tcLookupLocalIds, pprBinders,
+                         pprBinders, tcLookupLocalId_maybe, tcLookupId,
                          tcGetGlobalTyVars )
                          tcGetGlobalTyVars )
-import TcUnify         ( Expected(..), tcInfer, unifyTheta, 
+import TcUnify         ( tcInfer, tcSubExp, unifyTheta, 
                          bleatEscapedTvs, sigCtxt )
                          bleatEscapedTvs, sigCtxt )
-import TcSimplify      ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, 
-                         tcSimplifyToDicts, tcSimplifyIPs )
-import TcHsType                ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars,
-                         TcSigInfo(..), TcSigFun, lookupSig
-                       )
+import TcSimplify      ( tcSimplifyInfer, tcSimplifyInferCheck, 
+                         tcSimplifyRestricted, tcSimplifyIPs )
+import TcHsType                ( tcHsSigType, UserTypeCtxt(..) )
 import TcPat           ( tcPat, PatCtxt(..) )
 import TcSimplify      ( bindInstsOfLocalFuns )
 import TcPat           ( tcPat, PatCtxt(..) )
 import TcSimplify      ( bindInstsOfLocalFuns )
-import TcMType         ( newTyFlexiVarTy, zonkQuantifiedTyVar, 
-                         tcInstSigType, zonkTcTypes, zonkTcTyVar )
-import TcType          ( TcTyVar, SkolemInfo(SigSkol), 
-                         TcTauType, TcSigmaType, 
-                         mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType, 
+import TcMType         ( newFlexiTyVarTy, zonkQuantifiedTyVar, zonkSigTyVar,
+                         tcInstSigTyVars, tcInstSkolTyVars, tcInstType, 
+                         zonkTcType, zonkTcTypes, zonkTcTyVars )
+import TcType          ( TcType, TcTyVar, TcThetaType, 
+                         SkolemInfo(SigSkol), UserTypeCtxt(FunSigCtxt), 
+                         TcTauType, TcSigmaType, isUnboxedTupleType,
+                         mkTyVarTy, mkForAllTys, mkFunTys, exactTyVarsOfType, 
                          mkForAllTy, isUnLiftedType, tcGetTyVar, 
                          mkForAllTy, isUnLiftedType, tcGetTyVar, 
-                         mkTyVarTys, tidyOpenTyVar, tidyOpenType )
+                         mkTyVarTys, tidyOpenTyVar )
 import Kind            ( argTypeKind )
 import Kind            ( argTypeKind )
-import VarEnv          ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv, emptyTidyEnv ) 
+import VarEnv          ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv ) 
+import TysWiredIn      ( unitTy )
 import TysPrim         ( alphaTyVar )
 import TysPrim         ( alphaTyVar )
-import Id              ( mkLocalId, mkSpecPragmaId, setInlinePragma )
-import Var             ( idType, idName )
+import Id              ( Id, mkLocalId, mkVanillaGlobal )
+import IdInfo          ( vanillaIdInfo )
+import Var             ( TyVar, idType, idName )
 import Name            ( Name )
 import NameSet
 import Name            ( Name )
 import NameSet
+import NameEnv
 import VarSet
 import VarSet
-import SrcLoc          ( Located(..), unLoc, noLoc, getLoc )
+import SrcLoc          ( Located(..), unLoc, getLoc )
 import Bag
 import Bag
-import Util            ( isIn )
-import BasicTypes      ( TopLevelFlag(..), RecFlag(..), isNonRec, isRec, 
-                         isNotTopLevel, isAlwaysActive )
-import FiniteMap       ( listToFM, lookupFM )
+import ErrUtils                ( Message )
+import Digraph         ( SCC(..), stronglyConnComp )
+import Maybes          ( fromJust, isJust, isNothing, orElse )
+import Util            ( singleton )
+import BasicTypes      ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
+                         RecFlag(..), isNonRec, InlineSpec, defaultInlineSpec )
 import Outputable
 \end{code}
 
 import Outputable
 \end{code}
 
@@ -91,184 +102,246 @@ At the top-level the LIE is sure to contain nothing but constant
 dictionaries, which we resolve at the module level.
 
 \begin{code}
 dictionaries, which we resolve at the module level.
 
 \begin{code}
-tcTopBinds :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv)
+tcTopBinds :: HsValBinds Name -> TcM (LHsBinds TcId, TcLclEnv)
        -- Note: returning the TcLclEnv is more than we really
        --       want.  The bit we care about is the local bindings
        --       and the free type variables thereof
 tcTopBinds binds
        -- Note: returning the TcLclEnv is more than we really
        --       want.  The bit we care about is the local bindings
        --       and the free type variables thereof
 tcTopBinds binds
-  = tc_binds_and_then TopLevel glue binds $
-           do  { env <- getLclEnv
-               ; return (emptyLHsBinds, env) }
-  where
+  = do { (ValBindsOut prs _, env) <- tcValBinds TopLevel binds getLclEnv
+       ; return (foldr (unionBags . snd) emptyBag prs, env) }
        -- The top level bindings are flattened into a giant 
        -- The top level bindings are flattened into a giant 
-       -- implicitly-mutually-recursive MonoBinds
-    glue (HsBindGroup binds1 _ _) (binds2, env) = (binds1 `unionBags` binds2, env)
-    glue (HsIPBinds _)                   _             = panic "Top-level HsIpBinds"
-       -- Can't have a HsIPBinds at top level
+       -- implicitly-mutually-recursive LHsBinds
 
 
-tcHsBootSigs :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv)
+tcHsBootSigs :: HsValBinds Name -> TcM [Id]
 -- A hs-boot file has only one BindGroup, and it only has type
 -- signatures in it.  The renamer checked all this
 -- A hs-boot file has only one BindGroup, and it only has type
 -- signatures in it.  The renamer checked all this
-tcHsBootSigs [HsBindGroup _ sigs _]
-  = do { ids <- mapM (addLocM tc_sig) (filter isVanillaLSig sigs)
-       ; tcExtendIdEnv ids $ do 
-       { env <- getLclEnv
-       ; return (emptyLHsBinds, env) }}
+tcHsBootSigs (ValBindsOut binds sigs)
+  = do { checkTc (null binds) badBootDeclErr
+       ; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) }
   where
   where
-    tc_sig (Sig (L _ name) ty)
+    tc_boot_sig (TypeSig (L _ name) ty)
       = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
       = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
-          ; return (mkLocalId name sigma_ty) }
+          ; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) }
+       -- Notice that we make GlobalIds, not LocalIds
+tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
+
+badBootDeclErr :: Message
+badBootDeclErr = ptext SLIT("Illegal declarations in an hs-boot file")
 
 
-tcBindsAndThen
-       :: (HsBindGroup TcId -> thing -> thing)         -- Combinator
-       -> [HsBindGroup Name]
-       -> TcM thing
-       -> TcM thing
+------------------------
+tcLocalBinds :: HsLocalBinds Name -> TcM thing
+            -> TcM (HsLocalBinds TcId, thing)
 
 
-tcBindsAndThen = tc_binds_and_then NotTopLevel
+tcLocalBinds EmptyLocalBinds thing_inside 
+  = do { thing <- thing_inside
+       ; return (EmptyLocalBinds, thing) }
 
 
-tc_binds_and_then top_lvl combiner [] do_next
-  = do_next
-tc_binds_and_then top_lvl combiner (group : groups) do_next
-  = tc_bind_and_then top_lvl combiner group $ 
-    tc_binds_and_then top_lvl combiner groups do_next
+tcLocalBinds (HsValBinds binds) thing_inside
+  = do { (binds', thing) <- tcValBinds NotTopLevel binds thing_inside
+       ; return (HsValBinds binds', thing) }
 
 
-tc_bind_and_then top_lvl combiner (HsIPBinds binds) do_next
-  = getLIE do_next                             `thenM` \ (result, expr_lie) ->
-    mapAndUnzipM (wrapLocSndM tc_ip_bind) binds        `thenM` \ (avail_ips, binds') ->
+tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
+  = do { (thing, lie) <- getLIE thing_inside
+       ; (avail_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds
 
        -- If the binding binds ?x = E, we  must now 
        -- discharge any ?x constraints in expr_lie
 
        -- If the binding binds ?x = E, we  must now 
        -- discharge any ?x constraints in expr_lie
-    tcSimplifyIPs avail_ips expr_lie   `thenM` \ dict_binds ->
-
-    returnM (combiner (HsIPBinds binds') $
-            combiner (HsBindGroup dict_binds [] Recursive) result)
+       ; dict_binds <- tcSimplifyIPs avail_ips lie
+       ; return (HsIPBinds (IPBinds ip_binds' dict_binds), thing) }
   where
        -- I wonder if we should do these one at at time
        -- Consider     ?x = 4
        --              ?y = ?x + 1
     tc_ip_bind (IPBind ip expr)
   where
        -- I wonder if we should do these one at at time
        -- Consider     ?x = 4
        --              ?y = ?x + 1
     tc_ip_bind (IPBind ip expr)
-      = newTyFlexiVarTy argTypeKind            `thenM` \ ty ->
+      = newFlexiTyVarTy argTypeKind            `thenM` \ ty ->
        newIPDict (IPBindOrigin ip) ip ty       `thenM` \ (ip', ip_inst) ->
        newIPDict (IPBindOrigin ip) ip ty       `thenM` \ (ip', ip_inst) ->
-       tcCheckRho expr ty                      `thenM` \ expr' ->
+       tcMonoExpr expr ty                      `thenM` \ expr' ->
        returnM (ip_inst, (IPBind ip' expr'))
 
        returnM (ip_inst, (IPBind ip' expr'))
 
-tc_bind_and_then top_lvl combiner (HsBindGroup binds sigs is_rec) do_next
-  | isEmptyLHsBinds binds 
-  = do_next
-  | otherwise
- =      -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
-          -- Notice that they scope over 
-          --       a) the type signatures in the binding group
-          --       b) the bindings in the group
-          --       c) the scope of the binding group (the "in" part)
-      tcAddLetBoundTyVars binds  $
-      case top_lvl of
-          TopLevel       -- 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
-               -> tcBindWithSigs top_lvl binds sigs is_rec     `thenM` \ (poly_binds, poly_ids) ->
-                  tc_body poly_ids                             `thenM` \ (prag_binds, thing) ->
-                  returnM (combiner (HsBindGroup
-                                       (poly_binds `unionBags` prag_binds)
-                                        [] -- no sigs
-                                        Recursive)
-                                     thing)
-          NotTopLevel   -- For nested bindings we must do the bindInstsOfLocalFuns thing.
-               | not (isRec is_rec)            -- Non-recursive group
-               ->      -- We want to keep non-recursive things non-recursive
-                        -- so that we desugar unlifted bindings correctly
-                   tcBindWithSigs top_lvl binds sigs is_rec    `thenM` \ (poly_binds, poly_ids) ->
-                    getLIE (tc_body poly_ids)                  `thenM` \ ((prag_binds, thing), lie) ->
-                             -- Create specialisations of functions bound here
-                   bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds ->
-                   returnM (
-                       combiner (HsBindGroup poly_binds [] NonRecursive) $
-                       combiner (HsBindGroup prag_binds [] NonRecursive) $
-                       combiner (HsBindGroup lie_binds  [] Recursive)    $
-                        -- NB: the binds returned by tcSimplify and
-                        -- bindInstsOfLocalFuns aren't guaranteed in
-                        -- dependency order (though we could change that);
-                        -- hence the Recursive marker.
-                        thing)
-
-               | otherwise
-               ->      -- NB: polymorphic recursion means that a function
-                       -- may use an instance of itself, we must look at the LIE arising
-                       -- from the function's own right hand side.  Hence the getLIE
-                       -- encloses the tcBindWithSigs.
-
-                  getLIE (
-                     tcBindWithSigs top_lvl binds sigs is_rec  `thenM` \ (poly_binds, poly_ids) ->
-                     tc_body poly_ids                          `thenM` \ (prag_binds, thing) ->
-                     returnM (poly_ids, poly_binds `unionBags` prag_binds, thing)
-                   )   `thenM` \ ((poly_ids, extra_binds, thing), lie) ->
-                  bindInstsOfLocalFuns lie poly_ids    `thenM` \ lie_binds ->
-
-                   returnM (combiner (HsBindGroup
-                                        (extra_binds `unionBags` lie_binds)
-                                        [] Recursive) thing
-                  )
-  where
-    tc_body poly_ids   -- Type check the pragmas and "thing inside"
-      =   -- Extend the environment to bind the new polymorphic Ids
-         tcExtendIdEnv poly_ids        $
-  
-         -- Build bindings and IdInfos corresponding to user pragmas
-         tcSpecSigs sigs               `thenM` \ prag_binds ->
+------------------------
+tcValBinds :: TopLevelFlag 
+          -> HsValBinds Name -> TcM thing
+          -> TcM (HsValBinds TcId, thing) 
 
 
-         -- Now do whatever happens next, in the augmented envt
-         do_next                       `thenM` \ thing ->
+tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside
+  = pprPanic "tcValBinds" (ppr binds)
 
 
-         returnM (prag_binds, thing)
-\end{code}
+tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
+  = do         {       -- Typecheck the signature
+       ; let { prag_fn = mkPragFun sigs
+             ; ty_sigs = filter isVanillaLSig sigs
+             ; sig_fn  = mkSigFun ty_sigs }
 
 
+       ; poly_ids <- mapM tcTySig ty_sigs
 
 
-%************************************************************************
-%*                                                                     *
-\subsection{tcBindWithSigs}
-%*                                                                     *
-%************************************************************************
+               -- Extend the envt right away with all 
+               -- the Ids declared with type signatures
+       ; (binds', thing) <- tcExtendIdEnv poly_ids $
+                            tc_val_binds top_lvl sig_fn prag_fn 
+                                         binds thing_inside
 
 
-@tcBindWithSigs@ deals with a single binding group.  It does generalisation,
-so all the clever stuff is in here.
+       ; return (ValBindsOut binds' sigs, thing) }
 
 
-* binder_names and mbind must define the same set of Names
+------------------------
+tc_val_binds :: 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
+
+tc_val_binds top_lvl sig_fn prag_fn [] thing_inside
+  = do { thing <- thing_inside
+       ; return ([], thing) }
+
+tc_val_binds top_lvl sig_fn prag_fn (group : groups) thing_inside
+  = do { (group', (groups', thing))
+               <- tc_group top_lvl sig_fn prag_fn group $ 
+                  tc_val_binds top_lvl sig_fn prag_fn groups thing_inside
+       ; return (group' ++ groups', thing) }
 
 
-* The Names in tc_ty_sigs must be a subset of binder_names
+------------------------
+tc_group :: TopLevelFlag -> TcSigFun -> TcPragFun
+        -> (RecFlag, LHsBinds Name) -> TcM thing
+        -> TcM ([(RecFlag, LHsBinds TcId)], thing)
+
+-- Typecheck one strongly-connected component of the original program.
+-- We get a list of groups back, because there may 
+-- be specialisations etc as well
+
+tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
+  =    -- A single non-recursive binding
+       -- We want to keep non-recursive things non-recursive
+        -- so that we desugar unlifted bindings correctly
+    do { (binds, thing) <- tcPolyBinds top_lvl NonRecursive NonRecursive
+                                       sig_fn prag_fn binds thing_inside
+       ; return ([(NonRecursive, b) | b <- binds], thing) }
+
+tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
+  =    -- A recursive strongly-connected component
+       -- To maximise polymorphism (with -fglasgow-exts), we do a new 
+       -- strongly-connected-component analysis, this time omitting 
+       -- any references to variables with type signatures.
+       --
+       -- Then we bring into scope all the variables with type signatures
+    do { traceTc (text "tc_group rec" <+> pprLHsBinds binds)
+       ; gla_exts     <- doptM Opt_GlasgowExts
+       ; (binds,thing) <- if gla_exts 
+                          then go new_sccs
+                          else tc_binds Recursive binds thing_inside
+       ; return ([(Recursive, unionManyBags binds)], thing) }
+               -- Rec them all together
+  where
+    new_sccs :: [SCC (LHsBind Name)]
+    new_sccs = stronglyConnComp (mkEdges sig_fn binds)
 
 
-* The Ids in tc_ty_sigs don't necessarily have to have the same name
-  as the Name in the tc_ty_sig
+--  go :: SCC (LHsBind Name) -> TcM ([LHsBind TcId], thing)
+    go (scc:sccs) = do { (binds1, (binds2, thing)) <- go1 scc (go sccs)
+                       ; return (binds1 ++ binds2, thing) }
+    go []        = do  { thing <- thing_inside; return ([], thing) }
 
 
-\begin{code}
-tcBindWithSigs :: TopLevelFlag
-               -> LHsBinds Name
-               -> [LSig Name]
-               -> RecFlag
-               -> TcM (LHsBinds TcId, [TcId])
-       -- The returned TcIds are guaranteed zonked
-
-tcBindWithSigs top_lvl mbind sigs is_rec = do  
-  {    -- TYPECHECK THE SIGNATURES
-    tc_ty_sigs <- recoverM (returnM []) $
-                 tcTySigs (filter isVanillaLSig sigs)
-  ; let lookup_sig = lookupSig tc_ty_sigs
+    go1 (AcyclicSCC bind) = tc_binds NonRecursive (unitBag bind)
+    go1 (CyclicSCC binds) = tc_binds Recursive    (listToBag binds)
+
+    tc_binds rec_tc binds = tcPolyBinds top_lvl Recursive rec_tc sig_fn prag_fn binds
+
+------------------------
+mkEdges :: TcSigFun -> LHsBinds Name
+       -> [(LHsBind Name, BKey, [BKey])]
+
+type BKey  = Int -- Just number off the bindings
+
+mkEdges sig_fn binds
+  = [ (bind, key, [fromJust mb_key | n <- nameSetToList (bind_fvs (unLoc bind)),
+                                    let mb_key = lookupNameEnv key_map n,
+                                    isJust mb_key,
+                                    no_sig n ])
+    | (bind, key) <- keyd_binds
+    ]
+  where
+    no_sig :: Name -> Bool
+    no_sig n = isNothing (sig_fn n)
+
+    keyd_binds = bagToList binds `zip` [0::BKey ..]
+
+    key_map :: NameEnv BKey    -- Which binding it comes from
+    key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
+                                    , bndr <- bindersOfHsBind bind ]
+
+bindersOfHsBind :: HsBind Name -> [Name]
+bindersOfHsBind (PatBind { pat_lhs = pat })  = collectPatBinders pat
+bindersOfHsBind (FunBind { fun_id = L _ f }) = [f]
 
 
+------------------------
+tcPolyBinds :: TopLevelFlag 
+           -> RecFlag                  -- Whether the group is really recursive
+           -> RecFlag                  -- Whether it's recursive for typechecking purposes
+           -> TcSigFun -> TcPragFun
+           -> LHsBinds Name
+           -> TcM thing
+           -> TcM ([LHsBinds TcId], thing)
+
+-- Typechecks a single bunch of bindings all together, 
+-- and generalises them.  The bunch may be only part of a recursive
+-- group, because we use type signatures to maximise polymorphism
+--
+-- Deals with the bindInstsOfLocalFuns thing too
+--
+-- Returns a list because the input may be a single non-recursive binding,
+-- in which case the dependency order of the resulting bindings is
+-- important.  
+
+tcPolyBinds top_lvl rec_group rec_tc sig_fn prag_fn scc thing_inside
+  =    -- NB: polymorphic recursion means that a function
+       -- may use an instance of itself, we must look at the LIE arising
+       -- from the function's own right hand side.  Hence the getLIE
+       -- encloses the tc_poly_binds. 
+    do { traceTc (text "tcPolyBinds" <+> ppr scc)
+       ; ((binds1, poly_ids, thing), lie) <- getLIE $ 
+               do { (binds1, poly_ids) <- tc_poly_binds top_lvl rec_group rec_tc
+                                                        sig_fn prag_fn scc
+                  ; thing <- tcExtendIdEnv poly_ids thing_inside
+                  ; return (binds1, poly_ids, thing) }
+
+       ; if isTopLevel top_lvl 
+         then          -- 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
+               do { extendLIEs lie; return (binds1, thing) }
+
+         else do       -- Nested case
+               { lie_binds <- bindInstsOfLocalFuns lie poly_ids
+               ; return (binds1 ++ [lie_binds], thing) }}
+
+------------------------
+tc_poly_binds :: TopLevelFlag          -- See comments on tcPolyBinds
+             -> RecFlag -> RecFlag
+             -> TcSigFun -> TcPragFun
+             -> LHsBinds Name
+             -> TcM ([LHsBinds TcId], [TcId])
+-- Typechecks the bindings themselves
+-- Knows nothing about the scope of the bindings
+
+tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds
+  = let 
+        binder_names = collectHsBindBinders binds
+       bind_list    = bagToList binds
+
+       loc = getLoc (head bind_list)
+               -- TODO: location a bit awkward, but the mbinds have been
+               --       dependency analysed and may no longer be adjacent
+    in
        -- SET UP THE MAIN RECOVERY; take advantage of any type sigs
        -- SET UP THE MAIN RECOVERY; take advantage of any type sigs
-  ; recoverM (recoveryCode mbind lookup_sig) $ do
+    setSrcSpan loc                             $
+    recoverM (recoveryCode binder_names)       $ do 
 
 
-  { traceTc (ptext SLIT("--------------------------------------------------------"))
-  ; traceTc (ptext SLIT("Bindings for") <+> ppr (collectHsBindBinders mbind))
+  { traceTc (ptext SLIT("------------------------------------------------"))
+  ; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names)
 
        -- TYPECHECK THE BINDINGS
 
        -- TYPECHECK THE BINDINGS
-  ; ((mbind', mono_bind_infos), lie_req) 
-       <- getLIE (tcMonoBinds mbind lookup_sig is_rec)
+  ; ((binds', mono_bind_infos), lie_req) 
+       <- getLIE (tcMonoBinds bind_list sig_fn rec_tc)
 
        -- CHECK FOR UNLIFTED BINDINGS
        -- These must be non-recursive etc, and are not generalised
 
        -- CHECK FOR UNLIFTED BINDINGS
        -- These must be non-recursive etc, and are not generalised
@@ -276,23 +349,21 @@ tcBindWithSigs top_lvl mbind sigs is_rec = do
   ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos)
   ; if any isUnLiftedType zonked_mono_tys then
     do {       -- Unlifted bindings
   ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos)
   ; if any isUnLiftedType zonked_mono_tys then
     do {       -- Unlifted bindings
-         checkUnliftedBinds top_lvl is_rec mbind
+         checkUnliftedBinds top_lvl rec_group binds' mono_bind_infos
        ; extendLIEs lie_req
        ; let exports  = zipWith mk_export mono_bind_infos zonked_mono_tys
        ; extendLIEs lie_req
        ; let exports  = zipWith mk_export mono_bind_infos zonked_mono_tys
-             mk_export (name, Nothing,  mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id)
-             mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig,             mono_id)
+             mk_export (name, Nothing,  mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, [])
+             mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig,             mono_id, [])
+                       -- ToDo: prags for unlifted bindings
 
 
-       ; return ( unitBag $ noLoc $ AbsBinds [] [] exports emptyNameSet mbind',
-                  [poly_id | (_, poly_id, _) <- exports]) }    -- Guaranteed zonked
+       ; return ( [unitBag $ L loc $ AbsBinds [] [] exports binds'],
+                  [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked
 
     else do    -- The normal lifted case: GENERALISE
 
     else do    -- The normal lifted case: GENERALISE
-  { is_unres <- isUnRestrictedGroup mbind tc_ty_sigs
+  { is_unres <- isUnRestrictedGroup bind_list sig_fn
   ; (tyvars_to_gen, dict_binds, dict_ids)
   ; (tyvars_to_gen, dict_binds, dict_ids)
-       <- setSrcSpan (getLoc (head (bagToList mbind)))     $
-               -- TODO: location a bit awkward, but the mbinds have been
-               --       dependency analysed and may no longer be adjacent
-          addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
-          generalise top_lvl is_unres mono_bind_infos tc_ty_sigs lie_req
+       <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
+          generalise top_lvl is_unres mono_bind_infos lie_req
 
        -- FINALISE THE QUANTIFIED TYPE VARIABLES
        -- The quantified type variables often include meta type variables
 
        -- FINALISE THE QUANTIFIED TYPE VARIABLES
        -- The quantified type variables often include meta type variables
@@ -301,138 +372,118 @@ tcBindWithSigs top_lvl mbind sigs is_rec = do
   ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen
 
        -- BUILD THE POLYMORPHIC RESULT IDs
   ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen
 
        -- BUILD THE POLYMORPHIC RESULT IDs
-  ; let
-       exports  = map mk_export mono_bind_infos
-       poly_ids = [poly_id | (_, poly_id, _) <- exports]
-       dict_tys = map idType dict_ids
-
-       inlines = mkNameSet [ name
-                           | L _ (InlineSig True (L _ name) _) <- sigs]
-                       -- Any INLINE sig (regardless of phase control) 
-                       -- makes the RHS look small
-        inline_phases = listToFM [ (name, phase)
-                                | L _ (InlineSig _ (L _ name) phase) <- sigs, 
-                                  not (isAlwaysActive phase)]
-                       -- Set the IdInfo field to control the inline phase
-                       -- AlwaysActive is the default, so don't bother with them
-       add_inlines id = attachInlinePhase inline_phases id
-
-       mk_export (binder_name, mb_sig, mono_id)
-         = case mb_sig of
-             Just sig -> (sig_tvs sig, add_inlines (sig_id sig),  mono_id)
-             Nothing  -> (tyvars_to_gen', add_inlines new_poly_id, mono_id)
-         where
-           new_poly_id = mkLocalId binder_name poly_ty
-           poly_ty = mkForAllTys tyvars_to_gen'
-                   $ mkFunTys dict_tys 
-                   $ idType mono_id
+  ; exports <- mapM (mkExport prag_fn tyvars_to_gen' (map idType dict_ids))
+                   mono_bind_infos
 
        -- ZONK THE poly_ids, because they are used to extend the type 
        -- environment; see the invariant on TcEnv.tcExtendIdEnv 
 
        -- ZONK THE poly_ids, because they are used to extend the type 
        -- environment; see the invariant on TcEnv.tcExtendIdEnv 
+  ; let        poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
   ; zonked_poly_ids <- mappM zonkId poly_ids
 
   ; zonked_poly_ids <- mappM zonkId poly_ids
 
-  ; traceTc (text "binding:" <+> ppr ((dict_ids, dict_binds),
-                                     exports, map idType zonked_poly_ids))
+  ; traceTc (text "binding:" <+> ppr (zonked_poly_ids `zip` map idType zonked_poly_ids))
 
 
-  ; return (
-           unitBag $ noLoc $
-           AbsBinds tyvars_to_gen'
-                    dict_ids
-                    exports
-                    inlines
-                    (dict_binds `unionBags` mbind'),
-           zonked_poly_ids
-        )
-  } } }
+  ; let abs_bind = L loc $ AbsBinds tyvars_to_gen'
+                                   dict_ids exports
+                                   (dict_binds `unionBags` binds')
 
 
--- If typechecking the binds fails, then return with each
--- signature-less binder given type (forall a.a), to minimise 
--- subsequent error messages
-recoveryCode mbind lookup_sig
-  = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names)
-       ; return (emptyLHsBinds, poly_ids) }
-  where
-    forall_a_a    = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
-    binder_names  = collectHsBindBinders mbind
-    poly_ids      = map mk_dummy binder_names
-    mk_dummy name = case lookup_sig name of
-                     Just sig -> sig_id sig                    -- Signature
-                     Nothing  -> mkLocalId name forall_a_a     -- No signature
-
-attachInlinePhase inline_phases bndr
-  = case lookupFM inline_phases (idName bndr) of
-       Just prag -> bndr `setInlinePragma` prag
-       Nothing   -> bndr
+  ; return ([unitBag abs_bind], zonked_poly_ids)
+  } }
 
 
--- Check that non-overloaded unlifted bindings are
---     a) non-recursive,
---     b) not top level, 
---     c) not a multiple-binding group (more or less implied by (a))
 
 
-checkUnliftedBinds top_lvl is_rec mbind
-  = checkTc (isNotTopLevel top_lvl)
-           (unliftedBindErr "Top-level" mbind)         `thenM_`
-    checkTc (isNonRec is_rec)
-           (unliftedBindErr "Recursive" mbind)         `thenM_`
-    checkTc (isSingletonBag mbind)
-           (unliftedBindErr "Multiple" mbind)
-\end{code}
-
-
-Polymorphic recursion
-~~~~~~~~~~~~~~~~~~~~~
-The game plan for polymorphic recursion in the code above is 
-
-       * 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.
+--------------
+mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo
+        -> TcM ([TyVar], Id, Id, [Prag])
+mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
+  = case mb_sig of
+      Nothing  -> do { prags <- tcPrags poly_id (prag_fn poly_name)
+                    ; return (inferred_tvs, poly_id, mono_id, prags) }
+         where
+           poly_id = mkLocalId poly_name poly_ty
+           poly_ty = mkForAllTys inferred_tvs
+                                      $ mkFunTys dict_tys 
+                                      $ idType mono_id
 
 
-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:
+      Just sig -> do { let poly_id = sig_id sig
+                    ; prags <- tcPrags poly_id (prag_fn poly_name)
+                    ; sig_tys <- zonkTcTyVars (sig_tvs sig)
+                    ; let sig_tvs' = map (tcGetTyVar "mkExport") sig_tys
+                    ; return (sig_tvs', poly_id, mono_id, prags) }
+               -- We zonk the sig_tvs here so that the export triple
+               -- always has zonked type variables; 
+               -- a convenient invariant
 
 
-       f :: Eq a => [a] -> [a]
-       f xs = ...f...
 
 
-If we don't take care, after typechecking we get
+------------------------
+type TcPragFun = Name -> [LSig Name]
 
 
-       f = /\a -> \d::Eq a -> let f' = f a d
-                              in
-                              \ys:[a] -> ...f'...
+mkPragFun :: [LSig Name] -> TcPragFun
+mkPragFun sigs = \n -> lookupNameEnv env n `orElse` []
+       where
+         prs = [(fromJust (sigName sig), sig) | sig <- sigs, isPragLSig sig]
+         env = foldl add emptyNameEnv prs
+         add env (n,p) = extendNameEnv_Acc (:) singleton env n p
 
 
-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
+tcPrags :: Id -> [LSig Name] -> TcM [Prag]
+tcPrags poly_id prags = mapM tc_prag prags
+  where
+    tc_prag (L loc prag) = setSrcSpan loc $ 
+                          addErrCtxt (pragSigCtxt prag) $ 
+                          tcPrag poly_id prag
 
 
-       f = /\a -> \d::Eq a -> letrec
-                                fm = \ys:[a] -> ...fm...
-                              in
-                              fm
+pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag)
 
 
-This can lead to a massive space leak, from the following top-level defn
-(post-typechecking)
+tcPrag :: TcId -> Sig Name -> TcM Prag
+tcPrag poly_id (SpecSig orig_name hs_ty inl) = tcSpecPrag poly_id hs_ty inl
+tcPrag poly_id (SpecInstSig hs_ty)          = tcSpecPrag poly_id hs_ty defaultInlineSpec
+tcPrag poly_id (InlineSig v inl)             = return (InlinePrag inl)
 
 
-       ff :: [Int] -> [Int]
-       ff = f Int dEqInt
 
 
-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.
+tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
+tcSpecPrag poly_id hs_ty inl
+  = do { spec_ty <- tcHsSigType (FunSigCtxt (idName poly_id)) hs_ty
+       ; (co_fn, lie) <- getLIE (tcSubExp (idType poly_id) spec_ty)
+       ; extendLIEs lie
+       ; let const_dicts = map instToId lie
+       ; return (SpecPrag (mkHsCoerce co_fn (HsVar poly_id)) spec_ty const_dicts inl) }
+  
+--------------
+-- If typechecking the binds fails, then return with each
+-- signature-less binder given type (forall a.a), to minimise 
+-- subsequent error messages
+recoveryCode binder_names
+  = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names)
+       ; poly_ids <- mapM mk_dummy binder_names
+       ; return ([], poly_ids) }
+  where
+    mk_dummy name = do { mb_id <- tcLookupLocalId_maybe name
+                       ; case mb_id of
+                             Just id -> return id              -- Had signature, was in envt
+                             Nothing -> return (mkLocalId name forall_a_a) }    -- No signature
 
 
-       ff = f Int dEqInt
+forall_a_a :: TcType
+forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
 
 
-          = let f' = f Int dEqInt in \ys. ...f'...
 
 
-          = let f' = let f' = f Int dEqInt in \ys. ...f'...
-                     in \ys. ...f'...
+-- Check that non-overloaded unlifted bindings are
+--     a) non-recursive,
+--     b) not top level, 
+--     c) not a multiple-binding group (more or less implied by (a))
 
 
-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.
+checkUnliftedBinds :: TopLevelFlag -> RecFlag
+                  -> LHsBinds TcId -> [MonoBindInfo] -> TcM ()
+checkUnliftedBinds top_lvl rec_group mbind infos
+  = do         { checkTc (isNotTopLevel top_lvl)
+                 (unliftedBindErr "Top-level" mbind)
+       ; checkTc (isNonRec rec_group)
+                 (unliftedBindErr "Recursive" mbind)
+       ; checkTc (isSingletonBag mbind)
+                 (unliftedBindErr "Multiple" mbind) 
+       ; mapM_ check_sig infos }
+  where
+    check_sig (_, Just sig, _) = checkTc (null (sig_tvs sig) && null (sig_theta sig))
+                                        (badUnliftedSig sig)
+    check_sig other           = return ()
+\end{code}
 
 
 %************************************************************************
 
 
 %************************************************************************
@@ -441,35 +492,85 @@ is doing.
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 
-@tcMonoBinds@ deals with a single @MonoBind@.  
+@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
 The signatures have been dealt with already.
 
 \begin{code}
 The signatures have been dealt with already.
 
 \begin{code}
-tcMonoBinds :: LHsBinds Name
-           -> TcSigFun -> RecFlag
+tcMonoBinds :: [LHsBind Name]
+           -> TcSigFun
+           -> RecFlag  -- True <=> the binding is recursive for typechecking purposes
+                       --          i.e. the binders are mentioned in their RHSs, and
+                       --               we are not resuced by a type signature
            -> TcM (LHsBinds TcId, [MonoBindInfo])
 
            -> TcM (LHsBinds TcId, [MonoBindInfo])
 
-tcMonoBinds binds lookup_sig is_rec
-  = do { tc_binds <- mapBagM (wrapLocM (tcLhs lookup_sig)) binds
+tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
+                               fun_matches = matches, bind_fvs = fvs })]
+           sig_fn              -- Single function binding,
+           NonRecursive        -- binder isn't mentioned in RHS,
+  | Nothing <- sig_fn name     -- ...with no type signature
+  =    -- In this very special case we infer the type of the
+       -- right hand side first (it may have a higher-rank type)
+       -- and *then* make the monomorphic Id for the LHS
+       -- e.g.         f = \(x::forall a. a->a) -> <body>
+       --      We want to infer a higher-rank type for f
+    setSrcSpan b_loc   $
+    do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name matches)
+
+               -- Check for an unboxed tuple type
+               --      f = (# True, False #)
+               -- Zonk first just in case it's hidden inside a meta type variable
+               -- (This shows up as a (more obscure) kind error 
+               --  in the 'otherwise' case of tcMonoBinds.)
+       ; zonked_rhs_ty <- zonkTcType rhs_ty
+       ; checkTc (not (isUnboxedTupleType zonked_rhs_ty))
+                 (unboxedTupleErr name zonked_rhs_ty)
+
+       ; mono_name <- newLocalName name
+       ; let mono_id = mkLocalId mono_name zonked_rhs_ty
+       ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
+                                             fun_matches = matches', bind_fvs = fvs,
+                                             fun_co_fn = co_fn })),
+                 [(name, Nothing, mono_id)]) }
+
+tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
+                               fun_matches = matches, bind_fvs = fvs })]
+           sig_fn              -- Single function binding
+           non_rec     
+  | Just sig <- sig_fn name    -- ...with a type signature
+  =    -- When we have a single function binding, with a type signature
+       -- we can (a) use genuine, rigid skolem constants for the type variables
+       --        (b) bring (rigid) scoped type variables into scope
+    setSrcSpan b_loc   $
+    do { tc_sig <- tcInstSig True sig
+       ; mono_name <- newLocalName name
+       ; let mono_ty = sig_tau tc_sig
+             mono_id = mkLocalId mono_name mono_ty
+             rhs_tvs = [ (name, mkTyVarTy tv)
+                       | (name, tv) <- sig_scoped tc_sig `zip` sig_tvs tc_sig ]
+
+       ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs    $
+                              tcMatchesFun mono_name matches mono_ty
+
+       ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, 
+                                   fun_infix = inf, fun_matches = matches',
+                                   bind_fvs = placeHolderNames, fun_co_fn = co_fn }
+       ; return (unitBag (L b_loc fun_bind'),
+                 [(name, Just tc_sig, mono_id)]) }
 
 
-       -- Bring (a) the scoped type variables, and (b) the Ids, into scope for the RHSs
-       -- For (a) it's ok to bring them all into scope at once, even
-       -- though each type sig should scope only over its own RHS,
-       -- because the renamer has sorted all that out.
+tcMonoBinds binds sig_fn non_rec
+  = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn)) binds
+
+       -- Bring the monomorphic Ids, into scope for the RHSs
        ; let mono_info  = getMonoBindInfo tc_binds
        ; let mono_info  = getMonoBindInfo tc_binds
-             rhs_tvs    = [ (name, mkTyVarTy tv)
-                          | (_, Just sig, _) <- mono_info, 
-                            (name, tv) <- sig_scoped sig `zip` sig_tvs sig ]
-             rhs_id_env = map mk mono_info     -- A binding for each term variable
-
-       ; binds' <- tcExtendTyVarEnv2 rhs_tvs   $
-                   tcExtendIdEnv2   rhs_id_env $
-                   traceTc (text "tcMonoBinds" <+> vcat [ppr n <+> ppr id <+> ppr (idType id) | (n,id) <- rhs_id_env]) `thenM_`
-                   mapBagM (wrapLocM tcRhs) tc_binds
-       ; return (binds', mono_info) }
-   where
-    mk (name, Just sig, _)       = (name, sig_id sig)  -- Use the type sig if there is one
-    mk (name, Nothing,  mono_id) = (name, mono_id)     -- otherwise use a monomorphic version
+             rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info]
+                               -- A monomorphic binding for each term variable that lacks 
+                               -- a type sig.  (Ones with a sig are already in scope.)
+
+       ; binds' <- tcExtendIdEnv2    rhs_id_env $
+                   traceTc (text "tcMonoBinds" <+> vcat [ ppr n <+> ppr id <+> ppr (idType id) 
+                                                        | (n,id) <- rhs_id_env]) `thenM_`
+                   mapM (wrapLocM tcRhs) tc_binds
+       ; return (listToBag binds', mono_info) }
 
 ------------------------
 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
 
 ------------------------
 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
@@ -502,53 +603,63 @@ getMonoType :: MonoBindInfo -> TcTauType
 getMonoType (_,_,mono_id) = idType mono_id
 
 tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind
 getMonoType (_,_,mono_id) = idType mono_id
 
 tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind
-tcLhs lookup_sig (FunBind (L nm_loc name) inf matches)
-  = do { let mb_sig = lookup_sig name
+tcLhs sig_fn (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
+  = do { mb_sig <- tcInstSig_maybe (sig_fn name)
        ; mono_name <- newLocalName name
        ; mono_ty   <- mk_mono_ty mb_sig
        ; let mono_id = mkLocalId mono_name mono_ty
        ; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) }
   where
     mk_mono_ty (Just sig) = return (sig_tau sig)
        ; mono_name <- newLocalName name
        ; mono_ty   <- mk_mono_ty mb_sig
        ; let mono_id = mkLocalId mono_name mono_ty
        ; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) }
   where
     mk_mono_ty (Just sig) = return (sig_tau sig)
-    mk_mono_ty Nothing    = newTyFlexiVarTy argTypeKind
+    mk_mono_ty Nothing    = newFlexiTyVarTy argTypeKind
+
+tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss })
+  = do { mb_sigs <- mapM (tcInstSig_maybe . sig_fn) names
 
 
-tcLhs lookup_sig bind@(PatBind pat grhss _)
-  = do { let tc_pat exp_ty = tcPat (LetPat lookup_sig) pat exp_ty lookup_infos
-       ; ((pat', ex_tvs, infos), pat_ty) 
-               <- addErrCtxt (patMonoBindsCtxt pat grhss)
-                             (tcInfer tc_pat)
+       ; let nm_sig_prs  = names `zip` mb_sigs
+             tau_sig_env = mkNameEnv [ (name, sig_tau sig) | (name, Just sig) <- nm_sig_prs]
+             sig_tau_fn  = lookupNameEnv tau_sig_env
 
 
-       -- Don't know how to deal with pattern-bound existentials yet
-       ; checkTc (null ex_tvs) (existentialExplode bind)
+             tc_pat exp_ty = tcPat (LetPat sig_tau_fn) pat exp_ty unitTy $ \ _ ->
+                             mapM lookup_info nm_sig_prs
+               -- The unitTy is a bit bogus; it's the "result type" for lookup_info.  
+
+               -- After typechecking the pattern, look up the binder
+               -- names, which the pattern has brought into scope.
+             lookup_info :: (Name, Maybe TcSigInfo) -> TcM MonoBindInfo
+             lookup_info (name, mb_sig) = do { mono_id <- tcLookupId name
+                                             ; return (name, mb_sig, mono_id) }
+
+       ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
+                                    tcInfer tc_pat
 
        ; return (TcPatBind infos pat' grhss pat_ty) }
   where
     names = collectPatBinders pat
 
 
        ; return (TcPatBind infos pat' grhss pat_ty) }
   where
     names = collectPatBinders pat
 
-       -- After typechecking the pattern, look up the binder
-       -- names, which the pattern has brought into scope.
-    lookup_infos :: TcM [MonoBindInfo]
-    lookup_infos = do { mono_ids <- tcLookupLocalIds names
-                     ; return [ (name, lookup_sig name, mono_id)
-                              | (name, mono_id) <- names `zip` mono_ids] }
+
+tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind)
+       -- AbsBind, VarBind impossible
 
 -------------------
 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
 tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches)
 
 -------------------
 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
 tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches)
-  = do { matches' <- tcMatchesFun (idName mono_id) matches 
-                                  (Check (idType mono_id))
-       ; return (FunBind fun' inf matches') }
+  = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) matches 
+                                           (idType mono_id)
+       ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches',
+                           bind_fvs = placeHolderNames, fun_co_fn = co_fn }) }
 
 tcRhs bind@(TcPatBind _ pat' grhss pat_ty)
   = do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
 
 tcRhs bind@(TcPatBind _ pat' grhss pat_ty)
   = do { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
-                   tcGRHSsPat grhss (Check pat_ty)
-       ; return (PatBind pat' grhss' pat_ty) }
+                   tcGRHSsPat grhss pat_ty
+       ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty, 
+                           bind_fvs = placeHolderNames }) }
 
 
 ---------------------
 
 
 ---------------------
-getMonoBindInfo :: Bag (Located TcMonoBind) -> [MonoBindInfo]
+getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
 getMonoBindInfo tc_binds
 getMonoBindInfo tc_binds
-  = foldrBag (get_info . unLoc) [] tc_binds
+  = foldr (get_info . unLoc) [] tc_binds
   where
     get_info (TcFunBind info _ _ _)  rest = info : rest
     get_info (TcPatBind infos _ _ _) rest = infos ++ rest
   where
     get_info (TcFunBind info _ _ _)  rest = info : rest
     get_info (TcPatBind infos _ _ _) rest = infos ++ rest
@@ -557,71 +668,23 @@ getMonoBindInfo tc_binds
 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *
-\subsection{getTyVarsToGen}
+               Generalisation
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 
-Type signatures are tricky.  See Note [Signature skolems] in TcType
-
 \begin{code}
 \begin{code}
-tcTySigs :: [LSig Name] -> TcM [TcSigInfo]
--- The trick here is that all the signatures should have the same
--- context, and we want to share type variables for that context, so that
--- all the right hand sides agree a common vocabulary for their type
--- constraints
-tcTySigs [] = return []
-
-tcTySigs sigs
-  = do { (tc_sig1 : tc_sigs) <- mappM tcTySig sigs
-       ; mapM (check_ctxt tc_sig1) tc_sigs
-        ; return (tc_sig1 : tc_sigs) }
-  where
-       -- Check tha all the signature contexts are the same
-       -- 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.
-    check_ctxt :: TcSigInfo -> TcSigInfo -> TcM ()
-    check_ctxt sig1@(TcSigInfo { sig_theta = theta1 }) sig@(TcSigInfo { sig_theta = theta })
-       = setSrcSpan (instLocSrcSpan (sig_loc sig))     $
-         addErrCtxt (sigContextsCtxt sig1 sig)         $
-         unifyTheta theta1 theta
-
-
-tcTySig :: LSig Name -> TcM TcSigInfo
-tcTySig (L span (Sig (L _ name) ty))
-  = setSrcSpan span            $
-    do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
-       ; (tvs, theta, tau) <- tcInstSigType name sigma_ty
-       ; loc <- getInstLoc (SigOrigin (SigSkol name))
-
-       ; let poly_id = mkLocalId name sigma_ty
-
-               -- The scoped names are the ones explicitly mentioned
-               -- in the HsForAll.  (There may be more in sigma_ty, because
-               -- of nested type synonyms.  See Note [Scoped] with TcSigInfo.)
-             scoped_names = case ty of
-                               L _ (HsForAllTy _ tvs _ _) -> hsLTyVarNames tvs
-                               other                      -> []
-
-       ; return (TcSigInfo { sig_id = poly_id, sig_scoped = scoped_names,
-                             sig_tvs = tvs, sig_theta = theta, sig_tau = tau, 
-                             sig_loc = loc }) }
-\end{code}
-
-\begin{code}
-generalise :: TopLevelFlag -> Bool -> [MonoBindInfo] -> [TcSigInfo] -> [Inst]
+generalise :: TopLevelFlag -> Bool 
+          -> [MonoBindInfo] -> [Inst]
           -> TcM ([TcTyVar], TcDictBinds, [TcId])
           -> TcM ([TcTyVar], TcDictBinds, [TcId])
-generalise top_lvl is_unrestricted mono_infos sigs lie_req
+generalise top_lvl is_unrestricted mono_infos lie_req
   | not is_unrestricted        -- RESTRICTED CASE
   =    -- Check signature contexts are empty 
     do { checkTc (all is_mono_sig sigs)
   | not is_unrestricted        -- RESTRICTED CASE
   =    -- Check signature contexts are empty 
     do { checkTc (all is_mono_sig sigs)
-                 (restrictedBindCtxtErr bndr_names)
+                 (restrictedBindCtxtErr bndrs)
 
        -- Now simplify with exactly that set of tyvars
        -- We have to squash those Methods
 
        -- Now simplify with exactly that set of tyvars
        -- We have to squash those Methods
-       ; (qtvs, binds) <- tcSimplifyRestricted doc top_lvl bndr_names 
+       ; (qtvs, binds) <- tcSimplifyRestricted doc top_lvl bndrs 
                                                tau_tvs lie_req
 
        -- Check that signature type variables are OK
                                                tau_tvs lie_req
 
        -- Check that signature type variables are OK
@@ -633,11 +696,10 @@ generalise top_lvl is_unrestricted mono_infos sigs lie_req
   = tcSimplifyInfer doc tau_tvs lie_req
 
   | otherwise  -- UNRESTRICTED CASE, WITH TYPE SIGS
   = tcSimplifyInfer doc tau_tvs lie_req
 
   | otherwise  -- UNRESTRICTED CASE, WITH TYPE SIGS
-  = do { let sig1 = head sigs
-       ; sig_lie <- newDictsAtLoc (sig_loc sig1) (sig_theta sig1)
+  = do { sig_lie <- unifyCtxts sigs    -- sigs is non-empty
        ; let   -- The "sig_avails" is the stuff available.  We get that from
                -- the context of the type signature, BUT ALSO the lie_avail
        ; let   -- The "sig_avails" 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)
+               -- so that polymorphic recursion works right (see Note [Polymorphic recursion])
                local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos]
                sig_avails = sig_lie ++ local_meths
 
                local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos]
                sig_avails = sig_lie ++ local_meths
 
@@ -649,16 +711,44 @@ generalise top_lvl is_unrestricted mono_infos sigs lie_req
        ; final_qtvs <- checkSigsTyVars forall_tvs sigs
 
        ; returnM (final_qtvs, dict_binds, map instToId sig_lie) }
        ; final_qtvs <- checkSigsTyVars forall_tvs sigs
 
        ; returnM (final_qtvs, dict_binds, map instToId sig_lie) }
-
   where
   where
-    bndr_names = bndrNames mono_infos
-    tau_tvs = foldr (unionVarSet . tyVarsOfType . getMonoType) emptyVarSet mono_infos
+    bndrs   = bndrNames mono_infos
+    sigs    = [sig | (_, Just sig, _) <- mono_infos]
+    tau_tvs = foldr (unionVarSet . exactTyVarsOfType . getMonoType) emptyVarSet mono_infos
+               -- NB: exactTyVarsOfType; see Note [Silly type synonym] 
+               --     near defn of TcType.exactTyVarsOfType
     is_mono_sig sig = null (sig_theta sig)
     is_mono_sig sig = null (sig_theta sig)
-    doc = ptext SLIT("type signature(s) for") <+> pprBinders bndr_names
+    doc = ptext SLIT("type signature(s) for") <+> pprBinders bndrs
 
     mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, 
 
     mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, 
-                           sig_theta = theta, sig_tau = tau, sig_loc = loc }) mono_id
-      = Method mono_id poly_id (mkTyVarTys tvs) theta tau loc
+                           sig_theta = theta, sig_loc = loc }) mono_id
+      = Method mono_id poly_id (mkTyVarTys tvs) theta loc
+\end{code}
+
+unifyCtxts checks that all the signature contexts are the same
+The type signatures on a mutually-recursive group of definitions
+must all have the same context (or none).
+
+The trick here is that all the signatures should have the same
+context, and we want to share type variables for that context, so that
+all the right hand sides agree a common vocabulary for their type
+constraints
+
+We unify them because, with polymorphic recursion, their types
+might not otherwise be related.  This is a rather subtle issue.
+
+\begin{code}
+unifyCtxts :: [TcSigInfo] -> TcM [Inst]
+unifyCtxts (sig1 : sigs)       -- Argument is always non-empty
+  = do { mapM unify_ctxt sigs
+       ; newDictsAtLoc (sig_loc sig1) (sig_theta sig1) }
+  where
+    theta1 = sig_theta sig1
+    unify_ctxt :: TcSigInfo -> TcM ()
+    unify_ctxt sig@(TcSigInfo { sig_theta = theta })
+       = setSrcSpan (instLocSrcSpan (sig_loc sig))     $
+         addErrCtxt (sigContextsCtxt sig1 sig)         $
+         unifyTheta theta1 theta
 
 checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
 checkSigsTyVars qtvs sigs 
 
 checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
 checkSigsTyVars qtvs sigs 
@@ -697,15 +787,10 @@ checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar]
 --     (b) been unified with each other (all distinct)
 
 checkDistinctTyVars sig_tvs
 --     (b) been unified with each other (all distinct)
 
 checkDistinctTyVars sig_tvs
-  = do { zonked_tvs <- mapM zonk_one sig_tvs
+  = do { zonked_tvs <- mapM zonkSigTyVar sig_tvs
        ; foldlM check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs)
        ; return zonked_tvs }
   where
        ; foldlM check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs)
        ; return zonked_tvs }
   where
-    zonk_one sig_tv = do { ty <- zonkTcTyVar sig_tv
-                        ; return (tcGetTyVar "checkDistinctTyVars" ty) }
-       -- 'ty' is bound to be a type variable, because SigSkolTvs
-       -- can only be unified with type variables
-
     check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar)
        -- The TyVarEnv maps each zonked type variable back to its
        -- corresponding user-written signature type variable
     check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar)
        -- The TyVarEnv maps each zonked type variable back to its
        -- corresponding user-written signature type variable
@@ -716,12 +801,14 @@ checkDistinctTyVars sig_tvs
                Nothing -> return (extendVarEnv acc zonked_tv sig_tv)
 
     bomb_out sig_tv1 sig_tv2
                Nothing -> return (extendVarEnv acc zonked_tv sig_tv)
 
     bomb_out sig_tv1 sig_tv2
-       = failWithTc (ptext SLIT("Quantified type variable") <+> quotes (ppr tidy_tv1) 
-                    <+> ptext SLIT("is unified with another quantified type variable") 
-                    <+> ppr tidy_tv2)
+       = do { env0 <- tcInitTidyEnv
+           ; let (env1, tidy_tv1) = tidyOpenTyVar env0 sig_tv1
+                 (env2, tidy_tv2) = tidyOpenTyVar env1 sig_tv2
+                 msg = ptext SLIT("Quantified type variable") <+> quotes (ppr tidy_tv1) 
+                        <+> ptext SLIT("is unified with another quantified type variable") 
+                        <+> quotes (ppr tidy_tv2)
+           ; failWithTcM (env2, msg) }
        where
        where
-        (env1,  tidy_tv1) = tidyOpenTyVar emptyTidyEnv sig_tv1
-        (_env2, tidy_tv2) = tidyOpenTyVar env1         sig_tv2
 \end{code}    
 
 
 \end{code}    
 
 
@@ -764,104 +851,213 @@ 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.
 
 constrained tyvars. We don't use any of the results, except to
 find which tyvars are constrained.
 
-\begin{code}
-isUnRestrictedGroup :: LHsBinds Name -> [TcSigInfo] -> TcM Bool
-isUnRestrictedGroup binds sigs
-  = do { mono_restriction <- doptM Opt_MonomorphismRestriction
-       ; return (not mono_restriction || all_unrestricted) }
-  where 
-    all_unrestricted = all (unrestricted . unLoc) (bagToList binds)
-    tysig_names      = map (idName . sig_id) sigs
+Note [Polymorphic recursion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The game plan for polymorphic recursion in the code above is 
 
 
-    unrestricted (PatBind other _ _)   = False
-    unrestricted (VarBind v _)        = v `is_elem` tysig_names
-    unrestricted (FunBind v _ matches) = unrestricted_match matches 
-                                        || unLoc v `is_elem` tysig_names
+       * 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.
 
 
-    unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False
-       -- No args => like a pattern binding
-    unrestricted_match other             = True
-       -- Some args => a function binding
+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:
+
+       f :: Eq a => [a] -> [a]
+       f xs = ...f...
+
+If we don't take care, after typechecking we get
+
+       f = /\a -> \d::Eq a -> let f' = f a d
+                              in
+                              \ys:[a] -> ...f'...
+
+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).
+This can lead to a massive space leak, from the following top-level defn
+(post-typechecking)
+
+       ff :: [Int] -> [Int]
+       ff = f Int dEqInt
+
+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.
+
+       ff = f Int dEqInt
+
+          = let f' = f Int dEqInt in \ys. ...f'...
+
+          = let f' = let f' = f Int dEqInt in \ys. ...f'...
+                     in \ys. ...f'...
+
+Etc.
+
+NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
+which would make the space leak go away in this case
+
+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.
+
+Then we get
+
+       f = /\a -> \d::Eq a -> letrec
+                                fm = \ys:[a] -> ...fm...
+                              in
+                              fm
 
 
-is_elem v vs = isIn "isUnResMono" v vs
-\end{code}
 
 
 %************************************************************************
 %*                                                                     *
 
 
 %************************************************************************
 %*                                                                     *
-\subsection{SPECIALIZE pragmas}
+               Signatures
 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 
-@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.
-
-They look like this:
-
-\begin{verbatim}
-       f :: Ord a => [a] -> b -> b
-       {-# SPECIALIZE f :: [Int] -> b -> b #-}
-\end{verbatim}
-
-For this we generate:
-\begin{verbatim}
-       f* = /\ b -> let d1 = ...
-                    in f Int b d1
-\end{verbatim}
-
-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.
-
-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.
-
-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:
-       {-# RULES (f::<type>) = g #-}
+Type signatures are tricky.  See Note [Signature skolems] in TcType
+
+@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 installed.  All non-type-signature
+"RenamedSigs" are ignored.
+
+The @TcSigInfo@ contains @TcTypes@ because they are unified with
+the variable's type, and after that checked to see whether they've
+been instantiated.
 
 \begin{code}
 
 \begin{code}
-tcSpecSigs :: [LSig Name] -> TcM (LHsBinds TcId)
-tcSpecSigs (L loc (SpecSig (L nm_loc name) poly_ty) : sigs)
-  =    -- SPECIALISE f :: forall b. theta => tau  =  g
-    setSrcSpan loc                             $
-    addErrCtxt (valSpecSigCtxt name poly_ty)   $
-
-       -- Get and instantiate its alleged specialised type
-    tcHsSigType (FunSigCtxt name) poly_ty      `thenM` \ sig_ty ->
-
-       -- Check that f has a more general type, and build a RHS for
-       -- the spec-pragma-id at the same time
-    getLIE (tcCheckSigma (L nm_loc (HsVar name)) sig_ty)       `thenM` \ (spec_expr, spec_lie) ->
-
-       -- Squeeze out any Methods (see comments with tcSimplifyToDicts)
-    tcSimplifyToDicts spec_lie                 `thenM` \ 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.
-    newLocalName name                  `thenM` \ spec_name ->
-    let
-       spec_bind = VarBind (mkSpecPragmaId spec_name sig_ty)
-                               (mkHsLet spec_binds spec_expr)
-    in
+type TcSigFun = Name -> Maybe (LSig Name)
+
+mkSigFun :: [LSig Name] -> TcSigFun
+-- Search for a particular type signature
+-- Precondition: the sigs are all type sigs
+-- Precondition: no duplicates
+mkSigFun sigs = lookupNameEnv env
+  where
+    env = mkNameEnv [(fromJust (sigName sig), sig) | sig <- sigs]
+
+---------------
+data TcSigInfo
+  = TcSigInfo {
+       sig_id     :: TcId,             --  *Polymorphic* binder for this value...
+
+       sig_scoped :: [Name],           -- Names for any scoped type variables
+                                       -- Invariant: correspond 1-1 with an initial
+                                       -- segment of sig_tvs (see Note [Scoped])
+
+       sig_tvs    :: [TcTyVar],        -- Instantiated type variables
+                                       -- See Note [Instantiate sig]
+
+       sig_theta  :: TcThetaType,      -- Instantiated theta
+       sig_tau    :: TcTauType,        -- Instantiated tau
+       sig_loc    :: InstLoc           -- The location of the signature
+    }
+
+--     Note [Scoped]
+-- There may be more instantiated type variables than scoped 
+-- ones.  For example:
+--     type T a = forall b. b -> (a,b)
+--     f :: forall c. T c
+-- Here, the signature for f will have one scoped type variable, c,
+-- but two instantiated type variables, c' and b'.  
+--
+-- We assume that the scoped ones are at the *front* of sig_tvs,
+-- and remember the names from the original HsForAllTy in sig_scoped
+
+--     Note [Instantiate sig]
+-- It's vital to instantiate a type signature with fresh variable.
+-- For example:
+--     type S = forall a. a->a
+--     f,g :: S
+--     f = ...
+--     g = ...
+-- Here, we must use distinct type variables when checking f,g's right hand sides.
+-- (Instantiation is only necessary because of type synonyms.  Otherwise,
+-- it's all cool; each signature has distinct type variables from the renamer.)
+
+instance Outputable TcSigInfo where
+    ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau})
+       = ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau
+\end{code}
+
+\begin{code}
+tcTySig :: LSig Name -> TcM TcId
+tcTySig (L span (TypeSig (L _ name) ty))
+  = setSrcSpan span            $
+    do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
+       ; return (mkLocalId name sigma_ty) }
+
+-------------------
+tcInstSig_maybe :: Maybe (LSig Name) -> TcM (Maybe TcSigInfo)
+-- Instantiate with *meta* type variables; 
+-- this signature is part of a multi-signature group
+tcInstSig_maybe Nothing    = return Nothing
+tcInstSig_maybe (Just sig) = do { tc_sig <- tcInstSig False sig
+                               ; return (Just tc_sig) }
+
+tcInstSig :: Bool -> LSig Name -> TcM TcSigInfo
+-- Instantiate the signature, with either skolems or meta-type variables
+-- depending on the use_skols boolean
+--
+-- We always instantiate with freshs uniques,
+-- although we keep the same print-name
+--     
+--     type T = forall a. [a] -> [a]
+--     f :: T; 
+--     f = g where { g :: T; g = <rhs> }
+--
+-- We must not use the same 'a' from the defn of T at both places!!
+
+tcInstSig use_skols (L loc (TypeSig (L _ name) hs_ty))
+  = setSrcSpan loc $
+    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 | use_skols = tcInstSkolTyVars skol_info
+                         | otherwise = tcInstSigTyVars  skol_info
+       ; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id)
+       ; loc <- getInstLoc (SigOrigin skol_info)
+       ; return (TcSigInfo { sig_id = poly_id,
+                             sig_tvs = tvs, sig_theta = theta, sig_tau = tau, 
+                             sig_scoped = scoped_names, sig_loc = loc }) }
+               -- Note that the scoped_names and the sig_tvs will have
+               -- different Names. That's quite ok; when we bring the 
+               -- scoped_names into scope, we just bind them to the sig_tvs
+  where
+       -- The scoped names are the ones explicitly mentioned
+       -- in the HsForAll.  (There may be more in sigma_ty, because
+       -- of nested type synonyms.  See Note [Scoped] with TcSigInfo.)
+       -- We also only have scoped type variables when we are instantiating
+       -- with true skolems
+    scoped_names = case (use_skols, hs_ty) of
+                    (True, L _ (HsForAllTy Explicit tvs _ _)) -> hsLTyVarNames tvs
+                    other                                     -> []
 
 
-       -- Do the rest and combine
-    tcSpecSigs sigs                    `thenM` \ binds_rest ->
-    returnM (binds_rest `snocBag` L loc spec_bind)
+-------------------
+isUnRestrictedGroup :: [LHsBind Name] -> TcSigFun -> TcM Bool
+isUnRestrictedGroup binds sig_fn
+  = do { mono_restriction <- doptM Opt_MonomorphismRestriction
+       ; return (not mono_restriction || all_unrestricted) }
+  where 
+    all_unrestricted = all (unrestricted . unLoc) binds
+    has_sig n = isJust (sig_fn n)
+
+    unrestricted (PatBind {})                                           = False
+    unrestricted (VarBind { var_id = v })                       = has_sig v
+    unrestricted (FunBind { fun_id = v, fun_matches = matches }) = unrestricted_match matches 
+                                                                || has_sig (unLoc v)
 
 
-tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs
-tcSpecSigs []                = returnM emptyLHsBinds
+    unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False
+       -- No args => like a pattern binding
+    unrestricted_match other             = True
+       -- Some args => a function binding
 \end{code}
 
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
 \subsection[TcBinds-errors]{Error contexts and messages}
 %************************************************************************
 %*                                                                     *
 \subsection[TcBinds-errors]{Error contexts and messages}
@@ -876,11 +1072,6 @@ patMonoBindsCtxt pat grhss
   = hang (ptext SLIT("In a pattern binding:")) 4 (pprPatBind pat grhss)
 
 -----------------------------------------------
   = hang (ptext SLIT("In a pattern binding:")) 4 (pprPatBind pat grhss)
 
 -----------------------------------------------
-valSpecSigCtxt v ty
-  = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
-        nest 4 (ppr v <+> dcolon <+> ppr ty)]
-
------------------------------------------------
 sigContextsCtxt sig1 sig2
   = vcat [ptext SLIT("When matching the contexts of the signatures for"), 
          nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
 sigContextsCtxt sig1 sig2
   = vcat [ptext SLIT("When matching the contexts of the signatures for"), 
          nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
@@ -896,12 +1087,14 @@ unliftedBindErr flavour mbind
   = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:"))
         4 (ppr mbind)
 
   = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:"))
         4 (ppr mbind)
 
+badUnliftedSig sig
+  = hang (ptext SLIT("Illegal polymorphic signature in an unlifted binding"))
+        4 (ppr sig)
+
 -----------------------------------------------
 -----------------------------------------------
-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)
+unboxedTupleErr name ty
+  = hang (ptext SLIT("Illegal binding of unboxed tuple"))
+        4 (ppr name <+> dcolon <+> ppr ty)
 
 -----------------------------------------------
 restrictedBindCtxtErr binder_names
 
 -----------------------------------------------
 restrictedBindCtxtErr binder_names