Atomic operations for TDataValue
This commit is contained in:
Michael Schimmel
+83
-14
@@ -4,6 +4,7 @@ interface
|
||||
|
||||
uses
|
||||
System.SysUtils,
|
||||
System.SyncObjs,
|
||||
Myc.Utils,
|
||||
Myc.Data.Scalar,
|
||||
Myc.Data.Series;
|
||||
@@ -35,7 +36,6 @@ type
|
||||
FScalar: TScalar;
|
||||
FInterface: IInterface;
|
||||
|
||||
function GetKind: TDataValueKind; inline;
|
||||
function GetIsVoid: Boolean; inline;
|
||||
|
||||
public
|
||||
@@ -50,8 +50,9 @@ type
|
||||
class operator Implicit(const AValue: TDataValue.TFunc): TDataValue; overload; inline;
|
||||
class operator Implicit(const AValue: TObject): TDataValue; overload; inline;
|
||||
|
||||
class function CompareAndSet(var Target: TDataValue; const Expected, NewValue: TDataValue): Boolean; static;
|
||||
class function Reset(var Target: TDataValue; const NewValue: TDataValue): TDataValue; static;
|
||||
// atomic operations
|
||||
function CompareAndSet(const Expected, NewValue: TDataValue): Boolean;
|
||||
function Reset(const NewValue: TDataValue): TDataValue;
|
||||
|
||||
class function FromIntf<T: IInterface>(const AValue: T): TDataValue; static;
|
||||
function AsIntf<T: IInterface>: T; inline;
|
||||
@@ -78,7 +79,7 @@ type
|
||||
|
||||
function ToString: String;
|
||||
property IsVoid: Boolean read GetIsVoid;
|
||||
property Kind: TDataValueKind read GetKind;
|
||||
property Kind: TDataValueKind read FKind;
|
||||
end;
|
||||
|
||||
TDataValueKindHelper = record helper for TDataValueKind
|
||||
@@ -89,7 +90,7 @@ type
|
||||
implementation
|
||||
|
||||
uses
|
||||
TypInfo;
|
||||
System.TypInfo;
|
||||
|
||||
type
|
||||
TMapSeries = class(TInterfacedObject, ISeries)
|
||||
@@ -197,9 +198,51 @@ begin
|
||||
Result := (FInterface as TVal<String>).Value;
|
||||
end;
|
||||
|
||||
class function TDataValue.CompareAndSet(var Target: TDataValue; const Expected, NewValue: TDataValue): Boolean;
|
||||
function TDataValue.CompareAndSet(const Expected, NewValue: TDataValue): Boolean;
|
||||
|
||||
function IntfCompareExchange(var VTarget: IInterface; const AValue, Compare: IInterface): IInterface; inline;
|
||||
begin
|
||||
if AValue <> nil then
|
||||
AValue._AddRef;
|
||||
|
||||
Result := IInterface(TInterlocked.CompareExchange(Pointer(VTarget), Pointer(AValue), Pointer(Compare)));
|
||||
|
||||
if (AValue <> nil) and (Pointer(Result) <> Pointer(Compare)) then
|
||||
AValue._Release;
|
||||
end;
|
||||
|
||||
begin
|
||||
// Result := ;
|
||||
Result := false;
|
||||
if FKind <> Expected.Kind then
|
||||
exit;
|
||||
if FKind <> NewValue.Kind then
|
||||
raise EArgumentException.Create('Value kinds have to match');
|
||||
|
||||
if FKind = vkVoid then
|
||||
raise EArgumentException.Create('Value is void');
|
||||
|
||||
case FKind of
|
||||
vkScalar:
|
||||
case FScalar.Kind of
|
||||
TScalar.TKind.Ordinal:
|
||||
Result :=
|
||||
TInterlocked
|
||||
.CompareExchange(FScalar.Value.AsInt64, NewValue.AsScalar.Value.AsInt64, Expected.AsScalar.Value.AsInt64)
|
||||
= Expected.AsScalar.Value.AsInt64;
|
||||
TScalar.TKind.Float:
|
||||
Result :=
|
||||
TInterlocked
|
||||
.CompareExchange(FScalar.Value.AsDouble, NewValue.AsScalar.Value.AsDouble, Expected.AsScalar.Value.AsDouble)
|
||||
= Expected.AsScalar.Value.AsDouble;
|
||||
end;
|
||||
vkPointer:
|
||||
Result :=
|
||||
TInterlocked.CompareExchange(FScalar.Value.AsInt64, NewValue.AsScalar.Value.AsInt64, Expected.AsScalar.Value.AsInt64)
|
||||
= Expected.AsScalar.Value.AsInt64;
|
||||
|
||||
vkText, vkSeries, vkRecordSeries, vkRecord, vkManagedObject, vkMethod, vkInterface, vkGeneric:
|
||||
Result := IntfCompareExchange(FInterface, NewValue.FInterface, Expected.FInterface) = Expected.FInterface;
|
||||
end;
|
||||
end;
|
||||
|
||||
class function TDataValue.FromIntf<T>(const AValue: T): TDataValue;
|
||||
@@ -257,19 +300,45 @@ begin
|
||||
Result := FKind = vkVoid;
|
||||
end;
|
||||
|
||||
function TDataValue.GetKind: TDataValueKind;
|
||||
begin
|
||||
Result := TDataValueKind(FKind);
|
||||
end;
|
||||
|
||||
class function TDataValue.Map(const SourceSeries: ISeries; const MapperFunc: TFunc): ISeries;
|
||||
begin
|
||||
Result := TMapSeries.Create(SourceSeries, MapperFunc);
|
||||
end;
|
||||
|
||||
class function TDataValue.Reset(var Target: TDataValue; const NewValue: TDataValue): TDataValue;
|
||||
function TDataValue.Reset(const NewValue: TDataValue): TDataValue;
|
||||
|
||||
function IntfExchange(var VTarget: IInterface; const AValue: IInterface): IInterface; inline;
|
||||
begin
|
||||
if AValue <> nil then
|
||||
AValue._AddRef;
|
||||
|
||||
Result := IInterface(TInterlocked.Exchange(Pointer(VTarget), Pointer(AValue)));
|
||||
|
||||
if AValue <> nil then
|
||||
AValue._Release;
|
||||
end;
|
||||
|
||||
begin
|
||||
// Result := ;
|
||||
if FKind <> NewValue.Kind then
|
||||
raise EArgumentException.Create('Value kinds have to match');
|
||||
|
||||
if FKind = vkVoid then
|
||||
raise EArgumentException.Create('Value is void');
|
||||
|
||||
case FKind of
|
||||
vkScalar:
|
||||
case FScalar.Kind of
|
||||
TScalar.TKind.Ordinal: Result := TInterlocked.Exchange(FScalar.Value.AsInt64, NewValue.AsScalar.Value.AsInt64);
|
||||
TScalar.TKind.Float: Result := TInterlocked.Exchange(FScalar.Value.AsDouble, NewValue.AsScalar.Value.AsDouble);
|
||||
end;
|
||||
vkPointer: Result := TInterlocked.Exchange(FScalar.Value.AsInt64, NewValue.AsScalar.Value.AsInt64);
|
||||
|
||||
vkText, vkSeries, vkRecordSeries, vkRecord, vkManagedObject, vkMethod, vkInterface, vkGeneric:
|
||||
begin
|
||||
Result.FKind := FKind;
|
||||
Result.FInterface := IntfExchange(FInterface, NewValue.FInterface);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TDataValue.ToString: String;
|
||||
|
||||
+2
-1
@@ -33,7 +33,8 @@ uses
|
||||
TestDataDecimal in 'TestDataDecimal.pas',
|
||||
TestDataPOD in 'TestDataPOD.pas',
|
||||
Test.Ast.Interpreter.Scope in 'Test.Ast.Interpreter.Scope.pas',
|
||||
Myc.Data.Chunks in '..\Src\Data\Myc.Data.Chunks.pas';
|
||||
Myc.Data.Chunks in '..\Src\Data\Myc.Data.Chunks.pas',
|
||||
Test.Myc.Data.Value in 'Test.Myc.Data.Value.pas';
|
||||
|
||||
{ keep comment here to protect the following conditional from being removed by the IDE when adding a unit }
|
||||
{$IFNDEF TESTINSIGHT}
|
||||
|
||||
@@ -137,6 +137,7 @@ $(PreBuildEvent)]]></PreBuildEvent>
|
||||
<DCCReference Include="TestDataPOD.pas"/>
|
||||
<DCCReference Include="Test.Ast.Interpreter.Scope.pas"/>
|
||||
<DCCReference Include="..\Src\Data\Myc.Data.Chunks.pas"/>
|
||||
<DCCReference Include="Test.Myc.Data.Value.pas"/>
|
||||
<BuildConfiguration Include="Base">
|
||||
<Key>Base</Key>
|
||||
</BuildConfiguration>
|
||||
|
||||
@@ -0,0 +1,173 @@
|
||||
unit Test.Myc.Data.Value;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
DUnitX.TestFramework,
|
||||
System.SysUtils,
|
||||
System.Threading,
|
||||
Myc.Data.Value,
|
||||
Myc.Data.Scalar;
|
||||
|
||||
type
|
||||
[TestFixture]
|
||||
TTestDataValue = class(TObject)
|
||||
private
|
||||
type
|
||||
// Simple object for interface tests
|
||||
TTestObject = class(TInterfacedObject, IInterface)
|
||||
public
|
||||
ID: Integer;
|
||||
end;
|
||||
public
|
||||
[Test]
|
||||
procedure TestReset_Scalar;
|
||||
[Test]
|
||||
procedure TestReset_Interface;
|
||||
[Test]
|
||||
procedure TestCompareAndSet_Scalar;
|
||||
[Test]
|
||||
procedure TestCompareAndSet_Interface;
|
||||
[Test]
|
||||
procedure TestKindImmutability_ThrowsException;
|
||||
[Test]
|
||||
procedure TestAtomicity_ConcurrentIncrement;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TTestDataValue }
|
||||
|
||||
procedure TTestDataValue.TestReset_Scalar;
|
||||
var
|
||||
val: TDataValue;
|
||||
oldVal: TDataValue;
|
||||
begin
|
||||
// Test with Int64
|
||||
val := 10;
|
||||
oldVal := val.Reset(20);
|
||||
Assert.AreEqual(Int64(20), val.AsScalar.Value.AsInt64, 'Value should be updated to 20');
|
||||
Assert.AreEqual(Int64(10), oldVal.AsScalar.Value.AsInt64, 'Reset should return the old value 10');
|
||||
|
||||
// Test with Double
|
||||
val := 10.5;
|
||||
oldVal := val.Reset(20.5);
|
||||
Assert.AreEqual(Double(20.5), val.AsScalar.Value.AsDouble, 'Value should be updated to 20.5');
|
||||
Assert.AreEqual(Double(10.5), oldVal.AsScalar.Value.AsDouble, 'Reset should return the old value 10.5');
|
||||
end;
|
||||
|
||||
procedure TTestDataValue.TestReset_Interface;
|
||||
var
|
||||
objA, objB: IInterface;
|
||||
val: TDataValue;
|
||||
oldVal: TDataValue;
|
||||
begin
|
||||
objA := TTestObject.Create;
|
||||
objB := TTestObject.Create;
|
||||
|
||||
val := TDataValue.FromIntf(objA);
|
||||
oldVal := val.Reset(TDataValue.FromIntf(objB));
|
||||
|
||||
Assert.AreSame(objB, val.AsIntf<IInterface>, 'Value should be updated to objB');
|
||||
Assert.AreSame(objA, oldVal.AsIntf<IInterface>, 'Reset should return the old value objA');
|
||||
end;
|
||||
|
||||
procedure TTestDataValue.TestCompareAndSet_Scalar;
|
||||
var
|
||||
val: TDataValue;
|
||||
begin
|
||||
val := 100;
|
||||
|
||||
// Successful CAS
|
||||
Assert.IsTrue(val.CompareAndSet(100, 200), 'CAS should succeed when expected value matches');
|
||||
Assert.AreEqual(Int64(200), val.AsScalar.Value.AsInt64, 'Value should be 200 after successful CAS');
|
||||
|
||||
// Failing CAS
|
||||
Assert.IsFalse(val.CompareAndSet(100, 300), 'CAS should fail when expected value does not match');
|
||||
Assert.AreEqual(Int64(200), val.AsScalar.Value.AsInt64, 'Value should remain 200 after failed CAS');
|
||||
end;
|
||||
|
||||
procedure TTestDataValue.TestCompareAndSet_Interface;
|
||||
var
|
||||
objA, objB, objC: IInterface;
|
||||
val: TDataValue;
|
||||
begin
|
||||
objA := TTestObject.Create;
|
||||
objB := TTestObject.Create;
|
||||
objC := TTestObject.Create;
|
||||
val := TDataValue.FromIntf(objA);
|
||||
|
||||
// Successful CAS
|
||||
Assert.IsTrue(val.CompareAndSet(TDataValue.FromIntf(objA), TDataValue.FromIntf(objB)), 'CAS should succeed for interfaces');
|
||||
Assert.AreSame(objB, val.AsIntf<IInterface>, 'Value should be objB after successful CAS');
|
||||
|
||||
// Failing CAS
|
||||
Assert.IsFalse(val.CompareAndSet(TDataValue.FromIntf(objA), TDataValue.FromIntf(objC)), 'CAS should fail for interfaces');
|
||||
Assert.AreSame(objB, val.AsIntf<IInterface>, 'Value should remain objB after failed CAS');
|
||||
end;
|
||||
|
||||
procedure TTestDataValue.TestKindImmutability_ThrowsException;
|
||||
var
|
||||
scalarVal, textVal: TDataValue;
|
||||
begin
|
||||
scalarVal := 10;
|
||||
textVal := 'hello';
|
||||
|
||||
// Test Reset
|
||||
Assert.WillRaise(procedure begin scalarVal.Reset(textVal); end, EArgumentException, 'Reset must throw exception on kind mismatch');
|
||||
|
||||
// Test CompareAndSet
|
||||
Assert.WillRaise(
|
||||
procedure
|
||||
begin
|
||||
// NewValue has wrong kind
|
||||
scalarVal.CompareAndSet(10, textVal);
|
||||
end,
|
||||
EArgumentException,
|
||||
'CompareAndSet must throw exception on kind mismatch'
|
||||
);
|
||||
|
||||
// Expected value doesn't match kind, should just fail silently (return False)
|
||||
Assert.IsFalse(scalarVal.CompareAndSet(textVal, 20), 'CAS should return False if kinds of self and expected differ');
|
||||
end;
|
||||
|
||||
procedure TTestDataValue.TestAtomicity_ConcurrentIncrement;
|
||||
const
|
||||
NumThreads = 8;
|
||||
IncrementsPerThread = 25000;
|
||||
var
|
||||
sharedValue: TDataValue;
|
||||
tasks: array of ITask;
|
||||
i: Integer;
|
||||
begin
|
||||
sharedValue := 0; // TDataValue of kind vkScalar, Ordinal
|
||||
SetLength(tasks, NumThreads);
|
||||
|
||||
for i := 0 to High(tasks) do
|
||||
begin
|
||||
tasks[i] :=
|
||||
TTask.Run(
|
||||
procedure
|
||||
var
|
||||
j: Integer;
|
||||
oldVal, newVal: TDataValue;
|
||||
begin
|
||||
for j := 1 to IncrementsPerThread do
|
||||
begin
|
||||
// This is the classic lock-free swap loop
|
||||
repeat
|
||||
oldVal := sharedValue; // Read current value
|
||||
newVal := oldVal.AsScalar.Value.AsInt64 + 1;
|
||||
until sharedValue.CompareAndSet(oldVal, newVal);
|
||||
end;
|
||||
end
|
||||
);
|
||||
end;
|
||||
|
||||
TTask.WaitForAll(tasks);
|
||||
|
||||
const Expected = NumThreads * IncrementsPerThread;
|
||||
Assert.AreEqual(Int64(Expected), sharedValue.AsScalar.Value.AsInt64, 'Concurrent increments should result in the correct total sum');
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user