Commit 12306294 authored by niteria's avatar niteria
Browse files

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
parent 97a50f82
...@@ -39,8 +39,8 @@ import Pair ...@@ -39,8 +39,8 @@ import Pair
import Panic import Panic
import VarSet import VarSet
import Control.Monad import Control.Monad
import Data.Map (Map) import Data.Set (Set)
import qualified Data.Map as Map import qualified Data.Set as Set
#include "HsVersions.h" #include "HsVersions.h"
...@@ -120,28 +120,25 @@ certain that the modules in our `HscTypes.dep_finsts' are consistent.) ...@@ -120,28 +120,25 @@ certain that the modules in our `HscTypes.dep_finsts' are consistent.)
-- whose family instances need to be checked for consistency. -- whose family instances need to be checked for consistency.
-- --
data ModulePair = ModulePair Module Module 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 -- | Smart constructor that establishes the invariant
-- modulePair :: Module -> Module -> ModulePair
canon :: ModulePair -> (Module, Module) modulePair a b
canon (ModulePair m1 m2) | m1 < m2 = (m1, m2) | a < b = ModulePair a b
| otherwise = (m2, m1) | otherwise = ModulePair b a
instance Eq ModulePair where
mp1 == mp2 = canon mp1 == canon mp2
instance Ord ModulePair where
mp1 `compare` mp2 = canon mp1 `compare` canon mp2
instance Outputable ModulePair where instance Outputable ModulePair where
ppr (ModulePair m1 m2) = angleBrackets (ppr m1 <> comma <+> ppr m2) ppr (ModulePair m1 m2) = angleBrackets (ppr m1 <> comma <+> ppr m2)
-- Sets of module pairs -- Sets of module pairs
-- --
type ModulePairSet = Map ModulePair () type ModulePairSet = Set ModulePair
listToSet :: [ModulePair] -> ModulePairSet listToSet :: [ModulePair] -> ModulePairSet
listToSet l = Map.fromList (zip l (repeat ())) listToSet l = Set.fromList l
checkFamInstConsistency :: [Module] -> [Module] -> TcM () checkFamInstConsistency :: [Module] -> [Module] -> TcM ()
-- See Note [Checking family instance consistency] -- See Note [Checking family instance consistency]
...@@ -167,7 +164,8 @@ checkFamInstConsistency famInstMods directlyImpMods ...@@ -167,7 +164,8 @@ checkFamInstConsistency famInstMods directlyImpMods
-- instances of okPairs are consistent -- instances of okPairs are consistent
; criticalPairs = listToSet $ allPairs famInstMods ; criticalPairs = listToSet $ allPairs famInstMods
-- all pairs that we need to consider -- 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 -- the difference gives us the pairs we need to check now
} }
...@@ -175,7 +173,7 @@ checkFamInstConsistency famInstMods directlyImpMods ...@@ -175,7 +173,7 @@ checkFamInstConsistency famInstMods directlyImpMods
} }
where where
allPairs [] = [] 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) check hpt_fam_insts (ModulePair m1 m2)
= do { env1 <- getFamInsts hpt_fam_insts m1 = do { env1 <- getFamInsts hpt_fam_insts m1
......
...@@ -52,7 +52,7 @@ test('haddock.base', ...@@ -52,7 +52,7 @@ test('haddock.base',
test('haddock.Cabal', test('haddock.Cabal',
[unless(in_tree_compiler(), skip), req_haddock [unless(in_tree_compiler(), skip), req_haddock
,stats_num_field('bytes allocated', ,stats_num_field('bytes allocated',
[(wordsize(64), 10997887320, 5) [(wordsize(64), 10070330520, 5)
# 2012-08-14: 3255435248 (amd64/Linux) # 2012-08-14: 3255435248 (amd64/Linux)
# 2012-08-29: 3324606664 (amd64/Linux, new codegen) # 2012-08-29: 3324606664 (amd64/Linux, new codegen)
# 2012-10-08: 3373401360 (amd64/Linux) # 2012-10-08: 3373401360 (amd64/Linux)
...@@ -82,6 +82,7 @@ test('haddock.Cabal', ...@@ -82,6 +82,7 @@ test('haddock.Cabal',
# 2016-04-07: 10963514352 (amd64/Linux) - Revert to what phabricator claims # 2016-04-07: 10963514352 (amd64/Linux) - Revert to what phabricator claims
# 2016-05-22: 11805238152 (amd64/Linux) - Make Generic1 poly-kinded # 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-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) ,(platform('i386-unknown-mingw32'), 3293415576, 5)
# 2012-10-30: 1733638168 (x86/Windows) # 2012-10-30: 1733638168 (x86/Windows)
...@@ -103,7 +104,7 @@ test('haddock.Cabal', ...@@ -103,7 +104,7 @@ test('haddock.Cabal',
test('haddock.compiler', test('haddock.compiler',
[unless(in_tree_compiler(), skip), req_haddock [unless(in_tree_compiler(), skip), req_haddock
,stats_num_field('bytes allocated', ,stats_num_field('bytes allocated',
[(wordsize(64), 58017214568, 10) [(wordsize(64), 55314944264, 10)
# 2012P-08-14: 26070600504 (amd64/Linux) # 2012P-08-14: 26070600504 (amd64/Linux)
# 2012-08-29: 26353100288 (amd64/Linux, new CG) # 2012-08-29: 26353100288 (amd64/Linux, new CG)
# 2012-09-18: 26882813032 (amd64/Linux) # 2012-09-18: 26882813032 (amd64/Linux)
...@@ -117,6 +118,7 @@ test('haddock.compiler', ...@@ -117,6 +118,7 @@ test('haddock.compiler',
# 2015-12-03: 44721228752 (amd64/Linux) slow creep upwards # 2015-12-03: 44721228752 (amd64/Linux) slow creep upwards
# 2015-12-15: 49395782136 (amd64/Linux) more creep, following kind-equalities # 2015-12-15: 49395782136 (amd64/Linux) more creep, following kind-equalities
# 2015-12-17: 58017214568 (amd64/Linux) update Haddock to master # 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) ,(platform('i386-unknown-mingw32'), 902576468, 10)
# 2012-10-30: 13773051312 (x86/Windows) # 2012-10-30: 13773051312 (x86/Windows)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment