consolidate timing helpers

Author: mitchellwrosen

lib/unison-prelude/package.yaml

@@ -54,6 +54,7 @@ default-extensions:
   - LambdaCase
   - MultiParamTypeClasses
   - NamedFieldPuns
+  - NumericUnderscores
   - OverloadedLabels
   - OverloadedStrings
   - PatternSynonyms

lib/unison-prelude/src/Unison/Util/Timing.hs

@@ -1,46 +1,52 @@
 module Unison.Util.Timing
   ( time,
-    unsafeTime,
+    startTiming,
+    stopTiming,
   )
 where
 
-import Data.Time.Clock (picosecondsToDiffTime)
-import Data.Time.Clock.System (getSystemTime, systemToTAITime)
-import Data.Time.Clock.TAI (diffAbsoluteTime)
+import Data.Word (Word64)
+import GHC.Clock (getMonotonicTimeNSec)
 import System.CPUTime (getCPUTime)
-import System.IO.Unsafe (unsafePerformIO)
+import Text.Printf (printf)
 import Unison.Debug qualified as Debug
 import UnliftIO (MonadIO, liftIO)
 
 time :: (MonadIO m) => String -> m a -> m a
-time label ma =
+time label action =
   if Debug.shouldDebug Debug.Timing
     then do
-      systemStart <- liftIO getSystemTime
-      cpuPicoStart <- liftIO getCPUTime
-      liftIO $ putStrLn $ "Timing " ++ label ++ "..."
-      a <- ma
-      cpuPicoEnd <- liftIO getCPUTime
-      systemEnd <- liftIO getSystemTime
-      let systemDiff = diffAbsoluteTime (systemToTAITime systemEnd) (systemToTAITime systemStart)
-      let cpuDiff = picosecondsToDiffTime (cpuPicoEnd - cpuPicoStart)
-      liftIO $ putStrLn $ "Finished " ++ label ++ " in " ++ show cpuDiff ++ " (cpu), " ++ show systemDiff ++ " (system)"
-      pure a
-    else ma
+      startTime <- liftIO startTiming
+      result <- action
+      liftIO (stopTiming label startTime)
+      pure result
+    else action
 
--- Mitchell says: this function doesn't look like it would work at all; let's just delete it
-unsafeTime :: (Monad m) => String -> m a -> m a
-unsafeTime label ma =
-  if Debug.shouldDebug Debug.Timing
-    then do
-      let !systemStart = unsafePerformIO getSystemTime
-          !cpuPicoStart = unsafePerformIO getCPUTime
-          !_ = unsafePerformIO $ putStrLn $ "Timing " ++ label ++ "..."
-      a <- ma
-      let !cpuPicoEnd = unsafePerformIO getCPUTime
-          !systemEnd = unsafePerformIO getSystemTime
-      let systemDiff = diffAbsoluteTime (systemToTAITime systemEnd) (systemToTAITime systemStart)
-      let cpuDiff = picosecondsToDiffTime (cpuPicoEnd - cpuPicoStart)
-      let !_ = unsafePerformIO $ putStrLn $ "Finished " ++ label ++ " in " ++ show cpuDiff ++ " (cpu), " ++ show systemDiff ++ " (system)"
-      pure a
-    else ma
+startTiming :: IO (Word64, Integer)
+startTiming = (,) <$> getMonotonicTimeNSec <*> getCPUTime
+
+stopTiming :: String -> (Word64, Integer) -> IO ()
+stopTiming label (systemTimeStart, cpuTimeStart) = do
+  (systemTimeEnd, cpuTimeEnd) <- startTiming
+  let systemDiff = realToFrac @Word64 @Double (systemTimeEnd - systemTimeStart) / 1_000
+  let cpuDiff = realToFrac @Integer @Double (cpuTimeEnd - cpuTimeStart) / 1_000
+  printf "%s: %s (cpu), %s (system)\n" label (renderNanos cpuDiff) (renderNanos systemDiff)
+  where
+    -- Render nanoseconds, trying to fit into 4 characters.
+    renderNanos :: Double -> String
+    renderNanos ns
+      | ns < 0.5 = "0 ns"
+      | ns < 995 = printf "%.0f ns" ns
+      | ns < 9_950 = printf "%.2f µs" us
+      | ns < 99_500 = printf "%.1f µs" us
+      | ns < 995_000 = printf "%.0f µs" us
+      | ns < 9_950_000 = printf "%.2f ms" ms
+      | ns < 99_500_000 = printf "%.1f ms" ms
+      | ns < 995_000_000 = printf "%.0f ms" ms
+      | ns < 9_950_000_000 = printf "%.2f s" s
+      | ns < 99_500_000_000 = printf "%.1f s" s
+      | otherwise = printf "%.0f s" s
+      where
+        us = ns / 1_000
+        ms = ns / 1_000_000
+        s = ns / 1_000_000_000

lib/unison-prelude/unison-prelude.cabal

@@ -50,6 +50,7 @@ library
       LambdaCase
       MultiParamTypeClasses
       NamedFieldPuns
+      NumericUnderscores
       OverloadedLabels
       OverloadedStrings
       PatternSynonyms

lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs

@@ -40,6 +40,9 @@ module Unison.Sqlite.Transaction
 
     -- * Rows modified
     rowsModified,
+
+    -- * Debug-timing actions
+    time,
   )
 where
 
@@ -52,13 +55,15 @@ import Data.Unique (Unique, newUnique)
 import Database.SQLite.Simple qualified as Sqlite
 import Database.SQLite.Simple.FromField qualified as Sqlite
 import System.Random qualified as Random
+import Unison.Debug qualified as Debug
 import Unison.Prelude
 import Unison.Sqlite.Connection (Connection (..))
 import Unison.Sqlite.Connection qualified as Connection
 import Unison.Sqlite.Exception (SqliteExceptionReason, SqliteQueryException, pattern SqliteBusyException)
 import Unison.Sqlite.Sql (Sql)
 import Unison.Util.Cache (Cache)
 import Unison.Util.Cache qualified as Cache
+import Unison.Util.Timing qualified as Timing
 import UnliftIO.Exception (bracketOnError_, catchAny, trySyncOrAsync, uninterruptibleMask)
 import Unsafe.Coerce (unsafeCoerce)
 
@@ -236,8 +241,8 @@ unsafeGetConnection =
 
 -- | Unwrap the transaction newtype, throwing away the sending of BEGIN/COMMIT + automatic retry.
 unsafeUnTransaction :: Transaction a -> Connection -> IO a
-unsafeUnTransaction (Transaction action) =
-  action
+unsafeUnTransaction =
+  coerce
 
 -- Without results
 
@@ -355,3 +360,16 @@ rowsModified =
 
 transactionRetryDelay :: Int
 transactionRetryDelay = 100_000
+
+-- Debug timing
+
+-- | Time a transaction.
+time :: String -> Transaction a -> Transaction a
+time label action =
+  if Debug.shouldDebug Debug.Timing
+    then Transaction \conn -> do
+      startTime <- Timing.startTiming
+      result <- unsafeUnTransaction action conn
+      Timing.stopTiming label startTime
+      pure result
+    else action

unison-cli/src/Unison/Cli/Monad.hs

@@ -63,13 +63,8 @@ import Control.Monad.State.Strict qualified as State
 import Data.List.NonEmpty qualified as List (NonEmpty)
 import Data.List.NonEmpty qualified as List.NonEmpty
 import Data.List.NonEmpty qualified as NonEmpty
-import Data.Time.Clock (DiffTime, diffTimeToPicoseconds)
-import Data.Time.Clock.System (getSystemTime, systemToTAITime)
-import Data.Time.Clock.TAI (diffAbsoluteTime)
 import Data.Unique (Unique, newUnique)
-import System.CPUTime (getCPUTime)
 import System.Console.Regions qualified as Console.Regions
-import Text.Printf (printf)
 import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId)
 import U.Codebase.Sqlite.Queries qualified as Q
 import Unison.Auth.CredentialManager (CredentialManager)
@@ -96,6 +91,7 @@ import Unison.Term (Term)
 import Unison.Type (Type)
 import Unison.UnisonFile qualified as UF
 import Unison.Util.Pretty qualified as Pretty
+import Unison.Util.Timing qualified as Timing
 import Unsafe.Coerce (unsafeCoerce)
 
 -- | The main command-line app monad.
@@ -340,45 +336,11 @@ time :: String -> Cli a -> Cli a
 time label action =
   if Debug.shouldDebug Debug.Timing
     then Cli \env k s -> do
-      systemStart <- getSystemTime
-      cpuPicoStart <- getCPUTime
+      startTime <- Timing.startTiming
       a <- unCli action env (\a loopState -> pure (Success a, loopState)) s
-      cpuPicoEnd <- getCPUTime
-      systemEnd <- getSystemTime
-      let systemDiff =
-            diffTimeToNanos
-              (diffAbsoluteTime (systemToTAITime systemEnd) (systemToTAITime systemStart))
-      let cpuDiff = picosToNanos (cpuPicoEnd - cpuPicoStart)
-      printf "%s: %s (cpu), %s (system)\n" label (renderNanos cpuDiff) (renderNanos systemDiff)
+      Timing.stopTiming label startTime
       feed k a
     else action
-  where
-    diffTimeToNanos :: DiffTime -> Double
-    diffTimeToNanos =
-      picosToNanos . diffTimeToPicoseconds
-
-    picosToNanos :: Integer -> Double
-    picosToNanos =
-      (/ 1_000) . realToFrac
-
-    -- Render nanoseconds, trying to fit into 4 characters.
-    renderNanos :: Double -> String
-    renderNanos ns
-      | ns < 0.5 = "0 ns"
-      | ns < 995 = printf "%.0f ns" ns
-      | ns < 9_950 = printf "%.2f µs" us
-      | ns < 99_500 = printf "%.1f µs" us
-      | ns < 995_000 = printf "%.0f µs" us
-      | ns < 9_950_000 = printf "%.2f ms" ms
-      | ns < 99_500_000 = printf "%.1f ms" ms
-      | ns < 995_000_000 = printf "%.0f ms" ms
-      | ns < 9_950_000_000 = printf "%.2f s" s
-      | ns < 99_500_000_000 = printf "%.1f s" s
-      | otherwise = printf "%.0f s" s
-      where
-        us = ns / 1_000
-        ms = ns / 1_000_000
-        s = ns / 1_000_000_000
 
 getProjectPathIds :: Cli PP.ProjectPathIds
 getProjectPathIds = do