From 82f438a593458e657bca53e548f98761bea4cd38 Mon Sep 17 00:00:00 2001 From: Rio Sanjaya Date: Wed, 14 Oct 2026 07:42:47 +0700 Subject: [PATCH 1/5] Add threaded request reader and signaled queue --- src/protocol/PasLS.JSONSignaledQueue.pas | 99 ++++++++++++++++++ src/protocol/PasLS.TextLoop.pas | 123 ++++++++++++++--------- src/standard/pasls.lpr | 7 +- 3 files changed, 183 insertions(+), 46 deletions(-) create mode 100644 src/protocol/PasLS.JSONSignaledQueue.pas diff --git a/src/protocol/PasLS.JSONSignaledQueue.pas b/src/protocol/PasLS.JSONSignaledQueue.pas new file mode 100644 index 0000000..06c2a00 --- /dev/null +++ b/src/protocol/PasLS.JSONSignaledQueue.pas @@ -0,0 +1,99 @@ +unit PasLS.JSONSignaledQueue; + +{$mode objfpc}{$H+} + +interface + +uses + SysUtils, fpjson, fgl, syncobjs, Classes; + +type + TJSONSignaledQueue = class + private + FList: specialize TFPGObjectList; + FLock: TCriticalSection; + FReadyEvent: TEvent; // Event used to signal new data inQueue + public + constructor Create; + destructor Destroy; override; + + procedure Enqueue(AItem: TJSONData); + { DequeueWaiting blocks the calling thread until an item is available + or the timeout expires. Returns True if an item was successfully retrieved. } + function DequeueWaiting(out AItem: TJSONData; TimeoutMS: Cardinal = INFINITE): Boolean; + procedure SignalShutdown; + end; + +implementation + +constructor TJSONSignaledQueue.Create; +begin + inherited Create; + // FList owns request JSON Data + FList := specialize TFPGObjectList.Create(True); + FLock := TCriticalSection.Create; + // ManualReset = False (auto-resets when a thread wakes up) + // InitialState = False (starts unsignaled) + FReadyEvent := TEvent.Create(nil, False, False, ''); +end; + +destructor TJSONSignaledQueue.Destroy; +begin + FList.Free; + FReadyEvent.Free; + FLock.Free; + inherited Destroy; +end; + +procedure TJSONSignaledQueue.Enqueue(AItem: TJSONData); +begin + FLock.Acquire; + try + FList.Add(AItem); + finally + FLock.Release; + end; + // Signal DequeueWaiting to resume waiting + FReadyEvent.SetEvent; +end; + +function TJSONSignaledQueue.DequeueWaiting(out AItem: TJSONData; TimeoutMS: Cardinal): Boolean; +var + WaitResult: TWaitResult; +begin + AItem := nil; + Result := False; + + while True do + begin + FLock.Acquire; + try + if FList.Count > 0 then + begin + AItem := FList[0]; + // Effectively transfers ownership to AItem + FList.Extract(AItem); + Result := True; + end; + finally + FLock.Release; + end; + if Result then + Exit; // Successfully retrieved an item + + // Queue was empty; sleep efficiently until an item is pushed or timeout occurs + WaitResult := FReadyEvent.WaitFor(TimeoutMS); + + // If it timed out or the event was explicitly reset/abandoned, exit gracefully + if WaitResult <> wrSignaled then + Exit; + end; +end; + +procedure TJSONSignaledQueue.SignalShutdown; +begin + // Broadcast to all waiting threads so they wake up and check terminate status + FReadyEvent.SetEvent; +end; + +end. \ No newline at end of file diff --git a/src/protocol/PasLS.TextLoop.pas b/src/protocol/PasLS.TextLoop.pas index 1e751b6..ccc8bbd 100644 --- a/src/protocol/PasLS.TextLoop.pas +++ b/src/protocol/PasLS.TextLoop.pas @@ -24,7 +24,7 @@ interface uses - Classes, SysUtils, LSP.Base, LSP.Messages, fpjson; + Classes, SysUtils, LSP.Base, LSP.Messages, fpjson, PasLS.JSONSignaledQueue; Type @@ -44,7 +44,16 @@ TLSPTextTransport = class(TMessageTransport) Procedure EmitMessage(aMessage: TJSONStringType); end; - + TRequestReaderThread = class(TThread) + private + FQueue: TJSONSignaledQueue; + FFile: ^Text; + FContext: ^TLSPContext; + protected + procedure Execute; override; + public + constructor Create(AQueue: TJSONSignaledQueue; var aFile : text; var aContext : TLSPContext); + end; Procedure SetupTextLoop(var aInput,aOutput,aError : Text); Procedure RunMessageLoop(var aInput,aOutput,aError : Text; aContext : TLSPContext); @@ -89,9 +98,17 @@ procedure DebugSendMessage(var aFile : Text; aContext : TLSPContext; const aMeth end; +constructor TRequestReaderThread.Create(AQueue: TJSONSignaledQueue; var aFile : text; var aContext : TLSPContext); +begin + inherited Create(False); // Start immediately + FQueue := AQueue; + FreeOnTerminate := False; -Function ReadRequest(var aFile : text; aContext : TLSPContext) : TJSONData; + FFile := @aFile; + FContext := @aContext; +end; +procedure TRequestReaderThread.Execute; Var Header,Name,Value: String; Content : TJSONStringType; @@ -99,30 +116,34 @@ procedure DebugSendMessage(var aFile : Text; aContext : TLSPContext; const aMeth P : PJSONCharType; begin - Result:=Nil; - aContext.Log('Reading request'); - ReadLn(aFile,Header); - while Header <> '' do + while not Terminated and not EOF(FFile^) do begin - aContext.Log('Read header: %s',[Header]); - I := Pos(':', Header); - Name := Copy(Header, 1, I - 1); - Delete(Header, 1, i); - Value := Trim(Header); - if Name = 'Content-Length' then - ContentLength := StrToIntDef(Value,0); - ReadLn(aFile,Header); - end; - Content:=''; - SetLength(Content,ContentLength); - P:=PJSONCharType(Content); - for I:=1 to ContentLength do - begin - Read(aFile,P^); - inc(P); + FContext^.Log('Reading request'); + ReadLn(FFile^,Header); + + while Header <> '' do + begin + FContext^.Log('Read header: %s',[Header]); + I := Pos(':', Header); + Name := Copy(Header, 1, I - 1); + Delete(Header, 1, i); + Value := Trim(Header); + if Name = 'Content-Length' then + ContentLength := StrToIntDef(Value,0); + ReadLn(FFile^,Header); + end; + Content:=''; + SetLength(Content,ContentLength); + P:=PJSONCharType(Content); + for I:=1 to ContentLength do + begin + Read(FFile^,P^); + inc(P); + end; + if Content<>'' then + FQueue.Enqueue(GetJSON(Content, True)); + FContext^.Log('Waiting request'); end; - if Content<>'' then - Result:=GetJSON(Content, True); end; Procedure SendResponse(aTransport : TMessageTransport; aContext : TLSPContext; aResponse : TJSONData; aFreeResponse : Boolean = True); @@ -150,6 +171,8 @@ procedure DebugSendMessage(var aFile : Text; aContext : TLSPContext; const aMeth Procedure RunMessageLoop(var aInput,aOutput,aError : Text; aContext : TLSPContext); var + RequestQueue: TJSONSignaledQueue; + RequestReader: TRequestReaderThread; Request, Response: TJSONData; VerboseDebugging: boolean = false; IO : TLSPTextTransport; @@ -158,38 +181,48 @@ procedure DebugSendMessage(var aFile : Text; aContext : TLSPContext; const aMeth IO:=Nil; Request:=Nil; try + RequestQueue := TJSONSignaledQueue.Create; + RequestReader := TRequestReaderThread.Create(RequestQueue, aInput, aContext); + if aContext.Transport is TLSPTextTransport then IO:=aContext.Transport as TLSPTextTransport else IO:=TLSPTextTransport.Create(@aOutput,@aError); - while not EOF(aInput) do + while not RequestReader.Finished do begin - Request:=ReadRequest(aInput,aContext); - // log request payload - if VerboseDebugging then - begin - Writeln(aError, Request.FormatJSON); - Flush(aError); - end; - Response := aContext.Execute(Request); - if Assigned(Response) then - begin - // log response payload - if VerboseDebugging then + if RequestQueue.DequeueWaiting(Request, INFINITE) then begin - writeln(aError, Response.asJSON); - Flush(aError); + // log request payload + if VerboseDebugging then + begin + Writeln(aError, Request.FormatJSON); + Flush(aError); + end; + Response := aContext.Execute(Request); + if Assigned(Response) then + begin + // log response payload + if VerboseDebugging then + begin + writeln(aError, Response.asJSON); + Flush(aError); + end; + SendResponse(IO, aContext, Response,True); + end + else + aContext.Log('No response to request'); + FreeAndNil(Request); end; - SendResponse(IO, aContext, Response,True); - end - else - aContext.Log('No response to request'); - FreeAndNil(Request); end; finally if IO<>aContext.Transport then IO.Free; Request.Free; + RequestReader.Terminate; + RequestQueue.SignalShutdown; + RequestReader.WaitFor; + RequestReader.Free; + RequestQueue.Free; end; end; diff --git a/src/standard/pasls.lpr b/src/standard/pasls.lpr index ee373a1..193e7c2 100644 --- a/src/standard/pasls.lpr +++ b/src/standard/pasls.lpr @@ -23,6 +23,9 @@ {$mode objfpc}{$H+} uses + {$IFDEF UNIX} + cthreads, // Required for multi-threading on Linux/macOS + {$ENDIF} {$IFDEF WINDOWS} Windows, {$ENDIF} @@ -31,7 +34,7 @@ { Protocol } PasLS.AllCommands, PasLS.Settings, PasLS.Commands, LSP.Base, LSP.Basic, LSP.Capabilities, LSP.Options, - PasLS.TextLoop, PasLS.LSConfig, PasLS.General; + PasLS.TextLoop, PasLS.LSConfig, PasLS.General, LazLogger; Type @@ -296,6 +299,8 @@ procedure TLSPLogContext.DoTransportLog(sender: TObject; const Msg: UTF8String); begin + DebugLogger.LogName := '~/lazlogger.log'; + DebugLogger.CloseLogFileBetweenWrites := True; // Show help for the server if ParamStr(1) = '-h' then begin From 39d0eb1bdc1dd0528d7bafd39070d1fca7c3bf28 Mon Sep 17 00:00:00 2001 From: Rio Sanjaya Date: Wed, 14 Oct 2026 07:57:09 +0700 Subject: [PATCH 2/5] Log LSP method names in text loop --- src/protocol/PasLS.TextLoop.pas | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/protocol/PasLS.TextLoop.pas b/src/protocol/PasLS.TextLoop.pas index ccc8bbd..41552e2 100644 --- a/src/protocol/PasLS.TextLoop.pas +++ b/src/protocol/PasLS.TextLoop.pas @@ -114,6 +114,7 @@ procedure TRequestReaderThread.Execute; Content : TJSONStringType; I,ContentLength : Integer; P : PJSONCharType; + ContentData: TJSONData; begin while not Terminated and not EOF(FFile^) do @@ -141,7 +142,11 @@ procedure TRequestReaderThread.Execute; inc(P); end; if Content<>'' then - FQueue.Enqueue(GetJSON(Content, True)); + begin + ContentData := GetJSON(Content, True); + FContext^.Log('===theoi: content: %s', [(ContentData as TJSONObject).Strings['method']]); + FQueue.Enqueue(ContentData); + end; FContext^.Log('Waiting request'); end; end; From 72c013b7656a100d5373e261bc6d4479b6d0407e Mon Sep 17 00:00:00 2001 From: Rio Sanjaya Date: Thu, 15 Oct 2026 09:23:01 +0700 Subject: [PATCH 3/5] Coalesce redundant textDocument/didChange events in queue --- src/protocol/PasLS.JSONSignaledQueue.pas | 23 ++++++++++++++++++++++- src/protocol/PasLS.TextLoop.pas | 1 - 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/src/protocol/PasLS.JSONSignaledQueue.pas b/src/protocol/PasLS.JSONSignaledQueue.pas index 06c2a00..0011d85 100644 --- a/src/protocol/PasLS.JSONSignaledQueue.pas +++ b/src/protocol/PasLS.JSONSignaledQueue.pas @@ -46,10 +46,31 @@ destructor TJSONSignaledQueue.Destroy; end; procedure TJSONSignaledQueue.Enqueue(AItem: TJSONData); +var + I: Integer; + JSONObj: TJSONObject; begin FLock.Acquire; try - FList.Add(AItem); + if AItem is TJSONObject then + begin + JSONObj := (AItem as TJSONObject); + if JSONObj.Get('method', '') = 'textDocument/didChange' then + begin + for I := 0 to FList.Count - 1 do + begin + if Flist[I] is TJsonObject then + begin + if (Flist[I] as TJSONObject).Get('method', '') = 'textDocument/didChange' then + begin + FList.Remove(FList[I]); + break + end; + end; + end; + end; + end; + FList.Add(AItem); finally FLock.Release; end; diff --git a/src/protocol/PasLS.TextLoop.pas b/src/protocol/PasLS.TextLoop.pas index 41552e2..6bfa316 100644 --- a/src/protocol/PasLS.TextLoop.pas +++ b/src/protocol/PasLS.TextLoop.pas @@ -144,7 +144,6 @@ procedure TRequestReaderThread.Execute; if Content<>'' then begin ContentData := GetJSON(Content, True); - FContext^.Log('===theoi: content: %s', [(ContentData as TJSONObject).Strings['method']]); FQueue.Enqueue(ContentData); end; FContext^.Log('Waiting request'); From c3f84b1c1676e016cc8a9bdbbdb794de33820c82 Mon Sep 17 00:00:00 2001 From: Rio Sanjaya Date: Thu, 15 Oct 2026 09:33:00 +0700 Subject: [PATCH 4/5] pasls.lpr: remove debug --- src/standard/pasls.lpr | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/standard/pasls.lpr b/src/standard/pasls.lpr index 193e7c2..9848dcf 100644 --- a/src/standard/pasls.lpr +++ b/src/standard/pasls.lpr @@ -34,7 +34,7 @@ { Protocol } PasLS.AllCommands, PasLS.Settings, PasLS.Commands, LSP.Base, LSP.Basic, LSP.Capabilities, LSP.Options, - PasLS.TextLoop, PasLS.LSConfig, PasLS.General, LazLogger; + PasLS.TextLoop, PasLS.LSConfig, PasLS.General; Type @@ -299,8 +299,6 @@ procedure TLSPLogContext.DoTransportLog(sender: TObject; const Msg: UTF8String); begin - DebugLogger.LogName := '~/lazlogger.log'; - DebugLogger.CloseLogFileBetweenWrites := True; // Show help for the server if ParamStr(1) = '-h' then begin From 40b2dff0830f5895cd3f087830806c43681e96df Mon Sep 17 00:00:00 2001 From: Rio Sanjaya Date: Thu, 15 Oct 2026 10:02:55 +0700 Subject: [PATCH 5/5] Use hexadecimal literal for infinite timeout in request queue; backward compatibility --- src/protocol/PasLS.TextLoop.pas | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/protocol/PasLS.TextLoop.pas b/src/protocol/PasLS.TextLoop.pas index 6bfa316..13ea71c 100644 --- a/src/protocol/PasLS.TextLoop.pas +++ b/src/protocol/PasLS.TextLoop.pas @@ -194,7 +194,7 @@ procedure TRequestReaderThread.Execute; IO:=TLSPTextTransport.Create(@aOutput,@aError); while not RequestReader.Finished do begin - if RequestQueue.DequeueWaiting(Request, INFINITE) then + if RequestQueue.DequeueWaiting(Request, $FFFFFFFF) then begin // log request payload if VerboseDebugging then