[commit: ghc] master: Revert "Refactor CallStack defaulting slightly" (7a7bb5d)

[git at git.haskell.org]

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

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

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

commit 7a7bb5d27b0e240304bd18e7ebd2f60877e4cc12
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Nov 11 15:31:56 2016 +0000

    Revert "Refactor CallStack defaulting slightly"
    
    This reverts commit 317236db308d9bd497a11fa4c455428fc7477405.
    
    I totally missed that in simplifyInfer for local functions
    we must NOT default call stacks.  So I'm reverting this.
    
    Fortunately caught by T10845, which sadly isn't run by
    validate --fast


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

7a7bb5d27b0e240304bd18e7ebd2f60877e4cc12
 compiler/typecheck/TcSimplify.hs | 74 +++++++++++++++++++++-------------------
 1 file changed, 39 insertions(+), 35 deletions(-)

diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs
index c943596..0594313 100644
--- a/compiler/typecheck/TcSimplify.hs
+++ b/compiler/typecheck/TcSimplify.hs
@@ -148,7 +148,42 @@ simpl_top wanteds
              then do { wc_residual <- nestTcS (solveWantedsAndDrop wc)
                      ; try_class_defaulting wc_residual }
                   -- See Note [Overview of implicit CallStacks] in TcEvidence
-             else return wc }
+             else try_callstack_defaulting wc }
+
+    try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints
+    try_callstack_defaulting wc
+      | isEmptyWC wc
+      = return wc
+      | otherwise
+      = defaultCallStacks wc
+
+-- | Default any remaining @CallStack@ constraints to empty @CallStack at s.
+defaultCallStacks :: WantedConstraints -> TcS WantedConstraints
+-- See Note [Overview of implicit CallStacks] in TcEvidence
+defaultCallStacks wanteds
+  = do simples <- handle_simples (wc_simple wanteds)
+       implics <- mapBagM handle_implic (wc_impl wanteds)
+       return (wanteds { wc_simple = simples, wc_impl = implics })
+
+  where
+
+  handle_simples simples
+    = catBagMaybes <$> mapBagM defaultCallStack simples
+
+  handle_implic implic
+    = do { wanteds <- setEvBindsTcS (ic_binds implic) $
+                      -- defaultCallStack sets a binding, so
+                      -- we must set the correct binding group
+                      defaultCallStacks (ic_wanted implic)
+         ; return (implic { ic_wanted = wanteds }) }
+
+  defaultCallStack ct
+    | Just _ <- isCallStackPred (ctPred ct)
+    = do { solveCallStack (cc_ev ct) EvCsEmpty
+         ; return Nothing }
+
+  defaultCallStack ct
+    = return (Just ct)
 
 
 {- Note [Fail fast on kind errors]
@@ -1070,12 +1105,9 @@ solveWanteds wc@(WC { wc_simple = simples, wc_insol = insols, wc_impl = implics
        ; (floated_eqs, implics2) <- solveNestedImplications (implics `unionBags` implics1)
 
        ; dflags <- getDynFlags
-       ; wc2 <- simpl_loop 0 (solverIterations dflags) floated_eqs no_new_scs
-                             (WC { wc_simple = simples1, wc_impl = implics2
-                                 , wc_insol  = insols `unionBags` insols1 })
-
-       -- Do call-stack defaultin
-       ; final_wc <- defaultCallStacks wc2
+       ; final_wc <- simpl_loop 0 (solverIterations dflags) floated_eqs no_new_scs
+                                (WC { wc_simple = simples1, wc_impl = implics2
+                                    , wc_insol  = insols `unionBags` insols1 })
 
        ; bb <- TcS.getTcEvBindsMap
        ; traceTcS "solveWanteds }" $
@@ -1524,36 +1556,8 @@ Conclusion: we should call solveNestedImplications only if we did
 some unifiction in solveSimpleWanteds; because that's the only way
 we'll get more Givens (a unificaiton is like adding a Given) to
 allow the implication to make progress.
-
-Note [CallStack defaulting]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See Note [Overview of implicit CallStacks] in TcEvidence.
-
-We default an unsolved call stack to EvCsEmpty, in solveWanteds, after
-solving the wanteds as hard as we can, because that means that there
-are no gratuitous unsolved CallStack constraints lying around to
-clutter up the constraint tree. (Previously it was done in simpl_top,
-but that's really not the right place, because it left us with
-Unsolved impliations that has no wanted constraints, because
-defaultCallStacks had got rid of them.)
 -}
 
--- | Default any remaining @CallStack@ constraints to empty @CallStack at s.
--- See Note [CallStack defaulting]
-defaultCallStacks :: WantedConstraints -> TcS WantedConstraints
-defaultCallStacks wanteds@(WC { wc_simple = simples })
-  = do { simples' <- catBagMaybes <$> mapBagM defaultCallStack simples
-       ; return (wanteds { wc_simple = simples' }) }
-  where
-    defaultCallStack ct
-      | Just _ <- isCallStackPred (ctEvPred ev)
-      = do { solveCallStack ev EvCsEmpty
-           ; return Nothing }
-
-      | otherwise = return (Just ct)
-      where
-        ev = ctEvidence ct
-
 promoteTyVar :: TcLevel -> TcTyVar  -> TcM ()
 -- When we float a constraint out of an implication we must restore
 -- invariant (MetaTvInv) in Note [TcLevel and untouchable type variables] in TcType