[commit: haddock] ghc-head, ghc-head1, headdock-library-1.4.5, ie_avails, master, pr/cabal-desc, v2.18, wip/revert-ttg-2017-11-20, wip/ttg-2017-10-13, wip/ttg-2017-10-31, wip/ttg-2017-11-06, wip/ttg2-2017-11-10, wip/ttg3-2017-11-12, wip/ttg4-constraints-2017-11-13: Use new function getNameToInstancesIndex instead of tcRnGetInfo (#639) (d5d8cd1)
git at git.haskell.org
git at git.haskell.org
Mon Nov 20 21:08:38 UTC 2017
Repository : ssh://git@git.haskell.org/haddock
On branches: ghc-head,ghc-head1,headdock-library-1.4.5,ie_avails,master,pr/cabal-desc,v2.18,wip/revert-ttg-2017-11-20,wip/ttg-2017-10-13,wip/ttg-2017-10-31,wip/ttg-2017-11-06,wip/ttg2-2017-11-10,wip/ttg3-2017-11-12,wip/ttg4-constraints-2017-11-13
Link : http://git.haskell.org/haddock.git/commitdiff/d5d8cd1722b06f17155e830f2242a073b0a983eb
>---------------------------------------------------------------
commit d5d8cd1722b06f17155e830f2242a073b0a983eb
Author: Doug Wilson <dwilson at ricoh.co.nz>
Date: Fri Jun 23 06:23:29 2017 +1200
Use new function getNameToInstancesIndex instead of tcRnGetInfo (#639)
* Use new function getNameToInstancesIndex instead of tcRnGetInfo
There is some significant performance improvement in the ghc testsuite.
haddock.base: -23.3%
haddock.Cabal: -16.7%
haddock.compiler: -19.8%
* Remove unused imports
>---------------------------------------------------------------
d5d8cd1722b06f17155e830f2242a073b0a983eb
.../src/Haddock/Interface/AttachInstances.hs | 82 +++++++++++-----------
1 file changed, 40 insertions(+), 42 deletions(-)
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 7a3182b..527c6bc 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -21,7 +21,7 @@ import Haddock.GhcUtils
import Control.Arrow hiding ((<+>))
import Data.List
import Data.Ord (comparing)
-import Data.Maybe ( maybeToList, mapMaybe )
+import Data.Maybe ( maybeToList, mapMaybe, fromMaybe )
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -32,14 +32,13 @@ import ErrUtils
import FamInstEnv
import FastString
import GHC
-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 )
@@ -52,13 +51,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
@@ -74,37 +75,42 @@ attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances =
]
-attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap
- -> ExportItem Name
- -> Ghc (ExportItem Name)
-attachToExportItem expInfo iface ifaceMap instIfaceMap export =
+attachToExportItem
+ :: NameEnv ([ClsInst], [FamInst])
+ -> ExportInfo
+ -> Interface
+ -> IfaceMap
+ -> InstIfaceMap
+ -> ExportItem Name
+ -> Ghc (ExportItem Name)
+attachToExportItem index expInfo iface ifaceMap instIfaceMap export =
case attachFixities export of
e at 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
@@ -145,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
--------------------------------------------------------------------------------
More information about the ghc-commits
mailing list