perf: 60% faster cold builds via type dedup, solver memoization, and a larger GC nursery

builder/src/File.hs

@@ -11,13 +11,16 @@ module File
   , exists
   , remove
   , removeDir
+  , getFileTimings
   )
   where
 
 
 import qualified Codec.Archive.Zip as Zip
 import Control.Exception (catch)
 import qualified Data.Binary as Binary
+import qualified System.IO.Unsafe as Unsafe
+import qualified Data.IORef as IORef
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Internal as BS
 import qualified Data.ByteString.Builder as B
@@ -35,6 +38,7 @@ import qualified System.IO as IO
 import System.IO.Error (ioeGetErrorType, annotateIOError, modifyIOError)
 
 
+import qualified Ext.Common as Ext
 import Lamdera ((&), alternativeImplementation)
 
 -- TIME
@@ -65,16 +69,53 @@ instance Binary.Binary Time where
 -- BINARY
 
 
+{-# NOINLINE writeNanos #-}
+writeNanos :: IORef.IORef Integer
+writeNanos = Unsafe.unsafePerformIO (IORef.newIORef 0)
+
+{-# NOINLINE readNanos #-}
+readNanos :: IORef.IORef Integer
+readNanos = Unsafe.unsafePerformIO (IORef.newIORef 0)
+
+{-# NOINLINE timingEnabled #-}
+timingEnabled :: Bool
+timingEnabled = Ext.envFlag "LDEBUG_FILE_TIMING"
+
+
+timeIt :: IORef.IORef Integer -> IO a -> IO a
+timeIt ref action =
+  if timingEnabled
+    then do
+      t0 <- Time.getCurrentTime
+      result <- action
+      t1 <- Time.getCurrentTime
+      let dt = Time.diffUTCTime t1 t0
+          nanos = round (realToFrac dt * 1e9 :: Double) :: Integer
+      IORef.atomicModifyIORef' ref (\acc -> (acc + nanos, ()))
+      return result
+    else action
+
+
+-- | Get accumulated write/read times in milliseconds (for reporting).
+getFileTimings :: IO (Double, Double)
+getFileTimings = do
+  w <- IORef.readIORef writeNanos
+  r <- IORef.readIORef readNanos
+  return (fromIntegral w / 1e6, fromIntegral r / 1e6)
+
+
 writeBinary :: (Binary.Binary a) => FilePath -> a -> IO ()
 writeBinary path value =
-  do  let dir = FP.dropFileName path
+  timeIt writeNanos $ do
+      let dir = FP.dropFileName path
       Dir.createDirectoryIfMissing True dir
       Binary.encodeFile path value
 
 
 readBinary :: (Binary.Binary a) => FilePath -> IO (Maybe a)
 readBinary path =
-  do  pathExists <- Dir.doesFileExist path
+  timeIt readNanos $ do
+      pathExists <- Dir.doesFileExist path
       if pathExists
         then
           do  result <- Binary.decodeFileOrFail path

builder/src/Reporting.hs

@@ -36,6 +36,9 @@ import qualified System.Exit as Exit
 import qualified System.Info as Info
 import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout)
 
+import qualified File
+import qualified Elm.Interface as I
+
 import qualified Elm.ModuleName as ModuleName
 import qualified Elm.Package as Pkg
 import qualified Elm.Version as V
@@ -347,14 +350,22 @@ buildLoop chan done =
               buildLoop chan done1
 
         Right result ->
-          let
-            !message = toFinalMessage done result
-            !width = 12 + length (show done)
-          in
-          Lamdera.atomicPutStrLn $
-            if length message < width
-            then '\r' : replicate width ' ' ++ '\r' : message
-            else '\r' : message
+          do  (writeMs, readMs) <- File.getFileTimings
+              buildPoolMs       <- I.getDedupTimings
+              let
+                !message = toFinalMessage done result
+                !width = 12 + length (show done)
+              Lamdera.atomicPutStrLn $
+                if length message < width
+                then '\r' : replicate width ' ' ++ '\r' : message
+                else '\r' : message
+              when (writeMs > 0 || readMs > 0) $
+                Lamdera.atomicPutStrLn $
+                  "[FILE-TIMING] writeBinary=" ++ show writeMs
+                  ++ "ms readBinary=" ++ show readMs ++ "ms"
+              when (buildPoolMs > 0) $
+                Lamdera.atomicPutStrLn $
+                  "[DEDUP-TIMING] buildPool=" ++ show buildPoolMs ++ "ms"
 
 
 toFinalMessage :: Int -> BResult a -> [Char]