From 4d63b774988a6356ffbaced967365f6ce3d75208 Mon Sep 17 00:00:00 2001 From: Michael Messer <16529951+michaelmesser@users.noreply.github.com> Date: Sat, 29 May 2021 14:28:55 -0500 Subject: [PATCH 1/2] Add timing --- src/Server/Configuration.idr | 3 +++ src/Server/Log.idr | 21 +++++++++++++++++++++ src/Server/ProcessMessage.idr | 14 +++++++++----- 3 files changed, 33 insertions(+), 5 deletions(-) diff --git a/src/Server/Configuration.idr b/src/Server/Configuration.idr index e6dd021..3c35b23 100644 --- a/src/Server/Configuration.idr +++ b/src/Server/Configuration.idr @@ -57,6 +57,8 @@ record LSPConfiguration where longActionTimeout : Clock Duration ||| next id for requests to the server nextRequestId : Nat + ||| indent for duration + logDurationIndent : Nat ||| Server default configuration. Uses standard input and standard output for input/output. export @@ -78,4 +80,5 @@ defaultConfig = , cachedHovers = empty , longActionTimeout = makeDuration 5 0 , nextRequestId = 0 + , logDurationIndent = 0 } diff --git a/src/Server/Log.idr b/src/Server/Log.idr index 25ead35..b939b13 100644 --- a/src/Server/Log.idr +++ b/src/Server/Log.idr @@ -10,6 +10,8 @@ import Server.Utils import System.Directory import System.File import System.Path +import System.Clock +import Data.String.Extra %default total @@ -61,6 +63,25 @@ export logShow : Ref LSPConf LSPConfiguration => Show a => Severity -> a -> Core () logShow severity = logString severity . show +export +logDuration : Ref LSPConf LSPConfiguration => String -> Core a -> Core a +logDuration desc action = do + logDurationIndent <- gets LSPConf logDurationIndent + let nano = 1000000000 + logHandle <- gets LSPConf logHandle + startClock <- coreLift (clockTime Process) + let indent = replicate (logDurationIndent * 2) ' ' + ignore $ coreLift $ fPutStrLn logHandle ("TIMING: \{indent}\{desc} started") + modify LSPConf (record { logDurationIndent = logDurationIndent + 1 }) + result <- action + modify LSPConf (record { logDurationIndent = logDurationIndent }) + endClock <- coreLift (clockTime Process) + let duration = endClock `timeDifference` startClock + let nanoseconds = seconds duration * nano + nanoseconds duration + let milliseconds = nanoseconds `div` 1000000 + ignore $ coreLift $ fPutStrLn logHandle ("TIMING: \{indent}\{desc} took \{show milliseconds} ms") + pure result + ||| Changes the log file location, if possible. export covering changeLogFile : Ref LSPConf LSPConfiguration => String -> Core () diff --git a/src/Server/ProcessMessage.idr b/src/Server/ProcessMessage.idr index 5e1a9a5..fd1c350 100644 --- a/src/Server/ProcessMessage.idr +++ b/src/Server/ProcessMessage.idr @@ -79,7 +79,7 @@ loadURI : Ref LSPConf LSPConfiguration => Ref MD Metadata => Ref ROpts REPLOpts => InitializeParams -> URI -> Maybe Int -> Core (Either String ()) -loadURI conf uri version = do +loadURI conf uri version = logDuration "Loading \{uri.path}" $ do modify LSPConf (record {openFile = Just (uri, fromMaybe 0 version)}) resetContext "(interactive)" let fpath = uri.path @@ -221,7 +221,8 @@ handleRequest Shutdown params = do handleRequest TextDocumentHover params = whenActiveRequest $ \conf => do False <- isDirty params.textDocument.uri | True => pure $ pure $ make $ MkNull - withURI conf params.textDocument.uri Nothing (pure $ pure $ make $ MkNull) $ do + withURI conf params.textDocument.uri Nothing (pure $ pure $ make $ MkNull) $ + logDuration "Hover for loaded file \{params.textDocument.uri.path}" $ do Nothing <- gets LSPConf (map snd . head' . searchPos (cast params.position) . cachedHovers) | Just hover => do logString Debug "hover: found cached action" pure $ pure $ make hover @@ -259,7 +260,8 @@ handleRequest TextDocumentDefinition params = whenActiveRequest $ \conf => do handleRequest TextDocumentCodeAction params = whenActiveRequest $ \conf => do False <- isDirty params.textDocument.uri | True => pure $ pure $ make $ MkNull - withURI conf params.textDocument.uri Nothing (pure $ pure $ make $ MkNull) $ do + withURI conf params.textDocument.uri Nothing (pure $ pure $ make $ MkNull) $ + logDuration "Code actions for loaded file \{params.textDocument.uri.path}" $ do quickfixActions <- map Just <$> gets LSPConf quickfixes exprSearchAction <- map Just <$> exprSearch params splitAction <- caseSplit params @@ -288,7 +290,8 @@ handleRequest TextDocumentSignatureHelp params = whenActiveRequest $ \conf => do handleRequest TextDocumentDocumentSymbol params = whenActiveRequest $ \conf => do False <- isDirty params.textDocument.uri | True => pure $ pure $ make $ MkNull - withURI conf params.textDocument.uri Nothing (pure $ pure $ make $ MkNull) $ do + withURI conf params.textDocument.uri Nothing (pure $ pure $ make $ MkNull) $ + logDuration "Document symbols for loaded file \{params.textDocument.uri.path}" $ do documentSymbolData <- documentSymbol params pure $ pure $ make documentSymbolData @@ -306,7 +309,8 @@ handleRequest TextDocumentSemanticTokensFull params = whenActiveRequest $ \conf | True => pure $ Left (MkResponseError RequestCancelled "Document Dirty" JNull) False <- gets LSPConf (contains params.textDocument.uri . semanticTokensSentFiles) | True => pure $ Left (MkResponseError RequestCancelled "Semantic tokens already sent" JNull) - withURI conf params.textDocument.uri Nothing (pure $ Left (MkResponseError RequestCancelled "Document Errors" JNull)) $ do + withURI conf params.textDocument.uri Nothing (pure $ Left (MkResponseError RequestCancelled "Document Errors" JNull)) $ + logDuration "Highlighing for loaded file \{params.textDocument.uri.path}" $ do md <- get MD src <- getSource let srcLines = forget $ lines src From 0de2edda7d4a26449273296e453891f2ef444d27 Mon Sep 17 00:00:00 2001 From: Michael Messer <16529951+michaelmesser@users.noreply.github.com> Date: Sat, 29 May 2021 15:48:01 -0500 Subject: [PATCH 2/2] Improving timing --- Idris2 | 2 +- src/Server/Main.idr | 58 ++++++++++++++++++++++------------- src/Server/ProcessMessage.idr | 7 +++-- 3 files changed, 41 insertions(+), 26 deletions(-) diff --git a/Idris2 b/Idris2 index 6f83924..6df80ff 160000 --- a/Idris2 +++ b/Idris2 @@ -1 +1 @@ -Subproject commit 6f839240c5eac4c5c36bddd19f005415efeca3c2 +Subproject commit 6df80ffee9f65a0672fff3f11bdf2c5522e8c44c diff --git a/src/Server/Main.idr b/src/Server/Main.idr index 15ffe2d..cfa7c3e 100644 --- a/src/Server/Main.idr +++ b/src/Server/Main.idr @@ -65,21 +65,16 @@ parseHeaderPart h = do Just StartContent => pure $ Right Nothing Nothing => pure $ Right Nothing -handleMessage : Ref LSPConf LSPConfiguration - => Ref Ctxt Defs - => Ref UST UState - => Ref Syn SyntaxInfo - => Ref MD Metadata - => Ref ROpts REPLOpts - => Core () -handleMessage = do - inputHandle <- gets LSPConf inputHandle - Right (Just l) <- parseHeaderPart inputHandle - | _ => sendUnknownResponseMessage parseError - Right msg <- coreLift $ fGetChars inputHandle l - | Left err => do - logShow Error (show err) - sendUnknownResponseMessage (internalError "Error while recovering the content part of a message") +handleMessageString + : Ref LSPConf LSPConfiguration + => Ref Ctxt Defs + => Ref UST UState + => Ref Syn SyntaxInfo + => Ref MD Metadata + => Ref ROpts REPLOpts + => String + -> Core () +handleMessageString msg = logDuration "handleMessageString" $ do logString Debug msg let Just msg = parse msg | _ => sendUnknownResponseMessage parseError @@ -122,13 +117,32 @@ handleMessage = do | _ => sendUnknownResponseMessage (invalidRequest "Message does not have method or id") logString Warning "Ignoring response with id \{show idJSON}" -runServer : Ref LSPConf LSPConfiguration - => Ref Ctxt Defs - => Ref UST UState - => Ref Syn SyntaxInfo - => Ref MD Metadata - => Ref ROpts REPLOpts - => Core () +handleMessage + : Ref LSPConf LSPConfiguration + => Ref Ctxt Defs + => Ref UST UState + => Ref Syn SyntaxInfo + => Ref MD Metadata + => Ref ROpts REPLOpts + => Core () +handleMessage = do + inputHandle <- gets LSPConf inputHandle + Right (Just l) <- parseHeaderPart inputHandle + | _ => sendUnknownResponseMessage parseError + Right msg <- coreLift $ fGetChars inputHandle l + | Left err => do + logShow Error (show err) + sendUnknownResponseMessage (internalError "Error while recovering the content part of a message") + handleMessageString msg + +runServer + : Ref LSPConf LSPConfiguration + => Ref Ctxt Defs + => Ref UST UState + => Ref Syn SyntaxInfo + => Ref MD Metadata + => Ref ROpts REPLOpts + => Core () runServer = do handleMessage runServer diff --git a/src/Server/ProcessMessage.idr b/src/Server/ProcessMessage.idr index b59f5f9..ce6b217 100644 --- a/src/Server/ProcessMessage.idr +++ b/src/Server/ProcessMessage.idr @@ -80,7 +80,7 @@ loadURI : Ref LSPConf LSPConfiguration => Ref MD Metadata => Ref ROpts REPLOpts => InitializeParams -> URI -> Maybe Int -> Core (Either String ()) -loadURI conf uri version = logDuration "Loading \{uri.path}" $ do +loadURI conf uri version = logDuration "loadURI \{uri.path}" $ do modify LSPConf (record {openFile = Just (uri, fromMaybe 0 version)}) resetContext "(interactive)" let fpath = uri.path @@ -101,8 +101,9 @@ loadURI conf uri version = logDuration "Loading \{uri.path}" $ do logString Error msg pure $ Left msg setSource res - errs <- buildDeps fname -- FIXME: the compiler always dumps the errors on stdout, requires - -- a compiler change. + errs <- logDuration "buildDeps \{fname}" $ buildDeps fname + -- FIXME: the compiler always dumps the errors on stdout, + -- requires a compiler change. case errs of [] => pure () (_::_) => modify LSPConf (record { errorFiles $= insert uri })