From 7cecbd969298d5aa576750864a69fa5f70f71c32 Mon Sep 17 00:00:00 2001 From: Doug Wilson Date: Wed, 21 Jun 2017 19:27:33 +1200 Subject: Use new function getNameToInstancesIndex instead of tcRnGetInfo (#636) There is some performance improvement. GHC compiler: | version | bytes allocated | cpu_seconds --------------------------------- | before | 56057108648 | 41.0 | after | 51592019560 | 35.1 base: | version | bytes allocated | cpu_seconds --------------------------------- | before | 25174011784 | 14.6 | after | 23712637272 | 13.1 Cabal: | version | bytes allocated | cpu_seconds --------------------------------- | before | 18754966920 | 12.6 | after | 18198208864 | 11.6 --- .../src/Haddock/Interface/AttachInstances.hs | 82 +++++++++++----------- 1 file changed, 41 insertions(+), 41 deletions(-) (limited to 'haddock-api/src/Haddock') diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 6d0bed2a..1eb227b9 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -23,9 +23,10 @@ import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) import Data.Function (on) -import Data.Maybe ( maybeToList, mapMaybe ) +import Data.Maybe ( maybeToList, mapMaybe, fromMaybe ) import qualified Data.Map as Map import qualified Data.Set as Set +import Control.Monad import Class import DynFlags @@ -38,10 +39,10 @@ import GhcMonad (withSession) import InstEnv import MonadUtils (liftIO) import Name +import NameEnv import Outputable (text, sep, (<+>)) import PrelNames import SrcLoc -import TcRnDriver (tcRnGetInfo) import TyCon import TyCoRep import TysPrim( funTyCon ) @@ -54,13 +55,15 @@ type ExportInfo = (ExportedNames, Modules) -- Also attaches fixities attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface] -attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces +attachInstances expInfo ifaces instIfaceMap = do + (_msgs, mb_index) <- getNameToInstancesIndex + mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces where -- TODO: take an IfaceMap as input ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ] - attach iface = do - newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap) + attach index iface = do + newItems <- mapM (attachToExportItem index expInfo iface ifaceMap instIfaceMap) (ifaceExportItems iface) let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface) return $ iface { ifaceExportItems = newItems @@ -76,37 +79,42 @@ attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = ] -attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap - -> ExportItem GhcRn - -> Ghc (ExportItem GhcRn) -attachToExportItem expInfo iface ifaceMap instIfaceMap export = +attachToExportItem + :: NameEnv ([ClsInst], [FamInst]) + -> ExportInfo + -> Interface + -> IfaceMap + -> InstIfaceMap + -> ExportItem GhcRn + -> Ghc (ExportItem GhcRn) +attachToExportItem index expInfo iface ifaceMap instIfaceMap export = case attachFixities export of e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do - mb_info <- getAllInfo (tcdName d) - insts <- case mb_info of - Just (_, _, cls_instances, fam_instances) -> - let fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) ) - | i <- sortBy (comparing instFam) fam_instances - , let n = getName i - , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap - , not $ isNameHidden expInfo (fi_fam i) - , not $ any (isTypeHidden expInfo) (fi_tys i) - , let opaque = isTypeHidden expInfo (fi_rhs i) - ] - cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d))) - | let is = [ (instanceSig i, getName i) | i <- cls_instances ] - , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is - , not $ isInstanceHidden expInfo cls tys - ] + insts <- + let mb_instances = lookupNameEnv index (tcdName d) + cls_instances = maybeToList mb_instances >>= fst + fam_instances = maybeToList mb_instances >>= snd + fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) ) + | i <- sortBy (comparing instFam) fam_instances + , let n = getName i + , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap + , not $ isNameHidden expInfo (fi_fam i) + , not $ any (isTypeHidden expInfo) (fi_tys i) + , let opaque = isTypeHidden expInfo (fi_rhs i) + ] + cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d))) + | let is = [ (instanceSig i, getName i) | i <- cls_instances ] + , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is + , not $ isInstanceHidden expInfo cls tys + ] -- fam_insts but with failing type fams filtered out - cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ] - famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ] - in do - dfs <- getDynFlags - let mkBug = (text "haddock-bug:" <+>) . text - liftIO $ putMsg dfs (sep $ map mkBug famInstErrs) - return $ cls_insts ++ cleanFamInsts - Nothing -> return [] + cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ] + famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ] + in do + dfs <- getDynFlags + let mkBug = (text "haddock-bug:" <+>) . text + liftIO $ putMsg dfs (sep $ map mkBug famInstErrs) + return $ cls_insts ++ cleanFamInsts return $ e { expItemInstances = insts } e -> return e where @@ -143,14 +151,6 @@ instLookup f name iface ifaceMap instIfaceMap = iface' <- Map.lookup (nameModule name) ifaceMaps Map.lookup name (f iface') --- | Like GHC's getInfo but doesn't cut things out depending on the --- interative context, which we don't set sufficiently anyway. -getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst])) -getAllInfo name = withSession $ \hsc_env -> do - (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name - return r - - -------------------------------------------------------------------------------- -- Collecting and sorting instances -------------------------------------------------------------------------------- -- cgit v1.2.3