From: simonpj <unknown>
Date: Thu, 27 Oct 2005 14:35:21 +0000 (+0000)
Subject: [project @ 2005-10-27 14:35:20 by simonpj]
X-Git-Tag: Initial_conversion_from_CVS_complete~112
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=958924a2b338aebbcc8a88ba2cab511517762a19

[project @ 2005-10-27 14:35:20 by simonpj]
Add a new pragma: SPECIALISE INLINE

This amounts to adding an INLINE pragma to the specialised version
of the function.  You can add phase stuff too (SPECIALISE INLINE [2]),
and NOINLINE instead of INLINE.

The reason for doing this is to support inlining of type-directed
recursive functions.  The main example is this:

  -- non-uniform array type
  data Arr e where
    ArrInt  :: !Int -> ByteArray#       -> Arr Int
    ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)

  (!:) :: Arr e -> Int -> e
  {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}
  {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}
  ArrInt  _ ba    !: (I# i) = I# (indexIntArray# ba i)
  ArrPair _ a1 a2 !: i      = (a1 !: i, a2 !: i)

If we use (!:) at a particular array type, we want to inline (:!),
which is recursive, until all the type specialisation is done.


On the way I did a bit of renaming and tidying of the way that
pragmas are carried, so quite a lot of files are touched in a
fairly trivial way.
---

diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs
index 4497bfd..2cdf5ad 100644
--- a/ghc/compiler/basicTypes/BasicTypes.lhs
+++ b/ghc/compiler/basicTypes/BasicTypes.lhs
@@ -48,6 +48,7 @@ module BasicTypes(
 
 	CompilerPhase, 
 	Activation(..), isActive, isNeverActive, isAlwaysActive,
+	InlineSpec(..), defaultInlineSpec, alwaysInlineSpec,
 
 	SuccessFlag(..), succeeded, failed, successIf
    ) where
@@ -466,12 +467,26 @@ data Activation = NeverActive
 		| ActiveAfter CompilerPhase	-- Active in this phase and later
 		deriving( Eq )			-- Eq used in comparing rules in HsDecls
 
+data InlineSpec
+  = Inline 
+	Activation	-- Says during which phases inlining is allowed
+	Bool 		-- True <=> make the RHS look small, so that when inlining
+			--	    is enabled, it will definitely actually happen
+  deriving( Eq )
+
+defaultInlineSpec = Inline AlwaysActive False	-- Inlining is OK, but not forced
+alwaysInlineSpec  = Inline AlwaysActive True	-- Inline unconditionally
+
 instance Outputable Activation where
    ppr AlwaysActive     = empty		-- The default
    ppr (ActiveBefore n) = brackets (char '~' <> int n)
    ppr (ActiveAfter n)  = brackets (int n)
    ppr NeverActive      = ptext SLIT("NEVER")
     
+instance Outputable InlineSpec where
+   ppr (Inline act True)  = ptext SLIT("INLINE") <> ppr act
+   ppr (Inline act False) = ptext SLIT("NOINLINE") <> ppr act
+
 isActive :: CompilerPhase -> Activation -> Bool
 isActive p NeverActive      = False
 isActive p AlwaysActive     = True
diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index 5be1774..70980f9 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -28,9 +28,9 @@ import StaticFlags	( opt_AutoSccsOnAllToplevs,
 			  opt_AutoSccsOnExportedToplevs )
 import OccurAnal	( occurAnalyseExpr )
 import CostCentre	( mkAutoCC, IsCafCC(..) )
-import Id		( Id, idType, idName, isExportedId, mkLocalId, setInlinePragma )
+import Id		( Id, DictId, idType, idName, isExportedId, mkLocalId, setInlinePragma )
 import Rules		( addIdSpecialisations, mkLocalRule )
-import Var		( Var, isGlobalId, setIdNotExported )
+import Var		( TyVar, Var, isGlobalId, setIdNotExported )
 import VarEnv
 import Type		( mkTyVarTy, substTyWith )
 import TysWiredIn	( voidTy )
@@ -38,7 +38,7 @@ import Outputable
 import SrcLoc		( Located(..) )
 import Maybes		( isJust, catMaybes, orElse )
 import Bag		( bagToList )
-import BasicTypes	( Activation(..), isAlwaysActive )
+import BasicTypes	( Activation(..), InlineSpec(..), isAlwaysActive, defaultInlineSpec )
 import Monad		( foldM )
 import FastString	( mkFastString )
 import List		( (\\) )
@@ -117,7 +117,6 @@ dsHsBind auto_scc rest
 	-- Always treat the binds as recursive, because the typechecker
 	-- makes rather mixed-up dictionary bindings
 	core_bind = Rec core_prs
-	inline_env = mkVarEnv [(global, prag) | prag <- prags, isInlinePrag prag]
     in
     mappM (dsSpec all_tyvars dicts tyvars global local core_bind) 
 	  prags				`thenDs` \ mb_specs ->
@@ -125,8 +124,11 @@ dsHsBind auto_scc rest
 	(spec_binds, rules) = unzip (catMaybes mb_specs)
 	global' = addIdSpecialisations global rules
 	rhs'    = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
+	inl 	= case [inl | InlinePrag inl <- prags] of
+	    	 	[]      -> defaultInlineSpec 
+	    	 	(inl:_) -> inl
     in
-    returnDs (addInlineInfo inline_env (global', rhs') : spec_binds ++ rest)
+    returnDs (addInlineInfo inl global' rhs' : spec_binds ++ rest)
 
 dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
   = ds_lhs_binds (addSccs auto_scc exports) binds 	`thenDs` \ core_prs ->
@@ -171,8 +173,15 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 
     returnDs ((poly_tup_id, poly_tup_expr) : (concat export_binds_s ++ rest))
 
+dsSpec :: [TyVar] -> [DictId] -> [TyVar]
+       -> Id -> Id		-- Global, local
+       -> CoreBind -> Prag
+       -> DsM (Maybe ((Id,CoreExpr), 	-- Binding for specialised Id
+		      CoreRule))	-- Rule for the Global Id
+
 -- Example:
 --	f :: (Eq a, Ix b) => a -> b -> b
+--	{-# SPECIALISE f :: Ix b => Int -> b -> b #-}
 --
 --	AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
 -- 
@@ -190,9 +199,9 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind (InlinePrag {})
   = return Nothing
 
 dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
-       (SpecPrag spec_expr spec_ty const_dicts)
+       (SpecPrag spec_expr spec_ty const_dicts inl)
   = do	{ let poly_name = idName poly_id
-	; spec_name <- newLocalName (idName poly_id)
+	; spec_name <- newLocalName poly_name
 	; ds_spec_expr  <- dsExpr spec_expr
 	; let (bndrs, body) = collectBinders ds_spec_expr
 	      mb_lhs  	    = decomposeRuleLhs (bndrs ++ const_dicts) body
@@ -200,7 +209,7 @@ dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
 	; case mb_lhs of
 	    Nothing -> do { dsWarn msg; return Nothing }
 
-	    Just (bndrs', var, args) -> return (Just ((spec_id, spec_rhs), rule))
+	    Just (bndrs', var, args) -> return (Just (addInlineInfo inl spec_id spec_rhs, rule))
 		where
 		  local_poly  = setIdNotExported poly_id
 			-- Very important to make the 'f' non-exported,
@@ -296,18 +305,19 @@ simpleSubst subst expr
 					   [(c,bs,go r) | (c,bs,r) <- alts]
 
 addLocalInlines exports core_prs
-  = map (addInlineInfo inline_env) core_prs
+  = map add_inline core_prs
   where
+    add_inline (bndr,rhs) | Just inl <- lookupVarEnv inline_env bndr
+			  = addInlineInfo inl bndr rhs
+			  | otherwise 
+			  = (bndr,rhs)
     inline_env = mkVarEnv [(mono_id, prag) 
 			  | (_, _, mono_id, prags) <- exports,
-			    prag <- prags, isInlinePrag prag]
+			    InlinePrag prag <- prags]
 					   
-addInlineInfo :: IdEnv Prag -> (Id,CoreExpr) -> (Id,CoreExpr)
-addInlineInfo inline_env (bndr,rhs)
-  | Just (InlinePrag is_inline phase) <- lookupVarEnv inline_env bndr
+addInlineInfo :: InlineSpec -> Id -> CoreExpr -> (Id,CoreExpr)
+addInlineInfo (Inline phase is_inline) bndr rhs
   = (attach_phase bndr phase, wrap_inline is_inline rhs)
-  | otherwise
-  = (bndr, rhs)
   where
     attach_phase bndr phase 
 	| isAlwaysActive phase = bndr	-- Default phase
diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index 4f9f955..40c0ce1 100644
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -343,8 +343,8 @@ rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ;
 rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)]
 	-- Singleton => Ok
 	-- Empty     => Too hard, signature ignored
-rep_sig (L loc (Sig nm ty)) = rep_proto nm ty loc
-rep_sig other		    = return []
+rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc
+rep_sig other		        = return []
 
 rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)]
 rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ; 
diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs
index 7988c2c..90675fb 100644
--- a/ghc/compiler/deSugar/MatchCon.lhs
+++ b/ghc/compiler/deSugar/MatchCon.lhs
@@ -12,9 +12,9 @@ import {-# SOURCE #-} Match	( match )
 
 import HsSyn		( Pat(..), HsConDetails(..) )
 import DsBinds		( dsLHsBinds )
-import DataCon		( isVanillaDataCon, dataConTyVars, dataConInstOrigArgTys )
+import DataCon		( isVanillaDataCon, dataConInstOrigArgTys )
 import TcType		( tcTyConAppArgs )
-import Type		( substTys, zipTopTvSubst, mkTyVarTys )
+import Type		( mkTyVarTys )
 import CoreSyn
 import DsMonad
 import DsUtils
diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs
index ab9cf2c..a012cd1 100644
--- a/ghc/compiler/hsSyn/Convert.lhs
+++ b/ghc/compiler/hsSyn/Convert.lhs
@@ -47,7 +47,7 @@ convertToHsDecls loc ds = map (cvt_top loc) ds
 cvt_top :: SrcSpan -> TH.Dec -> Either (LHsDecl RdrName) Message
 cvt_top loc d@(TH.ValD _ _ _) = Left $ L loc $ Hs.ValD (unLoc (cvtd loc d))
 cvt_top loc d@(TH.FunD _ _)   = Left $ L loc $ Hs.ValD (unLoc (cvtd loc d))
-cvt_top loc (TH.SigD nm typ) = Left $ L loc $ Hs.SigD (Sig (L loc (vName nm)) (cvtType loc typ))
+cvt_top loc (TH.SigD nm typ) = Left $ L loc $ Hs.SigD (TypeSig (L loc (vName nm)) (cvtType loc typ))
  
 cvt_top loc (TySynD tc tvs rhs)
   = Left $ L loc $ TyClD (TySynonym (L loc (tconName tc)) (cvt_tvs loc tvs) (cvtType loc rhs))
@@ -233,7 +233,7 @@ cvtBindsAndSigs loc ds
   where 
     (sigs, non_sigs) = partition sigP ds
 
-cvtSig loc (TH.SigD nm typ) = L loc (Hs.Sig (L loc (vName nm)) (cvtType loc typ))
+cvtSig loc (TH.SigD nm typ) = L loc (Hs.TypeSig (L loc (vName nm)) (cvtType loc typ))
 
 cvtds :: SrcSpan -> [TH.Dec] -> LHsBinds RdrName
 cvtds loc []     = emptyBag
diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index 15f25f2..f20bcb4 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -18,7 +18,7 @@ import {-# SOURCE #-} HsPat  ( LPat )
 import HsTypes		( LHsType, PostTcType )
 import Name		( Name )
 import NameSet		( NameSet, elemNameSet )
-import BasicTypes	( IPName, RecFlag(..), Activation(..), Fixity )
+import BasicTypes	( IPName, RecFlag(..), InlineSpec(..), Fixity )
 import Outputable	
 import SrcLoc		( Located(..), SrcSpan, unLoc )
 import Util		( sortLe )
@@ -277,15 +277,15 @@ serves for both.
 type LSig name = Located (Sig name)
 
 data Sig name
-  = Sig		(Located name)	-- a bog-std type signature
+  = TypeSig	(Located name)	-- A bog-std type signature
 		(LHsType name)
 
-  | SpecSig 	(Located name)	-- specialise a function or datatype ...
+  | SpecSig 	(Located name)	-- Specialise a function or datatype ...
 		(LHsType name)	-- ... to these types
+		InlineSpec
 
-  | InlineSig	Bool		-- True <=> INLINE f, False <=> NOINLINE f
-	 	(Located name)	-- Function name
-		Activation	-- When inlining is *active*
+  | InlineSig	(Located name)	-- Function name
+		InlineSpec
 
   | SpecInstSig (LHsType name)	-- (Class tys); should be a specialisation of the 
 				-- current instance decl
@@ -297,20 +297,20 @@ data FixitySig name = FixitySig (Located name) Fixity
 
 -- A Prag conveys pragmas from the type checker to the desugarer
 data Prag 
-  = InlinePrag 	
-	Bool 		-- True <=> INLINE, False <=> NOINLINE
-	Activation
+  = InlinePrag 
+	InlineSpec
 
   | SpecPrag   
 	(HsExpr Id)	-- An expression, of the given specialised type, which
 	PostTcType 	-- specialises the polymorphic function
 	[Id]		-- Dicts mentioned free in the expression
+	InlineSpec 	-- Inlining spec for the specialised function
 
-isInlinePrag (InlinePrag _ _) = True
-isInlinePrag prag	      = False
+isInlinePrag (InlinePrag _) = True
+isInlinePrag prag	    = False
 
-isSpecPrag (SpecPrag _ _ _) = True
-isSpecPrag prag		    = False
+isSpecPrag (SpecPrag _ _ _ _) = True
+isSpecPrag prag		      = False
 \end{code}
 
 \begin{code}
@@ -318,9 +318,9 @@ okBindSig :: NameSet -> LSig Name -> Bool
 okBindSig ns sig = sigForThisGroup ns sig
 
 okHsBootSig :: LSig Name -> Bool
-okHsBootSig (L _ (Sig  _ _)) = True
-okHsBootSig (L _ (FixSig _)) = True
-okHsBootSig sig	      	     = False
+okHsBootSig (L _ (TypeSig  _ _)) = True
+okHsBootSig (L _ (FixSig _)) 	 = True
+okHsBootSig sig	      	     	 = False
 
 okClsDclSig :: LSig Name -> Bool
 okClsDclSig (L _ (SpecInstSig _)) = False
@@ -329,7 +329,7 @@ okClsDclSig sig 	          = True	-- All others OK
 okInstDclSig :: NameSet -> LSig Name -> Bool
 okInstDclSig ns lsig@(L _ sig) = ok ns sig
   where
-    ok ns (Sig _ _)	  = False
+    ok ns (TypeSig _ _)	  = False
     ok ns (FixSig _)	  = False
     ok ns (SpecInstSig _) = True
     ok ns sig		  = sigForThisGroup ns lsig
@@ -343,9 +343,9 @@ sigForThisGroup ns sig
 sigName :: LSig name -> Maybe name
 sigName (L _ sig) = f sig
  where
-    f (Sig         n _)        = Just (unLoc n)
-    f (SpecSig     n _)        = Just (unLoc n)
-    f (InlineSig _ n _)        = Just (unLoc n)
+    f (TypeSig   n _)          = Just (unLoc n)
+    f (SpecSig   n _ _)        = Just (unLoc n)
+    f (InlineSig n _)          = Just (unLoc n)
     f (FixSig (FixitySig n _)) = Just (unLoc n)
     f other			= Nothing
 
@@ -354,26 +354,25 @@ isFixityLSig (L _ (FixSig _)) = True
 isFixityLSig _	              = False
 
 isVanillaLSig :: LSig name -> Bool
-isVanillaLSig (L _(Sig name _)) = True
-isVanillaLSig sig	        = False
+isVanillaLSig (L _(TypeSig name _)) = True
+isVanillaLSig sig	            = False
 
 isSpecLSig :: LSig name -> Bool
-isSpecLSig (L _(SpecSig name _)) = True
-isSpecLSig sig	     		 = False
+isSpecLSig (L _(SpecSig name _ _)) = True
+isSpecLSig sig	     		   = False
 
 isSpecInstLSig (L _ (SpecInstSig _)) = True
 isSpecInstLSig sig	       	     = False
 
 isPragLSig :: LSig name -> Bool
 	-- Identifies pragmas 
-isPragLSig (L _ (SpecSig _ _))     = True
-isPragLSig (L _ (InlineSig _ _ _)) = True
-isPragLSig other		   = False
-
-hsSigDoc (Sig        _ _) 	  = ptext SLIT("type signature")
-hsSigDoc (SpecSig    _ _) 	  = ptext SLIT("SPECIALISE pragma")
-hsSigDoc (InlineSig True  _ _)    = ptext SLIT("INLINE pragma")
-hsSigDoc (InlineSig False _ _)    = ptext SLIT("NOINLINE pragma")
+isPragLSig (L _ (SpecSig _ _ _)) = True
+isPragLSig (L _ (InlineSig _ _)) = True
+isPragLSig other		 = False
+
+hsSigDoc (TypeSig    _ _) 	  = ptext SLIT("type signature")
+hsSigDoc (SpecSig    _ _ _) 	  = ptext SLIT("SPECIALISE pragma")
+hsSigDoc (InlineSig _ spec)   	  = ppr spec <+> ptext SLIT("pragma")
 hsSigDoc (SpecInstSig _)	  = ptext SLIT("SPECIALISE instance pragma")
 hsSigDoc (FixSig (FixitySig _ _)) = ptext SLIT("fixity declaration")
 \end{code}
@@ -383,8 +382,8 @@ Signature equality is used when checking for duplicate signatures
 \begin{code}
 eqHsSig :: LSig Name -> LSig Name -> Bool
 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
-eqHsSig (L _ (Sig n1 _))         	(L _ (Sig n2 _))                = unLoc n1 == unLoc n2
-eqHsSig (L _ (InlineSig b1 n1 _))	(L _ (InlineSig b2 n2 _))       = b1 == b2 && unLoc n1 == unLoc n2
+eqHsSig (L _ (TypeSig n1 _))         	(L _ (TypeSig n2 _))            = unLoc n1 == unLoc n2
+eqHsSig (L _ (InlineSig n1 s1))	(L _ (InlineSig n2 s2))    	        = s1 == s2 && unLoc n1 == unLoc n2
  	-- For specialisations, we don't have equality over
 	-- HsType, so it's not convenient to spot duplicate 
 	-- specialisations here.  Check for this later, when we're in Type land
@@ -396,10 +395,10 @@ instance (OutputableBndr name) => Outputable (Sig name) where
     ppr sig = ppr_sig sig
 
 ppr_sig :: OutputableBndr name => Sig name -> SDoc
-ppr_sig (Sig var ty)		  = pprVarSig (unLoc var) ty
+ppr_sig (TypeSig var ty)	  = pprVarSig (unLoc var) ty
 ppr_sig (FixSig fix_sig) 	  = ppr fix_sig
-ppr_sig (SpecSig var ty) 	  = pragBrackets (pprSpec var ty)
-ppr_sig (InlineSig inl var phase) = pragBrackets (pprInline var inl phase)
+ppr_sig (SpecSig var ty inl) 	  = pragBrackets (pprSpec var ty inl)
+ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
 ppr_sig (SpecInstSig ty) 	  = pragBrackets (ptext SLIT("SPECIALIZE instance") <+> ppr ty)
 
 instance Outputable name => Outputable (FixitySig name) where
@@ -408,17 +407,13 @@ instance Outputable name => Outputable (FixitySig name) where
 pragBrackets :: SDoc -> SDoc
 pragBrackets doc = ptext SLIT("{-#") <+> doc <+> ptext SLIT("#-}") 
 
-pprInline :: Outputable id => id -> Bool -> Activation -> SDoc
-pprInline var True  phase = hsep [ptext SLIT("INLINE"),   ppr phase, ppr var]
-pprInline var False phase = hsep [ptext SLIT("NOINLINE"), ppr phase, ppr var]
-
 pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
 pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
 
-pprSpec :: (Outputable id, Outputable ty) => id -> ty -> SDoc
-pprSpec var ty = sep [ptext SLIT("SPECIALIZE") <+> pprVarSig var ty]
+pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
+pprSpec var ty inl = sep [ptext SLIT("SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
 
 pprPrag :: Outputable id => id -> Prag -> SDoc
-pprPrag var (InlinePrag inl act) = pprInline var inl act
-pprPrag var (SpecPrag expr ty _) = pprSpec var ty
+pprPrag var (InlinePrag inl)         = ppr inl <+> ppr var
+pprPrag var (SpecPrag expr ty _ inl) = pprSpec var ty inl
 \end{code}
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index ddd11a6..1f67f6e 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -405,7 +405,7 @@ tyClDeclNames (TySynonym   {tcdLName = name})  = [name]
 tyClDeclNames (ForeignType {tcdLName = name})  = [name]
 
 tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs})
-  = cls_name : [n | L _ (Sig n _) <- sigs]
+  = cls_name : [n | L _ (TypeSig n _) <- sigs]
 
 tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons})
   = tc_name : conDeclsNames (map unLoc cons)
diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs
index b213764..3d8566a 100644
--- a/ghc/compiler/main/HscStats.lhs
+++ b/ghc/compiler/main/HscStats.lhs
@@ -105,11 +105,11 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _))
 
     count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
 
-    sig_info (FixSig _)		  = (1,0,0,0)
-    sig_info (Sig _ _)            = (0,1,0,0)
-    sig_info (SpecSig _ _)        = (0,0,1,0)
-    sig_info (InlineSig _ _ _)    = (0,0,0,1)
-    sig_info _                    = (0,0,0,0)
+    sig_info (FixSig _)		= (1,0,0,0)
+    sig_info (TypeSig _ _)      = (0,1,0,0)
+    sig_info (SpecSig _ _ _)    = (0,0,1,0)
+    sig_info (InlineSig _ _)    = (0,0,0,1)
+    sig_info _                  = (0,0,0,0)
 
     import_info (L _ (ImportDecl _ _ qual as spec))
 	= add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
diff --git a/ghc/compiler/parser/Lexer.x b/ghc/compiler/parser/Lexer.x
index 5351af1..407b5fa 100644
--- a/ghc/compiler/parser/Lexer.x
+++ b/ghc/compiler/parser/Lexer.x
@@ -175,12 +175,17 @@ $white_no_nl+ 				;
   "{-#" $whitechar* (RULES|rules)	{ token ITrules_prag }
 
 <0,glaexts> {
+  "{-#" $whitechar* (INLINE|inline)	{ token (ITinline_prag True) }
+  "{-#" $whitechar* (NO(T?)INLINE|no(t?)inline)
+  					{ token (ITinline_prag False) }
+  "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
+  					{ token ITspec_prag }
   "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
-  					{ token ITspecialise_prag }
+	$whitechar* (INLINE|inline)	{ token (ITspec_inline_prag True) }
+  "{-#" $whitechar* (SPECIALI[SZ]E|speciali[sz]e)
+	$whitechar* (NO(T?)INLINE|no(t?)inline)
+					{ token (ITspec_inline_prag False) }
   "{-#" $whitechar* (SOURCE|source)	{ token ITsource_prag }
-  "{-#" $whitechar* (INLINE|inline)	{ token ITinline_prag }
-  "{-#" $whitechar* (NO(T?)INLINE|no(t?)inline)
-  					{ token ITnoinline_prag }
   "{-#" $whitechar* (DEPRECATED|deprecated)
   					{ token ITdeprecated_prag }
   "{-#" $whitechar* (SCC|scc)		{ token ITscc_prag }
@@ -350,10 +355,11 @@ data Token
   | ITdotnet
   | ITmdo
 
-  | ITspecialise_prag		-- Pragmas
+	-- Pragmas
+  | ITinline_prag Bool		-- True <=> INLINE, False <=> NOINLINE
+  | ITspec_prag			-- SPECIALISE	
+  | ITspec_inline_prag Bool	-- SPECIALISE INLINE (or NOINLINE)
   | ITsource_prag
-  | ITinline_prag
-  | ITnoinline_prag
   | ITrules_prag
   | ITdeprecated_prag
   | ITline_prag
diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp
index 6ad9f6b..e204d11 100644
--- a/ghc/compiler/parser/Parser.y.pp
+++ b/ghc/compiler/parser/Parser.y.pp
@@ -34,7 +34,7 @@ import Module
 import StaticFlags	( opt_SccProfilingOn )
 import Type		( Kind, mkArrowKind, liftedTypeKind )
 import BasicTypes	( Boxity(..), Fixity(..), FixityDirection(..), IPName(..),
-			  Activation(..) )
+			  Activation(..), InlineSpec(..), defaultInlineSpec )
 import OrdList
 import Panic
 
@@ -184,10 +184,10 @@ incorrect.
  'proc'		{ L _ ITproc }		-- for arrow notation extension
  'rec'		{ L _ ITrec }		-- for arrow notation extension
 
- '{-# SPECIALISE'  { L _ ITspecialise_prag }
+ '{-# INLINE'      	  { L _ (ITinline_prag _) }
+ '{-# SPECIALISE'  	  { L _ ITspec_prag }
+ '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _) }
  '{-# SOURCE'	   { L _ ITsource_prag }
- '{-# INLINE'      { L _ ITinline_prag }
- '{-# NOINLINE'    { L _ ITnoinline_prag }
  '{-# RULES'	   { L _ ITrules_prag }
  '{-# CORE'        { L _ ITcore_prag }              -- hdaume: annotated core
  '{-# SCC'	   { L _ ITscc_prag }
@@ -537,10 +537,6 @@ activation :: { Activation }           -- Omitted means AlwaysActive
         : {- empty -}                           { AlwaysActive }
         | explicit_activation                   { $1 }
 
-inverse_activation :: { Activation }   -- Omitted means NeverActive
-        : {- empty -}                           { NeverActive }
-        | explicit_activation                   { $1 }
-
 explicit_activation :: { Activation }  -- In brackets
         : '[' INTEGER ']'		{ ActiveAfter  (fromInteger (getINTEGER $2)) }
         | '[' '~' INTEGER ']'		{ ActiveBefore (fromInteger (getINTEGER $3)) }
@@ -996,16 +992,17 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
 				      return (LL $ unitOL (LL $ SigD s)) }
 		-- See the above notes for why we need infixexp here
 	| var ',' sig_vars '::' sigtype	
-				{ LL $ toOL [ LL $ SigD (Sig n $5) | n <- $1 : unLoc $3 ] }
+				{ LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] }
 	| infix prec ops	{ LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
 					     | n <- unLoc $3 ] }
 	| '{-# INLINE'   activation qvar '#-}'	      
-				{ LL $ unitOL (LL $ SigD (InlineSig True  $3 $2)) }
-	| '{-# NOINLINE' inverse_activation qvar '#-}' 
-				{ LL $ unitOL (LL $ SigD (InlineSig False $3 $2)) }
+				{ LL $ unitOL (LL $ SigD (InlineSig $3 (Inline $2 (getINLINE $1)))) }
 	| '{-# SPECIALISE' qvar '::' sigtypes1 '#-}'
-			 	{ LL $ toOL [ LL $ SigD (SpecSig $2 t)
+			 	{ LL $ toOL [ LL $ SigD (SpecSig $2 t defaultInlineSpec)
 					    | t <- $4] }
+	| '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'
+			 	{ LL $ toOL [ LL $ SigD (SpecSig $3 t (Inline $2 (getSPEC_INLINE $1)))
+					    | t <- $5] }
 	| '{-# SPECIALISE' 'instance' inst_type '#-}'
 				{ LL $ unitOL (LL $ SigD (SpecInstSig $3)) }
 
@@ -1573,6 +1570,8 @@ getPRIMINTEGER	(L _ (ITprimint    x)) = x
 getPRIMFLOAT	(L _ (ITprimfloat  x)) = x
 getPRIMDOUBLE	(L _ (ITprimdouble x)) = x
 getTH_ID_SPLICE (L _ (ITidEscape x)) = x
+getINLINE	(L _ (ITinline_prag b)) = b
+getSPEC_INLINE	(L _ (ITspec_inline_prag b)) = b
 
 -- Utilities for combining source spans
 comb2 :: Located a -> Located b -> SrcSpan
diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index c8c29a1..6a478af 100644
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -601,7 +601,7 @@ checkValSig
 	:: LHsExpr RdrName
 	-> LHsType RdrName
 	-> P (Sig RdrName)
-checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty)
+checkValSig (L l (HsVar v)) ty | isUnqual v = return (TypeSig (L l v) ty)
 checkValSig (L l other)     ty
   = parseError l "Type signature given for an expression"
 
diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index f067e5d..3c23aba 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -188,7 +188,7 @@ rnTopBindsSrc binds@(ValBindsIn mbinds _)
 
 		-- Warn about missing signatures, 
 	; let	{ ValBindsOut _ sigs' = binds'
-		; ty_sig_vars = mkNameSet [ unLoc n | L _ (Sig n _) <- sigs']
+		; ty_sig_vars = mkNameSet [ unLoc n | L _ (TypeSig n _) <- sigs']
 		; un_sigd_bndrs = duDefs dus `minusNameSet` ty_sig_vars }
 
 	; warn_missing_sigs <- doptM Opt_WarnMissingSigs
@@ -361,8 +361,8 @@ mkSigTvFn sigs
   where
     env :: NameEnv [Name]
     env = mkNameEnv [ (name, map hsLTyVarName ltvs)
-		    | L _ (Sig (L _ name) 
-			       (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs]
+		    | L _ (TypeSig (L _ name) 
+			           (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs]
 	-- Note the pattern-match on "Explicit"; we only bind
 	-- type variables from signatures with an explicit top-level for-all
 				
@@ -522,23 +522,23 @@ check_sigs ok_sig sigs
 
 renameSig :: Sig RdrName -> RnM (Sig Name)
 -- FixitSig is renamed elsewhere.
-renameSig (Sig v ty)
+renameSig (TypeSig v ty)
   = lookupLocatedSigOccRn v			`thenM` \ new_v ->
     rnHsSigType (quotes (ppr v)) ty		`thenM` \ new_ty ->
-    returnM (Sig new_v new_ty)
+    returnM (TypeSig new_v new_ty)
 
 renameSig (SpecInstSig ty)
   = rnLHsType (text "A SPECIALISE instance pragma") ty `thenM` \ new_ty ->
     returnM (SpecInstSig new_ty)
 
-renameSig (SpecSig v ty)
+renameSig (SpecSig v ty inl)
   = lookupLocatedSigOccRn v		`thenM` \ new_v ->
     rnHsSigType (quotes (ppr v)) ty	`thenM` \ new_ty ->
-    returnM (SpecSig new_v new_ty)
+    returnM (SpecSig new_v new_ty inl)
 
-renameSig (InlineSig b v p)
+renameSig (InlineSig v s)
   = lookupLocatedSigOccRn v		`thenM` \ new_v ->
-    returnM (InlineSig b new_v p)
+    returnM (InlineSig new_v s)
 \end{code}
 
 
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 59f7076..53a412f 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -35,7 +35,7 @@ import PrelNames	( thFAKE, hasKey, assertIdKey, assertErrorName,
 			  negateName, thenMName, bindMName, failMName )
 import Name		( Name, nameOccName, nameIsLocalOrFrom )
 import NameSet
-import RdrName		( RdrName, emptyGlobalRdrEnv, plusGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv )
+import RdrName		( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv )
 import LoadIface	( loadHomeInterface )
 import UnicodeUtil	( stringToUtf8 )
 import UniqFM		( isNullUFM )
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index 6ce0379..8143a52 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -111,9 +111,9 @@ In all cases this is set up for interface-file declarations:
 hsSigsFVs :: [LSig Name] -> FreeVars
 hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs)
 
-hsSigFVs (Sig v ty) 	    = extractHsTyNames ty
+hsSigFVs (TypeSig v ty)     = extractHsTyNames ty
 hsSigFVs (SpecInstSig ty)   = extractHsTyNames ty
-hsSigFVs (SpecSig v ty)     = extractHsTyNames ty
+hsSigFVs (SpecSig v ty inl) = extractHsTyNames ty
 hsSigFVs other		    = emptyFVs
 
 ----------------
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 1fddb33..bf6e54a 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -351,7 +351,7 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs,
 
     new_simple rdr_name = newTopSrcBinder mod Nothing rdr_name
 
-    sig_hs_bndrs = [nm | L _ (Sig nm _) <- val_sigs]
+    sig_hs_bndrs = [nm | L _ (TypeSig nm _) <- val_sigs]
     val_hs_bndrs = collectHsBindLocatedBinders val_decls
     for_hs_bndrs = [nm | L _ (ForeignImport nm _ _ _) <- foreign_decls]
 
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 84ff47d..4bb9bd0 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -504,7 +504,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 	-- Check the signatures
 	-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
     let
-	sig_rdr_names_w_locs   = [op | L _ (Sig op _) <- sigs]
+	sig_rdr_names_w_locs   = [op | L _ (TypeSig op _) <- sigs]
     in
     checkDupNames sig_doc sig_rdr_names_w_locs	`thenM_` 
 	-- Typechecker is responsible for checking that we only
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index a4d163a..02bb9df 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -63,7 +63,7 @@ import Digraph		( SCC(..), stronglyConnComp )
 import Maybes		( fromJust, isJust, isNothing, orElse, catMaybes )
 import Util		( singleton )
 import BasicTypes	( TopLevelFlag(..), isTopLevel, isNotTopLevel,
-			  RecFlag(..), isNonRec )
+			  RecFlag(..), isNonRec, InlineSpec, defaultInlineSpec )
 import Outputable
 \end{code}
 
@@ -117,7 +117,7 @@ tcHsBootSigs (ValBindsOut binds sigs)
   = do	{ checkTc (null binds) badBootDeclErr
 	; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) }
   where
-    tc_boot_sig (Sig (L _ name) ty)
+    tc_boot_sig (TypeSig (L _ name) ty)
       = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
 	   ; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) }
 	-- Notice that we make GlobalIds, not LocalIds
@@ -161,6 +161,9 @@ tcValBinds :: TopLevelFlag
 	   -> HsValBinds Name -> TcM thing
 	   -> TcM (HsValBinds TcId, thing) 
 
+tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside
+  = pprPanic "tcValBinds" (ppr binds)
+
 tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
   = tcAddLetBoundTyVars binds  $
       -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
@@ -431,18 +434,18 @@ tcPrags poly_id prags = mapM tc_prag prags
 pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag)
 
 tcPrag :: TcId -> Sig Name -> TcM Prag
-tcPrag poly_id (SpecSig orig_name hs_ty) = tcSpecPrag poly_id hs_ty
-tcPrag poly_id (SpecInstSig hs_ty)	 = tcSpecPrag poly_id hs_ty
-tcPrag poly_id (InlineSig inl _ act)     = return (InlinePrag inl act)
+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)
 
 
-tcSpecPrag :: TcId -> LHsType Name -> TcM Prag
-tcSpecPrag poly_id hs_ty
+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 (tcSub spec_ty (idType poly_id))
 	; extendLIEs lie
 	; let const_dicts = map instToId lie
-	; return (SpecPrag (co_fn <$> (HsVar poly_id)) spec_ty const_dicts) }
+	; return (SpecPrag (co_fn <$> (HsVar poly_id)) spec_ty const_dicts inl) }
   
 --------------
 -- If typechecking the binds fails, then return with each
@@ -887,7 +890,7 @@ tcTySigs sigs = do { mb_sigs <- mappM tcTySig (filter isVanillaLSig sigs)
 		   ; return (catMaybes mb_sigs) }
 
 tcTySig :: LSig Name -> TcM (Maybe TcSigInfo)
-tcTySig (L span (Sig (L _ name) ty))
+tcTySig (L span (TypeSig (L _ name) ty))
   = recoverM (return Nothing)	$
     setSrcSpan span		$
     do	{ sigma_ty <- tcHsSigType (FunSigCtxt name) ty
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index b562968..b382af9 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -118,8 +118,8 @@ tcClassSigs clas sigs def_methods
   = do { dm_env <- checkDefaultBinds clas op_names def_methods
        ; mappM (tcClassSig dm_env) op_sigs }
   where
-    op_sigs  = [sig | sig@(L _ (Sig _ _))       <- sigs]
-    op_names = [n   | sig@(L _ (Sig (L _ n) _)) <- op_sigs]
+    op_sigs  = [sig | sig@(L _ (TypeSig _ _))       <- sigs]
+    op_names = [n   | sig@(L _ (TypeSig (L _ n) _)) <- op_sigs]
 
 
 checkDefaultBinds :: Name -> [Name] -> LHsBinds Name -> TcM (NameEnv Bool)
@@ -151,7 +151,7 @@ tcClassSig :: NameEnv Bool		-- Info about default methods;
 	   -> LSig Name
 	   -> TcM TcMethInfo
 
-tcClassSig dm_env (L loc (Sig (L _ op_name) op_hs_ty))
+tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
   = setSrcSpan loc $ do
     { op_ty <- tcHsKindedType op_hs_ty	-- Class tyvars already in scope
     ; let dm = case lookupNameEnv dm_env op_name of
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index a5d3f64..fecc6d4 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -340,11 +340,11 @@ zonk_bind env (AbsBinds tyvars dicts exports val_binds)
 	  zonkIdBndr env global		`thenM` \ new_global ->
 	  mapM zonk_prag prags		`thenM` \ new_prags -> 
 	  returnM (new_tyvars, new_global, zonkIdOcc env local, new_prags)
-    zonk_prag prag@(InlinePrag _ _) = return prag
-    zonk_prag (SpecPrag expr ty ds) = do { expr' <- zonkExpr env expr 
-					 ; ty'   <- zonkTcTypeToType env ty
-					 ; let ds' = zonkIdOccs env ds
-					 ; return (SpecPrag expr' ty' ds') }
+    zonk_prag prag@(InlinePrag {})  = return prag
+    zonk_prag (SpecPrag expr ty ds inl) = do { expr' <- zonkExpr env expr 
+					     ; ty'   <- zonkTcTypeToType env ty
+					     ; let ds' = zonkIdOccs env ds
+					     ; return (SpecPrag expr' ty' ds' inl) }
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 45117c2..432d3c8 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -41,7 +41,7 @@ import SrcLoc		( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
 import ListSetOps	( minusList )
 import Outputable
 import Bag
-import BasicTypes	( Activation( AlwaysActive ) )
+import BasicTypes	( Activation( AlwaysActive ), InlineSpec(..) )
 import FastString
 \end{code}
 
@@ -383,7 +383,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds })
 	scs_and_meths = map instToId sc_dicts ++ meth_ids
 	this_dict_id  = instToId this_dict
 	inline_prag | null dfun_arg_dicts = []
-		    | otherwise	= [InlinePrag True AlwaysActive]
+		    | otherwise	= [InlinePrag (Inline AlwaysActive True)]
 		-- Always inline the dfun; this is an experimental decision
 		-- because it makes a big performance difference sometimes.
 		-- Often it means we can do the method selection, and then
diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index d1d8528..a4032cd 100644
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -41,7 +41,7 @@ import UniqSupply	( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupp
 import Unique		( Unique )
 import DynFlags		( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode )
 import StaticFlags	( opt_PprStyle_Debug )
-import Bag		( snocBag, unionBags, unitBag )
+import Bag		( snocBag, unionBags )
 import Panic		( showException )
  
 import IO		( stderr )
@@ -448,14 +448,12 @@ addErrAt loc msg = addLongErrAt loc msg empty
 
 addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
 addLongErrAt loc msg extra
- = do {  errs_var <- getErrsVar ;
+  = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;	
+
+	 errs_var <- getErrsVar ;
 	 rdr_env <- getGlobalRdrEnv ;
 	 let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ;
 	 (warns, errs) <- readMutVar errs_var ;
-	 
-	 let style = mkErrStyle (unQualInScope rdr_env)
-	     doc   = mkLocMessage loc (msg $$ extra)
-	 in traceTc (ptext SLIT("Adding error:") <+> doc) ;	
   	 writeMutVar errs_var (warns, errs `snocBag` err) }
 
 addErrs :: [(SrcSpan,Message)] -> TcRn ()
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index a10a744..5df15c1 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -324,8 +324,8 @@ kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt,  tcdSigs = sigs})
 	; sigs' <- mappM (wrapLocM kc_sig) sigs
 	; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) }
   where
-    kc_sig (Sig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
-				; return (Sig nm op_ty') }
+    kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty
+				   ; return (TypeSig nm op_ty') }
     kc_sig other_sig	      = return other_sig
 
 kcTyClDecl decl@(ForeignType {})