[commit: haddock] ghc-head, ghc-head1, ie_avails, 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 (#636) (7cecbd9)

[git at git.haskell.org]

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

On branches: ghc-head,ghc-head1,ie_avails,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/7cecbd969298d5aa576750864a69fa5f70f71c32

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

commit 7cecbd969298d5aa576750864a69fa5f70f71c32
Author: Doug Wilson <dwilson at ricoh.co.nz>
Date:   Wed Jun 21 19:27:33 2017 +1200

    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


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

7cecbd969298d5aa576750864a69fa5f70f71c32
 .../src/Haddock/Interface/AttachInstances.hs       | 82 +++++++++++-----------
 1 file changed, 41 insertions(+), 41 deletions(-)

diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index 6d0bed2..1eb227b 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 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
@@ -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
 --------------------------------------------------------------------------------