Use foldGet in getSymbolTable

Implement @alexbiehl suggestion of using a foldGet function to avoid the
creation of an intermediate list while reading the symbol table.

Do something similar for reading the Hie symbol table and the interface
dictionary.

Metric Decrease:
    T10421

3 files changed, 50 insertions, 25 deletions

diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs
index 95abdf0530..a662ebb84b 100644
--- a/compiler/GHC/Iface/Binary.hs
+++ b/compiler/GHC/Iface/Binary.hs
@@ -281,25 +281,21 @@ putSymbolTable bh next_off symtab = do
 getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
 getSymbolTable bh name_cache = do
     sz <- get bh :: IO Int
-    od_names <- sequence (replicate sz (get bh))
-
     -- create an array of Names for the symbols and add them to the NameCache
     updateNameCache' name_cache $ \cache0 -> do
         mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int Name)
-        let go cache ((uid, mod_name, occ),i) = do
-              let mod = mkModule uid mod_name
-              case lookupOrigNameCache cache mod occ of
-                Just name -> do
-                  writeArray mut_arr i name
-                  return cache
-                Nothing   -> do
-                  uniq <- takeUniqFromNameCache name_cache
-                  let name      = mkExternalName uniq mod occ noSrcSpan
-                      new_cache = extendOrigNameCache cache mod occ name
-                  writeArray mut_arr i name
-                  return new_cache
-
-        cache <- foldM go cache0 (zip od_names [0..])
+        cache <- foldGet (fromIntegral sz) bh cache0 $ \i (uid, mod_name, occ) cache -> do
+          let mod = mkModule uid mod_name
+          case lookupOrigNameCache cache mod occ of
+            Just name -> do
+              writeArray mut_arr (fromIntegral i) name
+              return cache
+            Nothing   -> do
+              uniq <- takeUniqFromNameCache name_cache
+              let name      = mkExternalName uniq mod occ noSrcSpan
+                  new_cache = extendOrigNameCache cache mod occ name
+              writeArray mut_arr (fromIntegral i) name
+              return new_cache
         arr <- unsafeFreeze mut_arr
         return (cache, arr)
 
diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs
index 2d3a009153..1e2e4f7127 100644
--- a/compiler/GHC/Iface/Ext/Binary.hs
+++ b/compiler/GHC/Iface/Ext/Binary.hs
@@ -33,13 +33,15 @@ import GHC.Types.SrcLoc as SrcLoc
 import GHC.Types.Unique
 import GHC.Types.Unique.FM
 
-import qualified Data.Array as A
+import qualified Data.Array        as A
+import qualified Data.Array.IO     as A
+import qualified Data.Array.Unsafe as A
 import Data.IORef
 import Data.ByteString            ( ByteString )
 import qualified Data.ByteString  as BS
 import qualified Data.ByteString.Char8 as BSC
 import Data.Word                  ( Word8, Word32 )
-import Control.Monad              ( replicateM, when )
+import Control.Monad              ( replicateM, when, forM_ )
 import System.Directory           ( createDirectoryIfMissing )
 import System.FilePath            ( takeDirectory )
 
@@ -269,9 +271,12 @@ putSymbolTable bh next_off symtab = do
 getSymbolTable :: BinHandle -> NameCache -> IO SymbolTable
 getSymbolTable bh name_cache = do
   sz <- get bh
-  od_names <- replicateM sz (getHieName bh)
-  names <- mapM (fromHieName name_cache) od_names
-  pure $ A.listArray (0,sz-1) names
+  mut_arr <- A.newArray_ (0, sz-1) :: IO (A.IOArray Int Name)
+  forM_ [0..(sz-1)] $ \i -> do
+    od_name <- getHieName bh
+    name <- fromHieName name_cache od_name
+    A.writeArray mut_arr i name
+  A.unsafeFreeze mut_arr
 
 getSymTabName :: SymbolTable -> BinHandle -> IO Name
 getSymTabName st bh = do
diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs
index 791e61375a..daddd0ce0f 100644
--- a/compiler/GHC/Utils/Binary.hs
+++ b/compiler/GHC/Utils/Binary.hs
@@ -42,6 +42,8 @@ module GHC.Utils.Binary
    castBin,
    withBinBuffer,
 
+   foldGet,
+
    writeBinMem,
    readBinMem,
 
@@ -85,6 +87,8 @@ import GHC.Types.SrcLoc
 import Control.DeepSeq
 import Foreign
 import Data.Array
+import Data.Array.IO
+import Data.Array.Unsafe
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Internal as BS
 import qualified Data.ByteString.Unsafe   as BS
@@ -92,7 +96,7 @@ import Data.IORef
 import Data.Char                ( ord, chr )
 import Data.Time
 import Data.List (unfoldr)
-import Control.Monad            ( when, (<$!>), unless )
+import Control.Monad            ( when, (<$!>), unless, forM_ )
 import System.IO as IO
 import System.IO.Unsafe         ( unsafeInterleaveIO )
 import System.IO.Error          ( mkIOError, eofErrorType )
@@ -271,6 +275,23 @@ expandBin (BinMem _ _ sz_r arr_r) !off = do
       | otherwise
       = getSize (sz * 2)
 
+foldGet
+  :: Binary a
+  => Word -- n elements
+  -> BinHandle
+  -> b -- initial accumulator
+  -> (Word -> a -> b -> IO b)
+  -> IO b
+foldGet n bh init_b f = go 0 init_b
+  where
+    go i b
+      | i == n    = return b
+      | otherwise = do
+          a <- get bh
+          b' <- f i a b
+          go (i+1) b'
+
+
 -- -----------------------------------------------------------------------------
 -- Low-level reading/writing of bytes
 
@@ -980,9 +1001,12 @@ putDictionary bh sz dict = do
 
 getDictionary :: BinHandle -> IO Dictionary
 getDictionary bh = do
-  sz <- get bh
-  elems <- sequence (take sz (repeat (getFS bh)))
-  return (listArray (0,sz-1) elems)
+  sz <- get bh :: IO Int
+  mut_arr <- newArray_ (0, sz-1) :: IO (IOArray Int FastString)
+  forM_ [0..(sz-1)] $ \i -> do
+    fs <- getFS bh
+    writeArray mut_arr i fs
+  unsafeFreeze mut_arr
 
 ---------------------------------------------------------
 -- The Symbol Table