paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-14 20:39:34 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch from Rika to implement BitTestAndSet

Browse Source
This commit is contained in:
Michaël Van Canneyt 2023-07-15 21:57:36 +02:00
parent d5be4efc16
commit 3bd3a67189
2 changed files with 50 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
packages/fcl-base/src/syncobjs.pp
View File

@ -99,6 +99,8 @@ type
{$DEFINE NOPOINTER}
{$ENDIF}
TBitOffset = 0 .. 31;
TInterlocked = class sealed
class function Add(var Target: Longint; aIncrement: Longint): Longint; overload; static; inline;
class function Exchange(var Target: Longint; Value: Longint): Longint; overload; static; inline;
@ -106,6 +108,10 @@ type
class function CompareExchange(var Target: Longint; Value: Longint; Comparand: Longint; out Succeeded: Boolean): Longint; overload; static;
class function Decrement(var Target: Longint): Longint; overload; static; inline;
class function Increment(var Target: Longint): Longint; overload; static; inline;
class function BitTestAndSet(var Target: Longint; BitOffset: TBitOffset): Boolean; static;
class function BitTestAndClear(var Target: Longint; BitOffset: TBitOffset): Boolean; static;
{$ifdef FPC_HAS_TYPE_SINGLE}
class function Exchange(var Target: Single; Value: Single): Single; overload; static; inline;
class function CompareExchange(var Target: Single; Value: Single; Comparand: Single): Single; overload; static; inline;
@ -395,29 +401,41 @@ begin
Result := InterLockedIncrement(Target); // returns new value
end;
class function TInterlocked.BitTestAndSet(var Target: Longint; BitOffset: TBitOffset): Boolean;
var
Fetch, NewValue: Longint;
begin
repeat
Fetch := Target;
Result := Boolean(Fetch shr BitOffset and 1);
NewValue := Fetch or Longint(1) shl BitOffset;
until InterlockedCompareExchange(Target, NewValue, Fetch) = Fetch;
end;
class function TInterlocked.BitTestAndClear(var Target: Longint; BitOffset: TBitOffset): Boolean;
var
Fetch, NewValue: Longint;
begin
repeat
Fetch := Target;
Result := Boolean(Fetch shr BitOffset and 1);
NewValue := Fetch and not (Longint(1) shl BitOffset);
until InterlockedCompareExchange(Target, NewValue, Fetch) = Fetch;
end;
{ ---------------------------------------------------------------------
32-bit single versions
---------------------------------------------------------------------}
{$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^;
Result := TSingleRec(TInterlocked.Exchange(Longint(Target), Longint(Value))).Value;
end;
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^;
Result := TSingleRec(TInterlocked.CompareExchange(Longint(Target), Longint(Value), Longint(Comparand))).Value;
end;
{$endif}
@ -465,25 +483,15 @@ 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^;
Result := TDoubleRec(TInterlocked.CompareExchange(Int64(Target), Int64(Value), Int64(Comparand))).Value;
end;
{$endif}
{$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^;
Result := TDoubleRec(TInterlocked.Exchange(Int64(Target), Int64(Value))).Value;
end;
{$endif}

30
packages/fcl-base/tests/testinterlocked.pp
View File

@ -10,7 +10,7 @@ var
New32, Old32: Longint;
i64: Int64;
New64, Old64: Int64;
Changed: Boolean;
Changed, OldBitValue: Boolean;
list1, list2, oldlist: TStringList;
d1, d2, dOld: Double;
s1, s2, sOld: Single;
@ -50,6 +50,7 @@ begin
if Old32 <> 48 then halt(15);
if i32 <> 96 then halt(15);
{$ifdef cpu64}
{* test all kinds of Int64 usage *}
i64 := 12;
New64 := TInterlocked.Increment(i64);
@ -75,6 +76,7 @@ begin
Old64 := TInterlocked.Read(i64);
if Old64 <> 48 then halt(30);
if i64 <> 48 then halt(31);
{$endif}
{* test all kinds of TObject and generic class usage *}
list1 := TStringList.Create;
@ -112,6 +114,7 @@ begin
writeln('tests passed so far');
{$ifdef cpu64}
{* test all kinds of Double usage *}
d1 := Double(3.14);
d2 := Double(6.28);
@ -130,6 +133,7 @@ begin
if dOld <> Double(6.28) then halt(50);
if d1 <> Double(3.14) then halt(51);
if d1 = d2 then halt(52);
{$endif}
{* test all kinds of Single usage *}
s1 := Single(3.14);
@ -150,19 +154,21 @@ begin
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);
OldBitValue := TInterlocked.BitTestAndClear(i32, 6);
if OldBitValue <> True then halt(62);
if i32 <> 32 then halt(63);
}
OldBitValue := TInterlocked.BitTestAndClear(i32, 6);
if OldBitValue <> False then halt(64);
if i32 <> 32 then halt(65);
{* test BitTestAndSet usage *}
{
// enable when implemented!
Changed := TInterlocked.BitTestAndSet(i32, 4);
if Changed <> False then halt(64);
if i32 <> 48 then halt(65);
}
OldBitValue := TInterlocked.BitTestAndSet(i32, 6);
if OldBitValue <> False then halt(66);
if i32 <> 96 then halt(67);
OldBitValue := TInterlocked.BitTestAndSet(i32, 6);
if OldBitValue <> True then halt(68);
if i32 <> 96 then halt(69);
writeln('testing of TInterlocked methods ended');
end.