Частный threadvar (Теория)

[WhiskasTM]

Да будет интерфейс...

  ITEST = interface
  ['{EFC29E20-B8EA-45C4-8B8E-677A277AB6AE}']
    function GetLastFound:Integer;stdcall;

    function Exists(const Value:WideString):BOOL;overload;stdcall;
    function Exists(const Index:Integer):BOOL;overload;stdcall;
    function Read(const Value:WideString):WideString;overload;stdcall;
    function Read(const Index:Integer):WideString;overload;stdcall;

    property LastFound:Integer read GetLastFound;
  end;

...и класс.

  TTEST = class(TInterfacedObject, ITEST)
  private type

    TData = class(TInterfacedObject)
      List      : array of WideString;
      Count     : Integer;
    end;

  private
    FData          : TData;
    FLastFound     : Integer;
  private
    function GetLastFound:Integer;stdcall;
  public
    function Exists(const Value:WideString):BOOL;overload;stdcall;
    function Exists(const Index:Integer):BOOL;overload;stdcall;
    function Read(const Value:WideString):WideString;overload;stdcall;
    function Read(const Index:Integer):WideString;overload;stdcall;

    constructor Create;
    destructor Destroy;override;
  end;

implementation

constructor TTEST.Create;
var
i : Integer;
begin
FData := TData.Create;
FData._AddRef;                          //ставим кол-во 1
with FData do
begin
  //да будут данные
  Count := 25;
  SetLength(List,Count);
  for i := 0 to Count-1 do
    List[i] := IntToStr(Random(1000));
end;
FLastFound := -1;
end;

destructor TTEST.Destroy;
begin
FData._Release;                        //если станет 0  - данные не нужны, чистим память
end;

function TTEST.GetLastFound:Integer;
begin
Result := FLastFound;
end;

function TTEST.Exists(const Value:WideString):BOOL;
var
I : Integer;
begin
Result := TryStrToInt(Value,I) and Exists(I);
if Result then FLastFound := I;              //установка FLastFound
end;

function TTEST.Exists(const Index:Integer):BOOL;
begin
Result := (Index>=0) and (Index<FData.Count);
end;

function TTEST.Read(const Value:WideString):WideString;
begin
if Exists(Value) then
  Result := FData.List[FLastFound] else      //чтение FLastFound
  Result := '$not found$';
end;

function TTEST.Read(const Index:Integer):WideString;
begin
if Exists(Index) then
  Result := FData.List[Index] else
  Result := '$not found$';
end;

Когда Exists по строке класс сохраняет последний найденный индекс и в будущем можно использовать перегруженный метод, чтобы прочитать его побыстрее.

procedure DoSomething;
var
test : ITEST;
begin
test := _ITEST;
if test.Exists('10') then
begin
  //благодарим что True и воздаем какие-нибудь почести
  //<...>

  //показываем, что test все же приготовил нам
  ShowMessage(test.Read(test.LastFound)); 
end;
end;

Это убило возможность читать данные в потоках и даже в порядке очереди, ведь эта переменная FLastFound одна на экземпляр класса. Грубый фикс - новый экземпляр, но с указателем на тот же FData:

//добавляем в TTEST и ITEST метод
... 

procedure TTEST.MakeMultiThread(var test:ITEST);
var
_class : TTESTDummy;
begin
if test<>nil then Exit;
FData._AddRef;                              //+1 данные должны жить
test := TTESTDummy.Create;
_class := test as TTESTDummy;       
_class.FData := FData;                    //шарим данные
end;

...

//Класс-заглушка
  TTESTDummy = class(TTEST, ITEST)
  public
    constructor Create;
    destructor Destroy;override;
  end;

implementation

constructor TTESTDummy.Create;
begin
FLastFound := -1;
end;

destructor TTESTDummy.Destroy;
begin
inherited Destroy;                          //-1
end;

Вот теперь win:

var
  test : array [0..100] of ITEST;

procedure DoSomething;
var
i    : Integer;
begin
test[0] := _ITEST;  //создание первого экзмеляра
for i := 1 to 100 do
  test[0].MakeMultiThread(test[i]); //расшариваем
end;
test[25].Exists('2');    //test[25].LastFound = 2
test[27].Exists('14');  //test[27].LastFound = 14

Но. Класс наследуется от TInterfacedObject, значит компилятор будет делать автоматические _AddRef и _Release при присвавиании переменной ITEST куда-нибудь. Нужно как-то использовать эту возможность, чтобы после присваивания в другой переменной был свой частный FLastCount.

procedure DoSomething;
var
test1 : ITEST;
test2 : ITEST;
begin
test1 := _ITEST;  //создание первого экзмеляра
test2 := test1;    //компилятор делает _AddRef

test1.Exists('2');   
test2.Exists('14'); 
//Итого:
//test1.LastFound = 14;
//test2.LastFound = 14;

//Нужно:
//test1.LastFound = 2;
//test2.LastFound = 14;

Вообщем, пускай в _AddRef че-нибудь происходит и будет 'Нужно'. Это избавит от MakeMultiThread потому как я хочу чтобы все было автоматически. Бревно в глазу я чую, но пока не вижу =)

[Человек_Борща]

Погуглите OmniThreadLibrary

[WhiskasTM]

Сабж. Я сделал вариант "нужно" lol. Хук на _IntfCopy, он вызывается при присваивании интерфейсов.

//новый юнит
  IMultiThreadApartmentInterface = interface
  ['{50E740BC-AB91-4EB9-BE0C-E6B4156AC575}']
    function _SafeInstance(var Dst:IInterface):BOOL;stdcall;
  end;

  TMultiThreadApartmentInterface = class(TInterfacedObject, IMultiThreadApartmentInterface)
  protected
    function _SafeInstance(var Dest:IInterface):BOOL;virtual;stdcall;abstract; //на abstract компилятор сделает напоминание что нужно реализовывать
  end;

//меняем класс 
  TTEST = class(TMultiThreadApartmentInterface, ITEST)
  ....
  protected
    function _SafeInstance(var Dest:IInterface):BOOL;override;stdcall;
  ....

implementation

function TTEST._SafeInstance(var Dest:IInterface):BOOL;
var
_class : TTESTDummy;
begin
if Dest<>nil then Exit;
FData._AddRef;                              //+1 данные должны жить
Dest := TTESTDummy.Create as ITEST;
_class := Dest as TTESTDummy;
_class.FData := FData;
Result := True;
end;

//В приложении
procedure _IntfCopyEx(var Dest: IInterface; const Source: IInterface);
var
  P:   Pointer;
  MTA: IMultiThreadApartmentInterface;
begin
  P := Pointer(Dest);
  if Source <> nil then
    if Supports(Source,IMultiThreadApartmentInterface,MTA) and MTA._SafeInstance(Dest) then
      Exit
    else
      Source._AddRef;
  Pointer(Dest) := Pointer(Source);
  if P <> nil then
    IInterface(P)._Release;
end;

procedure _InitializeMultiThreadApartmentInterfaces;

  function _IntfCopy:Pointer;
  asm
    mov       rax,offset System.@IntfCopy
  end;

var
OldProtect : Cardinal;
begin
VirtualProtect(_IntfCopy,5,PAGE_EXECUTE_READWRITE,OldProtect);
PByte(_IntfCopy)^ := $E9;
PUINT(NativeUInt(_IntfCopy)+1)^ := UINT(NativeUInt(@_IntfCopyEx)-NativeUInt(_IntfCopy)-5);
VirtualProtect(_IntfCopy,5,OldProtect,OldProtect);
end;

initialization
_InitializeMultiThreadApartmentInterfaces;

Хак в экзешнике, а классы только в dll-ках и там нормальный IntfCopy во избежание рекурсии. Но наверное можно сделать регистрацию и все такое.

Человек_Борща, выглядит уж слишком навороченным. Посмотрю, спасибо.

[Slym]

я бы делал по принципу ThreadList.Lock, т.е. объект контейнер списка + минифабрика объектов доступа
List:=Data.GetList;
List.Exists(2);
или к Data вторым интерфейсом и в QueryInterface - подсовывать новый объект доступа

List[1]:=Data1 as ITEST;
Data2:=Data1;
List[2]:=Data2 as ITEST;
List[3]:=Data2 as ITEST;

можно на самого себя QueryInterface делать

var
 l:ITEST;
begin
  test[0] := _ITEST;  //создание первого экзмеляра
  test[1] := test[0];  //создание ссылки на экзмеляр
  for i := 2 to 100 do
    test[i]:=test[0] as ITEST; //создание нового экзмпляра через QueryInterface;
end;

[WhiskasTM]

Шикарно)) И параметром посылать можно и ооп не страдает, видно когда типа копия, а когда типа тру-референс.

function TTEST.QueryInterface(const IID:TGUID;out Obj):HRESULT;
var
_class : TTESTDummy;
begin
if GetInterface(IID, Obj) then
begin
  FData._AddRef;
  _class :=  TTESTDummy.Create;
  _class.FData := FData;
  IInterface(Obj) := _class as ITEST;
  Result := 0;
end
else
  Result := E_NOINTERFACE;
end;

Теперь можно думать про запись данных. В TThreadList TMonitor используется, он и главный поток не блочит, может однажды. Спасибо!

[Мордохвост]

Вообщем как-то так:

type
  ITls<T> = interface
  ['{1FE265E6-CA9F-416C-84DE-2D9F3DCF3CD9}']
    function Get:T;
    procedure Put(const Value:T);
  end;

FLastFound : ITls<Integer>;

Но сначала TThreadLocalCounter, и этот lock-free чудовищно экспериментальный. И 16 пока.

  TThreadInfo = record
    ThreadID  : PThreadID;
    Recursion : PUINT;
  end;

  TThreadLocalCounter = class(TInterfacedObject, IThreadLocalCounter)
  protected const
    MaxThreads = 16;
  strict private
    FActive : DWORD;
    FThread : array [0..1,0..MaxThreads-1] of Integer;
  strict private
    procedure RaiseThread;
    procedure RaiseInactive;
  public
    function Open(var ThreadInfo:TThreadInfo):Integer;
    function Delete(var ThreadInfo:TThreadInfo):Integer;
  end;

implementation

procedure TThreadLocalCounter.RaiseThread;
begin
raise Exception.Create('TThreadLocalCounter - attempt to delete not owned thread.');
Halt(0);
end;

procedure TThreadLocalCounter.RaiseInactive;
begin
raise Exception.Create('TThreadLocalCounter - attempt to delete inactive thread.');
Halt(0);
end;

function TThreadLocalCounter.Open(var ThreadInfo:TThreadInfo):Integer;
asm
  push      rbx
  push      rsi
  push      rdi
  mov       rbx,rcx
  mov       rdi,rdx
  call      GetCurrentThreadId
  xor       edx,edx
  lea       rsi,TThreadLocalCounter[rbx].[FThread]

@@search:
  prefetcht0 [rsi]
  movdqu    xmm1,[rsi+00]
  movdqu    xmm2,[rsi+16]
  movdqu    xmm3,[rsi+32]
  movdqu    xmm4,[rsi+48]
  movd      xmm5,eax
  pshufd    xmm5,xmm5,0
  movdqa    xmm0,xmm5
  pcmpeqd   xmm0,xmm1
  ptest     xmm0,xmm0
  jnz       @@f1
  movdqa    xmm0,xmm5
  pcmpeqd   xmm0,xmm2
  ptest     xmm0,xmm0
  jnz       @@f2
  movdqa    xmm0,xmm5
  pcmpeqd   xmm0,xmm3
  ptest     xmm0,xmm0
  jnz       @@f3
  movdqa    xmm0,xmm5
  pcmpeqd   xmm0,xmm4
  ptest     xmm0,xmm0
  jz        @@continue

@@f4:
  add       edx,4

@@f3:
  add       edx,4

@@f2:
  add       edx,4

@@f1:
  packssdw  xmm0,xmm0
  movq      r10,xmm0
  test      r10d,r10d
  setz      cl
  add       dl,cl
  add       dl,cl
  shl       cl,5
  shr       r10,cl
  test      r10w,r10w
  setz      cl
  add       dl,cl
  xor       ecx,ecx
  lock bts  TThreadLocalCounter[rbx].[FActive],dx
  jnc       @@break
  lock cmpxchg [rsi+rdx*4],eax
  je        @@leave

@@continue:
  pause
  mov       edx,TThreadLocalCounter[rbx].[FActive]
  xor       edx,$FFFFFFFF    //need to find nearest 0 (inactive thread index in array)
  bsf       edx,edx
  cmp       edx,MaxThreads
  jge       @@continue
  lock bts  TThreadLocalCounter[rbx].[FActive],dx
  jc        @@continue
  imul      ecx,0            //CF = 0 ZF = 0 (cmovbe execution avoid)

@@break:
  lock xchg [rsi+rdx*4],eax  //unsynchonized with "lock cmpxchg [rsi+rdx*4],eax"

@@leave:
  lea       r8,[rsi+rdx*4]
  lea       r9,[r8+64]
  cmovbe    ecx,[r9]
  inc       ecx
  mov       [r9],ecx
  mov       [rdi+00],r8
  mov       [rdi+08],r9
  mov       eax,edx
  pop       rdi
  pop       rsi
  pop       rbx
end;

function TThreadLocalCounter.Delete(var ThreadInfo:TThreadInfo):Integer;
asm
  push      rbx
  push      rsi
  push      rdi
  mov       rbx,rcx
  mov       rsi,TThreadInfo[rdx].[ThreadID]
  lea       rdi,TThreadLocalCounter[rcx].[FThread]
  call      GetCurrentThreadId
  sub       rdi,rsi
  neg       rdi
  shr       rdi,2
  xor       ecx,ecx
  lock cmpxchg [rsi],ecx
  jne       RaiseThread
  lock btr  TThreadLocalCounter[rbx].[FActive],di
  jnc       RaiseInactive
  pop       rdi
  pop       rsi
  pop       rbx
end;

Теперь базовый TThreadLocalStorage

type
  TThreadLocalStorage = class(TThreadLocalCounter)
  protected
    function _AddRef:Integer;stdcall;
    function _Release:Integer;stdcall;
  end;

implementation

function TThreadLocalStorage._AddRef:Integer;
var
ThreadInfo : TThreadInfo;
begin
Open(ThreadInfo);
Result := AtomicIncrement(FRefCount);
end;

function TThreadLocalStorage._Release:Integer;
var
ThreadInfo : TThreadInfo;
begin
Open(ThreadInfo);
Dec(ThreadInfo.Recursion^,2);
if ThreadInfo.Recursion^=0 then
  Delete(ThreadInfo);
Result := AtomicDecrement(FRefCount);
if Result = 0 then
begin
  __MarkDestroying(Self);
  Destroy;
end;
end;

И собственно дженерик:

type
  TTls<T> = class(TThreadLocalStorage, ITls<T>)
  strict private
    FVal : array [0..TThreadLocalCounter.MaxValues] of T;
  strict private
    function Get:T;
    procedure Put(const Value:T);
  end;

implementation

function TTls<T>.Get:T;
var
ThreadInfo : TThreadInfo;
begin
Result := FVal[Open(ThreadInfo)];
Dec(ThreadInfo.Recursion^); //???
end;

procedure TTls<T>.Put(const Value:T);
var
ThreadInfo : TThreadInfo;
begin
FVal[Open(ThreadInfo)] := Value;
Dec(ThreadInfo.Recursion^); //???
end;

[Мордохвост]

FLastFound := TTls<Integer>.Create;

Суть в том что переменная регистрируется при _AddRef и после никогда не пляшет с удалением, ни со сновадобавлением, просто живет пока есть ссылки... ??? короче я забыл пока мучался с TThreadLocalCounter. По обстановке надо решить нужно ли Dec(Recursion) или нет и затем соотвественно править _AddRef и _Release.

Вот так тестировал tlc(здесь tls - класс пока...), 4 потока и бонус Put-Get-Delete где-нить в нажатии кнопки(MainThread вообщем), если будет raise - ну, не сложилось...

var
  tls : TTls<Integer>;
  h   : array [0..3] of THandle;
  t   : array [0..3] of TThreadID;

procedure P0(Parameter:Pointer);
var
X : TThreadInfo;
begin
while True do
begin
  tls.Put(33);
  if tls.Get<>33 then
    raise Exception.Create('not 33');
  tls.Open(X);
  tls.Delete(X);
end;
end;

procedure P1(Parameter:Pointer);
var
X : TThreadInfo;
begin
while True do
begin
  tls.Put(99);
  if tls.Get<>99 then
    raise Exception.Create('not 99');
  tls.Open(X);
  tls.Delete(X);
end;
end;

procedure P2(Parameter:Pointer);
var
X : TThreadInfo;
begin
while True do
begin
  tls.Open(X);
  tls.Put(-112);
  if tls.Get<>-112 then
    raise Exception.Create('not -112');
  tls.Delete(X);
end;
end;

procedure P3(Parameter:Pointer);
var
X : TThreadInfo;
begin
while True do
begin
  tls.Open(X);
  tls.Put(-113);
  if tls.Get<>-113 then
    raise Exception.Create('not -113');
  tls.Delete(X);
end;
end;

initialization
tls := TTls<Integer>.Create;
h[0] := BeginThread(nil,0,@p0,nil,0,t[0]);
h[1] := BeginThread(nil,0,@p1,nil,0,t[1]);
h[2] := BeginThread(nil,0,@p2,nil,0,t[2]);
h[3] := BeginThread(nil,0,@p3,nil,0,t[3]);