This patch includes:

0) Typo in panic message.
1) prioritization of equalities over family equalities in the worklists.
2) rewriting of inert substitutions and solveds on-the-spot instead of
   kicking them out in the inerts. This required a monadic map over
   substitutions hence the modifications in UniqFM.
3) Just comments and removing stale commented code.

4) Useful SCC for simplifyInfer.

5) Making CoreStats outputable.

compiler/coreSyn/CoreUtils.lhs

@@ -1282,6 +1282,13 @@ altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
 \begin{code}
 data CoreStats = CS { cs_tm, cs_ty, cs_co :: Int }
 
+
+instance Outputable CoreStats where 
+ ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3 }) = 
+    text "size of" <+> vcat [ text "terms     =" <+> int i1
+                            , text "types     =" <+> int i2
+                            , text "coercions =" <+> int i3 ]
+
 plusCS :: CoreStats -> CoreStats -> CoreStats
 plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 })
        (CS { cs_tm = p2, cs_ty = q2, cs_co = r2 })

compiler/deSugar/Desugar.lhs

@@ -153,14 +153,8 @@ deSugar hsc_env
         -- You might think it doesn't matter, but the simplifier brings all top-level
         -- things into the in-scope set before simplifying; so we get no unfolding for F#!
 
-        -- Lint result if necessary, and print
-{-
-        ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
-               (vcat [ pprCoreBindings final_pgm
-                     , pprRules rules_for_imps ])
--}
-
 #ifdef DEBUG
+          -- Debug only as pre-simple-optimisation program may be really big
         ; endPass dflags CoreDesugar final_pgm rules_for_imps 
 #endif
         ; (ds_binds, ds_rules_for_imps, ds_vects) 

compiler/typecheck/TcCanonical.lhs

@@ -658,8 +658,9 @@ getCachedFlatEq tc xi_args fl feq_origin
        ; flat_cache <- getTcSEvVarFlatCache
        ; inerts <- getTcSInerts
        ; case lookupFunEq pty fl (inert_funeqs inerts) of
-           Nothing -> lookup_in_flat_cache pty flat_cache
-           res     -> return res }
+           Nothing 
+               -> lookup_in_flat_cache pty flat_cache
+           res -> return res }
   where lookup_in_flat_cache pty flat_cache 
           = case lookupTM pty flat_cache of
               Just (co',(xi',fl',when_generated)) -- ev' :: (TyConApp tc xi_args) ~ xi'
@@ -667,6 +668,9 @@ getCachedFlatEq tc xi_args fl feq_origin
                , feq_origin `origin_matches` when_generated
                -> do { traceTcS "getCachedFlatEq" $ text "success!"
                      ; (xi'',co) <- flatten 0 fl' xi' -- co :: xi'' ~ xi'
+                                    -- The only purpose of this flattening is to apply the
+                                    -- inert substitution (since everything in the flat cache
+                                    -- by construction will have a family-free RHS.
                      ; return $ Just (xi'', co' `mkTransCo` (mkSymCo co)) }
               _ -> do { traceTcS "getCachedFlatEq" $ text "failure!" <+> pprEvVarCache flat_cache
                       ; return Nothing }

compiler/typecheck/TcInteract.lhs

@@ -47,6 +47,9 @@ import Bag
 import Control.Monad ( foldM )
 import TrieMap
 
+import VarEnv
+import qualified Data.Traversable as Traversable
+
 import Control.Monad( when )
 import UniqFM
 import FastString ( sLit ) 
@@ -164,22 +167,14 @@ selectNextWorkItem max_depth
   = updWorkListTcS_return pick_next
   where 
     pick_next :: WorkList -> (SelectWorkItem, WorkList)
-    -- A simple priorititization of equalities (for now)
-    -- --------------------------------------------------------
-    pick_next wl@(WorkList { wl_eqs = eqs, wl_rest = rest })
-      = case (eqs,rest) of
-          ([],[])                        -- No more work
-              -> (NoWorkRemaining,wl)
-          ((ct:cts),_)
-            | cc_depth ct > max_depth  -- Depth exceeded
-            -> (MaxDepthExceeded ct,wl)
-            | otherwise                -- Equality work 
-            -> (NextWorkItem ct, wl { wl_eqs = cts })
-          ([],(ct:cts))
-            | cc_depth ct > max_depth  -- Depth exceeded
-            -> (MaxDepthExceeded ct,wl)
-            | otherwise                -- Non-equality work
-           -> (NextWorkItem ct, wl {wl_rest = cts})
+    pick_next wl = case selectWorkItem wl of
+                     (Nothing,_) 
+                         -> (NoWorkRemaining,wl)           -- No more work
+                     (Just ct, new_wl) 
+                         | cc_depth ct > max_depth         -- Depth exceeded
+                         -> (MaxDepthExceeded ct,new_wl)
+                     (Just ct, new_wl) 
+                         -> (NextWorkItem ct, new_wl)      -- New workitem and worklist
 
 runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline 
                   -> WorkItem                   -- The work item 
@@ -315,24 +310,23 @@ kickOutRewritableInerts :: Ct -> TcS ()
 -- Pre:  ct is a CTyEqCan 
 -- Post: the TcS monad is left with the thinner non-rewritable inerts; the 
 --       rewritable end up in the worklist
-kickOutRewritableInerts ct 
-  = do { wl <- modifyInertTcS (kick_out_rewritable ct)
+kickOutRewritableInerts ct
+  = do { (wl,ieqs,solved_out) <- modifyInertTcS (kick_out_rewritable ct)
 
-         -- Rewrite the rewritable solved on the spot and stick them back in the inerts
+       -- Rewrite the inert_eqs on the spot! 
+       ; let ct_subst = unitVarEnv (cc_tyvar ct) (ct, mkEqVarLCo (cc_id ct))
+             inscope  = mkInScopeSet $ tyVarsOfCt ct
 
-{- DV: I am commenting out the solved story altogether because I did not see any performance
-       improvement compared to just kicking out the solved ones any way. In fact there were
-       situations where performance got worse.
+       ; new_ieqs <- rewriteInertEqsFromInertEq (ct_subst,inscope) ieqs
+       ; modifyInertTcS (\is -> ((), is { inert_eqs = new_ieqs }))
+
+
+       -- Rewrite the rewritable solved on the spot and stick them back in the inerts
+       ; _unused <- mapBagM (rewrite_solved (ct_subst,inscope)) solved_out
 
-       ; let subst = unitVarEnv (cc_tyvar ct) (ct, mkEqVarLCo (cc_id ct))
-             inscope = mkInScopeSet $ tyVarsOfCt ct
-       ; solved_rewritten <- mapBagM (rewrite_solved (subst,inscope)) solved_out
-       ; _unused <- modifyInertTcS (add_new_solveds solved_rewritten)
-      
--}
        ; traceTcS "Kick out" (ppr ct $$ ppr wl)
        ; updWorkListTcS (unionWorkList wl) }
-{- 
+
   where rewrite_solved inert_eqs solved_ct 
           = do { (new_ev,_) <- rewriteFromInertEqs inert_eqs fl ev
                ; mk_canonical new_ev }
@@ -344,19 +338,24 @@ kickOutRewritableInerts ct
                   = do { let new_pty = evVarPred new_ev
                        ; r <- canEvVar new_ev (classifyPredType new_pty) d fl
                        ; case r of
-                           Stop -> pprPanic "kickOutRewritableInerts" $ 
-                                   vcat [ text "Should never Stop, solved constraint IS canonical!"
-                                        , text "Orig (solved)     =" <+> ppr solved_ct
-                                        , text "Rewritten (solved)=" <+> ppr new_pty ]
-                           ContinueWith ct -> return ct }
-        add_new_solveds cts is = ((), is { inert_solved = new_solved })
-           where orig_solveds     = inert_solved is
-                 do_one slvmap ct = let ct_key = mkPredKeyForTypeMap ct
-                                    in alterTM ct_key (\_ -> Just ct) slvmap
-                 new_solved       = foldlBag do_one orig_solveds cts
--}
-
-kick_out_rewritable :: Ct -> InertSet -> (WorkList,InertSet)
+                           Stop -> return ()
+                           ContinueWith ct -> updInertSetTcS ct }
+
+
+rewriteInertEqsFromInertEq :: (TyVarEnv (Ct,Coercion), InScopeSet) -- A new substitution
+                           -> TyVarEnv (Ct,Coercion)               -- The inert equalities
+                           -> TcS (TyVarEnv (Ct,Coercion))         -- The new inert equalities
+rewriteInertEqsFromInertEq the_subst ieqs = Traversable.mapM do_one ieqs
+ where do_one (ct,co)
+        | ev <- cc_id ct, fl <- cc_flavor ct
+        = do { (new_ev,not_rewritten) <- rewriteFromInertEqs the_subst fl ev
+             ; let EqPred _ xi = classifyPredType (evVarPred new_ev)
+             ; if not_rewritten then 
+                   return (ct,co) -- return the same
+               else
+                   return (ct { cc_id = new_ev, cc_rhs = xi }, mkEqVarLCo new_ev) }
+
+kick_out_rewritable :: Ct -> InertSet -> ((WorkList,TyVarEnv (Ct,Coercion),Cts), InertSet)
 kick_out_rewritable ct (IS { inert_eqs    = eqmap
                            , inert_eq_tvs = inscope
                            , inert_dicts  = dictmap
@@ -365,12 +364,13 @@ kick_out_rewritable ct (IS { inert_eqs    = eqmap
                            , inert_irreds = irreds
                            , inert_frozen = frozen
                            } )
-  = (kicked_out, remaining)
+  = ((kicked_out, eqs_in, feqs_out_solved `andCts` dicts_out_solved), remaining)
   where
 
-    kicked_out = WorkList { wl_eqs  = eqs_out ++ bagToList feqs_out
-                          , wl_rest = bagToList (fro_out `andCts` dicts_out 
-                                        `andCts` ips_out `andCts` irs_out) }
+    kicked_out = WorkList { wl_eqs    = eqs_out
+                          , wl_funeqs = bagToList feqs_out
+                          , wl_rest   = bagToList (fro_out `andCts` dicts_out 
+                                          `andCts` ips_out `andCts` irs_out) }
   
     remaining = IS { inert_eqs = eqs_in
                    , inert_eq_tvs = inscope -- keep the same, safe and cheap
@@ -383,18 +383,37 @@ kick_out_rewritable ct (IS { inert_eqs    = eqmap
 
     fl = cc_flavor ct
     tv = cc_tyvar ct
+          
+    (eqs_out,   eqs_in)   = partitionEqMap
+                               (\inert_ct -> rewritable inert_ct && 
+                                             not (cc_flavor inert_ct `canRewrite` fl)) eqmap
+                               -- Delicate: 
+                               -- We want to throw out only the rewritables which cannot
+                               -- themselves rewrite the workitem. Because, what will remain
+                               -- in eqs_in, even if rewritable, can be readily substituted
+                               -- in-place from the new item, without dangers for occurs
+                               -- loops or further need for canonicalization.
+
+    (ips_out,   ips_in)         = partitionCCanMap rewritable ipmap
 
-    (eqs_out,   eqs_in)   = partitionEqMap rewritable eqmap
-    (ips_out,   ips_in)   = partitionCCanMap rewritable ipmap 
+    (feqs_out_all,  feqs_in)    = partitionCtTypeMap rewritable funeqmap
+    (feqs_out_solved, feqs_out) = partitionBag is_solved feqs_out_all
 
-    (feqs_out,  feqs_in)  = partitionCtTypeMap rewritable funeqmap
-    (dicts_out, dicts_in) = partitionCCanMap rewritable dictmap
+    (dicts_out_all, dicts_in) = partitionCCanMap rewritable dictmap
+    (dicts_out_solved, dicts_out) = partitionBag is_solved dicts_out_all
 
     (irs_out,   irs_in)   = partitionBag rewritable irreds
     (fro_out,   fro_in)   = partitionBag rewritable frozen
-    rewritable ct = (fl `canRewrite` cc_flavor ct) && 
+
+    rewritable ct = (fl `canRewrite` cc_flavor ct)  &&
                     (tv `elemVarSet` tyVarsOfCt ct)
 
+    is_solved ct
+      | Just GivenSolved <- isGiven_maybe (cc_flavor ct)
+      = True
+      | otherwise = False
+
+      
 
                              
 data SPSolveResult = SPCantSolve
@@ -1387,8 +1406,8 @@ doTopReact _inerts workItem@(CFunEqCan { cc_id = eqv, cc_flavor = fl
 
                                        ; return $ 
                                          SomeTopInt { tir_rule = "Fun/Top (solved, more work)"
-                                                    , tir_new_item = ContinueWith solved } } 
-                       -- Cache in inerts the Solved item
+                                                    , tir_new_item = ContinueWith solved } }
+                                                     -- Cache in inerts the Solved item
 
                        Given {} -> do { eqv' <- newGivenEqVar fl xi rhs_ty $ 
                                                 mkSymCo (mkEqVarLCo eqv) `mkTransCo` coe

compiler/typecheck/TcRnDriver.lhs

@@ -1435,6 +1435,7 @@ tcRnExpr hsc_env ictxt rdr_expr
     let { fresh_it  = itName uniq (getLoc rdr_expr) } ;
     ((_tc_expr, res_ty), lie)	<- captureConstraints (tcInferRho rn_expr) ;
     ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ 
+                                      {-# SCC "simplifyInfer" #-}
                                       simplifyInfer True {- Free vars are closed -}
                                                     False {- No MR for now -}
                                                     [(fresh_it, res_ty)]

compiler/typecheck/TcRnMonad.lhs

@@ -1011,7 +1011,7 @@ emitWantedCts = mapBagM_ emit_wanted_ct
           | v <- cc_id ct 
           , Wanted loc <- cc_flavor ct 
           = emitFlat (EvVarX v loc)
-          | otherwise = panic "emitWantecCts: can't emit non-wanted!"
+          | otherwise = panic "emitWantedCts: can't emit non-wanted!"
 
 emitImplication :: Implication -> TcM ()
 emitImplication ct

compiler/typecheck/TcSMonad.lhs

@@ -14,7 +14,7 @@ module TcSMonad (
     WorkList(..), isEmptyWorkList, emptyWorkList,
     workListFromEq, workListFromNonEq, workListFromCt, 
     extendWorkListEq, extendWorkListNonEq, extendWorkListCt, 
-    appendWorkListCt, appendWorkListEqs, unionWorkList,
+    appendWorkListCt, appendWorkListEqs, unionWorkList, selectWorkItem,
 
     getTcSWorkList, updWorkListTcS, updWorkListTcS_return, keepWanted,
 
@@ -207,17 +207,22 @@ better rewrite it as much as possible before reporting it as an error to the use
 \begin{code}
 
 -- See Note [WorkList]
-data WorkList = WorkList { wl_eqs  :: [Ct], wl_rest :: [Ct] }
+data WorkList = WorkList { wl_eqs  :: [Ct], wl_funeqs :: [Ct], wl_rest :: [Ct] }
 
 
 unionWorkList :: WorkList -> WorkList -> WorkList
 unionWorkList new_wl orig_wl = 
-   WorkList { wl_eqs = wl_eqs new_wl ++ wl_eqs orig_wl
-            , wl_rest = wl_rest new_wl ++ wl_rest orig_wl }
+   WorkList { wl_eqs    = wl_eqs new_wl ++ wl_eqs orig_wl
+            , wl_funeqs = wl_funeqs new_wl ++ wl_funeqs orig_wl
+            , wl_rest   = wl_rest new_wl ++ wl_rest orig_wl }
 
 extendWorkListEq :: Ct -> WorkList -> WorkList
 -- Extension by equality
-extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }
+extendWorkListEq ct wl 
+  | Just {} <- isCFunEqCan_Maybe ct
+  = wl { wl_funeqs = ct : wl_funeqs wl }
+  | otherwise
+  = wl { wl_eqs = ct : wl_eqs wl }
 
 extendWorkListNonEq :: Ct -> WorkList -> WorkList
 -- Extension by non equality
@@ -238,25 +243,36 @@ appendWorkListEqs :: [Ct] -> WorkList -> WorkList
 appendWorkListEqs cts wl = foldr extendWorkListEq wl cts
 
 isEmptyWorkList :: WorkList -> Bool
-isEmptyWorkList wl = null (wl_eqs wl) &&  null (wl_rest wl)
+isEmptyWorkList wl 
+  = null (wl_eqs wl) &&  null (wl_rest wl) && null (wl_funeqs wl)
 
 emptyWorkList :: WorkList
-emptyWorkList = WorkList { wl_eqs  = [], wl_rest = [] }
+emptyWorkList = WorkList { wl_eqs  = [], wl_rest = [], wl_funeqs = []}
 
 workListFromEq :: Ct -> WorkList
-workListFromEq ct = WorkList { wl_eqs = [ct], wl_rest = [] }
+workListFromEq ct = extendWorkListEq ct emptyWorkList
 
 workListFromNonEq :: Ct -> WorkList
-workListFromNonEq ct = WorkList { wl_eqs = [], wl_rest = [ct] }
+workListFromNonEq ct = extendWorkListNonEq ct emptyWorkList
 
 workListFromCt :: Ct -> WorkList
 -- Agnostic 
 workListFromCt ct | isLCoVar (cc_id ct) = workListFromEq ct 
                   | otherwise           = workListFromNonEq ct
 
+
+selectWorkItem :: WorkList -> (Maybe Ct, WorkList)
+selectWorkItem wl@(WorkList { wl_eqs = eqs, wl_funeqs = feqs, wl_rest = rest })
+  = case (eqs,feqs,rest) of
+      (ct:cts,_,_)     -> (Just ct, wl { wl_eqs    = cts })
+      (_,(ct:cts),_)   -> (Just ct, wl { wl_funeqs = cts })
+      (_,_,(ct:cts))   -> (Just ct, wl { wl_rest   = cts })
+      (_,_,_)          -> (Nothing,wl)
+
 -- Pretty printing 
 instance Outputable WorkList where 
   ppr wl = vcat [ text "WorkList (eqs)   = " <+> ppr (wl_eqs wl)
+                , text "WorkList (funeqs)= " <+> ppr (wl_funeqs wl)
                 , text "WorkList (rest)  = " <+> ppr (wl_rest wl)
                 ]
 
@@ -483,14 +499,6 @@ updInertSet is item
         inscope' = extendInScopeSetSet (inert_eq_tvs is) (tyVarsOfCt item)
     in is { inert_eqs = eqs', inert_eq_tvs = inscope' }
 
-{-
-       -- /Solved/ non-equalities go to the solved map
-  | Just GivenSolved <- isGiven_maybe (cc_flavor item)
-  = let pty = mkPredKeyForTypeMap item
-        solved_orig = inert_solved is
-    in is { inert_solved = alterTM pty (\_ -> Just item) solved_orig }
--}
-
   | Just x  <- isCIPCan_Maybe item      -- IP 
   = is { inert_ips   = updCCanMap (x,item) (inert_ips is) }  
   | isCIrredEvCan item                  -- Presently-irreducible evidence
@@ -1267,7 +1275,15 @@ newEvVar :: CtFlavor -> TcPredType -> TcS EvVarCreated
 --     the call sites for this invariant to be quickly restored.
 newEvVar fl pty
   | isGivenOrSolved fl    -- Create new variable and update the cache
-  = do { new <- forceNewEvVar fl pty
+  = do { eref <- getTcSEvVarCache
+       ; ecache <- wrapTcS (TcM.readTcRef eref)
+       ; case lookupTM pty (evc_cache ecache) of
+           Just (_,cached_fl) 
+               | cached_fl `canSolve` fl 
+               -> pprTrace "Interesting: given newEvVar, missed caching opportunity!" empty $
+                  return ()
+           _ -> return ()
+       ; new <- forceNewEvVar fl pty
        ; return (EvVarCreated True new) }
 
   | otherwise             -- Otherwise lookup first
@@ -1442,14 +1458,24 @@ rewriteFromInertEqs (subst,inscope) fl v
        ; if isReflCo co then return (v,True)
          else do { traceTcS "rewriteFromInertEqs" $
                    text "Original item =" <+> ppr v <+> dcolon <+> ppr (evVarPred v)
-                 ; v' <- forceNewEvVar fl (pSnd (liftedCoercionKind co))
-                 ; case fl of 
-                     Wanted {}  -> setEvBind v (EvCast v' (mkSymCo co)) 
-                     Given {}   -> setEvBind v' (EvCast v co) 
-                     Derived {} -> return ()
-                 ; traceTcS "rewriteFromInertEqs" $
-                   text "Rewritten item =" <+> ppr v' <+> dcolon <+> ppr (evVarPred v')
-                 ; return (v',False) } }
+                 ; delCachedEvVar v
+                 ; evc <- newEvVar fl (pSnd (liftedCoercionKind co))
+                 ; let v' = evc_the_evvar evc
+                 ; if isNewEvVar evc then 
+                       do { case fl of 
+                              Wanted {}  -> setEvBind v (EvCast v' (mkSymCo co)) 
+                              Given {}   -> setEvBind v' (EvCast v co) 
+                              Derived {} -> return () 
+                          ; traceTcS "rewriteFromInertEqs" $
+                            text "Rewritten item =" <+> ppr v' <+>
+                                          dcolon <+> ppr (evVarPred v')
+                          ; return (v',False) } 
+                   else -- Maybe given, but when wanted set bind
+                       do { case fl of 
+                              Wanted {} -> setEvBind v (EvCast v' (mkSymCo co))
+                              _ -> return ()
+                          ; return (v',True) } -- As if rewriting never happened?
+                 } } 
 
 
 -- See Note [LiftInertEqs]

compiler/utils/UniqFM.lhs

@@ -20,7 +20,7 @@ and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order
 of arguments of combining function.
 
 \begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
+{-# OPTIONS -fno-warn-tabs -XGeneralizedNewtypeDeriving #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and
 -- detab the module (please do the detabbing in a separate patch). See
@@ -74,6 +74,7 @@ import Compiler.Hoopl   hiding (Unique)
 import Data.Function (on)
 import qualified Data.IntMap as M
 import qualified Data.Foldable as Foldable
+import qualified Data.Traversable as Traversable
 import Data.Typeable
 import Data.Data
 \end{code}
@@ -179,11 +180,19 @@ ufmToList	:: UniqFM elt -> [(Unique, elt)]
 
 \begin{code}
 newtype UniqFM ele = UFM { unUFM :: M.IntMap ele }
-  deriving (Typeable,Data)
+  deriving (Typeable,Data, Traversable.Traversable, Functor)
 
 instance Eq ele => Eq (UniqFM ele) where
     (==) = (==) `on` unUFM
 
+{-
+instance Functor UniqFM where
+   fmap f = fmap f . unUFM
+
+instance Traversable.Traversable UniqFM where 
+    traverse f = Traversable.traverse f . unUFM
+-}
+
 instance Foldable.Foldable UniqFM where
     foldMap f = Foldable.foldMap f . unUFM