X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=98e5aa51a8f37a80fd0d42f93954d81e28e95384;hb=aedb94f5f220b5e442b23ecc445fd38c8d9b6ba0;hp=cb6021ccf429a81927e02ac693fa01c8ab793608;hpb=fbbd2bfaa54b4424edc70cbc4bd4ff29e324f6a2;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index cb6021c..98e5aa5 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -16,6 +16,8 @@ module TcSimplify (
 
 	tcSimplifyDeriv, tcSimplifyDefault,
 	bindInstsOfLocalFuns, 
+	
+        tcSimplifyStagedExpr,
 
         misMatchMsg
     ) where
@@ -58,6 +60,7 @@ import Util
 import SrcLoc
 import DynFlags
 import FastString
+
 import Control.Monad
 import Data.List
 \end{code}
@@ -707,6 +710,13 @@ tcSimplifyInfer doc tau_tvs wanted
 		-- irreds2 will be empty.  But we don't want to generalise over b!
 	; let preds2 = fdPredsOfInsts irreds2	-- irreds2 is zonked
 	      qtvs   = grow preds2 tau_tvs2 `minusVarSet` oclose preds2 gbl_tvs2
+		---------------------------------------------------
+		-- BUG WARNING: there's a nasty bug lurking here
+		-- fdPredsOfInsts may return preds that mention variables quantified in
+		-- one of the implication constraints in irreds2; and that is clearly wrong:
+		-- we might quantify over too many variables through accidental capture
+		---------------------------------------------------
+
 	; let (free, irreds3) = partition (isFreeWhenInferring qtvs) irreds2
 	; extendLIEs free
 
@@ -861,7 +871,7 @@ Note [NO TYVARS]
 
 The excitement comes when simplifying the bindings for h.  Initially
 try to simplify {y @ [[t1]] t2, 0 @ t1}, with initial qtvs = {t2}.
-From this we get t1:=:t2, but also various bindings.  We can't forget
+From this we get t1~t2, but also various bindings.  We can't forget
 the bindings (because of [LOOP]), but in fact t1 is what g is
 polymorphic in.  
 
@@ -977,7 +987,7 @@ makeImplicationBind :: InstLoc -> [TcTyVar]
 --	(ir1, .., irn) = f qtvs givens
 -- where f is (evidence for) the new implication constraint
 --	f :: forall qtvs. givens => (ir1, .., irn)
--- qtvs includes coercion variables.
+-- qtvs includes coercion variables
 --
 -- This binding must line up the 'rhs' in reduceImplication
 makeImplicationBind loc all_tvs
@@ -997,7 +1007,7 @@ makeImplicationBind loc all_tvs
 	      name = mkInternalName uniq (mkVarOcc "ic") span
 	      implic_inst = ImplicInst { tci_name = name,
 					 tci_tyvars = all_tvs, 
-					 tci_given = (eq_givens ++ dict_givens),
+					 tci_given = eq_givens ++ dict_givens,
                                                        -- same order as binders
 					 tci_wanted = irreds, 
                                          tci_loc = loc }
@@ -1013,16 +1023,17 @@ makeImplicationBind loc all_tvs
 		     <.> mkWpTyApps eq_cotvs
 		     <.> mkWpTyApps (mkTyVarTys all_tvs)
 	      bind | [dict_irred_id] <- dict_irred_ids  
-                   = VarBind dict_irred_id rhs
+                   = mkVarBind dict_irred_id rhs
 		   | otherwise        
-                   = PatBind { pat_lhs = lpat
+                   = L span $ 
+                     PatBind { pat_lhs = lpat
 			     , pat_rhs = unguardedGRHSs rhs 
 			     , pat_rhs_ty = hsLPatType lpat
 			     , bind_fvs = placeHolderNames 
                              }
 
 	; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
-	; return ([implic_inst], unitBag (L span bind)) 
+	; return ([implic_inst], unitBag bind) 
         }
 
 -----------------------------------------------------------
@@ -2350,11 +2361,7 @@ reduceImplication env
               eq_cotvs = map instToVar extra_eq_givens
 	      dict_ids = map instToId  extra_dict_givens 
 
-                        -- Note [Always inline implication constraints]
-              wrap_inline | null dict_ids = idHsWrapper
-                          | otherwise	  = WpInline
-              co         = wrap_inline
-                           <.> mkWpTyLams tvs
+              co         = mkWpTyLams tvs
                            <.> mkWpTyLams eq_cotvs
                            <.> mkWpLams dict_ids
                            <.> WpLet (binds `unionBags` bind)
@@ -2366,12 +2373,15 @@ reduceImplication env
                            . filter (not . isEqInst) 
                            $ wanteds
               payload    = mkBigLHsTup dict_bndrs
-
 	
 	; traceTc (vcat [text "reduceImplication" <+> ppr name,
 			 ppr simpler_implic_insts,
 			 text "->" <+> ppr rhs])
-	; return (unitBag (L loc (VarBind (instToId orig_implic) rhs)),
+	; return (unitBag (L loc (VarBind { var_id= instToId orig_implic
+					  , var_rhs = rhs
+					  , var_inline = not (null dict_ids) }
+				-- See Note [Always inline implication constraints]
+			  )),
 		  simpler_implic_insts)
   	} 
     }
@@ -3014,6 +3024,26 @@ tcSimplifyDefault theta = do
     doc = ptext (sLit "default declaration")
 \end{code}
 
+@tcSimplifyStagedExpr@ performs a simplification but does so at a new
+stage. This is used when typechecking annotations and splices.
+
+\begin{code}
+
+tcSimplifyStagedExpr :: ThStage -> TcM a -> TcM (a, TcDictBinds)
+-- Type check an expression that runs at a top level stage as if
+--   it were going to be spliced and then simplify it
+tcSimplifyStagedExpr stage tc_action
+  = setStage stage $ do { 
+        -- Typecheck the expression
+	  (thing', lie) <- getLIE tc_action
+	
+	-- Solve the constraints
+	; const_binds <- tcSimplifyTop lie
+	
+	; return (thing', const_binds) }
+
+\end{code}
+
 
 %************************************************************************
 %*									*