View Issue Details

IDProjectCategoryView StatusLast Update
0037089FPCRTLpublic2020-06-21 02:38
ReporterNoName Assigned ToMichael Van Canneyt  
PrioritynormalSeverityminorReproducibilityalways
Status assignedResolutionopen 
Product Version3.3.1 
Summary0037089: Add TInterlocked class from Delphi
DescriptionNeeded for Delphi and easier/cleaner than using InterLockedIncrement/InterlockedCompareExchange/etc functions.

http://docwiki.embarcadero.com/Libraries/Rio/en/System.SyncObjs.TInterlocked
TagsNo tags attached.
Fixed in Revision
FPCOldBugId
FPCTarget
Attached Files

Activities

Bi0T1N

2020-05-20 18:10

reporter   ~0122957

Last edited: 2020-05-20 18:11

View 2 revisions

I've implemented most of it, just struggle with the Double/Single variant (no underlying function available for these types) and both BitTest* variants as my current code for them isn't atomic.


e.g. BitTestAndClear:
  // get actual value
  OldValue := InterlockedCompareExchange(Target, 0, 0);
  // bit set?
  Result := OldValue.TestBit(BitOffset);
  ChangedValue := OldValue.ClearBit(BitOffset);
  // write new value with bit set to zero if value is still the same in target
  InterlockedCompareExchange(Target, ChangedValue, OldValue);


Thaddy de Koning

2020-05-20 18:24

reporter   ~0122959

Last edited: 2020-05-20 18:25

View 2 revisions

Can you show the code? You can cast it to the bitpattern and on many cpu's the operations is already atomic (arm, intel) for most integer types, signed or not..

Bi0T1N

2020-05-20 20:54

reporter   ~0122963

The code above is from my function. The Double/Single exchange isn't implemented as I'd need to compare the values behind it - not just the memory addresses as you can do for objects.
Also attached my set of tests.
TInterlocked_tests.pas (4,743 bytes)   
program TInterlocked_tests;

{$mode Delphi}

uses
  SysUtils, SyncObjs, Classes;

var
  i32: Integer;
  New32, Old32: Integer;
  i64: Int64;
  New64, Old64: Int64;
  Changed: Boolean;
  list1, list2, oldlist: TStringList;
  d1, d2, dOld: Double;
  s1, s2, sOld: Single;

begin
  writeln('start testing of TInterlocked methods');

  {* test all kinds of integer usage *}
  i32 := 12;
  New32 := TInterlocked.Increment(i32);
  if New32 <> 13 then halt(1);
  if i32 <> 13 then halt(2);

  New32 := TInterlocked.Decrement(i32);
  if New32 <> 12 then halt(3);
  if i32 <> 12 then halt(4);

  New32 := TInterlocked.Add(i32, 12);
  if New32 <> 24 then halt(5);
  if i32 <> 24 then halt(6);

  Old32 := TInterlocked.CompareExchange(i32, 36, 24);
  if Old32 <> 24 then halt(7);
  if i32 <> 36 then halt(8);

  Old32 := TInterlocked.CompareExchange(i32, 48, 36, Changed);
  if Old32 <> 36 then halt(9);
  if Changed <> True then halt(10);
  if i32 <> 48 then halt(11);

  Old32 := TInterlocked.CompareExchange(i32, 123, 96, Changed);
  if Old32 <> 48 then halt(12);
  if Changed <> False then halt(13);
  if i32 <> 48 then halt(14);

  Old32 := TInterlocked.Exchange(i32, 96);
  if Old32 <> 48 then halt(15);
  if i32 <> 96 then halt(15);

  {* test all kinds of Int64 usage *}
  i64 := 12;
  New64 := TInterlocked.Increment(i64);
  if New64 <> 13 then halt(20);
  if i64 <> 13 then halt(21);

  New64 := TInterlocked.Decrement(i64);
  if New64 <> 12 then halt(22);
  if i64 <> 12 then halt(23);

  New64 := TInterlocked.Add(i64, 12);
  if New64 <> 24 then halt(24);
  if i64 <> 24 then halt(25);

  Old64 := TInterlocked.CompareExchange(i64, 36, 24);
  if Old64 <> 24 then halt(26);
  if i64 <> 36 then halt(27);

  Old64 := TInterlocked.Exchange(i64, 48);
  if Old64 <> 36 then halt(28);
  if i64 <> 48 then halt(29);

  Old64 := TInterlocked.Read(i64);
  if Old64 <> 48 then halt(30);
  if i64 <> 48 then halt(31);

  {* test all kinds of TObject and generic class usage *}
  list1 := TStringList.Create;
  list2 := TStringList.Create;
  try
    list1.Add('A');
    list2.Add('B');
    list2.Add('C');

    { TObject }
    oldlist := TStringList(TInterlocked.CompareExchange(TObject(list1), TObject(list2), TObject(list1)));
    if list1 <> list2 then halt(32);
    if oldlist.Count = list1.Count then halt(33);
    if oldlist.Count = list2.Count then halt(34);

    oldlist := TStringList(TInterlocked.Exchange(TObject(list1), TObject(oldlist)));
    if oldlist <> list2 then halt(35);
    if list1.Count <> 1 then halt(36);
    if list2.Count <> 2 then halt(37);

    { generic class }
    oldlist := TInterlocked.CompareExchange<TStringList>(list1, list2, list1);
    if list1 <> list2 then halt(38);
    if oldlist.Count = list1.Count then halt(39);
    if oldlist.Count = list2.Count then halt(40);

    oldlist := TInterlocked.Exchange<TStringList>(list1, oldlist);
    if oldlist <> list2 then halt(41);
    if list1.Count <> 1 then halt(42);
    if list2.Count <> 2 then halt(43);
  finally
    list1.Free;
    list2.Free;
  end;

  writeln('tests passed so far');

  {* test all kinds of Double usage *}
  d1 := Double(3.14);
  d2 := Double(6.28);
  dOld := TInterlocked.CompareExchange(d1, d2, d1);
  if dOld <> Double(3.14) then halt(44);
  if d1 = Double(3.14) then halt(45);
  if d1 <> d2 then halt(46);

  d1 := dOld;
  dOld := TInterlocked.Exchange(d1, d2);
  if dOld <> Double(3.14) then halt(47);
  if d1 <> Double(6.28) then halt(48);
  if d1 <> d2 then halt(49);

  dOld := TInterlocked.CompareExchange(d1, dOld, d2);
  if dOld <> Double(6.28) then halt(50);
  if d1 <> Double(3.14) then halt(51);
  if d1 = d2 then halt(52);

  {* test all kinds of Single usage *}
  s1 := Single(3.14);
  s2 := Single(6.28);
  sOld := TInterlocked.CompareExchange(s1, s2, s1);
  if sOld <> Single(3.14) then halt(53);
  if s1 = Single(3.14) then halt(54);
  if s1 <> s2 then halt(55);

  sOld := TInterlocked.CompareExchange(s1, sOld, s2);
  if sOld <> Single(6.28) then halt(56);
  if s1 <> Single(3.14) then halt(57);
  if s1 = s2 then halt(58);

  sOld := TInterlocked.Exchange(s2, s1);
  if sOld <> Single(6.28) then halt(59);
  if s1 <> Single(3.14) then halt(60);
  if s1 <> s2 then halt(61);

  {* test BitTestAndClear usage *}
  i32 := 96;
  Changed := TInterlocked.BitTestAndClear(i32, 6);
  if Changed <> True then halt(62);
  if i32 <> 32 then halt(63);

  {* test BitTestAndSet usage *}
  Changed := TInterlocked.BitTestAndSet(i32, 4);
  if Changed <> False then halt(64);
  if i32 <> 48 then halt(65);

  writeln('testing of TInterlocked methods ended');
  readln;
end.
TInterlocked_tests.pas (4,743 bytes)   
01-Add_TInterlocked_without_Single_Double_BitTest.patch (8,366 bytes)   
diff --git packages/fcl-base/src/syncobjs.pp packages/fcl-base/src/syncobjs.pp
index 84c0adebd4..062c5116bb 100644
--- packages/fcl-base/src/syncobjs.pp
+++ packages/fcl-base/src/syncobjs.pp
@@ -81,6 +81,38 @@ type
       constructor Create;
    end;
 
+  TIntegerBitOffset = 0..31;
+  TInterlocked = class sealed
+    class function Add(var Target: Integer; Increment: Integer): Integer; overload; static; inline;
+    class function Add(var Target: Int64; Increment: Int64): Int64; overload; static; inline;
+    class function BitTestAndClear(var Target: Integer; BitOffset: TIntegerBitOffset): Boolean; static;
+    class function BitTestAndSet(var Target: Integer; BitOffset: TIntegerBitOffset): Boolean; static;
+    class function CompareExchange(var Target: Pointer; Value: Pointer; Comparand: Pointer): Pointer; overload; static; inline;
+    class function CompareExchange(var Target: Integer; Value: Integer; Comparand: Integer): Integer; overload; static; inline;
+    class function CompareExchange(var Target: Integer; Value: Integer; Comparand: Integer; out Succeeded: Boolean): Integer; overload; static;
+    class function CompareExchange(var Target: Int64; Value: Int64; Comparand: Int64): Int64; overload; static; inline;
+    class function CompareExchange(var Target: TObject; Value: TObject; Comparand: TObject): TObject; overload; static; inline;
+    class function CompareExchange(var Target: Double; Value: Double; Comparand: Double): Double; overload; static; inline;
+    class function CompareExchange(var Target: Single; Value: Single; Comparand: Single): Single; overload; static; inline;
+{$ifndef VER3_0}
+    generic class function CompareExchange<T: class>(var Target: T; Value: T; Comparand: T): T; overload; static; inline;
+{$endif}
+    class function Decrement(var Target: Integer): Integer; overload; static; inline;
+    class function Decrement(var Target: Int64): Int64; overload; static; inline;
+    class function Exchange(var Target: Pointer; Value: Pointer): Pointer; overload; static; inline;
+    class function Exchange(var Target: Integer; Value: Integer): Integer; overload; static; inline;
+    class function Exchange(var Target: Int64; Value: Int64): Int64; overload; static; inline;
+    class function Exchange(var Target: TObject; Value: TObject): TObject; overload; static; inline;
+    class function Exchange(var Target: Double; Value: Double): Double; overload; static; inline;
+    class function Exchange(var Target: Single; Value: Single): Single; overload; static; inline;
+{$ifndef VER3_0}
+    generic class function Exchange<T: class>(var Target: T; Value: T): T; overload; static; inline;
+{$endif}
+    class function Increment(var Target: Integer): Integer; overload; static; inline;
+    class function Increment(var Target: Int64): Int64; overload; static; inline;
+    class function Read(var Target: Int64): Int64; static; inline;
+  end;
+
 implementation
 
 Resourcestring
@@ -203,4 +235,147 @@ begin
   inherited Create(nil, True, False, '');
 end;
 
+class function TInterlocked.Add(var Target: Integer; Increment: Integer): Integer; overload; static; inline;
+begin
+  InterLockedExchangeAdd(Target, Increment); // returns the previous value
+  Result := Target;
+end;
+
+class function TInterlocked.Add(var Target: Int64; Increment: Int64): Int64; overload; static; inline;
+begin
+  InterLockedExchangeAdd64(Target, Increment); // returns the previous value
+  Result := Target;
+end;
+
+class function TInterlocked.BitTestAndClear(var Target: Integer; BitOffset: TIntegerBitOffset): Boolean; static;
+var
+  OldValue, ChangedValue: Integer;
+begin
+{ * can't use two calls as this is not atomic
+  // get actual value
+  OldValue := InterlockedCompareExchange(Target, 0, 0);
+  // bit set?
+  Result := OldValue.TestBit(BitOffset);
+  ChangedValue := OldValue.ClearBit(BitOffset);
+  // write new value with bit set to zero if value is still the same in target
+  InterlockedCompareExchange(Target, ChangedValue, OldValue);
+}
+end;
+
+class function TInterlocked.BitTestAndSet(var Target: Integer; BitOffset: TIntegerBitOffset): Boolean; static;
+var
+  OldValue, ChangedValue: Integer;
+begin
+{ * can't use two calls as this is not atomic
+  // get actual value
+  OldValue := InterlockedCompareExchange(Target, 0, 0);
+  // bit set?
+  Result := OldValue.TestBit(BitOffset);
+  ChangedValue := OldValue.SetBit(BitOffset);
+  // write new value with bit set to one if value is still the same in target
+  InterlockedCompareExchange(Target, ChangedValue, OldValue);
+}
+end;
+
+class function TInterlocked.CompareExchange(var Target: Pointer; Value: Pointer; Comparand: Pointer): Pointer; overload; static; inline;
+begin
+  Result := InterlockedCompareExchange(Target, Value, Comparand);
+end;
+
+class function TInterlocked.CompareExchange(var Target: Integer; Value: Integer; Comparand: Integer): Integer; overload; static; inline;
+begin
+  Result := InterlockedCompareExchange(Target, Value, Comparand);
+end;
+
+class function TInterlocked.CompareExchange(var Target: Integer; Value: Integer; Comparand: Integer; out Succeeded: Boolean): Integer; overload; static;
+begin
+  Result := InterlockedCompareExchange(Target, Value, Comparand);
+  Succeeded := (Result = Comparand);
+end;
+
+class function TInterlocked.CompareExchange(var Target: Int64; Value: Int64; Comparand: Int64): Int64; overload; static; inline;
+begin
+  Result := InterlockedCompareExchange64(Target, Value, Comparand);
+end;
+
+class function TInterlocked.CompareExchange(var Target: TObject; Value: TObject; Comparand: TObject): TObject; overload; static; inline;
+begin
+  Result := TObject(InterlockedCompareExchange(Pointer(Target), Pointer(Value), Pointer(Comparand)));
+end;
+
+class function TInterlocked.CompareExchange(var Target: Double; Value: Double; Comparand: Double): Double; overload; static; inline;
+begin
+end;
+
+class function TInterlocked.CompareExchange(var Target: Single; Value: Single; Comparand: Single): Single; overload; static; inline;
+begin
+end;
+
+{$ifndef VER3_0}
+generic class function TInterlocked.CompareExchange<T>(var Target: T; Value: T; Comparand: T): T; overload; static; inline;
+begin
+  Result := T(InterlockedCompareExchange(Pointer(Target), Pointer(Value), Pointer(Comparand)));
+end;
+{$endif}
+
+class function TInterlocked.Decrement(var Target: Integer): Integer; overload; static; inline;
+begin
+  Result := InterLockedDecrement(Target); // returns the new value
+end;
+
+class function TInterlocked.Decrement(var Target: Int64): Int64; overload; static; inline;
+begin
+  Result := InterLockedDecrement64(Target); // returns the new value
+end;
+
+class function TInterlocked.Exchange(var Target: Pointer; Value: Pointer): Pointer; overload; static; inline;
+begin
+  Result := InterLockedExchange(Target, Value);
+end;
+
+class function TInterlocked.Exchange(var Target: Integer; Value: Integer): Integer; overload; static; inline;
+begin
+  Result := InterLockedExchange(Target, Value);
+end;
+
+class function TInterlocked.Exchange(var Target: Int64; Value: Int64): Int64; overload; static; inline;
+begin
+  Result := InterLockedExchange64(Target, Value);
+end;
+
+class function TInterlocked.Exchange(var Target: TObject; Value: TObject): TObject; overload; static; inline;
+begin
+  Result := TObject(InterLockedExchange(Pointer(Target), Pointer(Value)));
+end;
+
+class function TInterlocked.Exchange(var Target: Double; Value: Double): Double; overload; static; inline;
+begin
+end;
+
+class function TInterlocked.Exchange(var Target: Single; Value: Single): Single; overload; static; inline;
+begin
+end;
+
+{$ifndef VER3_0}
+generic class function TInterlocked.Exchange<T>(var Target: T; Value: T): T; overload; static; inline;
+begin
+  Result := T(InterLockedExchange(Pointer(Target), Pointer(Value)));
+end;
+{$endif}
+
+class function TInterlocked.Increment(var Target: Integer): Integer; overload; static; inline;
+begin
+  Result := InterLockedIncrement(Target); // returns the new value
+end;
+
+class function TInterlocked.Increment(var Target: Int64): Int64; overload; static; inline;
+begin
+  Result := InterLockedIncrement64(Target); // returns the new value
+end;
+
+class function TInterlocked.Read(var Target: Int64): Int64; static; inline;
+begin
+  Result := InterlockedCompareExchange64(Target, 0, 0);
+end;
+
 end.

Bi0T1N

2020-05-21 22:02

reporter   ~0122996

I forgot in my previous post to explicitly mention that TInterlocked.Add isn't fully atomic because InterLockedExchangeAdd returns the old value and thus the Result := Target is needed but in-between the value could have already be changed (doesn't happen/covered in the test as no threading is involved). This could be avoid by adding an InterlockedAdd intrinsic as recommended by NoName in 0037093 which returns the new value as stated in the MS docs.

Bi0T1N

2020-05-25 01:23

reporter   ~0123052

Please find attached the patch and tests with all functions from Delphi's TInterlocked class which can safely be implemented with the currently available Interlocked* functions. Those functions are tested in test/tinterlockedmt.pp and test/tinterlocked64mt.pp.
I'm going to create a separate issue for the missing Interlocked* functions.
01-Add_TInterlocked_with_currently_possible_functionality.patch (4,887 bytes)   
diff --git packages/fcl-base/src/syncobjs.pp packages/fcl-base/src/syncobjs.pp
index 84c0adebd4..b9e6e44993 100644
--- packages/fcl-base/src/syncobjs.pp
+++ packages/fcl-base/src/syncobjs.pp
@@ -81,6 +81,28 @@ type
       constructor Create;
    end;
 
+  TInterlocked = class sealed
+    class function CompareExchange(var Target: Pointer; Value: Pointer; Comparand: Pointer): Pointer; overload; static; inline;
+    class function CompareExchange(var Target: Integer; Value: Integer; Comparand: Integer): Integer; overload; static; inline;
+    class function CompareExchange(var Target: Int64; Value: Int64; Comparand: Int64): Int64; overload; static; inline;
+    class function CompareExchange(var Target: TObject; Value: TObject; Comparand: TObject): TObject; overload; static; inline;
+{$ifndef VER3_0}
+    generic class function CompareExchange<T: class>(var Target: T; Value: T; Comparand: T): T; overload; static; inline;
+{$endif}
+    class function Decrement(var Target: Integer): Integer; overload; static; inline;
+    class function Decrement(var Target: Int64): Int64; overload; static; inline;
+    class function Exchange(var Target: Pointer; Value: Pointer): Pointer; overload; static; inline;
+    class function Exchange(var Target: Integer; Value: Integer): Integer; overload; static; inline;
+    class function Exchange(var Target: Int64; Value: Int64): Int64; overload; static; inline;
+    class function Exchange(var Target: TObject; Value: TObject): TObject; overload; static; inline;
+{$ifndef VER3_0}
+    generic class function Exchange<T: class>(var Target: T; Value: T): T; overload; static; inline;
+{$endif}
+    class function Increment(var Target: Integer): Integer; overload; static; inline;
+    class function Increment(var Target: Int64): Int64; overload; static; inline;
+    class function Read(var Target: Int64): Int64; static; inline;
+  end;
+
 implementation
 
 Resourcestring
@@ -203,4 +225,83 @@ begin
   inherited Create(nil, True, False, '');
 end;
 
+class function TInterlocked.CompareExchange(var Target: Pointer; Value: Pointer; Comparand: Pointer): Pointer; overload; static; inline;
+begin
+  Result := InterlockedCompareExchange(Target, Value, Comparand);
+end;
+
+class function TInterlocked.CompareExchange(var Target: Integer; Value: Integer; Comparand: Integer): Integer; overload; static; inline;
+begin
+  Result := InterlockedCompareExchange(Target, Value, Comparand);
+end;
+
+class function TInterlocked.CompareExchange(var Target: Int64; Value: Int64; Comparand: Int64): Int64; overload; static; inline;
+begin
+  Result := InterlockedCompareExchange64(Target, Value, Comparand);
+end;
+
+class function TInterlocked.CompareExchange(var Target: TObject; Value: TObject; Comparand: TObject): TObject; overload; static; inline;
+begin
+  Result := TObject(InterlockedCompareExchange(Pointer(Target), Pointer(Value), Pointer(Comparand)));
+end;
+
+{$ifndef VER3_0}
+generic class function TInterlocked.CompareExchange<T>(var Target: T; Value: T; Comparand: T): T; overload; static; inline;
+begin
+  Result := T(InterlockedCompareExchange(Pointer(Target), Pointer(Value), Pointer(Comparand)));
+end;
+{$endif}
+
+class function TInterlocked.Decrement(var Target: Integer): Integer; overload; static; inline;
+begin
+  Result := InterLockedDecrement(Target);
+end;
+
+class function TInterlocked.Decrement(var Target: Int64): Int64; overload; static; inline;
+begin
+  Result := InterLockedDecrement64(Target);
+end;
+
+class function TInterlocked.Exchange(var Target: Pointer; Value: Pointer): Pointer; overload; static; inline;
+begin
+  Result := InterLockedExchange(Target, Value);
+end;
+
+class function TInterlocked.Exchange(var Target: Integer; Value: Integer): Integer; overload; static; inline;
+begin
+  Result := InterLockedExchange(Target, Value);
+end;
+
+class function TInterlocked.Exchange(var Target: Int64; Value: Int64): Int64; overload; static; inline;
+begin
+  Result := InterLockedExchange64(Target, Value);
+end;
+
+class function TInterlocked.Exchange(var Target: TObject; Value: TObject): TObject; overload; static; inline;
+begin
+  Result := TObject(InterLockedExchange(Pointer(Target), Pointer(Value)));
+end;
+
+{$ifndef VER3_0}
+generic class function TInterlocked.Exchange<T>(var Target: T; Value: T): T; overload; static; inline;
+begin
+  Result := T(InterLockedExchange(Pointer(Target), Pointer(Value)));
+end;
+{$endif}
+
+class function TInterlocked.Increment(var Target: Integer): Integer; overload; static; inline;
+begin
+  Result := InterLockedIncrement(Target);
+end;
+
+class function TInterlocked.Increment(var Target: Int64): Int64; overload; static; inline;
+begin
+  Result := InterLockedIncrement64(Target);
+end;
+
+class function TInterlocked.Read(var Target: Int64): Int64; static; inline;
+begin
+  Result := InterlockedCompareExchange64(Target, 0, 0);
+end;
+
 end.
TInterlocked_tests-2.pas (4,765 bytes)   
program TInterlocked_tests;

{$mode Delphi}

uses
  SysUtils, SyncObjs, Classes;

var
  i32: Integer;
  New32, Old32: Integer;
  i64: Int64;
  New64, Old64: Int64;
  Changed: Boolean;
  list1, list2, oldlist: TStringList;
  d1, d2, dOld: Double;
  s1, s2, sOld: Single;

begin
  writeln('start testing of TInterlocked methods');

  {* test all kinds of integer usage *}
  i32 := 12;
  New32 := TInterlocked.Increment(i32);
  if New32 <> 13 then halt(1);
  if i32 <> 13 then halt(2);

  New32 := TInterlocked.Decrement(i32);
  if New32 <> 12 then halt(3);
  if i32 <> 12 then halt(4);
{
  New32 := TInterlocked.Add(i32, 12);
  if New32 <> 24 then halt(5);
  if i32 <> 24 then halt(6);
}
  Old32 := TInterlocked.CompareExchange(i32, 36, 24);
  if Old32 <> 24 then halt(7);
  if i32 <> 36 then halt(8);
{
  Old32 := TInterlocked.CompareExchange(i32, 48, 36, Changed);
  if Old32 <> 36 then halt(9);
  if Changed <> True then halt(10);
  if i32 <> 48 then halt(11);

  Old32 := TInterlocked.CompareExchange(i32, 123, 96, Changed);
  if Old32 <> 48 then halt(12);
  if Changed <> False then halt(13);
  if i32 <> 48 then halt(14);
}
  Old32 := TInterlocked.Exchange(i32, 96);
  if Old32 <> 48 then halt(15);
  if i32 <> 96 then halt(15);

  {* test all kinds of Int64 usage *}
  i64 := 12;
  New64 := TInterlocked.Increment(i64);
  if New64 <> 13 then halt(20);
  if i64 <> 13 then halt(21);

  New64 := TInterlocked.Decrement(i64);
  if New64 <> 12 then halt(22);
  if i64 <> 12 then halt(23);
{
  New64 := TInterlocked.Add(i64, 12);
  if New64 <> 24 then halt(24);
  if i64 <> 24 then halt(25);
}
  Old64 := TInterlocked.CompareExchange(i64, 36, 24);
  if Old64 <> 24 then halt(26);
  if i64 <> 36 then halt(27);

  Old64 := TInterlocked.Exchange(i64, 48);
  if Old64 <> 36 then halt(28);
  if i64 <> 48 then halt(29);

  Old64 := TInterlocked.Read(i64);
  if Old64 <> 48 then halt(30);
  if i64 <> 48 then halt(31);

  {* test all kinds of TObject and generic class usage *}
  list1 := TStringList.Create;
  list2 := TStringList.Create;
  try
    list1.Add('A');
    list2.Add('B');
    list2.Add('C');

    { TObject }
    oldlist := TStringList(TInterlocked.CompareExchange(TObject(list1), TObject(list2), TObject(list1)));
    if list1 <> list2 then halt(32);
    if oldlist.Count = list1.Count then halt(33);
    if oldlist.Count = list2.Count then halt(34);

    oldlist := TStringList(TInterlocked.Exchange(TObject(list1), TObject(oldlist)));
    if oldlist <> list2 then halt(35);
    if list1.Count <> 1 then halt(36);
    if list2.Count <> 2 then halt(37);

    { generic class }
    oldlist := TInterlocked.CompareExchange<TStringList>(list1, list2, list1);
    if list1 <> list2 then halt(38);
    if oldlist.Count = list1.Count then halt(39);
    if oldlist.Count = list2.Count then halt(40);

    oldlist := TInterlocked.Exchange<TStringList>(list1, oldlist);
    if oldlist <> list2 then halt(41);
    if list1.Count <> 1 then halt(42);
    if list2.Count <> 2 then halt(43);
  finally
    list1.Free;
    list2.Free;
  end;

  writeln('tests passed so far');

  {* test all kinds of Double usage *}
{
  d1 := Double(3.14);
  d2 := Double(6.28);
  dOld := TInterlocked.CompareExchange(d1, d2, d1);
  if dOld <> Double(3.14) then halt(44);
  if d1 = Double(3.14) then halt(45);
  if d1 <> d2 then halt(46);

  d1 := dOld;
  dOld := TInterlocked.Exchange(d1, d2);
  if dOld <> Double(3.14) then halt(47);
  if d1 <> Double(6.28) then halt(48);
  if d1 <> d2 then halt(49);

  dOld := TInterlocked.CompareExchange(d1, dOld, d2);
  if dOld <> Double(6.28) then halt(50);
  if d1 <> Double(3.14) then halt(51);
  if d1 = d2 then halt(52);
}
  {* test all kinds of Single usage *}
{
  s1 := Single(3.14);
  s2 := Single(6.28);
  sOld := TInterlocked.CompareExchange(s1, s2, s1);
  if sOld <> Single(3.14) then halt(53);
  if s1 = Single(3.14) then halt(54);
  if s1 <> s2 then halt(55);

  sOld := TInterlocked.CompareExchange(s1, sOld, s2);
  if sOld <> Single(6.28) then halt(56);
  if s1 <> Single(3.14) then halt(57);
  if s1 = s2 then halt(58);

  sOld := TInterlocked.Exchange(s2, s1);
  if sOld <> Single(6.28) then halt(59);
  if s1 <> Single(3.14) then halt(60);
  if s1 <> s2 then halt(61);
}
  {* test BitTestAndClear usage *}
{
  i32 := 96;
  Changed := TInterlocked.BitTestAndClear(i32, 6);
  if Changed <> True then halt(62);
  if i32 <> 32 then halt(63);
}
  {* test BitTestAndSet usage *}
{
  Changed := TInterlocked.BitTestAndSet(i32, 4);
  if Changed <> False then halt(64);
  if i32 <> 48 then halt(65);
}
  writeln('testing of TInterlocked methods ended');
  readln;
end.
TInterlocked_tests-2.pas (4,765 bytes)   

Bi0T1N

2020-06-07 23:10

reporter   ~0123322

Last edited: 2020-06-07 23:11

View 2 revisions

I've implemented the functions for Single/Double by casting it to Integer/Int64 to use the already implemented intrinsics (seems there are no floating point assembly instructions available with lock prefix and therefore not directly possible). Thus I used fixed length types so that the casting will always work as expected without truncation.
The only missing functions are BitTestAndClear and BitTestAndSet but I've no clue how to implement them in a safe way.
01-Add_TInterlocked_fixed_length_types.patch (8,211 bytes)   
diff --git packages/fcl-base/src/syncobjs.pp packages/fcl-base/src/syncobjs.pp
index 84c0adebd4..7e5fbc0895 100644
--- packages/fcl-base/src/syncobjs.pp
+++ packages/fcl-base/src/syncobjs.pp
@@ -81,6 +81,43 @@ type
       constructor Create;
    end;
 
+  TInterlocked = class sealed
+    class function Add(var Target: Longint; Increment: Longint): Longint; overload; static; inline;
+    class function Add(var Target: Int64; Increment: Int64): Int64; overload; static; inline;
+    class function CompareExchange(var Target: Pointer; Value: Pointer; Comparand: Pointer): Pointer; overload; static; inline;
+    class function CompareExchange(var Target: Longint; Value: Longint; Comparand: Longint): Longint; overload; static; inline;
+    class function CompareExchange(var Target: Longint; Value: Longint; Comparand: Longint; out Succeeded: Boolean): Longint; overload; static;
+    class function CompareExchange(var Target: Int64; Value: Int64; Comparand: Int64): Int64; overload; static; inline;
+    class function CompareExchange(var Target: TObject; Value: TObject; Comparand: TObject): TObject; overload; static; inline;
+{$ifdef FPC_HAS_TYPE_DOUBLE}
+    class function CompareExchange(var Target: Double; Value: Double; Comparand: Double): Double; overload; static; inline;
+{$endif}
+{$ifdef FPC_HAS_TYPE_SINGLE}
+    class function CompareExchange(var Target: Single; Value: Single; Comparand: Single): Single; overload; static; inline;
+{$endif}
+{$ifndef VER3_0}
+    generic class function CompareExchange<T: class>(var Target: T; Value: T; Comparand: T): T; overload; static; inline;
+{$endif}
+    class function Decrement(var Target: Longint): Longint; overload; static; inline;
+    class function Decrement(var Target: Int64): Int64; overload; static; inline;
+    class function Exchange(var Target: Pointer; Value: Pointer): Pointer; overload; static; inline;
+    class function Exchange(var Target: Longint; Value: Longint): Longint; overload; static; inline;
+    class function Exchange(var Target: Int64; Value: Int64): Int64; overload; static; inline;
+    class function Exchange(var Target: TObject; Value: TObject): TObject; overload; static; inline;
+{$ifdef FPC_HAS_TYPE_DOUBLE}
+    class function Exchange(var Target: Double; Value: Double): Double; overload; static; inline;
+{$endif}
+{$ifdef FPC_HAS_TYPE_SINGLE}
+    class function Exchange(var Target: Single; Value: Single): Single; overload; static; inline;
+{$endif}
+{$ifndef VER3_0}
+    generic class function Exchange<T: class>(var Target: T; Value: T): T; overload; static; inline;
+{$endif}
+    class function Increment(var Target: Longint): Longint; overload; static; inline;
+    class function Increment(var Target: Int64): Int64; overload; static; inline;
+    class function Read(var Target: Int64): Int64; static; inline;
+  end;
+
 implementation
 
 Resourcestring
@@ -203,4 +240,154 @@ begin
   inherited Create(nil, True, False, '');
 end;
 
+class function TInterlocked.Add(var Target: Longint; Increment: Longint): Longint; overload; static; inline;
+var
+  PreviousValue: Longint;
+begin
+  PreviousValue := InterLockedExchangeAdd(Target, Increment); // returns previous value
+  Result := PreviousValue + Increment;
+end;
+
+class function TInterlocked.Add(var Target: Int64; Increment: Int64): Int64; overload; static; inline;
+var
+  PreviousValue: Int64;
+begin
+  PreviousValue := InterLockedExchangeAdd64(Target, Increment); // returns previous value
+  Result := PreviousValue + Increment;
+end;
+
+
+class function TInterlocked.CompareExchange(var Target: Pointer; Value: Pointer; Comparand: Pointer): Pointer; overload; static; inline;
+begin
+  Result := InterlockedCompareExchange(Target, Value, Comparand);
+end;
+
+class function TInterlocked.CompareExchange(var Target: Longint; Value: Longint; Comparand: Longint): Longint; overload; static; inline;
+begin
+  Result := InterlockedCompareExchange(Target, Value, Comparand);
+end;
+
+class function TInterlocked.CompareExchange(var Target: Longint; Value: Longint; Comparand: Longint; out Succeeded: Boolean): Longint; overload; static;
+begin
+  Result := InterlockedCompareExchange(Target, Value, Comparand);
+  Succeeded := (Result = Comparand);
+end;
+
+class function TInterlocked.CompareExchange(var Target: Int64; Value: Int64; Comparand: Int64): Int64; overload; static; inline;
+begin
+  Result := InterlockedCompareExchange64(Target, Value, Comparand);
+end;
+
+class function TInterlocked.CompareExchange(var Target: TObject; Value: TObject; Comparand: TObject): TObject; overload; static; inline;
+begin
+  Result := TObject(InterlockedCompareExchange(Pointer(Target), Pointer(Value), Pointer(Comparand)));
+end;
+
+{$ifdef FPC_HAS_TYPE_DOUBLE}
+class function TInterlocked.CompareExchange(var Target: Double; Value: Double; Comparand: Double): Double; overload; static; inline;
+var
+  Int64Value: Int64;
+  DoublePtr: PDouble;
+begin
+  Int64Value := TInterlocked.CompareExchange(Int64(Target), Int64(Value), Int64(Comparand));
+  DoublePtr := @Int64Value;
+  Result := DoublePtr^;
+end;
+{$endif}
+
+{$ifdef FPC_HAS_TYPE_SINGLE}
+class function TInterlocked.CompareExchange(var Target: Single; Value: Single; Comparand: Single): Single; overload; static; inline;
+var
+  IntValue: Longint;
+  SinglePtr: PSingle;
+begin
+  IntValue := TInterlocked.CompareExchange(Longint(Target), Longint(Value), Longint(Comparand));
+  SinglePtr := @IntValue;
+  Result := SinglePtr^;
+end;
+{$endif}
+
+{$ifndef VER3_0}
+generic class function TInterlocked.CompareExchange<T>(var Target: T; Value: T; Comparand: T): T; overload; static; inline;
+begin
+  Result := T(InterlockedCompareExchange(Pointer(Target), Pointer(Value), Pointer(Comparand)));
+end;
+{$endif}
+
+class function TInterlocked.Decrement(var Target: Longint): Longint; overload; static; inline;
+begin
+  Result := InterLockedDecrement(Target); // returns new value
+end;
+
+class function TInterlocked.Decrement(var Target: Int64): Int64; overload; static; inline;
+begin
+  Result := InterLockedDecrement64(Target); // returns new value
+end;
+
+class function TInterlocked.Exchange(var Target: Pointer; Value: Pointer): Pointer; overload; static; inline;
+begin
+  Result := InterLockedExchange(Target, Value);
+end;
+
+class function TInterlocked.Exchange(var Target: Longint; Value: Longint): Longint; overload; static; inline;
+begin
+  Result := InterLockedExchange(Target, Value);
+end;
+
+class function TInterlocked.Exchange(var Target: Int64; Value: Int64): Int64; overload; static; inline;
+begin
+  Result := InterLockedExchange64(Target, Value);
+end;
+
+class function TInterlocked.Exchange(var Target: TObject; Value: TObject): TObject; overload; static; inline;
+begin
+  Result := TObject(InterLockedExchange(Pointer(Target), Pointer(Value)));
+end;
+
+{$ifdef FPC_HAS_TYPE_DOUBLE}
+class function TInterlocked.Exchange(var Target: Double; Value: Double): Double; overload; static; inline;
+var
+  Int64Value: Int64;
+  DoublePtr: PDouble;
+begin
+  Int64Value := TInterlocked.Exchange(Int64(Target), Int64(Value));
+  DoublePtr := @Int64Value;
+  Result := DoublePtr^;
+end;
+{$endif}
+
+{$ifdef FPC_HAS_TYPE_SINGLE}
+class function TInterlocked.Exchange(var Target: Single; Value: Single): Single; overload; static; inline;
+var
+  IntValue: Longint;
+  SinglePtr: PSingle;
+begin
+  IntValue := TInterlocked.Exchange(Longint(Target), Longint(Value));
+  SinglePtr := @IntValue;
+  Result := SinglePtr^;
+end;
+{$endif}
+
+{$ifndef VER3_0}
+generic class function TInterlocked.Exchange<T>(var Target: T; Value: T): T; overload; static; inline;
+begin
+  Result := T(InterLockedExchange(Pointer(Target), Pointer(Value)));
+end;
+{$endif}
+
+class function TInterlocked.Increment(var Target: Longint): Longint; overload; static; inline;
+begin
+  Result := InterLockedIncrement(Target); // returns new value
+end;
+
+class function TInterlocked.Increment(var Target: Int64): Int64; overload; static; inline;
+begin
+  Result := InterLockedIncrement64(Target); // returns new value
+end;
+
+class function TInterlocked.Read(var Target: Int64): Int64; static; inline;
+begin
+  Result := InterlockedCompareExchange64(Target, 0, 0);
+end;
+
 end.
TInterlocked_tests-3.pas (4,813 bytes)   
program TInterlocked_tests;

{$mode Delphi}

uses
  SysUtils, SyncObjs, Classes;

var
  i32: Longint;
  New32, Old32: Longint;
  i64: Int64;
  New64, Old64: Int64;
  Changed: Boolean;
  list1, list2, oldlist: TStringList;
  d1, d2, dOld: Double;
  s1, s2, sOld: Single;

begin
  writeln('start testing of TInterlocked methods');

  {* test all kinds of Longint usage *}
  i32 := 12;
  New32 := TInterlocked.Increment(i32);
  if New32 <> 13 then halt(1);
  if i32 <> 13 then halt(2);

  New32 := TInterlocked.Decrement(i32);
  if New32 <> 12 then halt(3);
  if i32 <> 12 then halt(4);

  New32 := TInterlocked.Add(i32, 12);
  if New32 <> 24 then halt(5);
  if i32 <> 24 then halt(6);

  Old32 := TInterlocked.CompareExchange(i32, 36, 24);
  if Old32 <> 24 then halt(7);
  if i32 <> 36 then halt(8);

  Old32 := TInterlocked.CompareExchange(i32, 48, 36, Changed);
  if Old32 <> 36 then halt(9);
  if Changed <> True then halt(10);
  if i32 <> 48 then halt(11);

  Old32 := TInterlocked.CompareExchange(i32, 123, 96, Changed);
  if Old32 <> 48 then halt(12);
  if Changed <> False then halt(13);
  if i32 <> 48 then halt(14);

  Old32 := TInterlocked.Exchange(i32, 96);
  if Old32 <> 48 then halt(15);
  if i32 <> 96 then halt(15);

  {* test all kinds of Int64 usage *}
  i64 := 12;
  New64 := TInterlocked.Increment(i64);
  if New64 <> 13 then halt(20);
  if i64 <> 13 then halt(21);

  New64 := TInterlocked.Decrement(i64);
  if New64 <> 12 then halt(22);
  if i64 <> 12 then halt(23);

  New64 := TInterlocked.Add(i64, 12);
  if New64 <> 24 then halt(24);
  if i64 <> 24 then halt(25);

  Old64 := TInterlocked.CompareExchange(i64, 36, 24);
  if Old64 <> 24 then halt(26);
  if i64 <> 36 then halt(27);

  Old64 := TInterlocked.Exchange(i64, 48);
  if Old64 <> 36 then halt(28);
  if i64 <> 48 then halt(29);

  Old64 := TInterlocked.Read(i64);
  if Old64 <> 48 then halt(30);
  if i64 <> 48 then halt(31);

  {* test all kinds of TObject and generic class usage *}
  list1 := TStringList.Create;
  list2 := TStringList.Create;
  try
    list1.Add('A');
    list2.Add('B');
    list2.Add('C');

    { TObject }
    oldlist := TStringList(TInterlocked.CompareExchange(TObject(list1), TObject(list2), TObject(list1)));
    if list1 <> list2 then halt(32);
    if oldlist.Count = list1.Count then halt(33);
    if oldlist.Count = list2.Count then halt(34);

    oldlist := TStringList(TInterlocked.Exchange(TObject(list1), TObject(oldlist)));
    if oldlist <> list2 then halt(35);
    if list1.Count <> 1 then halt(36);
    if list2.Count <> 2 then halt(37);

    { generic class }
    oldlist := TInterlocked.CompareExchange<TStringList>(list1, list2, list1);
    if list1 <> list2 then halt(38);
    if oldlist.Count = list1.Count then halt(39);
    if oldlist.Count = list2.Count then halt(40);

    oldlist := TInterlocked.Exchange<TStringList>(list1, oldlist);
    if oldlist <> list2 then halt(41);
    if list1.Count <> 1 then halt(42);
    if list2.Count <> 2 then halt(43);
  finally
    list1.Free;
    list2.Free;
  end;

  writeln('tests passed so far');

  {* test all kinds of Double usage *}
  d1 := Double(3.14);
  d2 := Double(6.28);
  dOld := TInterlocked.CompareExchange(d1, d2, d1);
  if dOld <> Double(3.14) then halt(44);
  if d1 = Double(3.14) then halt(45);
  if d1 <> d2 then halt(46);

  d1 := dOld;
  dOld := TInterlocked.Exchange(d1, d2);
  if dOld <> Double(3.14) then halt(47);
  if d1 <> Double(6.28) then halt(48);
  if d1 <> d2 then halt(49);

  dOld := TInterlocked.CompareExchange(d1, dOld, d2);
  if dOld <> Double(6.28) then halt(50);
  if d1 <> Double(3.14) then halt(51);
  if d1 = d2 then halt(52);

  {* test all kinds of Single usage *}
  s1 := Single(3.14);
  s2 := Single(6.28);
  sOld := TInterlocked.CompareExchange(s1, s2, s1);
  if sOld <> Single(3.14) then halt(53);
  if s1 = Single(3.14) then halt(54);
  if s1 <> s2 then halt(55);

  sOld := TInterlocked.CompareExchange(s1, sOld, s2);
  if sOld <> Single(6.28) then halt(56);
  if s1 <> Single(3.14) then halt(57);
  if s1 = s2 then halt(58);

  sOld := TInterlocked.Exchange(s2, s1);
  if sOld <> Single(6.28) then halt(59);
  if s1 <> Single(3.14) then halt(60);
  if s1 <> s2 then halt(61);

  {* test BitTestAndClear usage *}
{
  // enable when implemented!
  i32 := 96;
  Changed := TInterlocked.BitTestAndClear(i32, 6);
  if Changed <> True then halt(62);
  if i32 <> 32 then halt(63);
}
  {* test BitTestAndSet usage *}
{
  // enable when implemented!
  Changed := TInterlocked.BitTestAndSet(i32, 4);
  if Changed <> False then halt(64);
  if i32 <> 48 then halt(65);
}
  writeln('testing of TInterlocked methods ended');
  readln;
end.
TInterlocked_tests-3.pas (4,813 bytes)   

NoName

2020-06-18 22:26

reporter   ~0123470

Thanks!! I'm use your code in my application now.

Do-wan Kim

2020-06-20 09:21

reporter   ~0123480

Int64 and Double need 64bit system.
37089_syncobjs.pp.patch (8,699 bytes)   
Index: packages/fcl-base/src/syncobjs.pp
===================================================================
--- packages/fcl-base/src/syncobjs.pp	(revision 45659)
+++ packages/fcl-base/src/syncobjs.pp	(working copy)
@@ -81,6 +81,57 @@
       constructor Create;
    end;
 
+  TInterlocked = class sealed
+    class function Add(var Target: Longint; Increment: Longint): Longint; overload; static; inline;
+{$ifdef cpu64}
+    class function Add(var Target: Int64; Increment: Int64): Int64; overload; static; inline;
+{$endif cpu64}
+    class function CompareExchange(var Target: Pointer; Value: Pointer; Comparand: Pointer): Pointer; overload; static; inline;
+    class function CompareExchange(var Target: Longint; Value: Longint; Comparand: Longint): Longint; overload; static; inline;
+    class function CompareExchange(var Target: Longint; Value: Longint; Comparand: Longint; out Succeeded: Boolean): Longint; overload; static;
+{$ifdef cpu64}
+    class function CompareExchange(var Target: Int64; Value: Int64; Comparand: Int64): Int64; overload; static; inline;
+{$endif cpu64}
+    class function CompareExchange(var Target: TObject; Value: TObject; Comparand: TObject): TObject; overload; static; inline;
+{$ifdef cpu64}
+{$ifdef FPC_HAS_TYPE_DOUBLE}
+    class function CompareExchange(var Target: Double; Value: Double; Comparand: Double): Double; overload; static; inline;
+{$endif}
+{$endif cpu64}
+{$ifdef FPC_HAS_TYPE_SINGLE}
+    class function CompareExchange(var Target: Single; Value: Single; Comparand: Single): Single; overload; static; inline;
+{$endif}
+{$ifndef VER3_0}
+    generic class function CompareExchange<T: class>(var Target: T; Value: T; Comparand: T): T; overload; static; inline;
+{$endif}
+    class function Decrement(var Target: Longint): Longint; overload; static; inline;
+{$ifdef cpu64}
+    class function Decrement(var Target: Int64): Int64; overload; static; inline;
+{$endif cpu64}
+    class function Exchange(var Target: Pointer; Value: Pointer): Pointer; overload; static; inline;
+    class function Exchange(var Target: Longint; Value: Longint): Longint; overload; static; inline;
+{$ifdef cpu64}
+    class function Exchange(var Target: Int64; Value: Int64): Int64; overload; static; inline;
+{$endif cpu64}
+    class function Exchange(var Target: TObject; Value: TObject): TObject; overload; static; inline;
+{$ifdef cpu64}
+{$ifdef FPC_HAS_TYPE_DOUBLE}
+    class function Exchange(var Target: Double; Value: Double): Double; overload; static; inline;
+{$endif}
+{$endif cpu64}
+{$ifdef FPC_HAS_TYPE_SINGLE}
+    class function Exchange(var Target: Single; Value: Single): Single; overload; static; inline;
+{$endif}
+{$ifndef VER3_0}
+    generic class function Exchange<T: class>(var Target: T; Value: T): T; overload; static; inline;
+{$endif}
+    class function Increment(var Target: Longint): Longint; overload; static; inline;
+{$ifdef cpu64}
+    class function Increment(var Target: Int64): Int64; overload; static; inline;
+    class function Read(var Target: Int64): Int64; static; inline;
+{$endif cpu64}
+  end;
+
 implementation
 
 Resourcestring
@@ -203,4 +254,167 @@
   inherited Create(nil, True, False, '');
 end;
 
+class function TInterlocked.Add(var Target: Longint; Increment: Longint): Longint; overload; static; inline;
+var
+  PreviousValue: Longint;
+begin
+  PreviousValue := InterLockedExchangeAdd(Target, Increment); // returns previous value
+  Result := PreviousValue + Increment;
+end;
+
+{$ifdef cpu64}
+class function TInterlocked.Add(var Target: Int64; Increment: Int64): Int64; overload; static; inline;
+var
+  PreviousValue: Int64;
+begin
+  PreviousValue := System.InterLockedExchangeAdd64(Target, Increment); // returns previous value
+  Result := PreviousValue + Increment;
+end;
+{$endif cpu64}
+
+class function TInterlocked.CompareExchange(var Target: Pointer; Value: Pointer; Comparand: Pointer): Pointer; overload; static; inline;
+begin
+  Result := InterlockedCompareExchange(Target, Value, Comparand);
+end;
+
+class function TInterlocked.CompareExchange(var Target: Longint; Value: Longint; Comparand: Longint): Longint; overload; static; inline;
+begin
+  Result := InterlockedCompareExchange(Target, Value, Comparand);
+end;
+
+class function TInterlocked.CompareExchange(var Target: Longint; Value: Longint; Comparand: Longint; out Succeeded: Boolean): Longint; overload; static;
+begin
+  Result := InterlockedCompareExchange(Target, Value, Comparand);
+  Succeeded := (Result = Comparand);
+end;
+
+{$ifdef cpu64}
+class function TInterlocked.CompareExchange(var Target: Int64; Value: Int64; Comparand: Int64): Int64; overload; static; inline;
+begin
+  Result := System.InterlockedCompareExchange64(Target, Value, Comparand);
+end;
+{$endif cpu64}
+
+class function TInterlocked.CompareExchange(var Target: TObject; Value: TObject; Comparand: TObject): TObject; overload; static; inline;
+begin
+  Result := TObject(InterlockedCompareExchange(Pointer(Target), Pointer(Value), Pointer(Comparand)));
+end;
+
+{$ifdef cpu64}
+{$ifdef FPC_HAS_TYPE_DOUBLE}
+class function TInterlocked.CompareExchange(var Target: Double; Value: Double; Comparand: Double): Double; overload; static; inline;
+var
+  Int64Value: Int64;
+  DoublePtr: PDouble;
+begin
+  Int64Value := TInterlocked.CompareExchange(Int64(Target), Int64(Value), Int64(Comparand));
+  DoublePtr := @Int64Value;
+  Result := DoublePtr^;
+end;
+{$endif}
+{$endif cpu64}
+
+{$ifdef FPC_HAS_TYPE_SINGLE}
+class function TInterlocked.CompareExchange(var Target: Single; Value: Single; Comparand: Single): Single; overload; static; inline;
+var
+  IntValue: Longint;
+  SinglePtr: PSingle;
+begin
+  IntValue := TInterlocked.CompareExchange(Longint(Target), Longint(Value), Longint(Comparand));
+  SinglePtr := @IntValue;
+  Result := SinglePtr^;
+end;
+{$endif}
+
+{$ifndef VER3_0}
+generic class function TInterlocked.CompareExchange<T>(var Target: T; Value: T; Comparand: T): T; overload; static; inline;
+begin
+  Result := T(InterlockedCompareExchange(Pointer(Target), Pointer(Value), Pointer(Comparand)));
+end;
+{$endif}
+
+class function TInterlocked.Decrement(var Target: Longint): Longint; overload; static; inline;
+begin
+  Result := InterLockedDecrement(Target); // returns new value
+end;
+
+{$ifdef cpu64}
+class function TInterlocked.Decrement(var Target: Int64): Int64; overload; static; inline;
+begin
+  Result := InterLockedDecrement64(Target); // returns new value
+end;
+{$endif cpu64}
+
+class function TInterlocked.Exchange(var Target: Pointer; Value: Pointer): Pointer; overload; static; inline;
+begin
+  Result := InterLockedExchange(Target, Value);
+end;
+
+class function TInterlocked.Exchange(var Target: Longint; Value: Longint): Longint; overload; static; inline;
+begin
+  Result := InterLockedExchange(Target, Value);
+end;
+
+{$ifdef cpu64}
+class function TInterlocked.Exchange(var Target: Int64; Value: Int64): Int64; overload; static; inline;
+begin
+  Result := System.InterLockedExchange64(Target, Value);
+end;
+{$endif cpu64}
+
+class function TInterlocked.Exchange(var Target: TObject; Value: TObject): TObject; overload; static; inline;
+begin
+  Result := TObject(InterLockedExchange(Pointer(Target), Pointer(Value)));
+end;
+
+{$ifdef cpu64}
+{$ifdef FPC_HAS_TYPE_DOUBLE}
+class function TInterlocked.Exchange(var Target: Double; Value: Double): Double; overload; static; inline;
+var
+  Int64Value: Int64;
+  DoublePtr: PDouble;
+begin
+  Int64Value := TInterlocked.Exchange(Int64(Target), Int64(Value));
+  DoublePtr := @Int64Value;
+  Result := DoublePtr^;
+end;
+{$endif}
+{$endif cpu64}
+
+{$ifdef FPC_HAS_TYPE_SINGLE}
+class function TInterlocked.Exchange(var Target: Single; Value: Single): Single; overload; static; inline;
+var
+  IntValue: Longint;
+  SinglePtr: PSingle;
+begin
+  IntValue := TInterlocked.Exchange(Longint(Target), Longint(Value));
+  SinglePtr := @IntValue;
+  Result := SinglePtr^;
+end;
+{$endif}
+
+{$ifndef VER3_0}
+generic class function TInterlocked.Exchange<T>(var Target: T; Value: T): T; overload; static; inline;
+begin
+  Result := T(InterLockedExchange(Pointer(Target), Pointer(Value)));
+end;
+{$endif}
+
+class function TInterlocked.Increment(var Target: Longint): Longint; overload; static; inline;
+begin
+  Result := InterLockedIncrement(Target); // returns new value
+end;
+
+{$ifdef cpu64}
+class function TInterlocked.Increment(var Target: Int64): Int64; overload; static; inline;
+begin
+  Result := InterLockedIncrement64(Target); // returns new value
+end;
+
+class function TInterlocked.Read(var Target: Int64): Int64; static; inline;
+begin
+  Result := InterlockedCompareExchange64(Target, 0, 0);
+end;
+{$endif cpu64}
+
 end.
37089_syncobjs.pp.patch (8,699 bytes)   

Bi0T1N

2020-06-20 13:35

reporter   ~0123482

@Do-wan Kim
That's not fully true. For instance, i386 'implements' (emulates) InterlockedCompareExchange64 for Int64 and also supports Int64/Double in normal code. But I agree with you that some platforms (e.g. 32-bit RISC-V) don't implement the Int64 Interlocked functions (probably because it's not supported).
I'd say the proper $IFDEF should be {$IF defined(CPU386) or defined(CPU64)} (or are there others which also support it on 32-bit?). I also assume that FPC_HAS_TYPE_DOUBLE is only defined if it supports Int64 as both types are 8 byte but maybe a dev could confirm?

Do-wan Kim

2020-06-21 02:38

reporter   ~0123493

@Bi0T1N My Compiler directive based on system unit interlocked*64 functions. There are defined with 'cpu64'.

Issue History

Date Modified Username Field Change
2020-05-17 00:54 NoName New Issue
2020-05-20 18:10 Bi0T1N Note Added: 0122957
2020-05-20 18:11 Bi0T1N Note Edited: 0122957 View Revisions
2020-05-20 18:24 Thaddy de Koning Note Added: 0122959
2020-05-20 18:25 Thaddy de Koning Note Edited: 0122959 View Revisions
2020-05-20 20:54 Bi0T1N Note Added: 0122963
2020-05-20 20:54 Bi0T1N File Added: TInterlocked_tests.pas
2020-05-20 20:54 Bi0T1N File Added: 01-Add_TInterlocked_without_Single_Double_BitTest.patch
2020-05-21 22:02 Bi0T1N Note Added: 0122996
2020-05-25 01:23 Bi0T1N Note Added: 0123052
2020-05-25 01:23 Bi0T1N File Added: 01-Add_TInterlocked_with_currently_possible_functionality.patch
2020-05-25 01:23 Bi0T1N File Added: TInterlocked_tests-2.pas
2020-06-04 00:01 Michael Van Canneyt Assigned To => Michael Van Canneyt
2020-06-04 00:01 Michael Van Canneyt Status new => assigned
2020-06-07 23:10 Bi0T1N Note Added: 0123322
2020-06-07 23:10 Bi0T1N File Added: 01-Add_TInterlocked_fixed_length_types.patch
2020-06-07 23:10 Bi0T1N File Added: TInterlocked_tests-3.pas
2020-06-07 23:11 Bi0T1N Note Edited: 0123322 View Revisions
2020-06-18 22:26 NoName Note Added: 0123470
2020-06-20 09:21 Do-wan Kim Note Added: 0123480
2020-06-20 09:21 Do-wan Kim File Added: 37089_syncobjs.pp.patch
2020-06-20 13:35 Bi0T1N Note Added: 0123482
2020-06-21 02:38 Do-wan Kim Note Added: 0123493