aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAlec Theriault <alec.theriault@gmail.com>2018-07-23 13:23:35 -0700
committerBen Gamari <ben@smart-cactus.org>2018-08-21 19:09:37 -0400
commit40eb5aabed0ae52982a690be311177b2dea2a0bb (patch)
treed851e590b102f46815d5f848ced3c3150625f102
parent9765c10a27013b5c9168ee507d1f3b34cb4be26f (diff)
Accumulate explicitly which modules to load for 'attachInstances'
The old approach to fixing #469, while correct, consumes a lot of memory. We ended up with a HUGE 'GblRdrEnv' in 'ic_rn_gbl_env'. However, 'getNameToInstancesIndex' takes that environment and compresses it down to a much smaller 'ModuleSet'. Now, we compute that 'ModuleSet' explicitly as we process modules. That way we can just tell 'getNameToInstancesIndex' what modules to load (instead of it trying to compute that information from the interactive context). (cherry picked from commit 5c7c596c51d69b92164e9ba920157b36ce2b2ec1)
-rw-r--r--haddock-api/src/Haddock/Interface.hs59
-rw-r--r--haddock-api/src/Haddock/Interface/AttachInstances.hs11
2 files changed, 42 insertions, 28 deletions
diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs
index a66745ea..c330c5fe 100644
--- a/haddock-api/src/Haddock/Interface.hs
+++ b/haddock-api/src/Haddock/Interface.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, OverloadedStrings #-}
+{-# LANGUAGE CPP, OverloadedStrings, BangPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Interface
@@ -51,6 +51,7 @@ import System.Directory
import System.FilePath
import Text.Printf
+import Module (mkModuleSet, emptyModuleSet, unionModuleSet, ModuleSet)
import Digraph
import DynFlags hiding (verbosity)
import Exception
@@ -59,7 +60,9 @@ import HscTypes
import FastString (unpackFS)
import MonadUtils (liftIO)
import TcRnTypes (tcg_rdr_env)
-import RdrName (plusGlobalRdrEnv)
+import Name (nameIsFromExternalPackage, nameOccName)
+import OccName (isTcOcc)
+import RdrName (unQualOK, gre_name, globalRdrEnvElts)
import ErrUtils (withTiming)
#if defined(mingw32_HOST_OS)
@@ -87,7 +90,7 @@ processModules verbosity modules flags extIfaces = do
out verbosity verbose "Creating interfaces..."
let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces
, iface <- ifInstalledIfaces ext ]
- interfaces <- createIfaces0 verbosity modules flags instIfaceMap
+ (interfaces, ms) <- createIfaces0 verbosity modules flags instIfaceMap
let exportedNames =
Set.unions $ map (Set.fromList . ifaceExports) $
@@ -96,7 +99,7 @@ processModules verbosity modules flags extIfaces = do
out verbosity verbose "Attaching instances..."
interfaces' <- {-# SCC attachInstances #-}
withTiming getDynFlags "attachInstances" (const ()) $ do
- attachInstances (exportedNames, mods) interfaces instIfaceMap
+ attachInstances (exportedNames, mods) interfaces instIfaceMap ms
out verbosity verbose "Building cross-linking environment..."
-- Combine the link envs of the external packages into one
@@ -120,7 +123,7 @@ processModules verbosity modules flags extIfaces = do
--------------------------------------------------------------------------------
-createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]
+createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc ([Interface], ModuleSet)
createIfaces0 verbosity modules flags instIfaceMap =
-- Output dir needs to be set before calling depanal since depanal uses it to
-- compute output file names that are stored in the DynFlags of the
@@ -150,43 +153,51 @@ createIfaces0 verbosity modules flags instIfaceMap =
depanal [] False
-createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface]
+createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc ([Interface], ModuleSet)
createIfaces verbosity flags instIfaceMap mods = do
let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing
out verbosity normal "Haddock coverage:"
- (ifaces, _) <- foldM f ([], Map.empty) sortedMods
- return (reverse ifaces)
+ (ifaces, _, !ms) <- foldM f ([], Map.empty, emptyModuleSet) sortedMods
+ return (reverse ifaces, ms)
where
- f (ifaces, ifaceMap) modSummary = do
+ f (ifaces, ifaceMap, !ms) modSummary = do
x <- {-# SCC processModule #-}
withTiming getDynFlags "processModule" (const ()) $ do
processModule verbosity modSummary flags ifaceMap instIfaceMap
return $ case x of
- Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap)
- Nothing -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces.
+ Just (iface, ms') -> ( iface:ifaces
+ , Map.insert (ifaceMod iface) iface ifaceMap
+ , unionModuleSet ms ms' )
+ Nothing -> ( ifaces
+ , ifaceMap
+ , ms ) -- Boot modules don't generate ifaces.
-processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface)
+processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe (Interface, ModuleSet))
processModule verbosity modsum flags modMap instIfaceMap = do
out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..."
tm <- {-# SCC "parse/typecheck/load" #-} loadModule =<< typecheckModule =<< parseModule modsum
- -- We need to modify the interactive context's environment so that when
- -- Haddock later looks for instances, it also looks in the modules it
- -- encountered while typechecking.
- --
- -- See https://github.com/haskell/haddock/issues/469.
- hsc_env@HscEnv{ hsc_IC = old_IC } <- getSession
- let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
- setSession hsc_env{ hsc_IC = old_IC {
- ic_rn_gbl_env = ic_rn_gbl_env old_IC `plusGlobalRdrEnv` new_rdr_env
- } }
-
if not $ isBootSummary modsum then do
out verbosity verbose "Creating interface..."
(interface, msgs) <- {-# SCC createIterface #-}
withTiming getDynFlags "createInterface" (const ()) $ do
runWriterGhc $ createInterface tm flags modMap instIfaceMap
+
+ -- We need to keep track of which modules were somehow in scope so that when
+ -- Haddock later looks for instances, it also looks in these modules too.
+ --
+ -- See https://github.com/haskell/haddock/issues/469.
+ hsc_env <- getSession
+ let new_rdr_env = tcg_rdr_env . fst . GHC.tm_internals_ $ tm
+ this_pkg = thisPackage (hsc_dflags hsc_env)
+ !mods = mkModuleSet [ nameModule name
+ | gre <- globalRdrEnvElts new_rdr_env
+ , let name = gre_name gre
+ , nameIsFromExternalPackage this_pkg name
+ , isTcOcc (nameOccName name) -- Types and classes only
+ , unQualOK gre ] -- In scope unqualified
+
liftIO $ mapM_ putStrLn (nub msgs)
dflags <- getDynFlags
let (haddockable, haddocked) = ifaceHaddockCoverage interface
@@ -220,7 +231,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do
unless header $ out verbosity normal " Module header"
mapM_ (out verbosity normal . (" " ++)) undocumentedExports
interface' <- liftIO $ evaluate interface
- return (Just interface')
+ return (Just (interface', mods))
else
return Nothing
diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs
index bf50ded3..2d72d117 100644
--- a/haddock-api/src/Haddock/Interface/AttachInstances.hs
+++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, MagicHash #-}
+{-# LANGUAGE CPP, MagicHash, BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
@@ -34,6 +34,7 @@ import FamInstEnv
import FastString
import GHC
import InstEnv
+import Module ( ModuleSet, moduleSetElts )
import MonadUtils (liftIO)
import Name
import NameEnv
@@ -51,11 +52,13 @@ type Modules = Set.Set Module
type ExportInfo = (ExportedNames, Modules)
-- Also attaches fixities
-attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface]
-attachInstances expInfo ifaces instIfaceMap = do
- (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces)
+attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> ModuleSet -> Ghc [Interface]
+attachInstances expInfo ifaces instIfaceMap mods = do
+ (_msgs, mb_index) <- getNameToInstancesIndex (map ifaceMod ifaces) mods'
mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces
where
+ mods' = Just (moduleSetElts mods)
+
-- TODO: take an IfaceMap as input
ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ]