[commit: ghc] master: Optimise partitionFunEqs for the 'false' case (37c2ed4)

[git at git.haskell.org]

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

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

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

commit 37c2ed4bc3d4ff0a4681e9d27c7f748886e413f6
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon Dec 8 11:50:21 2014 +0000

    Optimise partitionFunEqs for the 'false' case
    
    In the examples from Trac #9872 we were getting a large set of inert CFunEqCans,
    and partitioning them was taking ages.  This patch improves it somewhat by optimising
    the partition for the case where the predicat is false.
    
    The ticket has more info.


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

37c2ed4bc3d4ff0a4681e9d27c7f748886e413f6
 compiler/typecheck/TcSMonad.hs | 22 ++++++++++++++--------
 1 file changed, 14 insertions(+), 8 deletions(-)

diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index 4775394..ffdfb27 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -960,17 +960,23 @@ filterFunEqs = filterTcAppMap
 insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a
 insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val
 
-insertFunEqCt :: FunEqMap Ct -> Ct -> FunEqMap Ct
-insertFunEqCt m ct@(CFunEqCan { cc_fun = tc, cc_tyargs = tys })
-  = insertFunEq m tc tys ct
-insertFunEqCt _ ct = pprPanic "insertFunEqCt" (ppr ct)
+-- insertFunEqCt :: FunEqMap Ct -> Ct -> FunEqMap Ct
+-- insertFunEqCt m ct@(CFunEqCan { cc_fun = tc, cc_tyargs = tys })
+--  = insertFunEq m tc tys ct
+-- insertFunEqCt _ ct = pprPanic "insertFunEqCt" (ppr ct)
 
 partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> (Bag Ct, FunEqMap Ct)
-partitionFunEqs f m = foldTcAppMap k m (emptyBag, emptyFunEqs)
+-- Optimise for the case where the predicate is false
+-- partitionFunEqs is called only from kick-out, and kick-out usually
+-- kicks out very few equalities, so we want to optimise for that case
+partitionFunEqs f m = (yeses, foldrBag del m yeses)
   where
-    k ct (yeses, noes)
-      | f ct      = (yeses `snocBag` ct, noes)
-      | otherwise = (yeses, insertFunEqCt noes ct)
+    yeses = foldTcAppMap k m emptyBag
+    k ct yeses | f ct      = yeses `snocBag` ct
+               | otherwise = yeses
+    del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m
+        = delFunEq m tc tys
+    del ct _ = pprPanic "partitionFunEqs" (ppr ct)
 
 delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a
 delFunEq m tc tys = delTcApp m (getUnique tc) tys