X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=7a7edb42cfa6a8c0f24c43ee15a4e3a3abd78ee7;hb=f04dead93a15af1cb818172f207b8a81d2c81298;hp=59cd315e0bf703e053856f2b11a09b9c4305c996;hpb=831a35dd00faff195cf938659c2dd736192b865f;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 59cd315..7a7edb4 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -7,7 +7,7 @@
 \begin{code}
 module TcBinds ( tcLocalBinds, tcTopBinds, 
                  tcHsBootSigs, tcMonoBinds, tcPolyBinds,
-                 TcPragFun, tcSpecPrag, tcPrags, mkPragFun, 
+                 TcPragFun, tcPrags, mkPragFun, 
                  TcSigInfo(..), TcSigFun, mkTcSigFun,
                  badBootDeclErr ) where
 
@@ -26,7 +26,6 @@ import TcHsType
 import TcPat
 import TcMType
 import TcType
-import {- Kind parts of -} Type
 import Coercion
 import VarEnv
 import TysPrim
@@ -41,7 +40,6 @@ import Bag
 import ErrUtils
 import Digraph
 import Maybes
-import List
 import Util
 import BasicTypes
 import Outputable
@@ -425,21 +423,24 @@ pragSigCtxt prag = hang (ptext (sLit "In the pragma")) 2 (ppr prag)
 tcPrag :: TcId -> Sig Name -> TcM Prag
 -- Pre-condition: the poly_id is zonked
 -- Reason: required by tcSubExp
-tcPrag poly_id (SpecSig _ hs_ty inl) = tcSpecPrag poly_id hs_ty inl
-tcPrag poly_id (SpecInstSig hs_ty)   = tcSpecPrag poly_id hs_ty defaultInlineSpec
-tcPrag _       (InlineSig _ inl)     = return (InlinePrag inl)
-tcPrag _       sig	             = pprPanic "tcPrag" (ppr sig)
-
-
-tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
-tcSpecPrag poly_id hs_ty inl
+-- Most of the work of specialisation is done by 
+-- the desugarer, guided by the SpecPrag
+tcPrag poly_id (SpecSig _ hs_ty inl) 
   = do  { let name = idName poly_id
         ; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty
         ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty
         ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty inl) }
-        -- Most of the work of specialisation is done by 
-        -- the desugarer, guided by the SpecPrag
-  
+tcPrag poly_id (SpecInstSig hs_ty)
+  = do  { let name = idName poly_id
+        ; (tyvars, theta, tau) <- tcHsInstHead hs_ty	
+        ; let spec_ty = mkSigmaTy tyvars theta tau
+        ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty
+        ; return (SpecPrag (mkHsWrap co_fn (HsVar poly_id)) spec_ty defaultInlineSpec) }
+
+tcPrag _  (InlineSig _ inl) = return (InlinePrag inl)
+tcPrag _  sig	            = pprPanic "tcPrag" (ppr sig)
+
+
 --------------
 -- If typechecking the binds fails, then return with each
 -- signature-less binder given type (forall a.a), to minimise 
@@ -478,7 +479,8 @@ checkStrictBinds top_lvl rec_group mbind mono_tys infos
         -- This should be a checkTc, not a warnTc, but as of GHC 6.11
         -- the versions of alex and happy available have non-conforming
         -- templates, so the GHC build fails if it's an error:
-        ; warnTc (not bang_pat)
+        ; warnUnlifted <- doptM Opt_WarnLazyUnliftedBindings
+        ; warnTc (warnUnlifted && not bang_pat)
                  (unliftedMustBeBang mbind)
         ; mapM_ check_sig infos
         ; return True }
@@ -495,6 +497,7 @@ unliftedMustBeBang :: LHsBindsLR Var Var -> SDoc
 unliftedMustBeBang mbind
   = hang (text "Bindings containing unlifted types must use an outermost bang pattern:")
          4 (pprLHsBinds mbind)
+ $$ text "*** This will be an error in GHC 6.14! Fix your code now!"
 
 strictBindErr :: String -> Bool -> LHsBindsLR Var Var -> SDoc
 strictBindErr flavour unlifted mbind
@@ -734,7 +737,7 @@ generalise :: DynFlags -> TopLevelFlag
 -- The returned [TyVar] are all ready to quantify
 
 generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
-  | isMonoGroup dflags bind_list
+  | isMonoGroup dflags top_lvl bind_list sigs
   = do  { extendLIEs lie_req
         ; return ([], [], emptyBag) }
 
@@ -805,7 +808,8 @@ unifyCtxts :: [TcSigInfo] -> TcM [Inst]
 -- Post-condition: the returned Insts are full zonked
 unifyCtxts [] = panic "unifyCtxts []"
 unifyCtxts (sig1 : sigs)        -- Argument is always non-empty
-  = do  { mapM unify_ctxt sigs
+  = do  { traceTc $ text "unifyCtxts" <+> ppr (sig1 : sigs)
+	; mapM_ unify_ctxt sigs
         ; theta <- zonkTcThetaType (sig_theta sig1)
         ; newDictBndrs (sig_loc sig1) theta }
   where
@@ -864,7 +868,7 @@ checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar]
 
 checkDistinctTyVars sig_tvs
   = do  { zonked_tvs <- mapM zonkSigTyVar sig_tvs
-        ; foldlM check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs)
+        ; foldlM_ check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs)
         ; return zonked_tvs }
   where
     check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar)
@@ -1157,10 +1161,12 @@ tcInstSig use_skols name
                               sig_loc = loc }) }
 
 -------------------
-isMonoGroup :: DynFlags -> [LHsBind Name] -> Bool
+isMonoGroup :: DynFlags -> TopLevelFlag -> [LHsBind Name]
+            -> [TcSigInfo] ->  Bool
 -- No generalisation at all
-isMonoGroup dflags binds
-  = dopt Opt_MonoPatBinds dflags && any is_pat_bind binds
+isMonoGroup dflags top_lvl binds sigs
+  =  (dopt Opt_MonoPatBinds dflags && any is_pat_bind binds)
+  || (dopt Opt_MonoLocalBinds dflags && null sigs && not (isTopLevel top_lvl))
   where
     is_pat_bind (L _ (PatBind {})) = True
     is_pat_bind _                  = False