Properly ppr InstEqs in wanteds of implication constraints

[ghc-hetmet.git] / compiler / typecheck / TcSimplify.lhs

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index af58138..aff019e 100644 (file)
--- 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
@@ -2934,11 +2952,10 @@ groupErrs :: ([Inst] -> TcM ()) -- Deal with one group
 -- We want to report them together in error messages
 
 groupErrs report_err [] 
-  = returnM ()
+  = return ()
 groupErrs report_err (inst:insts) 
-  = do_one (inst:friends)              `thenM_`
-    groupErrs report_err others
-
+  = do { do_one (inst:friends)
+       ; groupErrs report_err others }
   where
        -- (It may seem a bit crude to compare the error messages,
        --  but it makes sure that we combine just what the user sees,
@@ -3003,11 +3020,11 @@ report_no_instances tidy_env mb_what insts
             (insts2, overlaps) = partitionWith (check_overlap inst_envs) insts1
              (eqInsts, insts3)  = partition isEqInst insts2
        ; traceTc (text "reportNoInstances" <+> vcat 
-                       [ppr implics, ppr insts1, ppr insts2])
+                       [ppr insts, ppr implics, ppr insts1, ppr insts2])
        ; mapM_ complain_implic implics
        ; mapM_ (\doc -> addErrTcM (tidy_env, doc)) overlaps
        ; groupErrs complain_no_inst insts3 
-       ; mapM_ eqInstMisMatch eqInsts
+       ; mapM_ (addErrTcM . mk_eq_err) eqInsts
        }
   where
     complain_no_inst insts = addErrTcM (tidy_env, mk_no_inst_err insts)
@@ -3053,6 +3070,9 @@ report_no_instances tidy_env mb_what insts
       where
        ispecs = [ispec | (ispec, _) <- matches]
 
+    mk_eq_err :: Inst -> (TidyEnv, SDoc)
+    mk_eq_err inst = misMatchMsg tidy_env (eqInstTys inst)
+
     mk_no_inst_err insts
       | null insts = empty