Replace TEncoding.FLock with interlocked operations.

rtl/objpas/sysutils/sysencoding.inc

@@ -15,25 +15,37 @@
 
 { TEncoding }
 
-class function TEncoding.GetANSI: TEncoding;
+class function TEncoding.GetStandard(Se: TStandardEncoding; Ctr: TCreateEncodingProc): TEncoding;
 begin
+  Result := FStandardEncodings[Se];
+  if Assigned(Result) then
+    Exit;
+
+  Result := Ctr();
 {$ifdef FPC_HAS_FEATURE_THREADING}
-  EnterCriticalSection(FLock);
-  try
-{$endif}
-    if not Assigned(FStandardEncodings[seAnsi]) then
-    begin
-      if Assigned(widestringmanager.GetStandardCodePageProc) then
-        FStandardEncodings[seAnsi] := TMBCSEncoding.Create(widestringmanager.GetStandardCodePageProc(scpAnsi))
-      else
-        FStandardEncodings[seAnsi] := TMBCSEncoding.Create(DefaultSystemCodePage);
-    end;
-{$ifdef FPC_HAS_FEATURE_THREADING}
-  finally
-    LeaveCriticalSection(FLock);
+  if InterlockedCompareExchange(Pointer(FStandardEncodings[Se]), Pointer(Result), nil) <> nil then
+  begin
+    Result.Free;
+    Result := FStandardEncodings[Se];
   end;
+{$else}
+  FStandardEncodings[Se] := Result;
 {$endif}
-  Result := FStandardEncodings[seAnsi];
+end;
+
+class function TEncoding.CreateANSI: TEncoding;
+var
+  Cp: TSystemCodePage;
+begin
+  Cp := DefaultSystemCodePage;
+  if Assigned(widestringmanager.GetStandardCodePageProc) then
+    Cp := widestringmanager.GetStandardCodePageProc(scpAnsi);
+  Result := TMBCSEncoding.Create(Cp);
+end;
+
+class function TEncoding.GetANSI: TEncoding;
+begin
+  Result := GetStandard(seAnsi, @CreateANSI);
 end;
 
 function TEncoding.GetAnsiBytes(const S: ansistring): TBytes;
@@ -65,36 +77,24 @@ begin
   SetCodePage(RawByteString(Result), DefaultSystemCodePage, False);
 end;
 
+class function TEncoding.CreateASCII: TEncoding;
+begin
+  Result := TMBCSEncoding.Create(CP_ASCII);
+end;
+
 class function TEncoding.GetASCII: TEncoding;
 begin
-{$ifdef FPC_HAS_FEATURE_THREADING}
-  EnterCriticalSection(FLock);
-  try
-{$endif}
-    if not Assigned(FStandardEncodings[seAscii]) then
-      FStandardEncodings[seAscii] := TMBCSEncoding.Create(CP_ASCII);
-{$ifdef FPC_HAS_FEATURE_THREADING}
-  finally
-    LeaveCriticalSection(FLock);
-  end;
-{$endif}
-  Result := FStandardEncodings[seAscii];
+  Result := GetStandard(seAscii, @CreateASCII);
+end;
+
+class function TEncoding.CreateBigEndianUnicode: TEncoding;
+begin
+  Result := TBigEndianUnicodeEncoding.Create;
 end;
 
 class function TEncoding.GetBigEndianUnicode: TEncoding;
 begin
-{$ifdef FPC_HAS_FEATURE_THREADING}
-  EnterCriticalSection(FLock);
-  try
-{$endif}
-    if not Assigned(FStandardEncodings[seBigEndianUnicode]) then
-      FStandardEncodings[seBigEndianUnicode] := TBigEndianUnicodeEncoding.Create;
-{$ifdef FPC_HAS_FEATURE_THREADING}
-  finally
-    LeaveCriticalSection(FLock);
-  end;
-{$endif}
-  Result := FStandardEncodings[seBigEndianUnicode];
+  Result := GetStandard(seBigEndianUnicode, @CreateBigEndianUnicode);
 end;
 
 class function TEncoding.GetDefault: TEncoding;
@@ -104,124 +104,79 @@ end;
 
 class function TEncoding.GetSystemEncoding: TEncoding;
 var
-  I: Integer;
-begin
-{$ifdef FPC_HAS_FEATURE_THREADING}
-  EnterCriticalSection(FLock);
-  try
-{$endif}
-    for I := Low(FSystemEncodings) to High(FSystemEncodings) do
-    begin
-      if FSystemEncodings[I].CodePage=DefaultSystemCodePage then
-      begin
-        Result := FSystemEncodings[I];
-        if I<>Low(FSystemEncodings) then // exchange with first position to find it faster the next time
-        begin
-          FSystemEncodings[I] := FSystemEncodings[Low(FSystemEncodings)];
-          FSystemEncodings[Low(FSystemEncodings)] := Result;
-        end;
-        Exit;
-      end;
-    end;
+  Cp: TSystemCodePage;
+  Head: TEncoding;
+begin
+  repeat
+    Cp := DefaultSystemCodePage;
+    Head := FSystemEncodingsList; // Must not be re-read until InterlockedCompareExchange to guarantee that search was performed against this head.
+    Result := Head;
+    while Assigned(Result) do
+      if Result.CodePage = Cp then
+        Exit
+      else
+        Result := Result.FNext;
+
     // not found - create new encoding at first position
-    Result := TMBCSEncoding.Create(DefaultSystemCodePage);
-    SetLength(FSystemEncodings, Length(FSystemEncodings)+1);
-    if High(FSystemEncodings)<>Low(FSystemEncodings) then
-      FSystemEncodings[High(FSystemEncodings)] := FSystemEncodings[Low(FSystemEncodings)];
-    FSystemEncodings[Low(FSystemEncodings)] := Result;
+    Result := TMBCSEncoding.Create(Cp);
+    Result.FNext := Head;
 {$ifdef FPC_HAS_FEATURE_THREADING}
-  finally
-    LeaveCriticalSection(FLock);
-  end;
+    if InterlockedCompareExchange(Pointer(FSystemEncodingsList), Pointer(Result), Pointer(Head)) = Pointer(Head) then
+      break
+    else
+      Result.Free;
+{$else}
+    FSystemEncodingsList := Result;
+    break;
 {$endif}
+  until false;
+end;
+
+class function TEncoding.CreateUnicode: TEncoding;
+begin
+  Result := TUnicodeEncoding.Create;
 end;
 
 class function TEncoding.GetUnicode: TEncoding;
 begin
-{$ifdef FPC_HAS_FEATURE_THREADING}
-  EnterCriticalSection(FLock);
-  try
-{$endif}
-    if not Assigned(FStandardEncodings[seUnicode]) then
-      FStandardEncodings[seUnicode] := TUnicodeEncoding.Create;
-{$ifdef FPC_HAS_FEATURE_THREADING}
-  finally
-    LeaveCriticalSection(FLock);
-  end;
-{$endif}
-  Result := FStandardEncodings[seUnicode];
+  Result := GetStandard(seUnicode, @CreateUnicode);
 end;
 
-class function TEncoding.GetUTF7: TEncoding;
+class function TEncoding.CreateUTF7: TEncoding;
 begin
-{$ifdef FPC_HAS_FEATURE_THREADING}
-  EnterCriticalSection(FLock);
-  try
-{$endif}
-    if not Assigned(FStandardEncodings[seUTF7]) then
-      FStandardEncodings[seUTF7] := TUTF7Encoding.Create;
-{$ifdef FPC_HAS_FEATURE_THREADING}
-  finally
-    LeaveCriticalSection(FLock);
-  end;
-{$endif}
-  Result := FStandardEncodings[seUTF7];
+  Result := TUTF7Encoding.Create;
 end;
 
-class function TEncoding.GetUTF8: TEncoding;
+class function TEncoding.GetUTF7: TEncoding;
 begin
-{$ifdef FPC_HAS_FEATURE_THREADING}
-  EnterCriticalSection(FLock);
-  try
-{$endif}
-    if not Assigned(FStandardEncodings[seUTF8]) then
-      FStandardEncodings[seUTF8] := TUTF8Encoding.Create;
-{$ifdef FPC_HAS_FEATURE_THREADING}
-  finally
-    LeaveCriticalSection(FLock);
-  end;
-{$endif}
-  Result := FStandardEncodings[seUTF8];
+  Result := GetStandard(seUTF7, @CreateUTF7);
 end;
 
-class procedure TEncoding.FreeEncodings;
-var
-  E: TStandardEncoding;
-  I: Integer;
+class function TEncoding.CreateUTF8: TEncoding;
 begin
-{$ifdef FPC_HAS_FEATURE_THREADING}
-  EnterCriticalSection(FLock);
-  try
-{$endif}
-    for E := Low(FStandardEncodings) to High(FStandardEncodings) do
-      FreeAndNil(FStandardEncodings[E]);
-    for I := Low(FSystemEncodings) to High(FSystemEncodings) do
-      FSystemEncodings[I].Free;
-    SetLength(FSystemEncodings, 0);
-{$ifdef FPC_HAS_FEATURE_THREADING}
-  finally
-    LeaveCriticalSection(FLock);
-  end;
-{$endif}
+  Result := TUTF8Encoding.Create;
 end;
 
-class constructor TEncoding.Create;
-var
-  E: TStandardEncoding;
+class function TEncoding.GetUTF8: TEncoding;
 begin
-  for E := Low(FStandardEncodings) to High(FStandardEncodings) do
-    FStandardEncodings[E] := nil;
-{$ifdef FPC_HAS_FEATURE_THREADING}
-  InitCriticalSection(FLock);
-{$endif}
+  Result := GetStandard(seUTF8, @CreateUTF8);
 end;
 
 class destructor TEncoding.Destroy;
+var
+  E: TStandardEncoding;
+  Se: TEncoding;
 begin
-  FreeEncodings;
-{$ifdef FPC_HAS_FEATURE_THREADING}
-  DoneCriticalSection(FLock);
-{$endif}
+  // Synchronization shouldn't be required for class destructors.
+  for E := Low(FStandardEncodings) to High(FStandardEncodings) do
+    FreeAndNil(FStandardEncodings[E]);
+  repeat
+    Se := FSystemEncodingsList;
+    if not Assigned(Se) then
+      break;
+    FSystemEncodingsList := Se.FNext;
+    Se.Free;
+  until false;
 end;
 
 function TEncoding.Clone: TEncoding;
@@ -250,9 +205,12 @@ begin
     for Encoding in FStandardEncodings do
       if Encoding = AEncoding then
         Exit(True);
-    for Encoding in FSystemEncodings do
+    Encoding := FSystemEncodingsList;
+    while Assigned(Encoding) do
       if Encoding = AEncoding then
-        Exit(True);
+        Exit(True)
+      else
+        Encoding := Encoding.FNext;
   end;
   Result := False;
 end;

rtl/objpas/sysutils/sysencodingh.inc

@@ -28,26 +28,32 @@ type
         seBigEndianUnicode,
         seUTF7,
         seUTF8);
-    var
-      FStandardEncodings: array[TStandardEncoding] of TEncoding; static;
-      FSystemEncodings: array of TEncoding; static;
+      TCreateEncodingProc = function: TEncoding; // "case Se of" or the like is simpler but would link all encodings into the executable.
     Class Var
-      FLock : TRTLCriticalSection;
-    class function GetANSI: TEncoding; static;
-    class function GetASCII: TEncoding; static;
-    class function GetBigEndianUnicode: TEncoding; static;
+      FStandardEncodings: array[TStandardEncoding] of TEncoding;
+      FSystemEncodingsList: TEncoding;
+    var
+      FNext: TEncoding;
+    class function GetStandard(Se: TStandardEncoding; Ctr: TCreateEncodingProc): TEncoding; static;
+    class function CreateANSI: TEncoding; static;
+    class function GetANSI: TEncoding; static; inline;
+    class function CreateASCII: TEncoding; static;
+    class function GetASCII: TEncoding; static; inline;
+    class function CreateBigEndianUnicode: TEncoding; static;
+    class function GetBigEndianUnicode: TEncoding; static; inline;
     class function GetDefault: TEncoding; static;
     class function GetSystemEncoding: TEncoding; static;
-    class function GetUnicode: TEncoding; static;
-    class function GetUTF7: TEncoding; static;
-    class function GetUTF8: TEncoding; static;
+    class function CreateUnicode: TEncoding; static;
+    class function GetUnicode: TEncoding; static; inline;
+    class function CreateUTF7: TEncoding; static;
+    class function GetUTF7: TEncoding; static; inline;
+    class function CreateUTF8: TEncoding; static;
+    class function GetUTF8: TEncoding; static; inline;
 
-    class constructor Create;
     class destructor Destroy;
   strict protected
     FIsSingleByte: Boolean;
     FMaxCharSize: Integer;
-    class procedure FreeEncodings;
     function GetByteCount(Chars: PUnicodeChar; CharCount: Integer): Integer; overload; virtual; abstract;
     function GetBytes(Chars: PUnicodeChar; CharCount: Integer; Bytes: PByte; ByteCount: Integer): Integer; overload; virtual; abstract;
     function GetCharCount(Bytes: PByte; ByteCount: Integer): Integer; overload; virtual; abstract;