X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcBinds.lhs;h=a5b15f3cdd0a6e6c8d2b9ea709adfd52e43a295a;hp=b4c0d1afa81aa8e0f85fed8b59649dd26cb4c0ca;hb=d95ce839533391e7118257537044f01cbb1d6694;hpb=901f574d7b472053cae3bece13c1e4dd31810667

diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index b4c0d1a..a5b15f3 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -352,7 +352,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
 
         -- BUILD THE POLYMORPHIC RESULT IDs
   ; let dict_vars = map instToVar dicts -- May include equality constraints
-  ; exports <- mapM (mkExport top_lvl prag_fn tyvars_to_gen (map varType dict_vars))
+  ; exports <- mapM (mkExport top_lvl rec_group prag_fn tyvars_to_gen (map varType dict_vars))
                     mono_bind_infos
 
   ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
@@ -367,7 +367,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
 
 
 --------------
-mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType]
+mkExport :: TopLevelFlag -> RecFlag -> TcPragFun -> [TyVar] -> [TcType]
          -> MonoBindInfo
          -> TcM ([TyVar], Id, Id, [LPrag])
 -- mkExport generates exports with 
@@ -381,13 +381,13 @@ mkExport :: TopLevelFlag -> TcPragFun -> [TyVar] -> [TcType]
 
 -- Pre-condition: the inferred_tvs are already zonked
 
-mkExport top_lvl prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
+mkExport top_lvl rec_group prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
   = do  { warn_missing_sigs <- doptM Opt_WarnMissingSigs
         ; let warn = isTopLevel top_lvl && warn_missing_sigs
         ; (tvs, poly_id) <- mk_poly_id warn mb_sig
                 -- poly_id has a zonked type
 
-        ; prags <- tcPrags poly_id (prag_fn poly_name)
+        ; prags <- tcPrags rec_group poly_id (prag_fn poly_name)
                 -- tcPrags requires a zonked poly_id
 
         ; return (tvs, poly_id, mono_id, prags) }
@@ -413,24 +413,34 @@ mkPragFun sigs = \n -> lookupNameEnv env n `orElse` []
           env = foldl add emptyNameEnv prs
           add env (n,p) = extendNameEnv_Acc (:) singleton env n p
 
-tcPrags :: Id -> [LSig Name] -> TcM [LPrag]
-tcPrags poly_id prags = mapM (wrapLocM tc_prag) prags
+tcPrags :: RecFlag -> Id -> [LSig Name] -> TcM [LPrag]
+-- Pre-condition: the poly_id is zonked
+-- Reason: required by tcSubExp
+tcPrags rec_group poly_id prags = mapM tc_lprag prags
   where
-    tc_prag prag = addErrCtxt (pragSigCtxt prag) $ 
-                   tcPrag poly_id prag
+    tc_lprag :: LSig Name -> TcM LPrag
+    tc_lprag (L loc prag) = setSrcSpan loc                $
+    	     	    	    addErrCtxt (pragSigCtxt prag) $ 
+ 			    do { prag' <- tc_prag prag
+                               ; return (L loc prag') }
+
+    tc_prag (SpecSig _ hs_ty inl) = tcSpecPrag poly_id hs_ty inl
+    tc_prag (SpecInstSig hs_ty)   = tcSpecPrag poly_id hs_ty defaultInlineSpec
+    tc_prag (InlineSig _ inl)     = do { warnIfRecInline rec_group inl poly_id
+    	    	       	 	       ; return (InlinePrag inl) }
+    tc_prag (FixSig {})           = panic "tcPrag FixSig"
+    tc_prag (TypeSig {})          = panic "tcPrag TypeSig"
 
 pragSigCtxt :: Sig Name -> SDoc
 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 _       (FixSig {})           = panic "tcPrag FixSig"
-tcPrag _       (TypeSig {})          = panic "tcPrag TypeSig"
-
+warnIfRecInline :: RecFlag -> InlineSpec -> TcId -> TcM ()
+warnIfRecInline rec_group (Inline _ is_inline) poly_id
+  | is_inline && isRec rec_group = addWarnTc warn
+  | otherwise                    = return ()
+  where
+    warn = ptext (sLit "INLINE pragma for recursive binder") <+> quotes (ppr poly_id)
+    	   <+> ptext (sLit "may be discarded")
 
 tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
 tcSpecPrag poly_id hs_ty inl