[commit: ghc] master: Make checkFamInstConsistency less expensive (1230629)

[git at git.haskell.org]

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

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

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

commit 123062946dfdbcfc24abd468e24e358118b8e2eb
Author: Bartosz Nitka <niteria at gmail.com>
Date:   Tue Jun 21 15:54:00 2016 -0700

    Make checkFamInstConsistency less expensive
    
    Doing canonicalization on every comparison turned
    out to be very expensive.
    
    Caching the canonicalization through the smart `modulePair` constructor
    gives `8%` reduction in allocations on `haddock.compiler` and
    `8.5%` reduction in allocations on `haddock.Cabal`.
    Possibly other things as well, but it's really visible in Haddock.
    
    Test Plan: ./validate
    
    Reviewers: jstolarek, simonpj, austin, simonmar, bgamari
    
    Reviewed By: simonpj, simonmar
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D2350
    
    GHC Trac Issues: #12191


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

123062946dfdbcfc24abd468e24e358118b8e2eb
 compiler/typecheck/FamInst.hs      | 32 +++++++++++++++-----------------
 testsuite/tests/perf/haddock/all.T |  6 ++++--
 2 files changed, 19 insertions(+), 19 deletions(-)

diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs
index a18bd9c..403639a 100644
--- a/compiler/typecheck/FamInst.hs
+++ b/compiler/typecheck/FamInst.hs
@@ -39,8 +39,8 @@ import Pair
 import Panic
 import VarSet
 import Control.Monad
-import Data.Map (Map)
-import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
 
 #include "HsVersions.h"
 
@@ -120,28 +120,25 @@ certain that the modules in our `HscTypes.dep_finsts' are consistent.)
 -- whose family instances need to be checked for consistency.
 --
 data ModulePair = ModulePair Module Module
+                  -- Invariant: first Module < second Module
+                  -- use the smart constructor
+  deriving (Ord, Eq)
 
--- canonical order of the components of a module pair
---
-canon :: ModulePair -> (Module, Module)
-canon (ModulePair m1 m2) | m1 < m2   = (m1, m2)
-                         | otherwise = (m2, m1)
-
-instance Eq ModulePair where
-  mp1 == mp2 = canon mp1 == canon mp2
-
-instance Ord ModulePair where
-  mp1 `compare` mp2 = canon mp1 `compare` canon mp2
+-- | Smart constructor that establishes the invariant
+modulePair :: Module -> Module -> ModulePair
+modulePair a b
+  | a < b = ModulePair a b
+  | otherwise = ModulePair b a
 
 instance Outputable ModulePair where
   ppr (ModulePair m1 m2) = angleBrackets (ppr m1 <> comma <+> ppr m2)
 
 -- Sets of module pairs
 --
-type ModulePairSet = Map ModulePair ()
+type ModulePairSet = Set ModulePair
 
 listToSet :: [ModulePair] -> ModulePairSet
-listToSet l = Map.fromList (zip l (repeat ()))
+listToSet l = Set.fromList l
 
 checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
 -- See Note [Checking family instance consistency]
@@ -167,7 +164,8 @@ checkFamInstConsistency famInstMods directlyImpMods
                  -- instances of okPairs are consistent
              ; criticalPairs = listToSet $ allPairs famInstMods
                  -- all pairs that we need to consider
-             ; toCheckPairs  = Map.keys $ criticalPairs `Map.difference` okPairs
+             ; toCheckPairs  =
+                 Set.elems $ criticalPairs `Set.difference` okPairs
                  -- the difference gives us the pairs we need to check now
              }
 
@@ -175,7 +173,7 @@ checkFamInstConsistency famInstMods directlyImpMods
        }
   where
     allPairs []     = []
-    allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms
+    allPairs (m:ms) = map (modulePair m) ms ++ allPairs ms
 
     check hpt_fam_insts (ModulePair m1 m2)
       = do { env1 <- getFamInsts hpt_fam_insts m1
diff --git a/testsuite/tests/perf/haddock/all.T b/testsuite/tests/perf/haddock/all.T
index 3f4926a..b9a3ab3 100644
--- a/testsuite/tests/perf/haddock/all.T
+++ b/testsuite/tests/perf/haddock/all.T
@@ -52,7 +52,7 @@ test('haddock.base',
 test('haddock.Cabal',
      [unless(in_tree_compiler(), skip), req_haddock
      ,stats_num_field('bytes allocated',
-          [(wordsize(64), 10997887320, 5)
+          [(wordsize(64), 10070330520, 5)
             # 2012-08-14: 3255435248 (amd64/Linux)
             # 2012-08-29: 3324606664 (amd64/Linux, new codegen)
             # 2012-10-08: 3373401360 (amd64/Linux)
@@ -82,6 +82,7 @@ test('haddock.Cabal',
             # 2016-04-07: 10963514352 (amd64/Linux) - Revert to what phabricator claims
             # 2016-05-22: 11805238152 (amd64/Linux) - Make Generic1 poly-kinded
             # 2016-06-05: 10997887320 (amd64/Linux) - Refactor derived Generic instances to reduce allocations
+            # 2016-06-21: 10070330520 (amd64/Linux) - D2350: Make checkFamInstConsistency less expensive
 
           ,(platform('i386-unknown-mingw32'), 3293415576, 5)
             # 2012-10-30:                     1733638168 (x86/Windows)
@@ -103,7 +104,7 @@ test('haddock.Cabal',
 test('haddock.compiler',
      [unless(in_tree_compiler(), skip), req_haddock
      ,stats_num_field('bytes allocated',
-          [(wordsize(64), 58017214568, 10)
+          [(wordsize(64), 55314944264, 10)
             # 2012P-08-14: 26070600504 (amd64/Linux)
             # 2012-08-29: 26353100288 (amd64/Linux, new CG)
             # 2012-09-18: 26882813032 (amd64/Linux)
@@ -117,6 +118,7 @@ test('haddock.compiler',
             # 2015-12-03: 44721228752 (amd64/Linux) slow creep upwards
             # 2015-12-15: 49395782136 (amd64/Linux) more creep, following kind-equalities
             # 2015-12-17: 58017214568 (amd64/Linux) update Haddock to master
+            # 2016-06-21: 55314944264 (amd64/Linux) D2350: Make checkFamInstConsistency less expensive
 
           ,(platform('i386-unknown-mingw32'),   902576468, 10)
             # 2012-10-30:                     13773051312 (x86/Windows)