From: Debian Haskell Group Date: Wed, 19 Jun 2019 21:08:21 +0000 (+0100) Subject: haddock-out-of-memory X-Git-Tag: archive/raspbian/8.4.4+dfsg1-3+rpi1^2~5 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=2eb772d94b75c3882c1b8c2baad97d47562bf3d9;p=ghc.git haddock-out-of-memory commit 18cb44dfae3f0847447da33c9d7a25d2709d838f Author: Alec Theriault Date: Tue Aug 21 16:03:40 2018 -0400 Explicitly tell 'getNameToInstances' mods to load Calculating which modules to load based on the InteractiveContext means maintaining a potentially very large GblRdrEnv. In Haddock's case, it is much cheaper (from a memory perspective) to just keep track of which modules interfaces we want loaded then hand these off explicitly to 'getNameToInstancesIndex'. Bumps haddock submodule (commit 40eb5aabed0ae) Reviewers: alexbiehl, bgamari Reviewed By: alexbiehl Subscribers: rwbarton, thomie, carter Differential Revision: https://phabricator.haskell.org/D5003 (cherry picked from commit c971e1193fa44bb507d1806d5bb61768670dc912) Gbp-Pq: Name haddock-out-of-memory.patch --- diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 1e54f0ef..35a781b8 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -117,6 +117,7 @@ module GHC ( showModule, moduleIsBootOrNotObjectLinkable, getNameToInstancesIndex, + getNameToInstancesIndex2, -- ** Inspecting types and kinds exprType, TcRnExprMode(..), @@ -297,7 +298,8 @@ import HscMain import GhcMake import DriverPipeline ( compileOne' ) import GhcMonad -import TcRnMonad ( finalSafeMode, fixSafeInstances ) +import TcRnMonad ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) +import LoadIface ( loadSysInterface ) import TcRnTypes import Packages import NameSet @@ -1247,10 +1249,27 @@ getNameToInstancesIndex :: GhcMonad m => [Module] -- ^ visible modules. An orphan instance will be returned if and -- only it is visible from at least one module in the list. -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst]))) -getNameToInstancesIndex visible_mods = do +getNameToInstancesIndex visible_mods = + getNameToInstancesIndex2 visible_mods Nothing + +-- | Retrieve all type and family instances in the environment, indexed +-- by 'Name'. Each name's lists will contain every instance in which that name +-- is mentioned in the instance head. +getNameToInstancesIndex2 :: GhcMonad m + => [Module] -- ^ visible modules. An orphan instance will be returned + -- if it is visible from at least one module in the list. + -> Maybe [Module] -- ^ modules to load. If this is not specified, we load + -- modules for everything that is in scope unqualified. + -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst]))) +getNameToInstancesIndex2 visible_mods mods_to_load = do hsc_env <- getSession liftIO $ runTcInteractive hsc_env $ - do { loadUnqualIfaces hsc_env (hsc_IC hsc_env) + do { case mods_to_load of + Nothing -> loadUnqualIfaces hsc_env (hsc_IC hsc_env) + Just mods -> + let doc = text "Need interface for reporting instances in scope" + in initIfaceTcRn $ mapM_ (loadSysInterface doc) mods + ; InstEnvs {ie_global, ie_local} <- tcGetInstEnvs ; let visible_mods' = mkModuleSet visible_mods ; (pkg_fie, home_fie) <- tcGetFamInstEnvs diff --git a/utils/haddock/haddock-api/src/Haddock/Interface.hs b/utils/haddock/haddock-api/src/Haddock/Interface.hs index 89064a6c..9aed889c 100644 --- a/utils/haddock/haddock-api/src/Haddock/Interface.hs +++ b/utils/haddock/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,52 @@ 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, msg) <- {-# SCC createIterface #-} withTiming getDynFlags "createInterface" (const ()) $ do runWriterGhc $ createInterface tm flags modMap instIfaceMap + + -- 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 <- 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 msg dflags <- getDynFlags let (haddockable, haddocked) = ifaceHaddockCoverage interface @@ -220,7 +232,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/utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs b/utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs index d0ed1698..2f0964f4 100644 --- a/utils/haddock/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/utils/haddock/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) <- getNameToInstancesIndex2 (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 ]