Fix space leak in BinIface.getSymbolTable

Replace a call to mapAccumR, which uses linear stack space, with a
gadget that uses constant space.

Remove an unused parameter from fromOnDiskName.

The tests T1292_imports and T4239 are now reporting imported names in a
different order. I don't completely understand why, but I presume it is
because the symbol tables are now read more strictly. The new order
seems better in T1792_imports, and equally random in T4239.

There are several performance test improvements.

Test Plan: ./validate

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: alexbiehl, rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D4124

1 files changed, 23 insertions, 10 deletions

diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 969dc85c04..8ab2310bc4 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables #-}
+{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-}
 
 --
 --  (c) The University of Glasgow 2002-2006
@@ -44,14 +44,18 @@ import FastString
 import Constants
 import Util
 
+import Data.Array
+import Data.Array.ST
+import Data.Array.Unsafe
 import Data.Bits
 import Data.Char
-import Data.List
 import Data.Word
-import Data.Array
 import Data.IORef
+import Data.Foldable
 import Control.Monad
-
+import Control.Monad.ST
+import Control.Monad.Trans.Class
+import qualified Control.Monad.Trans.State.Strict as State
 
 -- ---------------------------------------------------------------------------
 -- Reading and writing binary interface files
@@ -261,15 +265,24 @@ getSymbolTable bh ncu = do
     sz <- get bh
     od_names <- sequence (replicate sz (get bh))
     updateNameCache ncu $ \namecache ->
-        let arr = listArray (0,sz-1) names
-            (namecache', names) =
-                mapAccumR (fromOnDiskName arr) namecache od_names
-        in (namecache', arr)
+        runST $ flip State.evalStateT namecache $ do
+            mut_arr <- lift $ newSTArray_ (0, sz-1)
+            for_ (zip [0..] od_names) $ \(i, odn) -> do
+                (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn
+                lift $ writeArray mut_arr i n
+                State.put nc
+            arr <- lift $ unsafeFreeze mut_arr
+            namecache' <- State.get
+            return (namecache', arr)
+  where
+    -- This binding is required because the type of newArray_ cannot be inferred
+    newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)
+    newSTArray_ = newArray_
 
 type OnDiskName = (UnitId, ModuleName, OccName)
 
-fromOnDiskName :: Array Int Name -> NameCache -> OnDiskName -> (NameCache, Name)
-fromOnDiskName _ nc (pid, mod_name, occ) =
+fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)
+fromOnDiskName nc (pid, mod_name, occ) =
     let mod   = mkModule pid mod_name
         cache = nsNames nc
     in case lookupOrigNameCache cache  mod occ of