From a20b326ff0a7e4ce913af90f5cf968e312891643 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Thu, 4 Feb 2021 22:33:32 +0100 Subject: Fix after NameCache changes --- haddock-api/src/Documentation/Haddock.hs | 2 - haddock-api/src/Haddock.hs | 21 ++-- haddock-api/src/Haddock/Backends/Hyperlinker.hs | 9 +- haddock-api/src/Haddock/InterfaceFile.hs | 161 +++--------------------- 4 files changed, 36 insertions(+), 157 deletions(-) (limited to 'haddock-api/src') diff --git a/haddock-api/src/Documentation/Haddock.hs b/haddock-api/src/Documentation/Haddock.hs index 10d6849a..e5d84796 100644 --- a/haddock-api/src/Documentation/Haddock.hs +++ b/haddock-api/src/Documentation/Haddock.hs @@ -52,9 +52,7 @@ module Documentation.Haddock ( -- * Interface files InterfaceFile(..), readInterfaceFile, - nameCacheFromGhc, freshNameCache, - NameCacheAccessor, -- * Flags and options Flag(..), diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs index 8182707d..d955ae4f 100644 --- a/haddock-api/src/Haddock.hs +++ b/haddock-api/src/Haddock.hs @@ -71,6 +71,7 @@ import GHC.Settings.Config import GHC.Driver.Session hiding (projectVersion, verbosity) import GHC.Driver.Env import GHC.Utils.Error +import GHC.Types.Name.Cache import GHC.Unit import GHC.Utils.Panic (handleGhcException) import GHC.Data.FastString @@ -188,7 +189,8 @@ haddockWithGhc ghc args = handleTopExceptions $ do unit_state <- hsc_units <$> getSession forM_ (optShowInterfaceFile flags) $ \path -> liftIO $ do - mIfaceFile <- readInterfaceFiles freshNameCache [(("", Nothing), path)] noChecks + name_cache <- freshNameCache + mIfaceFile <- readInterfaceFiles name_cache [(("", Nothing), path)] noChecks forM_ mIfaceFile $ \(_, ifaceFile) -> do putMsg logger dflags $ renderJson (jsonInterfaceFile ifaceFile) @@ -210,7 +212,8 @@ haddockWithGhc ghc args = handleTopExceptions $ do throwE "No input file(s)." -- Get packages supplied with --read-interface. - packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) noChecks + name_cache <- liftIO $ freshNameCache + packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks -- Render even though there are no input files (usually contents/index). liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages [] @@ -253,7 +256,8 @@ readPackagesAndProcessModules :: [Flag] -> [String] readPackagesAndProcessModules flags files = do -- Get packages supplied with --read-interface. let noChecks = Flag_BypassInterfaceVersonCheck `elem` flags - packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) noChecks + name_cache <- hsc_NC <$> getSession + packages <- liftIO $ readInterfaceFiles name_cache (readIfaceArgs flags) noChecks -- Create the interfaces -- this is the core part of Haddock. let ifaceFiles = map snd packages @@ -441,18 +445,17 @@ render logger dflags unit_state flags sinceQual qual ifaces installedIfaces extS ------------------------------------------------------------------------------- -readInterfaceFiles :: MonadIO m - => NameCacheAccessor m +readInterfaceFiles :: NameCache -> [(DocPaths, FilePath)] -> Bool - -> m [(DocPaths, InterfaceFile)] -readInterfaceFiles name_cache_accessor pairs bypass_version_check = do + -> IO [(DocPaths, InterfaceFile)] +readInterfaceFiles name_cache pairs bypass_version_check = do catMaybes `liftM` mapM ({-# SCC readInterfaceFile #-} tryReadIface) pairs where -- try to read an interface, warn if we can't tryReadIface (paths, file) = - readInterfaceFile name_cache_accessor file bypass_version_check >>= \case - Left err -> liftIO $ do + readInterfaceFile name_cache file bypass_version_check >>= \case + Left err -> do putStrLn ("Warning: Cannot read " ++ file ++ ":") putStrLn (" " ++ err) putStrLn "Skipping this interface." diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker.hs b/haddock-api/src/Haddock/Backends/Hyperlinker.hs index d16aa24e..39be6762 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker.hs @@ -9,6 +9,7 @@ module Haddock.Backends.Hyperlinker import Haddock.Types import Haddock.Utils (writeUtf8File, out, verbose, Verbosity) +import Haddock.InterfaceFile import Haddock.Backends.Hyperlinker.Renderer import Haddock.Backends.Hyperlinker.Parser import Haddock.Backends.Hyperlinker.Types @@ -20,7 +21,7 @@ import System.Directory import System.FilePath import GHC.Iface.Ext.Types ( pattern HiePath, HieFile(..), HieASTs(..), HieAST(..), SourcedNodeInfo(..) ) -import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result, NameCacheUpdater(..)) +import GHC.Iface.Ext.Binary ( readHieFile, hie_file_result ) import GHC.Types.SrcLoc ( realSrcLocSpan, mkRealSrcLoc ) import Data.Map as M import GHC.Data.FastString ( mkFastString ) @@ -58,15 +59,13 @@ ppHyperlinkedModuleSource :: Verbosity -> FilePath -> Bool -> SrcMaps -> Interfa ppHyperlinkedModuleSource verbosity srcdir pretty srcs iface = case ifaceHieFile iface of Just hfp -> do -- Parse the GHC-produced HIE file - u <- mkSplitUniqSupply 'a' - let nc = (initNameCache u []) - ncu = NCU $ \f -> pure $ snd $ f nc + nc <- freshNameCache HieFile { hie_hs_file = file , hie_asts = HieASTs asts , hie_types = types , hie_hs_src = rawSrc } <- hie_file_result - <$> (readHieFile ncu hfp) + <$> (readHieFile nc hfp) -- Get the AST and tokens corresponding to the source file we want let fileFs = mkFastString file diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 211c7d55..7147dc9d 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -16,7 +16,7 @@ ----------------------------------------------------------------------------- module Haddock.InterfaceFile ( InterfaceFile(..), ifUnitId, ifModule, - readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, + readInterfaceFile, freshNameCache, writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where @@ -32,7 +32,7 @@ import qualified Data.Map as Map import Data.Map (Map) import Data.Word -import GHC.Iface.Binary (getSymtabName, getDictFastString) +import GHC.Iface.Binary (getWithUserData, putSymbolTable) import GHC.Utils.Binary import GHC.Data.FastMutInt import GHC.Data.FastString @@ -165,103 +165,32 @@ writeInterfaceFile filename iface = do return () -type NameCacheAccessor m = (m NameCache, NameCache -> m ()) - - -nameCacheFromGhc :: forall m. GhcMonad m => NameCacheAccessor m -nameCacheFromGhc = ( read_from_session , write_to_session ) - where - read_from_session = do - ref <- withSession (return . hsc_NC) - liftIO $ readIORef ref - write_to_session nc' = do - ref <- withSession (return . hsc_NC) - liftIO $ writeIORef ref nc' - - -freshNameCache :: NameCacheAccessor IO -freshNameCache = ( create_fresh_nc , \_ -> return () ) - where - create_fresh_nc = do - u <- mkSplitUniqSupply 'a' -- ?? - return (initNameCache u []) - +freshNameCache :: IO NameCache +freshNameCache = do + u <- mkSplitUniqSupply 'a' -- ?? + initNameCache u [] -- | Read a Haddock (@.haddock@) interface file. Return either an -- 'InterfaceFile' or an error message. -- -- This function can be called in two ways. Within a GHC session it will -- update the use and update the session's name cache. Outside a GHC session --- a new empty name cache is used. The function is therefore generic in the --- monad being used. The exact monad is whichever monad the first --- argument, the getter and setter of the name cache, requires. --- -readInterfaceFile :: forall m. - MonadIO m - => NameCacheAccessor m +-- a new empty name cache is used. +readInterfaceFile :: NameCache -> FilePath -> Bool -- ^ Disable version check. Can cause runtime crash. - -> m (Either String InterfaceFile) -readInterfaceFile (get_name_cache, set_name_cache) filename bypass_checks = do - bh0 <- liftIO $ readBinMem filename - - magic <- liftIO $ get bh0 - version <- liftIO $ get bh0 - - case () of - _ | magic /= binaryInterfaceMagic -> return . Left $ - "Magic number mismatch: couldn't load interface file: " ++ filename - | not bypass_checks - , (version `notElem` binaryInterfaceVersionCompatibility) -> return . Left $ - "Interface file is of wrong version: " ++ filename - | otherwise -> with_name_cache $ \update_nc -> do - - dict <- get_dictionary bh0 - - -- read the symbol table so we are capable of reading the actual data - bh1 <- do - let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") - (getDictFastString dict) - symtab <- update_nc (get_symbol_table bh1) - return $ setUserData bh1 $ newReadState (getSymtabName (NCU (\f -> update_nc (return . f))) dict symtab) - (getDictFastString dict) - - -- load the actual data - iface <- liftIO $ get bh1 - return (Right iface) - where - with_name_cache :: forall a. - ((forall n b. MonadIO n - => (NameCache -> n (NameCache, b)) - -> n b) - -> m a) - -> m a - with_name_cache act = do - nc_var <- get_name_cache >>= (liftIO . newIORef) - x <- act $ \f -> do - nc <- liftIO $ readIORef nc_var - (nc', x) <- f nc - liftIO $ writeIORef nc_var nc' - return x - liftIO (readIORef nc_var) >>= set_name_cache - return x - - get_dictionary bin_handle = liftIO $ do - dict_p <- get bin_handle - data_p <- tellBin bin_handle - seekBin bin_handle dict_p - dict <- getDictionary bin_handle - seekBin bin_handle data_p - return dict - - get_symbol_table bh1 theNC = liftIO $ do - symtab_p <- get bh1 - data_p' <- tellBin bh1 - seekBin bh1 symtab_p - (nc', symtab) <- getSymbolTable bh1 theNC - seekBin bh1 data_p' - return (nc', symtab) - + -> IO (Either String InterfaceFile) +readInterfaceFile name_cache filename bypass_checks = do + bh <- readBinMem filename + + magic <- get bh + if magic /= binaryInterfaceMagic + then return . Left $ "Magic number mismatch: couldn't load interface file: " ++ filename + else do + version <- get bh + if not bypass_checks && (version `notElem` binaryInterfaceVersionCompatibility) + then return . Left $ "Interface file is of wrong version: " ++ filename + else Right <$> getWithUserData name_cache bh ------------------------------------------------------------------------------- -- * Symbol table @@ -312,56 +241,6 @@ data BinDictionary = BinDictionary { -- indexed by FastString } - -putSymbolTable :: BinHandle -> Int -> UniqFM Name (Int,Name) -> IO () -putSymbolTable bh next_off symtab = do - put_ bh next_off - let names = elems (array (0,next_off-1) (eltsUFM symtab)) - mapM_ (\n -> serialiseName bh n symtab) names - - -getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name) -getSymbolTable bh namecache = do - sz <- get bh - od_names <- replicateM sz (get bh) - let arr = listArray (0,sz-1) names - (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names - return (namecache', arr) - - -type OnDiskName = (Unit, ModuleName, OccName) - - -fromOnDiskName - :: Array Int Name - -> NameCache - -> OnDiskName - -> (NameCache, Name) -fromOnDiskName _ nc (pid, mod_name, occ) = - let - modu = mkModule pid mod_name - cache = nsNames nc - in - case lookupOrigNameCache cache modu occ of - Just name -> (nc, name) - Nothing -> - let - us = nsUniqs nc - u = uniqFromSupply us - name = mkExternalName u modu occ noSrcSpan - new_cache = extendNameCache cache modu occ name - in - case splitUniqSupply us of { (us',_) -> - ( nc{ nsUniqs = us', nsNames = new_cache }, name ) - } - - -serialiseName :: BinHandle -> Name -> UniqFM Name (Int,Name) -> IO () -serialiseName bh name _ = do - let modu = nameModule name - put_ bh (moduleUnit modu, moduleName modu, nameOccName name) - - ------------------------------------------------------------------------------- -- * GhcBinary instances ------------------------------------------------------------------------------- -- cgit v1.2.3 From adca17adc9f53bb8ab451d0a11911c04145c8fb3 Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Mon, 8 Feb 2021 16:03:17 +0100 Subject: NameCache doesn't store a UniqSupply anymore --- haddock-api/src/Haddock/InterfaceFile.hs | 14 ++------------ hypsrc-test/ref/src/Classes.html | 14 +++++++------- hypsrc-test/ref/src/Records.html | 16 ++++++++-------- 3 files changed, 17 insertions(+), 27 deletions(-) (limited to 'haddock-api/src') diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 7147dc9d..f47e2df0 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -23,11 +23,7 @@ module Haddock.InterfaceFile ( import Haddock.Types -import Control.Monad -import Control.Monad.IO.Class ( MonadIO(..) ) -import Data.Array import Data.IORef -import Data.List (mapAccumR) import qualified Data.Map as Map import Data.Map (Map) import Data.Word @@ -37,13 +33,8 @@ import GHC.Utils.Binary import GHC.Data.FastMutInt import GHC.Data.FastString import GHC hiding (NoLink) -import GHC.Driver.Monad (withSession) -import GHC.Driver.Env import GHC.Types.Name.Cache -import GHC.Iface.Env -import GHC.Types.Name import GHC.Types.Unique.FM -import GHC.Types.Unique.Supply import GHC.Types.Unique data InterfaceFile = InterfaceFile { @@ -166,9 +157,8 @@ writeInterfaceFile filename iface = do freshNameCache :: IO NameCache -freshNameCache = do - u <- mkSplitUniqSupply 'a' -- ?? - initNameCache u [] +freshNameCache = initNameCache 'a' -- ?? + [] -- | Read a Haddock (@.haddock@) interface file. Return either an -- 'InterfaceFile' or an error message. diff --git a/hypsrc-test/ref/src/Classes.html b/hypsrc-test/ref/src/Classes.html index 688b6db6..16d3b333 100644 --- a/hypsrc-test/ref/src/Classes.html +++ b/hypsrc-test/ref/src/Classes.html @@ -194,7 +194,7 @@ >bar :: Int -> Int barbaz :: Int -> (Int, Int) bazbar :: [a] -> Int barbaz :: Int -> ([a], [a]) baznorf :: [Int] -> Int norfquux :: ([a], [a]) -> [a] quuxplugh :: forall a b. Either a a -> Either b b -> Either (a -> b) (b -> a) plughInt -x :: Int x :: Point -> Int +x :: Int xInt -y :: Int y :: Point -> Int +y :: Int yInt -y :: Int -x :: Int -y :: Point -> Int x :: Point -> Int +y :: Point -> Int +x :: Int +y :: Int ..