View Issue Details

IDProjectCategoryView StatusLast Update
0037302FPCPackagespublic2020-07-07 12:28
ReporterImants Gulbis Assigned To 
PrioritynormalSeverityminorReproducibilityalways
Status newResolutionopen 
Product Version3.3.1 
Summary0037302: Rtti.pp unit is not thread safe
DescriptionI attached patch for fixing some problems with using rtti unit in multiple threads.

Specially I got problems with GetParameters, GetDeclaredMethods and GetProperties methods they time to time raised 'A RTTI object with handle 0x%x is already registered' error and sometimes it created more than one TPoolToken for same context which caused problems with GRttiPool
TagsNo tags attached.
Fixed in Revision
FPCOldBugId
FPCTarget
Attached Files

Activities

Imants Gulbis

2020-07-06 09:12

reporter  

rtti.pp.patch (13,864 bytes)   
Index: packages/rtl-objpas/src/inc/rtti.pp
===================================================================
--- packages/rtl-objpas/src/inc/rtti.pp	(revision 45712)
+++ packages/rtl-objpas/src/inc/rtti.pp	(working copy)
@@ -185,6 +185,9 @@
     FContextToken: IInterface;
     function GetByHandle(AHandle: Pointer): TRttiObject;
     procedure AddObject(AObject: TRttiObject);
+    procedure Lock;
+    procedure Unlock;
+    function GetContextToken: IInterface;
   public
     class function Create: TRttiContext; static;
     procedure  Free;
@@ -654,6 +657,8 @@
     function GetType(ATypeInfo: PTypeInfo): TRttiType;
     function GetByHandle(aHandle: Pointer): TRttiObject;
     procedure AddObject(aObject: TRttiObject);
+    procedure Lock; inline;
+    procedure Unlock; inline;
     constructor Create;
     destructor Destroy; override;
   end;
@@ -802,6 +807,7 @@
 var
   PoolRefCount : integer;
   GRttiPool    : TRttiPool;
+  GLock        : TRTLCriticalSection;
   FuncCallMgr: TFunctionCallManagerArray;
 
 function AllocateMemory(aSize: PtrUInt): Pointer;
@@ -1320,6 +1326,20 @@
 {$endif}
 end;
 
+procedure TRttiPool.Lock;
+begin
+  {$ifdef FPC_HAS_FEATURE_THREADING}
+  EnterCriticalsection(FLock);
+  {$endif}
+end;
+
+procedure TRttiPool.Unlock;
+begin
+  {$ifdef FPC_HAS_FEATURE_THREADING}
+  LeaveCriticalsection(FLock);
+  {$endif}
+end;
+
 procedure TRttiPool.AddObject(aObject: TRttiObject);
 var
   idx: LongInt;
@@ -2842,19 +2862,20 @@
   context: TRttiContext;
   obj: TRttiObject;
 begin
-  if aWithHidden and (Length(FParamsAll) > 0) then
-    Exit(FParamsAll);
-  if not aWithHidden and (Length(FParams) > 0) then
-    Exit(FParams);
+  Context := TRttiContext.Create;
+  Context.Lock;
+  try
+    if aWithHidden and (Length(FParamsAll) > 0) then
+      Exit(FParamsAll);
+    if not aWithHidden and (Length(FParams) > 0) then
+      Exit(FParams);
 
-  if FIntfMethodEntry^.ParamCount = 0 then
-    Exit(Nil);
+    if FIntfMethodEntry^.ParamCount = 0 then
+      Exit(Nil);
 
-  SetLength(FParams, FIntfMethodEntry^.ParamCount);
-  SetLength(FParamsAll, FIntfMethodEntry^.ParamCount);
+    SetLength(FParams, FIntfMethodEntry^.ParamCount);
+    SetLength(FParamsAll, FIntfMethodEntry^.ParamCount);
 
-  context := TRttiContext.Create;
-  try
     total := 0;
     visible := 0;
     param := FIntfMethodEntry^.Param[0];
@@ -2876,16 +2897,17 @@
       Inc(total);
     end;
 
-    if visible <> total then
-      SetLength(FParams, visible);
+      if visible <> total then
+        SetLength(FParams, visible);
+
+    if aWithHidden then
+      Result := FParamsAll
+    else
+      Result := FParams
   finally
-    context.Free;
-  end;
-
-  if aWithHidden then
-    Result := FParamsAll
-  else
-    Result := FParams;
+    Context.Unlock;
+    Context.Free
+  end
 end;
 
 { TRttiInt64Type }
@@ -3408,55 +3430,56 @@
   context: TRttiContext;
   obj: TRttiObject;
 begin
-  if aWithHidden and (Length(FParamsAll) > 0) then
-    Exit(FParamsAll);
-  if not aWithHidden and (Length(FParams) > 0) then
-    Exit(FParams);
+  Context := TRttiContext.Create;
+  Context.Lock;
+  try
+    if aWithHidden and (Length(FParamsAll) > 0) then
+      Exit(FParamsAll);
+    if not aWithHidden and (Length(FParams) > 0) then
+      Exit(FParams);
 
-  ptr := @FTypeData^.ParamList[0];
+    ptr := @FTypeData^.ParamList[0];
 
-  visible := 0;
-  total := 0;
+    visible := 0;
+    total := 0;
 
-  if FTypeData^.ParamCount > 0 then begin
-    SetLength(infos, FTypeData^.ParamCount);
+    if FTypeData^.ParamCount > 0 then begin
+      SetLength(infos, FTypeData^.ParamCount);
 
-    while total < FTypeData^.ParamCount do begin
-      { align }
-      ptr := AlignTParamFlags(ptr);
-      infos[total].Handle := ptr;
-      infos[total].Flags := PParamFlags(ptr)^;
-      Inc(ptr, SizeOf(TParamFlags));
-      { handle name }
-      infos[total].Name := PShortString(ptr)^;
-      Inc(ptr, ptr^ + SizeOf(Byte));
-      { skip type name }
-      Inc(ptr, ptr^ + SizeOf(Byte));
+      while total < FTypeData^.ParamCount do begin
+        { align }
+        ptr := AlignTParamFlags(ptr);
+        infos[total].Handle := ptr;
+        infos[total].Flags := PParamFlags(ptr)^;
+        Inc(ptr, SizeOf(TParamFlags));
+        { handle name }
+        infos[total].Name := PShortString(ptr)^;
+        Inc(ptr, ptr^ + SizeOf(Byte));
+        { skip type name }
+        Inc(ptr, ptr^ + SizeOf(Byte));
 
-      if not (pfHidden in infos[total].Flags) then
-        Inc(visible);
-      Inc(total);
+        if not (pfHidden in infos[total].Flags) then
+          Inc(visible);
+        Inc(total);
+      end;
     end;
-  end;
 
-  if FTypeData^.MethodKind in [mkFunction, mkClassFunction] then begin
-    { skip return type name }
-    ptr := AlignToPtr(PByte(ptr) + ptr^ + SizeOf(Byte));
-    { handle return type }
-    FReturnType := GRttiPool.GetType(PPPTypeInfo(ptr)^^);
-    Inc(ptr, SizeOf(PPTypeInfo));
-  end;
+    if FTypeData^.MethodKind in [mkFunction, mkClassFunction] then begin
+      { skip return type name }
+      ptr := AlignToPtr(PByte(ptr) + ptr^ + SizeOf(Byte));
+      { handle return type }
+      FReturnType := GRttiPool.GetType(PPPTypeInfo(ptr)^^);
+      Inc(ptr, SizeOf(PPTypeInfo));
+    end;
 
-  { handle calling convention }
-  FCallConv := PCallConv(ptr)^;
-  Inc(ptr, SizeOf(TCallConv));
+    { handle calling convention }
+    FCallConv := PCallConv(ptr)^;
+    Inc(ptr, SizeOf(TCallConv));
 
-  SetLength(FParamsAll, FTypeData^.ParamCount);
-  SetLength(FParams, visible);
+    SetLength(FParamsAll, FTypeData^.ParamCount);
+    SetLength(FParams, visible);
 
-  if FTypeData^.ParamCount > 0 then begin
-    context := TRttiContext.Create;
-    try
+    if FTypeData^.ParamCount > 0 then begin
       paramtypes := PPPTypeInfo(AlignTypeData(ptr));
       visible := 0;
       for i := 0 to FTypeData^.ParamCount - 1 do begin
@@ -3477,15 +3500,16 @@
           Inc(visible);
         end;
       end;
-    finally
-      context.Free;
     end;
-  end;
 
-  if aWithHidden then
-    Result := FParamsAll
-  else
-    Result := FParams;
+    if aWithHidden then
+      Result := FParamsAll
+    else
+      Result := FParams
+  finally
+    Context.Unlock;
+    Context.Free
+  end
 end;
 
 function TRttiMethodType.GetCallingConvention: TCallConv;
@@ -3537,19 +3561,20 @@
   obj: TRttiObject;
   context: TRttiContext;
 begin
-  if aWithHidden and (Length(FParamsAll) > 0) then
-    Exit(FParamsAll);
-  if not aWithHidden and (Length(FParams) > 0) then
-    Exit(FParams);
+  Context := TRttiContext.Create;
+  Context.Lock;
+  try
+    if aWithHidden and (Length(FParamsAll) > 0) then
+      Exit(FParamsAll);
+    if not aWithHidden and (Length(FParams) > 0) then
+      Exit(FParams);
 
-  if FTypeData^.ProcSig.ParamCount = 0 then
-    Exit(Nil);
+    if FTypeData^.ProcSig.ParamCount = 0 then
+      Exit(Nil);
 
-  SetLength(FParamsAll, FTypeData^.ProcSig.ParamCount);
-  SetLength(FParams, FTypeData^.ProcSig.ParamCount);
+    SetLength(FParamsAll, FTypeData^.ProcSig.ParamCount);
+    SetLength(FParams, FTypeData^.ProcSig.ParamCount);
 
-  context := TRttiContext.Create;
-  try
     param := AlignToPtr(PProcedureParam(@FTypeData^.ProcSig.ParamCount + SizeOf(FTypeData^.ProcSig.ParamCount)));
     visible := 0;
     for i := 0 to FTypeData^.ProcSig.ParamCount - 1 do begin
@@ -3570,14 +3595,15 @@
     end;
 
     SetLength(FParams, visible);
+
+    if aWithHidden then
+      Result := FParamsAll
+    else
+      Result := FParams
   finally
-    context.Free;
-  end;
-
-  if aWithHidden then
-    Result := FParamsAll
-  else
-    Result := FParams;
+    Context.Unlock;
+    Context.Free
+  end
 end;
 
 function TRttiProcedureType.GetCallingConvention: TCallConv;
@@ -3664,26 +3690,27 @@
   parent: TRttiInterfaceType;
   parentmethodcount: Word;
 begin
-  if Assigned(fDeclaredMethods) then
-    Exit(fDeclaredMethods);
+  Context := TRttiContext.Create;
+  Context.Lock;
+  try
+    if Assigned(fDeclaredMethods) then
+      Exit(fDeclaredMethods);
 
-  methtable := MethodTable;
-  if not Assigned(methtable) then
-    Exit(Nil);
+    methtable := MethodTable;
+    if not Assigned(methtable) then
+      Exit(Nil);
 
-  if (methtable^.Count = 0) or (methtable^.RTTICount = $ffff) then
-    Exit(Nil);
+    if (methtable^.Count = 0) or (methtable^.RTTICount = $ffff) then
+      Exit(Nil);
 
-  parent := GetIntfBaseType;
-  if Assigned(parent) then
-    parentmethodcount := parent.IntfMethodCount
-  else
-    parentmethodcount := 0;
+    parent := GetIntfBaseType;
+    if Assigned(parent) then
+      parentmethodcount := parent.IntfMethodCount
+    else
+      parentmethodcount := 0;
 
-  SetLength(fDeclaredMethods, methtable^.Count);
+    SetLength(fDeclaredMethods, methtable^.Count);
 
-  context := TRttiContext.Create;
-  try
     method := methtable^.Method[0];
     count := methtable^.Count;
     while count > 0 do begin
@@ -3699,11 +3726,12 @@
       method := method^.Next;
       Dec(count);
     end;
+
+    Result := fDeclaredMethods
   finally
-    context.Free;
-  end;
-
-  Result := fDeclaredMethods;
+    Context.Unlock;
+    Context.Free
+  end
 end;
 
 { TRttiInstanceType }
@@ -3750,46 +3778,51 @@
   Count: longint;
   obj: TRttiObject;
 begin
-  if not FPropertiesResolved then
-    begin
-      TypeInfo := FTypeInfo;
+  GRttiPool.Lock;
+  try
+    if FPropertiesResolved then
+      Exit(FProperties);
 
-      // Get the total properties count
-      SetLength(FProperties,FTypeData^.PropCount);
-      TypeRttiType:= self;
-      repeat
-        TD:=GetTypeData(TypeInfo);
+    TypeInfo := FTypeInfo;
 
-        // published properties count for this object
-        // skip the attribute-info if available
-        PPD := PClassData(TD)^.PropertyTable;
-        Count:=PPD^.PropCount;
-        // Now point TP to first propinfo record.
-        TP:=PPropInfo(@PPD^.PropList);
-        While Count>0 do
-          begin
-            // Don't overwrite properties with the same name
-            if FProperties[TP^.NameIndex]=nil then begin
-              obj := GRttiPool.GetByHandle(TP);
-              if Assigned(obj) then
-                FProperties[TP^.NameIndex] := obj as TRttiProperty
-              else begin
-                FProperties[TP^.NameIndex] := TRttiProperty.Create(TypeRttiType, TP);
-                GRttiPool.AddObject(FProperties[TP^.NameIndex]);
-              end;
+    // Get the total properties count
+    SetLength(FProperties,FTypeData^.PropCount);
+    TypeRttiType:= self;
+    repeat
+      TD:=GetTypeData(TypeInfo);
+
+      // published properties count for this object
+      // skip the attribute-info if available
+      PPD := PClassData(TD)^.PropertyTable;
+      Count:=PPD^.PropCount;
+      // Now point TP to first propinfo record.
+      TP:=PPropInfo(@PPD^.PropList);
+      While Count>0 do
+        begin
+          // Don't overwrite properties with the same name
+          if FProperties[TP^.NameIndex]=nil then begin
+            obj := GRttiPool.GetByHandle(TP);
+            if Assigned(obj) then
+              FProperties[TP^.NameIndex] := obj as TRttiProperty
+            else begin
+              FProperties[TP^.NameIndex] := TRttiProperty.Create(TypeRttiType, TP);
+              GRttiPool.AddObject(FProperties[TP^.NameIndex]);
             end;
-
-            // Point to TP next propinfo record.
-            // Located at Name[Length(Name)+1] !
-            TP:=TP^.Next;
-            Dec(Count);
           end;
-        TypeInfo:=TD^.Parentinfo;
-        TypeRttiType:= GRttiPool.GetType(TypeInfo);
-      until TypeInfo=nil;
-    end;
 
-  result := FProperties;
+          // Point to TP next propinfo record.
+          // Located at Name[Length(Name)+1] !
+          TP:=TP^.Next;
+          Dec(Count);
+        end;
+      TypeInfo:=TD^.Parentinfo;
+      TypeRttiType:= GRttiPool.GetType(TypeInfo);
+    until TypeInfo=nil;
+
+    Result := FProperties
+  finally
+    GRttiPool.Unlock
+  end
 end;
 
 { TRttiMember }
@@ -4263,23 +4296,43 @@
 
 function TRttiContext.GetByHandle(AHandle: Pointer): TRttiObject;
 begin
-  if not Assigned(FContextToken) then
-    FContextToken := TPoolToken.Create;
-  Result := (FContextToken as IPooltoken).RttiPool.GetByHandle(AHandle);
+  Result := (GetContextToken as IPooltoken).RttiPool.GetByHandle(AHandle);
 end;
 
+procedure TRttiContext.Lock;
+begin
+  (GetContextToken as IPooltoken).RttiPool.Lock;
+end;
+
+procedure TRttiContext.Unlock;
+begin
+  (GetContextToken as IPooltoken).RttiPool.Unlock;
+end;
+
+function TRttiContext.GetContextToken: IInterface;
+begin
+  {$ifdef FPC_HAS_FEATURE_THREADING}
+  EnterCriticalSection(GLock);
+  try
+  {$endif}
+    if not Assigned(FContextToken) then
+      FContextToken := TPoolToken.Create;
+    Result := FContextToken;
+  {$ifdef FPC_HAS_FEATURE_THREADING}
+  finally
+    LeaveCriticalSection(GLock);
+  end;
+  {$endif}
+end;
+
 procedure TRttiContext.AddObject(AObject: TRttiObject);
 begin
-  if not Assigned(FContextToken) then
-    FContextToken := TPoolToken.Create;
-  (FContextToken as IPooltoken).RttiPool.AddObject(AObject);
+  (GetContextToken as IPooltoken).RttiPool.AddObject(AObject);
 end;
 
 function TRttiContext.GetType(ATypeInfo: PTypeInfo): TRttiType;
 begin
-  if not assigned(FContextToken) then
-    FContextToken := TPoolToken.Create;
-  result := (FContextToken as IPooltoken).RttiPool.GetType(ATypeInfo);
+  Result := (GetContextToken as IPooltoken).RttiPool.GetType(ATypeInfo);
 end;
 
 
@@ -4456,10 +4509,19 @@
 {$endif}
 
 initialization
+{$ifdef FPC_HAS_FEATURE_THREADING}
+  InitCriticalSection(GLock);
+{$endif}
   PoolRefCount := 0;
   InitDefaultFunctionCallManager;
 {$ifdef SYSTEM_HAS_INVOKE}
   InitSystemFunctionCallManager;
 {$endif}
+
+finalization
+{$ifdef FPC_HAS_FEATURE_THREADING}
+  DoneCriticalsection(GLock);
+{$endif}
+
 end.
 
rtti.pp.patch (13,864 bytes)   

jamie philbrook

2020-07-06 12:36

reporter   ~0123776

Are you kidding me?

  That is a large patch for something that is only going to open a whole can of worms. The majority of the LCL isn't thread safe and that is a known fact.

 All this will do is start a campaign of bloatware and slowness to the LCL, basically rendering it useless.

 The LCL is fat and slow enough already, in fact a campaign should be started to put it on a diet..

 Putting that aside, if you have some sort of personal need for a thread safe object, there are plenty of safe guards available already to add to your code that will fix that, as you notice I said your code, not everyone else's code.


 Sync Calls, CricticalSections etc.

runewalsh

2020-07-06 14:04

reporter   ~0123778

Last edited: 2020-07-06 14:11

View 3 revisions

jamie philbrook
RTTI is a very generic mechanism that can be used by many unrelated parts of your program. Would you prefer to have, say, non-atomic string refcounts?

Furthermore, RTTI pretends to be a thread-safe entity. Look at TRttiContext.Create() call: when you ‘Create()’ something local to your thread, you expect for it to be safe to work from this thread without any synchronization, right? So all those global things and locks are implementation details.

Bloating has nothing to do with thread safety.

Imants Gulbis
At least you can avoid locking (and, after a first call, any extra atomics at all) in GetContextToken using double-checked locking antipattern and atomic exchange:

function TRttiContext.GetContextToken: IInterface;
begin
    result := FContextToken;
    if Assigned(result) then exit; // this will shortcut all calls after first

    result := TPoolToken.Create;
    if InterlockedCompareExchange(pointer(FContextToken), pointer(result), nil) = nil then
        // exchange was succesful; fixup reference count, as FContextToken received second ‘result’ reference and pointer() cast bypassed compiler magic
        result._AddRef
    else
        // other thread slipped in and managed to set FContextToken successfully; so just reread.
        // Or you can use here the value returned from InterlockedCompareExchange(), but then you’ll need another manual _AddRef on it. Reread is slightly suboptimal, but looks much shorter.
        result := FContextToken;
end;

Also, why return IInterface and constantly cast it to IPoolToken (a whole QueryInterface call!) instead of just returning IPoolToken?

jamie philbrook

2020-07-06 14:47

reporter   ~0123780

My response still applies, it does not change my stance on it.

  I've been in this camp to many years, I am an old timer at this and I've seen it come and go and what usually goes is the end product after its been butchered.
 
  But its nice to know you can come here and get the DEV's to push the apply button so your theories can be tested out. Because in the end that is really what is all about.

 Mean while the rest of us turn into gene pigs.

 More the reason my boss is pushing me to stand on track with Delphi, maybe he has insight that I don't..

runewalsh

2020-07-06 15:24

reporter   ~0123782

After what they did in ‘NextGen’ compilers (how on earth the fundamentals of your language should depend on target platform?), you better be careful with such insights :D

Imants Gulbis

2020-07-06 16:29

reporter   ~0123783

runewalsh I do not know why but IPoolToken is declared in implementation section not in implementation section that is why I can use only IInterface in interface section and performe cast in implementation.

I little bit do not understand your code:

    //If more than one process gets here TPoolToken would be created multiple times?
    result := TPoolToken.Create;
    if InterlockedCompareExchange(pointer(FContextToken), pointer(result), nil) = nil then
        //Why do we add ref? Isn't it allredy added because result is IInterface?
        result._AddRef
    else
        //If other thread is now only creating TPoolToken at this moment and object is only partly created isn't ti too dangerous to use it now?
        result := FContextToken;

jamie philbrook partial thread support is already implemented in rtti unit with FPC_HAS_FEATURE_THREADING define. We can fix it or remove it all together but do not left it partially implemented.

runewalsh

2020-07-06 17:58

reporter   ~0123784

Last edited: 2020-07-06 18:05

View 3 revisions

Ah, wait, wait, wait, I misunderstood the original code (I don't use RTTI unit much). But I'll answer first.

>If more than one process gets here TPoolToken would be created multiple times?
Yes, (rarely) several threads can race: they detect FContextToken = nil and start to create TPoolToken’s simultaneously. It is safe, as long as those created objects stay local to them. Each of threads will then try to store the object they created into FContextToken. One of the threads will succeed (InterlockedCompareExchange will return nil as an old value), all other will fail (return value will be non-nil) and TPoolToken they created (as it turned out, unnecessarily) gets destroyed at the line ‘result := FContextToken’, which implicitly _Release()’s old ’result’ value.

>Why do we add ref? Isn't it allredy added because result is IInterface?
InterlockedCompareExchange works with plain pointers. When working with interfaces, compiler implicitly manages references, for example, my line

>result := FContextToken

turns into something like

>if Assigned(FContextToken) then FContextToken._AddRef;
>if Assigned(result) then result._Release;
>pointer(result) := pointer(FContextToken); // raw pointer assignment

With failed InterlockedCompareExchange, we did nothing. With successful InterlockedCompareExchange, we duplicated the raw ‘result’ pointer into ex-nil ‘FContextToken’, bypassing reference counting. So we need to count this reference manually.

>If other thread is now only creating TPoolToken at this moment and object is only partly created isn't ti too dangerous to use it now?
No, other thread creates it in its own local context first, and stores to its own local variable. Then it atomically compare-exchanges it with FContextToken. What we read from FContextToken in ‘else’ branch is the result of successful InterlockedCompareExchange performed by other thread, because our InterlockedCompareExchange failed, and it fails if and only if FContextToken was already non-nil.

Now, the thing I wanted to say from the start is:

TRttiContext, indeed, SHOULD NOT be thread-safe.
You supposed to use it as a local variable. Other threads won’t interfere with your local variables. If you instead, in order to ~optimize~ things, stored TRttiContext in some place and used it from several threads — then you need to synchronize accesses yourself (or just don’t do this strange thing: create local TRttiContext’s when you need them, as usual).

What needs to be fixed is GRttiPool creation. Presently, the code

>if InterlockedIncrement(PoolRefCount)=1 then
> GRttiPool := TRttiPool.Create;

isn’t thread-safe (InterlockedIncrement does not help): several threads can still create several TRttiPools and store them without any checks, leaking the previous one. Instead it should use the same trick, with the single difference of manually Free’ing the unnecesary object in the case of unsuccesful InterlockedCompareExchange, because we work with unmanaged class references:

constructor TPoolToken.Create;
var
    newRttiPool: TRttiPool;
begin
    inherited Create;
    if not Assigned(GRttiPool) then
    begin
        newRttiPool := TRttiPool.Create;
        if InterlockedCompareExchange(pointer(GRttiPool), pointer(newRttiPool), nil) = nil then
            // succeed, newRttiPool was stored to GRttiPool; do nothing more
        else
            // failed, i. e. another thread managed to create TRttiPool and store it to GRttiPool; destroy our redundantly created object.
            newRttiPool.Free;
    end;
end;

destructor TPoolToken.Destroy;
begin
    inherited;
end;

finalization
    GRttiPool.Free;

With this implementation, we CAN’T reliably destroy GRttiPool, so it must be freed only in ‘finalization’ section. Also, PoolRefCount is redundant.

If we instead keep RefCount and GRttiPool destroying logic (actually I dislike this variant, because of constant pool recreations), then we must use global lock instead of those interlocked things. So it will be like:

constructor TPoolToken.Create;
begin
    inherited Create;
    EnterCriticalSection(GRttiPoolLock);
    try
        if PoolRefCount = 0 then GRttiPool := TRttiPool.Create; // in theory, can throw OOM, so defer inc()
        inc(PoolRefCount);
    finally
        LeaveCriticalSection(GRttiPoolLock);
    end;
end;

destructor TPoolToken.Destroy;
begin
    EnterCriticalSection(GRttiPoolLock);
    try
        dec(PoolRefCount);
        if PoolRefCount = 0 then FreeAndNil(GRttiPool);
    finally
        LeaveCriticalSection(GRttiPoolLock);
    end;
    inherited;
end;

runewalsh

2020-07-06 18:59

reporter   ~0123785

Last edited: 2020-07-06 19:12

View 4 revisions

There is also slightly more complex and unobvious hybrid variant that avoids locking of non-first callers and still allows safe GRttiPool destroying:

constructor TPoolToken.Create;
begin
    inherited Create;
    if InterlockedIncrement(PoolRefCount) = 1 then
        try
            EnterCriticalSection(GRttiPoolLock);
            try
                if not Assigned(GRttiPool) then // see below
                    GRttiPool := TRttiPool.Create;
            finally
                LeaveCriticalSection(GRttiPoolLock);
            end;
        except // paranoia actually, can be removed
            dec(PoolRefCount);
            raise;
        end;
end;

destructor TPoolToken.Destroy;
begin
    if InterlockedDecrement(PoolRefCount) = 0 then
    begin
        EnterCriticalSection(GRttiPoolLock);
        try
            if PoolRefCount = 0 then // see below
                FreeAndNil(GRttiPool);
        finally
            LeaveCriticalSection(GRttiPoolLock);
        end;
    end;
    inherited;
end;

“See below”:
Why these checks required? Look at this scenario:

Right after InterlockedDecrement() at Destroy, thread A that is now going to destroy GRttiPool gets preempted.
Then, the thread B calls TPoolToken.Create, performs InterlockedIncrement(), sees that he just incremented refcount from zero to one and thus must create pool, and gets preempted too.
Now we have two threads, A and B, where A is going to destroy GRttiPool and B is going to create.
They will enter the critical section one after one.

If A (destroyer) enters it first, it will recheck refcount and notice that a Create() call slipped in, thus destroyer got late and GRttiPool must stay alive.
But when it happens, neither B (creator) should create GRttiPool, but instead reuse the one that stayed alive.

If B (creator) enters it first... actually everything will be just the same.

Sigh.

Imants Gulbis

2020-07-06 20:42

reporter   ~0123788

We could choose most easiest, fastest, simplest and straight forward implementation :). Create GRttiPool in initialization and free it in finalization and use it in all cases. I myself do not see real benefit of freeing pool. Maybe if it is relay needed it could be done manually by calling some procedure "ClerarRttiPool" when all threads done they're work?

runewalsh

2020-07-06 21:36

reporter   ~0123789

Haha, for some reason didn't even think about it.
There are two (marginal) problems, however:
— If other unit in its initialization section calls something that uses RTTI unit, -AND- this unit is initialized before RTTI unit, it will crash. (Same problem with finalization.) Good citizens shouldn’t do any nontrivial things at initialization sections, though.
— Pool is created even if it won’t be used a single time.
The simplicity overweights them both, I think.

Maybe original author worried that those TRtti*Type instances waste memory. After all, compiler stores RTTI data in more compact form, and they ‘unpack’ it. But even then, it’s not the scale you need to worry about, and I believe that CPU time is more valuable than memory, so it’s unwise to spend it on all those recreations.

>"ClerarRttiPool" when all threads done they're work
No, there might be RTTI-using units you don’t control.

Sven Barth

2020-07-06 23:14

manager   ~0123790

Last edited: 2020-07-06 23:17

View 3 revisions

@jamie: the Rtti unit is not used by the LCL (at least not yet). The LCL uses the low level RTTI functionality provided by the TypInfo unit (which is also used by the Rtti unit). The TypInfo unit does not create any object instances thus it does not need any explicit thread safety, the Rtti unit on the other hand is highly object oriented and creates many objects, thus it does need to be thread safe. Also the Rtti unit (as a more low level unit than the LCL) might be used in other frameworks which do use multiple threads. The requirements for thread safety between the LCL and the RTL/FCL are different.

@runewalsh: No, memory is more important. Imagine a software where you create some data objects based on objects provided by the Rtti unit at startup. You then don't need the Rtti unit anymore for the whole lifetime of the application. It's simply an absolute waste to keep that memory allocated in that case. This is a base unit we're talking about, it needs to behave as much as a good citizen as possible.

Imants Gulbis

2020-07-07 12:28

reporter   ~0123797

I updated patch with two more fixes GetAttributes was not thread safe too and in TPoolToken.Destroy I got situation when new GRttiPool where destroyed instead of old one because different thread managed to create new GRttiPool before old one was destroyed
rtti.pp.2.patch (13,864 bytes)   
Index: packages/rtl-objpas/src/inc/rtti.pp
===================================================================
--- packages/rtl-objpas/src/inc/rtti.pp	(revision 45712)
+++ packages/rtl-objpas/src/inc/rtti.pp	(working copy)
@@ -185,6 +185,9 @@
     FContextToken: IInterface;
     function GetByHandle(AHandle: Pointer): TRttiObject;
     procedure AddObject(AObject: TRttiObject);
+    procedure Lock;
+    procedure Unlock;
+    function GetContextToken: IInterface;
   public
     class function Create: TRttiContext; static;
     procedure  Free;
@@ -654,6 +657,8 @@
     function GetType(ATypeInfo: PTypeInfo): TRttiType;
     function GetByHandle(aHandle: Pointer): TRttiObject;
     procedure AddObject(aObject: TRttiObject);
+    procedure Lock; inline;
+    procedure Unlock; inline;
     constructor Create;
     destructor Destroy; override;
   end;
@@ -802,6 +807,7 @@
 var
   PoolRefCount : integer;
   GRttiPool    : TRttiPool;
+  GLock        : TRTLCriticalSection;
   FuncCallMgr: TFunctionCallManagerArray;
 
 function AllocateMemory(aSize: PtrUInt): Pointer;
@@ -1320,6 +1326,20 @@
 {$endif}
 end;
 
+procedure TRttiPool.Lock;
+begin
+  {$ifdef FPC_HAS_FEATURE_THREADING}
+  EnterCriticalsection(FLock);
+  {$endif}
+end;
+
+procedure TRttiPool.Unlock;
+begin
+  {$ifdef FPC_HAS_FEATURE_THREADING}
+  LeaveCriticalsection(FLock);
+  {$endif}
+end;
+
 procedure TRttiPool.AddObject(aObject: TRttiObject);
 var
   idx: LongInt;
@@ -2842,19 +2862,20 @@
   context: TRttiContext;
   obj: TRttiObject;
 begin
-  if aWithHidden and (Length(FParamsAll) > 0) then
-    Exit(FParamsAll);
-  if not aWithHidden and (Length(FParams) > 0) then
-    Exit(FParams);
+  Context := TRttiContext.Create;
+  Context.Lock;
+  try
+    if aWithHidden and (Length(FParamsAll) > 0) then
+      Exit(FParamsAll);
+    if not aWithHidden and (Length(FParams) > 0) then
+      Exit(FParams);
 
-  if FIntfMethodEntry^.ParamCount = 0 then
-    Exit(Nil);
+    if FIntfMethodEntry^.ParamCount = 0 then
+      Exit(Nil);
 
-  SetLength(FParams, FIntfMethodEntry^.ParamCount);
-  SetLength(FParamsAll, FIntfMethodEntry^.ParamCount);
+    SetLength(FParams, FIntfMethodEntry^.ParamCount);
+    SetLength(FParamsAll, FIntfMethodEntry^.ParamCount);
 
-  context := TRttiContext.Create;
-  try
     total := 0;
     visible := 0;
     param := FIntfMethodEntry^.Param[0];
@@ -2876,16 +2897,17 @@
       Inc(total);
     end;
 
-    if visible <> total then
-      SetLength(FParams, visible);
+      if visible <> total then
+        SetLength(FParams, visible);
+
+    if aWithHidden then
+      Result := FParamsAll
+    else
+      Result := FParams
   finally
-    context.Free;
-  end;
-
-  if aWithHidden then
-    Result := FParamsAll
-  else
-    Result := FParams;
+    Context.Unlock;
+    Context.Free
+  end
 end;
 
 { TRttiInt64Type }
@@ -3408,55 +3430,56 @@
   context: TRttiContext;
   obj: TRttiObject;
 begin
-  if aWithHidden and (Length(FParamsAll) > 0) then
-    Exit(FParamsAll);
-  if not aWithHidden and (Length(FParams) > 0) then
-    Exit(FParams);
+  Context := TRttiContext.Create;
+  Context.Lock;
+  try
+    if aWithHidden and (Length(FParamsAll) > 0) then
+      Exit(FParamsAll);
+    if not aWithHidden and (Length(FParams) > 0) then
+      Exit(FParams);
 
-  ptr := @FTypeData^.ParamList[0];
+    ptr := @FTypeData^.ParamList[0];
 
-  visible := 0;
-  total := 0;
+    visible := 0;
+    total := 0;
 
-  if FTypeData^.ParamCount > 0 then begin
-    SetLength(infos, FTypeData^.ParamCount);
+    if FTypeData^.ParamCount > 0 then begin
+      SetLength(infos, FTypeData^.ParamCount);
 
-    while total < FTypeData^.ParamCount do begin
-      { align }
-      ptr := AlignTParamFlags(ptr);
-      infos[total].Handle := ptr;
-      infos[total].Flags := PParamFlags(ptr)^;
-      Inc(ptr, SizeOf(TParamFlags));
-      { handle name }
-      infos[total].Name := PShortString(ptr)^;
-      Inc(ptr, ptr^ + SizeOf(Byte));
-      { skip type name }
-      Inc(ptr, ptr^ + SizeOf(Byte));
+      while total < FTypeData^.ParamCount do begin
+        { align }
+        ptr := AlignTParamFlags(ptr);
+        infos[total].Handle := ptr;
+        infos[total].Flags := PParamFlags(ptr)^;
+        Inc(ptr, SizeOf(TParamFlags));
+        { handle name }
+        infos[total].Name := PShortString(ptr)^;
+        Inc(ptr, ptr^ + SizeOf(Byte));
+        { skip type name }
+        Inc(ptr, ptr^ + SizeOf(Byte));
 
-      if not (pfHidden in infos[total].Flags) then
-        Inc(visible);
-      Inc(total);
+        if not (pfHidden in infos[total].Flags) then
+          Inc(visible);
+        Inc(total);
+      end;
     end;
-  end;
 
-  if FTypeData^.MethodKind in [mkFunction, mkClassFunction] then begin
-    { skip return type name }
-    ptr := AlignToPtr(PByte(ptr) + ptr^ + SizeOf(Byte));
-    { handle return type }
-    FReturnType := GRttiPool.GetType(PPPTypeInfo(ptr)^^);
-    Inc(ptr, SizeOf(PPTypeInfo));
-  end;
+    if FTypeData^.MethodKind in [mkFunction, mkClassFunction] then begin
+      { skip return type name }
+      ptr := AlignToPtr(PByte(ptr) + ptr^ + SizeOf(Byte));
+      { handle return type }
+      FReturnType := GRttiPool.GetType(PPPTypeInfo(ptr)^^);
+      Inc(ptr, SizeOf(PPTypeInfo));
+    end;
 
-  { handle calling convention }
-  FCallConv := PCallConv(ptr)^;
-  Inc(ptr, SizeOf(TCallConv));
+    { handle calling convention }
+    FCallConv := PCallConv(ptr)^;
+    Inc(ptr, SizeOf(TCallConv));
 
-  SetLength(FParamsAll, FTypeData^.ParamCount);
-  SetLength(FParams, visible);
+    SetLength(FParamsAll, FTypeData^.ParamCount);
+    SetLength(FParams, visible);
 
-  if FTypeData^.ParamCount > 0 then begin
-    context := TRttiContext.Create;
-    try
+    if FTypeData^.ParamCount > 0 then begin
       paramtypes := PPPTypeInfo(AlignTypeData(ptr));
       visible := 0;
       for i := 0 to FTypeData^.ParamCount - 1 do begin
@@ -3477,15 +3500,16 @@
           Inc(visible);
         end;
       end;
-    finally
-      context.Free;
     end;
-  end;
 
-  if aWithHidden then
-    Result := FParamsAll
-  else
-    Result := FParams;
+    if aWithHidden then
+      Result := FParamsAll
+    else
+      Result := FParams
+  finally
+    Context.Unlock;
+    Context.Free
+  end
 end;
 
 function TRttiMethodType.GetCallingConvention: TCallConv;
@@ -3537,19 +3561,20 @@
   obj: TRttiObject;
   context: TRttiContext;
 begin
-  if aWithHidden and (Length(FParamsAll) > 0) then
-    Exit(FParamsAll);
-  if not aWithHidden and (Length(FParams) > 0) then
-    Exit(FParams);
+  Context := TRttiContext.Create;
+  Context.Lock;
+  try
+    if aWithHidden and (Length(FParamsAll) > 0) then
+      Exit(FParamsAll);
+    if not aWithHidden and (Length(FParams) > 0) then
+      Exit(FParams);
 
-  if FTypeData^.ProcSig.ParamCount = 0 then
-    Exit(Nil);
+    if FTypeData^.ProcSig.ParamCount = 0 then
+      Exit(Nil);
 
-  SetLength(FParamsAll, FTypeData^.ProcSig.ParamCount);
-  SetLength(FParams, FTypeData^.ProcSig.ParamCount);
+    SetLength(FParamsAll, FTypeData^.ProcSig.ParamCount);
+    SetLength(FParams, FTypeData^.ProcSig.ParamCount);
 
-  context := TRttiContext.Create;
-  try
     param := AlignToPtr(PProcedureParam(@FTypeData^.ProcSig.ParamCount + SizeOf(FTypeData^.ProcSig.ParamCount)));
     visible := 0;
     for i := 0 to FTypeData^.ProcSig.ParamCount - 1 do begin
@@ -3570,14 +3595,15 @@
     end;
 
     SetLength(FParams, visible);
+
+    if aWithHidden then
+      Result := FParamsAll
+    else
+      Result := FParams
   finally
-    context.Free;
-  end;
-
-  if aWithHidden then
-    Result := FParamsAll
-  else
-    Result := FParams;
+    Context.Unlock;
+    Context.Free
+  end
 end;
 
 function TRttiProcedureType.GetCallingConvention: TCallConv;
@@ -3664,26 +3690,27 @@
   parent: TRttiInterfaceType;
   parentmethodcount: Word;
 begin
-  if Assigned(fDeclaredMethods) then
-    Exit(fDeclaredMethods);
+  Context := TRttiContext.Create;
+  Context.Lock;
+  try
+    if Assigned(fDeclaredMethods) then
+      Exit(fDeclaredMethods);
 
-  methtable := MethodTable;
-  if not Assigned(methtable) then
-    Exit(Nil);
+    methtable := MethodTable;
+    if not Assigned(methtable) then
+      Exit(Nil);
 
-  if (methtable^.Count = 0) or (methtable^.RTTICount = $ffff) then
-    Exit(Nil);
+    if (methtable^.Count = 0) or (methtable^.RTTICount = $ffff) then
+      Exit(Nil);
 
-  parent := GetIntfBaseType;
-  if Assigned(parent) then
-    parentmethodcount := parent.IntfMethodCount
-  else
-    parentmethodcount := 0;
+    parent := GetIntfBaseType;
+    if Assigned(parent) then
+      parentmethodcount := parent.IntfMethodCount
+    else
+      parentmethodcount := 0;
 
-  SetLength(fDeclaredMethods, methtable^.Count);
+    SetLength(fDeclaredMethods, methtable^.Count);
 
-  context := TRttiContext.Create;
-  try
     method := methtable^.Method[0];
     count := methtable^.Count;
     while count > 0 do begin
@@ -3699,11 +3726,12 @@
       method := method^.Next;
       Dec(count);
     end;
+
+    Result := fDeclaredMethods
   finally
-    context.Free;
-  end;
-
-  Result := fDeclaredMethods;
+    Context.Unlock;
+    Context.Free
+  end
 end;
 
 { TRttiInstanceType }
@@ -3750,46 +3778,51 @@
   Count: longint;
   obj: TRttiObject;
 begin
-  if not FPropertiesResolved then
-    begin
-      TypeInfo := FTypeInfo;
+  GRttiPool.Lock;
+  try
+    if FPropertiesResolved then
+      Exit(FProperties);
 
-      // Get the total properties count
-      SetLength(FProperties,FTypeData^.PropCount);
-      TypeRttiType:= self;
-      repeat
-        TD:=GetTypeData(TypeInfo);
+    TypeInfo := FTypeInfo;
 
-        // published properties count for this object
-        // skip the attribute-info if available
-        PPD := PClassData(TD)^.PropertyTable;
-        Count:=PPD^.PropCount;
-        // Now point TP to first propinfo record.
-        TP:=PPropInfo(@PPD^.PropList);
-        While Count>0 do
-          begin
-            // Don't overwrite properties with the same name
-            if FProperties[TP^.NameIndex]=nil then begin
-              obj := GRttiPool.GetByHandle(TP);
-              if Assigned(obj) then
-                FProperties[TP^.NameIndex] := obj as TRttiProperty
-              else begin
-                FProperties[TP^.NameIndex] := TRttiProperty.Create(TypeRttiType, TP);
-                GRttiPool.AddObject(FProperties[TP^.NameIndex]);
-              end;
+    // Get the total properties count
+    SetLength(FProperties,FTypeData^.PropCount);
+    TypeRttiType:= self;
+    repeat
+      TD:=GetTypeData(TypeInfo);
+
+      // published properties count for this object
+      // skip the attribute-info if available
+      PPD := PClassData(TD)^.PropertyTable;
+      Count:=PPD^.PropCount;
+      // Now point TP to first propinfo record.
+      TP:=PPropInfo(@PPD^.PropList);
+      While Count>0 do
+        begin
+          // Don't overwrite properties with the same name
+          if FProperties[TP^.NameIndex]=nil then begin
+            obj := GRttiPool.GetByHandle(TP);
+            if Assigned(obj) then
+              FProperties[TP^.NameIndex] := obj as TRttiProperty
+            else begin
+              FProperties[TP^.NameIndex] := TRttiProperty.Create(TypeRttiType, TP);
+              GRttiPool.AddObject(FProperties[TP^.NameIndex]);
             end;
-
-            // Point to TP next propinfo record.
-            // Located at Name[Length(Name)+1] !
-            TP:=TP^.Next;
-            Dec(Count);
           end;
-        TypeInfo:=TD^.Parentinfo;
-        TypeRttiType:= GRttiPool.GetType(TypeInfo);
-      until TypeInfo=nil;
-    end;
 
-  result := FProperties;
+          // Point to TP next propinfo record.
+          // Located at Name[Length(Name)+1] !
+          TP:=TP^.Next;
+          Dec(Count);
+        end;
+      TypeInfo:=TD^.Parentinfo;
+      TypeRttiType:= GRttiPool.GetType(TypeInfo);
+    until TypeInfo=nil;
+
+    Result := FProperties
+  finally
+    GRttiPool.Unlock
+  end
 end;
 
 { TRttiMember }
@@ -4263,23 +4296,43 @@
 
 function TRttiContext.GetByHandle(AHandle: Pointer): TRttiObject;
 begin
-  if not Assigned(FContextToken) then
-    FContextToken := TPoolToken.Create;
-  Result := (FContextToken as IPooltoken).RttiPool.GetByHandle(AHandle);
+  Result := (GetContextToken as IPooltoken).RttiPool.GetByHandle(AHandle);
 end;
 
+procedure TRttiContext.Lock;
+begin
+  (GetContextToken as IPooltoken).RttiPool.Lock;
+end;
+
+procedure TRttiContext.Unlock;
+begin
+  (GetContextToken as IPooltoken).RttiPool.Unlock;
+end;
+
+function TRttiContext.GetContextToken: IInterface;
+begin
+  {$ifdef FPC_HAS_FEATURE_THREADING}
+  EnterCriticalSection(GLock);
+  try
+  {$endif}
+    if not Assigned(FContextToken) then
+      FContextToken := TPoolToken.Create;
+    Result := FContextToken;
+  {$ifdef FPC_HAS_FEATURE_THREADING}
+  finally
+    LeaveCriticalSection(GLock);
+  end;
+  {$endif}
+end;
+
 procedure TRttiContext.AddObject(AObject: TRttiObject);
 begin
-  if not Assigned(FContextToken) then
-    FContextToken := TPoolToken.Create;
-  (FContextToken as IPooltoken).RttiPool.AddObject(AObject);
+  (GetContextToken as IPooltoken).RttiPool.AddObject(AObject);
 end;
 
 function TRttiContext.GetType(ATypeInfo: PTypeInfo): TRttiType;
 begin
-  if not assigned(FContextToken) then
-    FContextToken := TPoolToken.Create;
-  result := (FContextToken as IPooltoken).RttiPool.GetType(ATypeInfo);
+  Result := (GetContextToken as IPooltoken).RttiPool.GetType(ATypeInfo);
 end;
 
 
@@ -4456,10 +4509,19 @@
 {$endif}
 
 initialization
+{$ifdef FPC_HAS_FEATURE_THREADING}
+  InitCriticalSection(GLock);
+{$endif}
   PoolRefCount := 0;
   InitDefaultFunctionCallManager;
 {$ifdef SYSTEM_HAS_INVOKE}
   InitSystemFunctionCallManager;
 {$endif}
+
+finalization
+{$ifdef FPC_HAS_FEATURE_THREADING}
+  DoneCriticalsection(GLock);
+{$endif}
+
 end.
 
rtti.pp.2.patch (13,864 bytes)   

Issue History

Date Modified Username Field Change
2020-07-06 09:12 Imants Gulbis New Issue
2020-07-06 09:12 Imants Gulbis File Added: rtti.pp.patch
2020-07-06 12:36 jamie philbrook Note Added: 0123776
2020-07-06 14:04 runewalsh Note Added: 0123778
2020-07-06 14:10 runewalsh Note Edited: 0123778 View Revisions
2020-07-06 14:11 runewalsh Note Edited: 0123778 View Revisions
2020-07-06 14:47 jamie philbrook Note Added: 0123780
2020-07-06 15:24 runewalsh Note Added: 0123782
2020-07-06 16:29 Imants Gulbis Note Added: 0123783
2020-07-06 17:58 runewalsh Note Added: 0123784
2020-07-06 18:05 runewalsh Note Edited: 0123784 View Revisions
2020-07-06 18:05 runewalsh Note Edited: 0123784 View Revisions
2020-07-06 18:59 runewalsh Note Added: 0123785
2020-07-06 19:00 runewalsh Note Edited: 0123785 View Revisions
2020-07-06 19:11 runewalsh Note Edited: 0123785 View Revisions
2020-07-06 19:12 runewalsh Note Edited: 0123785 View Revisions
2020-07-06 20:42 Imants Gulbis Note Added: 0123788
2020-07-06 21:36 runewalsh Note Added: 0123789
2020-07-06 23:14 Sven Barth Note Added: 0123790
2020-07-06 23:14 Sven Barth Note Edited: 0123790 View Revisions
2020-07-06 23:17 Sven Barth Note Edited: 0123790 View Revisions
2020-07-07 12:28 Imants Gulbis Note Added: 0123797
2020-07-07 12:28 Imants Gulbis File Added: rtti.pp.2.patch