[commit: ghc] master: Allow the solved dictionaries to propagate from outside in (c945477)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/c945477fba81b541b5a9c59d982447b862f601f4/ghc

>---------------------------------------------------------------

commit c945477fba81b541b5a9c59d982447b862f601f4
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Thu Nov 6 13:54:20 2014 +0000

    Allow the solved dictionaries to propagate from outside in
    
    See Note [Propagate solved dictionaries] in TcSMonad.  This
    can signficantly reduce the number of solver steps.


>---------------------------------------------------------------

c945477fba81b541b5a9c59d982447b862f601f4
 compiler/typecheck/TcSMonad.lhs | 29 ++++++++++++++++++++++++++---
 1 file changed, 26 insertions(+), 3 deletions(-)

diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index c539c1e..0b3b9d8 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -1165,8 +1165,9 @@ recoverTcS (TcS recovery_code) (TcS thing_inside)
 
 nestTcS ::  TcS a -> TcS a
 -- Use the current untouchables, augmenting the current
--- evidence bindings, and solved caches
--- But have no effect on the InertCans or insolubles
+-- evidence bindings, and solved dictionaries
+-- But have no effect on the InertCans, or on the inert_flat_cache
+--  (the latter because the thing inside a nestTcS does unflattening)
 nestTcS (TcS thing_inside)
   = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->
     do { inerts <- TcM.readTcRef inerts_var
@@ -1174,7 +1175,14 @@ nestTcS (TcS thing_inside)
        ; new_wl_var    <- TcM.newTcRef emptyWorkList
        ; let nest_env = env { tcs_inerts   = new_inert_var
                             , tcs_worklist = new_wl_var }
-       ; thing_inside nest_env }
+
+       ; res <- thing_inside nest_env
+
+       ; new_inerts <- TcM.readTcRef new_inert_var
+       ; TcM.writeTcRef inerts_var  -- See Note [Propagate the solved dictionaries]
+                        (inerts { inert_solved_dicts = inert_solved_dicts new_inerts })
+
+       ; return res }
 
 tryTcS :: TcS a -> TcS a
 -- Like runTcS, but from within the TcS monad
@@ -1191,7 +1199,21 @@ tryTcS (TcS thing_inside)
                             , tcs_inerts   = is_var
                             , tcs_worklist = wl_var }
        ; thing_inside nest_env }
+\end{code}
+
+Note [Propagate the solved dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's really quite important that nestTcS does not discard the solved
+dictionaries from the thing_inside.
+Consider
+   Eq [a]
+   forall b. empty =>  Eq [a]
+We solve the flat (Eq [a]), under nestTcS, and then turn our attention to
+the implications.  It's definitely fine to use the solved dictionaries on
+the inner implications, and it can make a signficant performance difference
+if you do so.
 
+\begin{code}
 -- Getters and setters of TcEnv fields
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -1365,6 +1387,7 @@ zonkFlats :: Cts -> TcS Cts
 zonkFlats cts = wrapTcS (TcM.zonkFlats cts)
 \end{code}
 
+
 Note [Do not add duplicate derived insolubles]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In general we *must* add an insoluble (Int ~ Bool) even if there is