X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSimplify.lhs;h=aff019e851b649d76fe60fffdb9a09d77386d26d;hp=5b654fcdb6203a79d5968c4b1a6cc83f9911cc2f;hb=aafdba3bce91afb003f5f50e001e141744837bae;hpb=2e68d0410f319a99f3f36c5e9d9be656ca10dc70

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 5b654fc..aff019e 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -1014,14 +1014,17 @@ makeImplicationBind loc all_tvs reft
 	      tup_ty = mkTupleTy Boxed n_dict_irreds (map idType dict_irred_ids)
 	      pat = TuplePat (map nlVarPat dict_irred_ids) Boxed tup_ty
 	      rhs = L span (mkHsWrap co (HsVar (instToId implic_inst)))
-	      co  = mkWpApps (map instToId dict_givens) <.> mkWpTyApps eq_tyvar_cos <.> mkWpTyApps (mkTyVarTys all_tvs)
+	      co  = mkWpApps (map instToId dict_givens)
+		    <.> mkWpTyApps eq_tyvar_cos
+		    <.> mkWpTyApps (mkTyVarTys all_tvs)
 	      bind | [dict_irred_id] <- dict_irred_ids  = VarBind dict_irred_id rhs
 		   | otherwise        = PatBind { pat_lhs = L span pat, 
 				                  pat_rhs = unguardedGRHSs rhs, 
 				      	          pat_rhs_ty = tup_ty,
 				      	          bind_fvs = placeHolderNames }
-	; -- pprTrace "Make implic inst" (ppr (implic_inst,irreds,dict_irreds,tup_ty)) $
-	  return ([implic_inst], unitBag (L span bind)) }
+	; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
+	; return ([implic_inst], unitBag (L span bind)) 
+        }
 
 -----------------------------------------------------------
 tryHardCheckLoop :: SDoc
@@ -1846,7 +1849,7 @@ reduceContext env wanteds
 	     text "----",
 	     text "avails" <+> pprAvails avails,
 	     text "improved =" <+> ppr improved,
-	     text "irreds = " <+> ppr irreds,
+	     text "(all) irreds = " <+> ppr all_irreds,
 	     text "binds = " <+> ppr binds,
 	     text "needed givens = " <+> ppr needed_givens,
 	     text "----------------------"
@@ -2216,8 +2219,13 @@ reduceImplication env orig_avails name reft tvs extra_givens wanteds inst_loc
 			-- SLPJ Sept07: this looks Utterly Wrong to me, but I think
 			--	        that current extra_givens has no EqInsts, so
 			--		it makes no difference
-		-- dict_ids = map instToId extra_givens
-		co  = mkWpTyLams tvs <.> mkWpTyLams eq_tyvars <.> mkWpLams dict_ids <.> WpLet (binds `unionBags` bind)
+		co  = wrap_inline	-- Note [Always inline implication constraints]
+		      <.> mkWpTyLams tvs
+		      <.> mkWpTyLams eq_tyvars
+		      <.> mkWpLams dict_ids
+		      <.> WpLet (binds `unionBags` bind)
+		wrap_inline | null dict_ids = idHsWrapper
+			    | otherwise	    = WpInline
 		rhs = mkHsWrap co payload
 	        loc = instLocSpan inst_loc
 		payload | [dict_wanted] <- dict_wanteds = HsVar (instToId dict_wanted)
@@ -2232,6 +2240,16 @@ reduceImplication env orig_avails name reft tvs extra_givens wanteds inst_loc
     }
 \end{code}
 
+Note [Always inline implication constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose an implication constraint floats out of an INLINE function.
+Then although the implication has a single call site, it won't be 
+inlined.  And that is bad because it means that even if there is really
+*no* overloading (type signatures specify the exact types) there will
+still be dictionary passing in the resulting code.  To avert this,
+we mark the implication constraints themselves as INLINE, at least when
+there is no loss of sharing as a result.
+
 Note [Reducing implication constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Suppose we are trying to simplify