View Issue Details

IDProjectCategoryView StatusLast Update
0037360LazarusWidgetsetpublic2020-08-09 19:11
ReporterBrunoK Assigned ToMartin Friebe  
PrioritynormalSeverityminorReproducibilityhave not tried
Status assignedResolutionopen 
PlatformWin10 + Manjaro OSWin10 / Linux 
Summary0037360: Proposed improvements for TLCLComponent.NewInstance
DescriptionIn the present situation, WSRegisterClass is always called as the first action. This leads to much up class inheritance calls that tends slow creation of forms with many controls (Frames etc...). In WSLCLClasses 2 TStringList's are used and they are sorted by ClassName.
The proposed code does first seek and exploit the existence of registered widgets (or their parent) before calling WSRegisterClass if needed.
WSLCLClasses holds a single TFPList and classes are sorted in this list by the ClassType's pointers of the TLCLComponent descendants..
Additional InformationAttachments :
- Patch for LCLClasses and WSLCLClasses on trunk (LCLComponent.patch).
- ZIP of these 2 units that allows a better visualisation of the changes. (lcl.zip)
- Optional patches for control.inc, wincontrol.inc and buttons.inc that cut inheritance recursion quickly. (Registered.patch)
TagsNo tags attached.
Fixed in Revisionr63619
LazTarget-
Widgetset
Attached Files

Relationships

related to 0037407 resolvedJuha Manninen Patch of r63619 breaks Lazarus startup 
related to 0037435 resolvedMartin Friebe Can't choose default editor font in IDE 

Activities

BrunoK

2020-07-15 13:54

reporter  

LCLComponent.patch (35,029 bytes)   
Index: lcl/lclclasses.pp
===================================================================
--- lcl/lclclasses.pp	(revision 63021)
+++ lcl/lclclasses.pp	(working copy)
@@ -1,8 +1,8 @@
 { $Id$}
 {
  *****************************************************************************
- *                               lclclasses.pp                               * 
- *                               -------------                               * 
+ *                               lclclasses.pp                               *
+ *                               -------------                               *
  *                                                                           *
  *                                                                           *
  *****************************************************************************
@@ -56,7 +56,7 @@
     property LCLRefCount: integer read FLCLRefCount;
     property WidgetSetClass: TWSLCLComponentClass read FWidgetSetClass;
   end;
-  
+
   { TLCLReferenceComponent }
 
   // A base class for all components having a handle
@@ -89,23 +89,90 @@
 uses
   InterfaceBase;
 
+const
+  cWSRegisterOffset : integer = 0; // Offset of WSRegisterClass in class
+                                   // virtual methods
+  cLCLComponentWSReg : CodePointer = nil; // Adress of TLCLComponent.WSRegisterClass
+
+type
+  TLCLComponentClass = class of TLCLComponent;
+
+function WSRegisterLCLComponent: boolean;
+begin
+  RegisterWSComponent(TLCLComponent, TWSLCLComponent, nil, True);
+  Result := True;
+end;
+
 class procedure TLCLComponent.WSRegisterClass;
+const
+  Registered : boolean = False;
 begin
-  //
+  if Registered then
+    Exit;
+  if not Assigned(FindWSRegistered(TLCLComponent)) then
+    WSRegisterLCLComponent;
+  Registered := True;
 end;
 
 // This method allows descendents to override the FWidgetSetClass
-class function TLCLComponent.GetWSComponentClass(ASelf: TLCLComponent): TWSLCLComponentClass;
+{ This method handles registration of the comonent in WSLVLClasses list of
+  components.
+  It is only called if there wasn't a direct or parent hit at the beginining of
+  NewInstance. }
+class function TLCLComponent.GetWSComponentClass(ASelf: TLCLComponent
+            ): TWSLCLComponentClass;
+  procedure UpdateOffset;
+  var
+    lWSRegisterProc : CodePointer;
+    lPPtrArray : PPointerArray;
+    I : integer;
+  begin
+    cLCLComponentWSReg := @TLCLComponent.WSRegisterClass;
+    lPPtrArray := Pointer(TLCLComponent);
+    I := 0;
+    while lPPtrArray^[i]<>cLCLComponentWSReg do
+      inc(i);
+    cWSRegisterOffset := I * SizeOf(Pointer);
+  end;
+var
+  lPSelfWSReg,
+  lPSelfParentWSReg : CodePointer;
+  lClassParent : TLCLComponentClass;
 begin
-  Result := FindWSComponentClass(Self);
+  if cWSRegisterOffset = 0 then begin
+    UpdateOffset;
+    { Always create the top node ! }
+    RegisterWSComponent(TLCLComponent, TWSLCLComponent);
+  end;
 
-  if Result = nil then
-  begin
-    {$IFDEF VerboseLCL}
-    DebugLn(['TLCLComponent.NewInstance WARNING: missing FWidgetSetClass ',ClassName]);
-    {$ENDIF}
-    Result := TWSLCLComponent;
-  end;
+  lClassParent := TLCLComponentClass(ClassParent);
+  lPSelfWSReg := PCodePointer(Pointer(Self) + cWSRegisterOffset)^;
+  lPSelfParentWSReg := PCodePointer(Pointer(lClassParent) + cWSRegisterOffset)^;
+
+  WSRegisterClass;
+  Result := FindWSRegistered(Self);
+
+  if Result <> nil then
+    Exit;
+
+  { The Self.ComponentClass didn't register itself but the parent should now
+    be registered }
+  repeat
+    if lPSelfWSReg = lPSelfParentWSReg then begin
+      Result := FindWSRegistered(TComponentClass(lClassParent));
+      if Assigned(Result) then
+        Break
+      else
+        { Force creation of intermediate nodes for parent }
+        RegisterWSComponent(TComponentClass(lClassParent), nil, nil, True);
+    end
+    else begin
+      { Force creation of intermediate nodes for Self and a leaf node for Self }
+      RegisterWSComponent(Self, nil, nil, True);
+      Result := FindWSRegistered(Self);
+      Break;
+    end;
+  until False;
 end;
 
 constructor TLCLComponent.Create(TheOwner: TComponent);
@@ -135,11 +202,36 @@
 end;
 
 class function TLCLComponent.NewInstance: TObject;
+var
+  lWidgetSetClass: TWSLCLComponentClass;
+  lClassParent : TLCLComponentClass;
 begin
   Result := inherited NewInstance;
-  WSRegisterClass;
 
+  { Look if already registered. If true set FWidgetSetClass and exit }
+  lWidgetSetClass := FindWSRegistered(Self);
+  if Assigned(lWidgetSetClass) then begin
+    TLCLComponent(Result).FWidgetSetClass := lWidgetSetClass;
+    // inc(cWSLCLDirectHit);
+    Exit;
+  end;
+
+  { Look if directly inherits WSRegisterClass from its parent }
+  lClassParent := TLCLComponentClass(ClassParent);
+  if (PCodePointer(Pointer(Self)  + cWSRegisterOffset)^
+     = PCodePointer(Pointer(lClassParent) + cWSRegisterOffset)^)
+  then begin
+    lWidgetSetClass := FindWSRegistered(lClassParent);
+    if Assigned(lWidgetSetClass) then begin
+      TLCLComponent(Result).FWidgetSetClass := lWidgetSetClass;
+      // inc(cWSLCLParentHit);
+      Exit;
+    end;
+  end;
+
+  { WSRegisterClass and manage WSLVLClasses list }
   TLCLComponent(Result).FWidgetSetClass := GetWSComponentClass(TLCLComponent(Result));
+  // inc(cWSLCLRegister);
 end;
 
 procedure TLCLComponent.RemoveAllHandlersOfObject(AnObject: TObject);
Index: lcl/widgetset/wslclclasses.pp
===================================================================
--- lcl/widgetset/wslclclasses.pp	(revision 63021)
+++ lcl/widgetset/wslclclasses.pp	(working copy)
@@ -22,6 +22,7 @@
 {off$DEFINE VerboseWSRegistration}
 {off$DEFINE VerboseWSRegistration_methods}
 {off$DEFINE VerboseWSRegistration_treedump}
+{off$DEFINE VerboseWSBrunoK}
 {$IFDEF VerboseWSRegistration_methods}
 {$DEFINE VerboseWSRegistration}
 {$ENDIF}
@@ -93,6 +94,19 @@
 function GetWSLazDeviceAPIs: TWSObjectClass;
 procedure RegisterWSLazDeviceAPIs(const AWSObject: TWSObjectClass);
 
+// ~bk Search for already registered classes
+function FindWSRegistered(const AComponent: TComponentClass): TWSLCLComponentClass;
+
+{ Debug : Dump the WSClassesList nodes }
+{$IFDEF VerboseWSBrunoK}
+const
+  cWSLCLDirectHit : integer = 0;
+  cWSLCLParentHit : integer = 0;
+  cWSLCLRegister : integer = 0;
+
+procedure DumpWSClassesList;
+{$ENDIF}
+
 implementation
 
 uses
@@ -106,11 +120,12 @@
 type
   PClassNode = ^TClassNode;
   TClassNode = record
-    LCLClass: TComponentClass;
-    WSClass: TWSLCLComponentClass;
-    VClass: Pointer;
-    VClassName: ShortString;
-    VClassNew: Boolean; // Indicates that VClass=WSClass, VClass is not created during runtime
+    LCLClass: TComponentClass;     { Class of the created instances }
+    WSClass: TWSLCLComponentClass; { WidgetSet specific implementation class }
+    VClass: Pointer;               { Adjusted vmt table to handle WS virtual methods }
+    VClassName: ShortString;       { Class name attibuted when node was create }
+    VClassNew: Boolean;            { True Indicates that VClass=Parent.VClass.
+                                     When True VClass is not runtime created }
     Parent: PClassNode;
     Child: PClassNode;
     Sibling: PClassNode;
@@ -120,32 +135,58 @@
   // vmtAutoTable is something Delphi 2 and not used, we 'borrow' the vmt entry
   vmtWSPrivate = vmtAutoTable;
 
+
+type
+
+  { TWSClassesList }
+
+  // Holds list of already registered TWidgetSetClass'es so TLCLComponent.NewInstance
+  // can find faster the WidgetSetClass of the newinstance.
+
+  TWSClassesList = class(TFPList)
+  private
+    FLastFoundIdx: integer;
+    FLastFoundLCLClass: TComponentClass;
+    function FindWSClass(const AComponent: TComponentClass): TWSLCLComponentClass;
+    function Get(Index: integer): PClassNode; { inline; }
+    function Search(const aItem: TClass; Out Index: integer): boolean;
+    property Items[Index: integer]: PClassNode read Get; { write Put; default; }
+    {$IFDEF VerboseWSBrunoK} {$ENDIF}
+    {$IFDEF VerboseWSBrunoK}
+    procedure DumpNode(aN : integer; aPClassNode : PClassNode);
+    procedure DumpNodes;
+    {$ENDIF}
+  end;
+
 var
-  MComponentIndex: TStringList;
-  MWSRegisterIndex: TStringList;
+  WSClassesList: TWSClassesList = nil;
   WSLazAccessibleObjectClass: TWSObjectClass;
   WSLazDeviceAPIsClass: TWSObjectClass;
 
+function FindNodeParent(AComponent: TClass): PClassNode;
+var
+  idx: integer;
+begin
+  while AComponent <> nil do begin
+    if WSClassesList.Search(AComponent, idx) then begin
+      Result := PClassNode(WSClassesList[idx]);
+      Exit;
+    end;
+    AComponent := AComponent.ClassParent;
+  end;
+  Result := nil;
+end;
+
 function FindClassNode(const AComponent: TComponentClass): PClassNode;
 var
-  idx: Integer;
-  cls: TClass;
+  idx: integer;
 begin
-  if MWSRegisterIndex = nil then
-    DoInitialization;
-
   Result := nil;
-  cls := AComponent;
-  while cls <> nil do
-  begin
-    idx := MWSRegisterIndex.IndexOf(cls.ClassName);
-    if idx <> -1 then
-    begin
-      Result := PClassNode(MWSRegisterIndex.Objects[idx]);
-      Break;
-    end;
-    cls := cls.ClassParent;
+  if WSClassesList.Search(AComponent, idx) then begin
+    Result := WSClassesList[idx];
+    Exit;
   end;
+  Result := FindNodeParent(AComponent.ClassParent);
 end;
 
 function FindWSComponentClass(
@@ -187,57 +228,27 @@
   TPointerArray = packed array[0..9999999] of Pointer;
   PPointerArray = ^TPointerArray;
 
-// ANewRegistration - If true, VClass is not created during runtime,
-// but instead normal, Object Pascal class creation is used
-procedure RegisterWSComponent(const AComponent: TComponentClass;
-  const AWSComponent: TWSLCLComponentClass;
-  const AWSPrivate: TWSPrivateClass = nil;
-  const ANewRegistration: Boolean = False);
+function  GetClassNameP(aClassName:string) : Pointer;
+var
+  lLen: integer;
+  lShortStr : shortstring;
+begin
+  lShortStr := aClassName + #0;
+  lLen := Length(lShortStr);
+  SetLength(lShortStr,lLen-1);
+  Result := GetMem(lLen+1);
+  move(lShortStr, Result^, lLen + 2);
+end;
 
-  function GetNode(const AClass: TClass): PClassNode;
-  var
-    idx: Integer;
-    Name: String;
-  begin
-    if (AClass = nil)
-    or not (AClass.InheritsFrom(TLCLComponent))
-    then begin
-      Result := nil;
-      Exit;
-    end;
 
-    Name := AClass.ClassName;
-    idx := MComponentIndex.IndexOf(Name);
-    if idx = -1
-    then begin
-      New(Result);
-      Result^.LCLClass := TComponentClass(AClass);
-      Result^.WSClass := nil;
-      Result^.VClass := nil;
-      Result^.VClassName := '';
-      Result^.VClassNew := False;
-      Result^.Child := nil;
-      Result^.Parent := GetNode(AClass.ClassParent);
-      if Result^.Parent = nil
-      then begin
-        Result^.Sibling := nil;
-      end
-      else begin
-        Result^.Sibling := Result^.Parent^.Child;
-        Result^.Parent^.Child := Result;
-      end;
-      MComponentIndex.AddObject(Name, TObject(Result));
-    end
-    else begin
-      Result := PClassNode(MComponentIndex.Objects[idx]);
-    end;
-  end;
+procedure CreateVClass(const ANode: PClassNode;
+  const AWSPrivate: TWSPrivateClass = nil;
+  AOldPrivate: TClass = nil);
 
   function FindParentWSClassNode(const ANode: PClassNode): PClassNode;
   begin
     Result := ANode^.Parent;
-    while Result <> nil do
-    begin
+    while Result <> nil do begin
       if Result^.WSClass <> nil then Exit;
       Result := Result^.Parent;
     end;
@@ -247,177 +258,246 @@
   function FindCommonAncestor(const AClass1, AClass2: TClass): TClass;
   begin
     Result := AClass1;
-    if AClass2.InheritsFrom(Result)
-    then Exit;
-
+    if AClass2.InheritsFrom(Result) then Exit;
     Result := AClass2;
-    while Result <> nil do
-    begin
-      if AClass1.InheritsFrom(Result)
-      then Exit;
+    while Result <> nil do begin
+      if AClass1.InheritsFrom(Result) then Exit;
       Result := Result.ClassParent;
     end;
-
     Result := nil;
   end;
 
-  procedure CreateVClass(const ANode: PClassNode; AOldPrivate: TClass = nil);
-  var
-    ParentWSNode: PClassNode;
-    CommonClass: TClass;
-    Vvmt, Cvmt, Pvmt: PPointerArray;
-    Cmnt: PMethodNameTable;
-    SearchAddr: Pointer;
-    n, idx: Integer;
-    WSPrivate, OrgPrivate: TClass;
-    Processed: array of Boolean;
-    VvmtCount,
-    VvmtSize : Integer;
-    {$IFDEF VerboseWSRegistration}
-    Indent: String;
-    {$ENDIF}
-  begin
-    if AWSPrivate = nil
-    then WSPrivate := TWSPrivate
-    else WSPrivate := AWSPrivate;
+var
+  ParentWSNode: PClassNode;
+  CommonClass: TClass;
+  Vvmt, Cvmt, Pvmt: PPointerArray;
+  Cmnt: PMethodNameTable;
+  SearchAddr: Pointer;
+  n, idx: integer;
+  WSPrivate, OrgPrivate: TClass;
+  Processed: array of boolean;
+  VvmtCount, VvmtSize: integer;
+  {$IFDEF VerboseWSRegistration}
+  Indent: string;
+  {$ENDIF}
+begin
+  if AWSPrivate = nil then WSPrivate := TWSPrivate
+  else WSPrivate := AWSPrivate;
 
-    // Determine VMT count and size => http://wiki.freepascal.org/Compiler-generated_data_and_data_structures
-    VvmtCount := 0;
-    Vvmt := Pointer(ANode^.WSClass) + vmtMethodStart; // AWSComponent is equal to ANode^.WSClass;
-    while (Vvmt^[VvmtCount] <> nil) do
-      Inc(VvmtCount);
-    VvmtSize := vmtMethodStart + VvmtCount * SizeOf(Pointer);
+  // Determine VMT count and size => http://wiki.freepascal.org/Compiler-generated_data_and_data_structures
+  VvmtCount := 0;
+  Vvmt := Pointer(ANode^.WSClass) + vmtMethodStart;
+  // AWSComponent is equal to ANode^.WSClass;
+  while (Vvmt^[VvmtCount] <> nil) do
+    Inc(VvmtCount);                                         { ~bk 1 more for nil at end }
+  VvmtSize := vmtMethodStart + VvmtCount * SizeOf(Pointer) + SizeOf(Pointer);
+  if ANode^.VClass = nil then begin
+    ANode^.VClass := GetMem(VvmtSize);
+  end
+  else begin
+    // keep original WSPrivate (only when different than default class)
+    OrgPrivate := PClass(ANode^.VClass + vmtWSPrivate)^;
 
-    if ANode^.VClass = nil
-    then begin
-      ANode^.VClass := GetMem(VvmtSize)
-    end
-    else begin
-      // keep original WSPrivate (only when different than default class)
-      OrgPrivate := PClass(ANode^.VClass + vmtWSPrivate)^;
-      
-      if (OrgPrivate <> nil) and (OrgPrivate <> AOldPrivate) and OrgPrivate.InheritsFrom(WSPrivate)
-      then begin
-        {$IFDEF VerboseWSRegistration}
-        DebugLn('Keep org private: ', WSPrivate.ClassName, ' -> ', OrgPrivate.Classname);
-        {$ENDIF}
-        WSPrivate := OrgPrivate;
-      end;
-    end;
-
-    // Initially copy the WSClass
-    Move(Pointer(ANode^.WSClass)^, ANode^.VClass^, VvmtSize);
-
-    // Set WSPrivate class
-    ParentWSNode := FindParentWSClassNode(ANode);
-    if ParentWSNode = nil
-    then begin
-      // nothing to do
-      PClass(ANode^.VClass + vmtWSPrivate)^ := WSPrivate;
+    if (OrgPrivate <> nil) and (OrgPrivate <> AOldPrivate) and
+      OrgPrivate.InheritsFrom(WSPrivate) then begin
       {$IFDEF VerboseWSRegistration}
-      DebugLn('Virtual parent: nil, WSPrivate: ', PClass(ANode^.VClass + vmtWSPrivate)^.ClassName);
+      DebugLn('Keep org private: ', WSPrivate.ClassName, ' -> ', OrgPrivate.ClassName);
       {$ENDIF}
-      Exit;
+      WSPrivate := OrgPrivate;
     end;
+  end;
 
-    if WSPrivate = TWSPrivate
-    then begin
-      if ParentWSNode^.VClass = nil
-      then begin
-        DebugLN('[WARNING] Missing VClass for: ', ParentWSNode^.WSClass.ClassName);
-        PClass(ANode^.VClass + vmtWSPrivate)^ := TWSPrivate;
-      end
-      else PClass(ANode^.VClass + vmtWSPrivate)^ := PClass(ParentWSNode^.VClass + vmtWSPrivate)^;
-    end
-    else PClass(ANode^.VClass + vmtWSPrivate)^ := WSPrivate;
+  // Initially copy the WSClass
+  Move(Pointer(ANode^.WSClass)^, ANode^.VClass^, VvmtSize);
 
+  // Set WSPrivate class
+  ParentWSNode := FindParentWSClassNode(ANode);
+  if ParentWSNode = nil then begin
+    // nothing to do
+    PClass(ANode^.VClass + vmtWSPrivate)^ := WSPrivate;
     {$IFDEF VerboseWSRegistration}
-    DebugLn('Virtual parent: ', ParentWSNode^.WSClass.ClassName, ', WSPrivate: ', PClass(ANode^.VClass + vmtWSPrivate)^.ClassName);
+    DebugLn('Virtual parent: nil, WSPrivate: ', PClass(ANode^.VClass +
+      vmtWSPrivate)^.ClassName);
     {$ENDIF}
+    Exit;
+  end;
 
-    // Try to find the common ancestor
-    CommonClass := FindCommonAncestor(ANode^.WSClass, ParentWSNode^.WSClass);
-    {$IFDEF VerboseWSRegistration}
-    DebugLn('Common: ', CommonClass.ClassName);
-    Indent := '';
-    {$ENDIF}
+  if WSPrivate = TWSPrivate then begin
+    if ParentWSNode^.VClass = nil then begin
+      DebugLN('[WARNING] Missing VClass for: ', ParentWSNode^.WSClass.ClassName);
+      PClass(ANode^.VClass + vmtWSPrivate)^ := TWSPrivate;
+    end
+    else PClass(ANode^.VClass + vmtWSPrivate)^ :=
+        PClass(ParentWSNode^.VClass + vmtWSPrivate)^;
+  end
+  else PClass(ANode^.VClass + vmtWSPrivate)^ := WSPrivate;
 
-    Vvmt := ANode^.VClass + vmtMethodStart;
-    Pvmt := ParentWSNode^.VClass + vmtMethodStart;
-    SetLength(Processed, VvmtCount);
-    FillChar(Processed[0], SizeOf(Processed), 0);
+  {$IFDEF VerboseWSRegistration}
+  DebugLn('Virtual parent: ', ParentWSNode^.WSClass.ClassName,
+    ', WSPrivate: ', PClass(ANode^.VClass + vmtWSPrivate)^.ClassName);
+  {$ENDIF}
 
-    while CommonClass <> nil do
-    begin
-      Cmnt := PPointer(Pointer(CommonClass) + vmtMethodTable)^;
-      if Cmnt <> nil
-      then begin
+  // Try to find the common ancestor
+  CommonClass := FindCommonAncestor(ANode^.WSClass, ParentWSNode^.WSClass);
+  {$IFDEF VerboseWSRegistration}
+  DebugLn('Common: ', CommonClass.ClassName);
+  Indent := '';
+  {$ENDIF}
+
+  Vvmt := ANode^.VClass + vmtMethodStart;
+  Pvmt := ParentWSNode^.VClass + vmtMethodStart;
+  SetLength(Processed, VvmtCount);
+  FillChar(Processed[0], SizeOf(Processed), 0);
+
+  while CommonClass <> nil do begin
+    Cmnt := PPointer(Pointer(CommonClass) + vmtMethodTable)^;
+    if Cmnt <> nil then begin
+      {$IFDEF VerboseWSRegistration_methods}
+      DebugLn(Indent, '*', CommonClass.ClassName, ' method count: ',
+        IntToStr(Cmnt^.Count));
+      Indent := Indent + ' ';
+      {$ENDIF}
+
+      Cvmt := Pointer(CommonClass) + vmtMethodStart;
+      Assert(Cmnt^.Count < VvmtCount,
+        'MethodTable count is larger than determined VvmtCount');
+
+      // Loop through the VMT to see what is overridden
+      for n := 0 to Cmnt^.Count - 1 do begin
+        SearchAddr := Cmnt^.Entries[n].Addr;
         {$IFDEF VerboseWSRegistration_methods}
-        DebugLn(Indent, '*', CommonClass.Classname, ' method count: ', IntToStr(Cmnt^.Count));
-        Indent := Indent + ' ';
+        DebugLn('%sSearch: %s (%p)', [Indent, Cmnt^.Entries[n].Name^, SearchAddr]);
         {$ENDIF}
 
-        Cvmt := Pointer(CommonClass) + vmtMethodStart;
-        Assert(Cmnt^.Count < VvmtCount, 'MethodTable count is larger than determined VvmtCount');
+        for idx := 0 to VvmtCount - 1 do begin
+          if Cvmt^[idx] = SearchAddr then begin
+            {$IFDEF VerboseWSRegistration_methods}
+            DebugLn('%sFound at index: %d (v=%p p=%p)',
+              [Indent, idx, Vvmt^[idx], Pvmt^[idx]]);
+            {$ENDIF}
 
-        // Loop through the VMT to see what is overridden
-        for n := 0 to Cmnt^.Count - 1 do
-        begin
-          SearchAddr := Cmnt^.Entries[n].Addr;
-          {$IFDEF VerboseWSRegistration_methods}
-          DebugLn('%sSearch: %s (%p)', [Indent, Cmnt^.Entries[n].Name^, SearchAddr]);
-          {$ENDIF}
-
-          for idx := 0 to VvmtCount - 1 do
-          begin
-            if Cvmt^[idx] = SearchAddr
-            then begin
+            if Processed[idx] then begin
               {$IFDEF VerboseWSRegistration_methods}
-              DebugLn('%sFound at index: %d (v=%p p=%p)', [Indent, idx, Vvmt^[idx], Pvmt^[idx]]);
+              DebugLn(Indent, 'Processed -> skipping');
               {$ENDIF}
+              Break;
+            end;
+            Processed[idx] := True;
 
-              if Processed[idx]
-              then begin
-                {$IFDEF VerboseWSRegistration_methods}
-                DebugLn(Indent, 'Processed -> skipping');
-                {$ENDIF}
-                Break;
-              end;
-              Processed[idx] := True;
-
-              if  (Vvmt^[idx] = SearchAddr)  //original
+            if (Vvmt^[idx] = SearchAddr)  //original
               and (Pvmt^[idx] <> SearchAddr) //overridden by parent
-              then begin
-                {$IFDEF VerboseWSRegistration_methods}
-                DebugLn('%sUpdating %p -> %p', [Indent, Vvmt^[idx], Pvmt^[idx]]);
-                {$ENDIF}
-                Vvmt^[idx] := Pvmt^[idx];
-              end;
-
-              Break;
-            end;
-            if idx = VvmtCount - 1
             then begin
-              DebugLn('[WARNING] VMT entry "', Cmnt^.Entries[n].Name^, '" not found in "', CommonClass.ClassName, '"');
-              Break;
+              {$IFDEF VerboseWSRegistration_methods}
+              DebugLn('%sUpdating %p -> %p', [Indent, Vvmt^[idx], Pvmt^[idx]]);
+              {$ENDIF}
+              Vvmt^[idx] := Pvmt^[idx];
             end;
+
+            Break;
           end;
+          if idx = VvmtCount - 1 then begin
+            DebugLn('[WARNING] VMT entry "', Cmnt^.Entries[n].Name^,
+              '" not found in "', CommonClass.ClassName, '"');
+            Break;
+          end;
         end;
       end;
-      CommonClass := Commonclass.ClassParent;
     end;
+    CommonClass := Commonclass.ClassParent;
+  end;
 
-    // Adjust classname
-    ANode^.VClassName := '(V)' + ANode^.WSClass.ClassName;
-    PPointer(ANode^.VClass + vmtClassName)^ := @ANode^.VClassName;
-    // Adjust classparent
-    {$IF (FPC_FULLVERSION >= 30101)}
-    PPointer(ANode^.VClass + vmtParent)^ := @ParentWSNode^.WSClass;
-    {$ELSE}
-    PPointer(ANode^.VClass + vmtParent)^ := ParentWSNode^.WSClass;
-    {$ENDIF}
-    // Delete methodtable entry
-    PPointer(ANode^.VClass + vmtMethodTable)^ := nil;
+  // Adjust classname
+  ANode^.VClassName := '(V)' + ANode^.WSClass.ClassName;
+  PPointer(ANode^.VClass + vmtClassName)^ := @ANode^.VClassName;
+  // Adjust classparent
+  {$IF (FPC_FULLVERSION >= 30101)}
+  PPointer(ANode^.VClass + vmtParent)^ := @ParentWSNode^.WSClass;
+  {$ELSE}
+  PPointer(ANode^.VClass + vmtParent)^ := ParentWSNode^.WSClass;
+  {$ENDIF}
+  // Delete methodtable entry
+  PPointer(ANode^.VClass + vmtMethodTable)^ := nil;
+end;
+
+// ANewRegistration - If true, VClass is not created during runtime,
+// but instead normal, Object Pascal class creation is used
+procedure RegisterWSComponent(const AComponent: TComponentClass;
+  const AWSComponent: TWSLCLComponentClass;
+  const AWSPrivate: TWSPrivateClass = nil;
+  const ANewRegistration: Boolean = False);
+
+  { Get note is recursive, we want to detect if a new node may be an
+    un registered intermediate in the enacestor class tree }
+  function GetNode(const AClass: TClass; aParentGet: boolean; aLeaf: boolean): PClassNode;
+  var
+    idx: Integer;
+    OldCount: integer;
+    lParentNode : PClassNode;
+    lClassNode : TClassNode; { A temp local node to fake normal processing
+                               of a node that won't be stored aParentGet = 0
+                               and TWSLCLComponentClass = nil }
+    lInsertNode : boolean;   { Indicator that New(Result) has been requested }
+  begin
+    if (AClass = nil)
+      or not (AClass.InheritsFrom(TLCLComponent))
+    then begin
+      Result := nil;
+      Exit;
+    end;
+
+    if not WSClassesList.Search(AClass, idx) then begin
+      if not aParentGet and (AWSComponent = nil) then begin
+        lInsertNode := False;
+        Result := @lClassNode;
+      end
+      else begin
+        lInsertNode := True;
+        New(Result);
+      end;
+      Result^.LCLClass := TComponentClass(AClass);
+      Result^.WSClass := nil;
+      Result^.VClass := nil;
+      Result^.VClassName := '';
+      Result^.VClassNew := aParentGet;
+      Result^.Child := nil;
+      lParentNode := GetNode(AClass.ClassParent, True, False);
+      Result^.Parent := lParentNode;
+      { Unregistered Intermediate nodes are patched with the parent information }
+      if aParentGet then begin
+        Result^.WSClass := lParentNode^.WSClass;
+        Result^.VClass := lParentNode^.VClass;
+        PPointer(Result^.VClass + vmtWSPrivate)^ := PPointer(lParentNode^.VClass + vmtWSPrivate)^;
+        // Build a VClassName
+        if aLeaf then
+          { Node that has an empty WSRegisterClass procedure }
+          Result^.VClassName := '(L)' + Result^.WSClass.ClassName
+        else
+          { Internal node needed for tree consistency }
+          Result^.VClassName := '(I)' + Result^.WSClass.ClassName
+      end;
+      if lParentNode = nil then begin
+        Result^.Sibling := nil;
+        if aLeaf then
+          Result^.VClassName := '(ROOT)' + AClass.ClassName
+      end
+      else begin
+        if lInsertNode then begin
+          Result^.Sibling := lParentNode^.Child;
+          lParentNode^.Child := Result;
+        end
+        else
+          Result^.Sibling := nil;
+      end;
+      if lInsertNode then begin
+        WSClassesList.Search(aClass, idx);
+        WSClassesList.Insert(idx, Result);
+      end
+      else
+        Result := nil;
+    end
+    else begin
+      Result := WSClassesList[idx];
+    end;
   end;
 
   procedure UpdateChildren(const ANode: PClassNode; AOldPrivate: TClass);
@@ -432,7 +512,7 @@
         {$IFDEF VerboseWSRegistration}
         DebugLn('Update VClass for: ', Node^.WSClass.ClassName);
         {$ENDIF}
-        CreateVClass(Node, AOldPrivate);
+        CreateVClass(Node, AWSPrivate, AOldPrivate);
       end;
       UpdateChildren(Node, AOldPrivate);
       Node := Node^.Sibling;
@@ -442,34 +522,33 @@
 var
   Node: PClassNode;
   OldPrivate: TClass;
+  idx: Integer;
 begin
-  if MWSRegisterIndex = nil then
-    DoInitialization;
-  Node := GetNode(AComponent);
-  if Node = nil then Exit;
+  Node := GetNode(AComponent, False or ANewRegistration, True);
+  if Node = nil then // No node created
+    Exit;
 
-  if Node^.WSClass = nil
-  then MWSRegisterIndex.AddObject(AComponent.ClassName, TObject(Node));
-  Node^.WSClass := AWSComponent;
-
   if ANewRegistration then
-  begin
-    Node^.VClass := AWSComponent;
-    Node^.VClassNew := True;
     Exit;
-  end;
 
+  { If AWSComponent specified but node already exists, nothing more to do. }
+  if Assigned(AWSComponent) and (Node^.WSClass = AWSComponent) then
+    Exit;
+
+  Node^.WSClass := AWSComponent;
+
   // childclasses "inherit" the private from their parent
   // the child privates should only be updated when their private is still
   // the same as their parents
-  if Node^.VClass = nil
-  then OldPrivate := nil
-  else OldPrivate := PClass(Node^.VClass + vmtWSPrivate)^;
+  if Node^.VClass = nil then
+    OldPrivate := nil
+  else
+    OldPrivate := PClass(Node^.VClass + vmtWSPrivate)^;
 
   {$IFDEF VerboseWSRegistration}
   DebugLn('Create VClass for: ', AComponent.ClassName, ' -> ', Node^.WSClass.ClassName);
   {$ENDIF}
-  CreateVClass(Node);
+  CreateVClass(Node, AWSPrivate);
 
   // Since child classes may depend on us, recreate them
   UpdateChildren(Node, OldPrivate);
@@ -495,84 +574,167 @@
   WSLazDeviceAPIsClass := AWSObject;
 end;
 
-{ TWSLCLComponent }
+function FindWSRegistered(const AComponent: TComponentClass): TWSLCLComponentClass;
+begin
+  if not Assigned(WSClassesList) then
+    DoInitialization;
+  Result := WSClassesList.FindWSClass(AComponent);
+end;
 
-class function TWSLCLComponent.WSPrivate: TWSPrivateClass; //inline;
+{$IFDEF VerboseWSBrunoK}
+procedure DumpWSClassesList;
 begin
-  Result := TWSPrivateClass(PClass(Pointer(Self) + vmtWSPrivate)^);
+  WSClassesList.DumpNodes;
 end;
+{$ENDIF}
 
-{ TWSLCLHandleComponent }
+{ TWSClassesList }
 
-class procedure TWSLCLReferenceComponent.DestroyReference(AComponent: TComponent);
+function TWSClassesList.Get(Index: integer): PClassNode;
 begin
+  Result := PClassNode(inherited Get(Index));
 end;
 
-procedure DoInitialization;
+function TWSClassesList.FindWSClass(
+  const AComponent: TComponentClass): TWSLCLComponentClass;
+var
+  I: integer;
 begin
-  MComponentIndex := TStringList.Create;
-  MComponentIndex.Sorted := True;
-  MComponentIndex.Duplicates := dupError;
+  {$IFDEF VerboseWSBrunoK} Write('Searching ', AComponent.ClassName); {$ENDIF}
+  if Search(AComponent, i) then begin
+    Result := TWSLCLComponentClass(Items[i]^.VClass);
+    {$IFDEF VerboseWSBrunoK} WriteLn(' -> FOUND'); {$ENDIF}
+    Exit;
+  end;
+  {$IFDEF VerboseWSBrunoK} WriteLn(' -> NOT FOUND'); {$ENDIF}
+  Result := nil;
+end;
 
-  MWSRegisterIndex := TStringList.Create;
-  MWSRegisterIndex.Sorted := True;
-  MWSRegisterIndex.Duplicates := dupError;
+{ Searches a match for AComponent.ClassType. Returns index in items of
+  the matching AComponent or the next bigger one }
+function TWSClassesList.Search(const aItem: TClass; out Index: integer
+  ): boolean;
+const
+  cIndex: integer = 0;
+var
+  L, R: integer;
+  lLCLClass: TClass;
+  lPClassNode: PClassNode;
+begin
+  L := 0;
+  R := Count - 1;
+  // Use binary search.
+  if R >= 0 then begin
+    if Pointer(aItem) = Pointer(FLastFoundLCLClass) then begin
+      Index := FLastFoundIdx;
+      Exit(True);
+    end;
+    while (L <= R) do begin
+      Index := L + ((R - L) div 2);
+      lLCLClass := PClassNode(List^[Index])^.LCLClass;
+      if Pointer(aItem) < Pointer(lLCLClass) then
+        R := Index - 1
+      else begin
+        if aItem = lLCLClass then begin
+          FLastFoundIdx := Index;
+          FLastFoundLCLClass := TComponentClass(lLCLClass);
+          Exit(True);
+        end;
+        L := Index + 1;
+      end;
+    end;
+  end;
+  Index := L;
+  Result := False;
 end;
 
-{$ifdef VerboseWSRegistration_treedump}
-procedure DumpVTree;
-  procedure DumpNode(ANode: PClassNode; AIndent: String = '');
-  begin
-    if ANode = nil then Exit;
+{$IFDEF VerboseWSBrunoK}
+procedure TWSClassesList.DumpNode(aN: integer; aPClassNode: PClassNode);
+var
+  LCLClassClassName, lWSClassClassName, lVClassName, ParentVClassName: string;
+  lClassNode : PClassNode;
+begin
+  with aPClassNode^ do begin
+    if Assigned(LCLClass) then
+      LCLClassClassName := LCLClass.ClassName
+    else
+      LCLClassClassName := '???';
+    if Assigned(WSClass) then
+      lWSClassClassName := WSClass.ClassName
+    else
+      lWSClassClassName := '???';
+    if Assigned(VClass) then
+      lVClassName := TClass(VClass).ClassName
+    else
+      lVClassName := '???';
+    if Assigned(Parent) and  Assigned(PClassNode(Parent)^.WSClass) then
+      ParentVClassName := PClassNode(Parent)^.WSClass.ClassName
+    else
+      ParentVClassName := '???';
+    writeln(
+      aN, ';',
+      { DbgCreateSeq, ';', }
+      HexStr(aPClassNode), ';',
+      HexStr(LCLClass), ';',  // : TComponentClass;
+      LCLClassClassName, ';',
+      HexStr(WSClass), ';', // : TWSLCLComponentClass;
+      lWSClassClassName, ';',
+      HexStr(VClass), ';', // : Pointer;
+      VClassName, ';',
+      // VVmtCount, ';',
+      lVClassName, ';',
+      VClassNew, ';',    // : Boolean;
+      HexStr(Parent), ';', // Parent: PClassNode;
+      ParentVClassName, ';', // ShortString;
+      HexStr(Child), ';',   // Child: PClassNode;
+      HexStr(Sibling)  // Sibling: PClassNode;
+      );
+  end;
+end;
 
-    DbgOut(AIndent);
+procedure TWSClassesList.DumpNodes;
+var
+  i: integer;
+begin
+  WriteLn('n;',          // aN, ';',
+    { 'CreateSeq;',        // DbgCreateSeq, ';', }
+    'PClassNode;',        // Node
+    'LCLClass;',         // HexStr(LCLClass), ';',  // : TComponentClass;
+    'LCLClassName;',     // LCLClassClassName, ';',
+    'WSClass;',          // HexStr(WSClass), ';', // : TWSLCLComponentClass
+    'WSClassName;',      // lWSClassClassName, ';',
+    'VClass;',           // HexStr(VClass), ';', // : Pointer;
+    'VClassName;',       // VClassName
+  {  'VVmtCount', }      // VVmtCount, ';',
+    'VClassName;',       // lVClassName, ';',
+    'VClassNew;',        // VClassNew,           ';',  // : Boolean;
+    'Parent;',           // HexStr(Parent), ';', // Parent: PClassNode;
+    'Parent.Name;',      // ParentClassName, ';', // ShortString;
+    'Child;',            // HexStr(Child), ';',   // Child: PClassNode;
+    'Sibling'            // HexStr(Sibling)  // Sibling: PClassNode;
+    );
+  for i := 0 to Count - 1 do
+    DumpNode(i, PClassNode(Items[i]));
+end;
+{$ENDIF}
 
-    DbgOut('LCLClass=');
-    if ANode^.LCLClass = nil
-    then DbgOut('nil')
-    else DbgOut(ANode^.LCLClass.Classname);
+{ TWSLCLComponent }
 
-    DbgOut(' WSClass=');
-    if ANode^.WSClass = nil
-    then DbgOut('nil')
-    else DbgOut(ANode^.WSClass.Classname);
+class function TWSLCLComponent.WSPrivate: TWSPrivateClass; //inline;
+begin
+  Result := TWSPrivateClass(PClass(Pointer(Self) + vmtWSPrivate)^);
+end;
 
-    DbgOut(' VClass=');
-    if ANode^.VClass = nil
-    then DbgOut('nil')
-    else begin
-      DbgOut(TClass(ANode^.VClass).Classname);
-      DbgOut(' VClass.Parent=');
-      if TClass(ANode^.VClass).ClassParent = nil
-      then DbgOut('nil')
-      else DbgOut(TClass(ANode^.VClass).ClassParent.ClassName);
-      
-      DbgOut(' Private=');
-      if PClass(ANode^.VClass + vmtWSPrivate)^ = nil
-      then DbgOut('nil')
-      else DbgOut(PClass(ANode^.VClass + vmtWSPrivate)^.ClassName);
-    end;
+{ TWSLCLHandleComponent }
 
-    DbgOut(' VClassName=''', ANode^.VClassName, '''');
-    DebugLn;
+class procedure TWSLCLReferenceComponent.DestroyReference(AComponent: TComponent);
+begin
+end;
 
-    DumpNode(ANode^.Child, AIndent + ' ');
-
-    DumpNode(ANode^.Sibling, AIndent);
-  end;
-
-var
-  n: Integer;
-  Node: PClassNode;
+procedure DoInitialization;
 begin
-  for n := 0 to MComponentIndex.Count - 1 do
-  begin
-    Node := PClassNode(MComponentIndex.Objects[n]);
-    if Node^.Parent = nil
-    then DumpNode(Node);
-  end;
+  WSClassesList := TWSClassesList.Create;
 end;
-{$endif}
 
 procedure DoFinalization;
 var
@@ -579,19 +741,21 @@
   n: Integer;
   Node: PClassNode;
 begin
-  {$ifdef VerboseWSRegistration_treedump}
-  DumpVTree;
-  {$endif}
-
-  for n := 0 to MComponentIndex.Count - 1 do
+  {$IFDEF VerboseWSBrunoK}
+  WSClassesList.DumpNodes;
+  WriteLn;
+  WriteLn('cWSLCLDirectHit=', cWSLCLDirectHit,
+          ' cWSLCLParentHit=', cWSLCLParentHit,
+          ' cWSLCLRegister=', cWSLCLRegister);
+  {$ENDIF}
+  for n := 0 to WSClassesList.Count - 1 do
   begin
-    Node := PClassNode(MComponentIndex.Objects[n]);
+    Node := WSClassesList[n];
     if (Node^.VClass <> nil) and (not Node^.VClassNew) then
       Freemem(Node^.VClass);
     Dispose(Node);
   end;
-  FreeAndNil(MComponentIndex);
-  FreeAndNil(MWSRegisterIndex);
+  FreeAndNil(WSClassesList);
 end;
 
 
LCLComponent.patch (35,029 bytes)   
lcl.zip (8,513 bytes)
Registered.patch (2,537 bytes)   
Index: lcl/include/buttons.inc
===================================================================
--- lcl/include/buttons.inc	(revision 63021)
+++ lcl/include/buttons.inc	(working copy)
@@ -239,7 +239,11 @@
 end;
 
 class procedure TCustomButton.WSRegisterClass;
+const
+  Registered : boolean = False;
 begin
+  if Registered then
+    Exit;
   inherited WSRegisterClass;
   RegisterCustomButton;
   RegisterPropertyToSkip(TCustomButton, 'ElevationRequired',  'VCL compatibility property', '');
@@ -250,6 +254,7 @@
   RegisterPropertyToSkip(TCustomButton, 'HotImageIndex',      'VCL compatibility property', '');
   RegisterPropertyToSkip(TCustomButton, 'PressedImageIndex',  'VCL compatibility property', '');
   RegisterPropertyToSkip(TCustomButton, 'SelectedImageIndex', 'VCL compatibility property', '');
+  Registered := True;
 end;
 
 function TCustomButton.ChildClassAllowed(ChildClass: TClass): boolean;
Index: lcl/include/control.inc
===================================================================
--- lcl/include/control.inc	(revision 63021)
+++ lcl/include/control.inc	(working copy)
@@ -4264,7 +4264,11 @@
 end;
 
 class procedure TControl.WSRegisterClass;
+const
+  Registered : boolean = False;
 begin
+  if Registered then
+    Exit;
   inherited WSRegisterClass;
   RegisterControl;
   RegisterPropertyToSkip(TControl, 'AlignWithMargins', 'VCL compatibility property', '');
@@ -4276,6 +4280,7 @@
   RegisterPropertyToSkip(TControl, 'ExplicitHeight',   'VCL compatibility property', '');
   RegisterPropertyToSkip(TControl, 'ExplicitTop',      'VCL compatibility property', '');
   RegisterPropertyToSkip(TControl, 'ExplicitWidth',    'VCL compatibility property', '');
+  Registered := True;
 end;
 
 function TControl.GetCursor: TCursor;
Index: lcl/include/wincontrol.inc
===================================================================
--- lcl/include/wincontrol.inc	(revision 63021)
+++ lcl/include/wincontrol.inc	(working copy)
@@ -6279,12 +6279,17 @@
 end;
 
 class procedure TWinControl.WSRegisterClass;
+const
+  Registered : boolean = False;
 begin
+  if Registered then
+    Exit;
   inherited WSRegisterClass;
   RegisterWinControl;
   RegisterPropertyToSkip(TWinControl, 'ParentDoubleBuffered', 'VCL compatibility property', '');
   RegisterPropertyToSkip(TWinControl, 'ImeMode', 'VCL compatibility property', '');
   RegisterPropertyToSkip(TWinControl, 'ImeName', 'VCL compatibility property', '');
+  Registered := True;
 end;
 
 function TWinControl.IsClientHeightStored: boolean;
Registered.patch (2,537 bytes)   

BrunoK

2020-07-16 12:20

reporter   ~0124084

Minor improvements in V1 patch and corresponding lcl_V.zip

Statistics of calls for one of my lazarus trunk install with revised code :
Total TLCLComponent.NewInstance : 2'919
Of which :
    64 Call WSRegisterClass (Slow) + 64 Retrievals from TLCLComponent parent / itself
1'520 Retrieved from TLCLComponent parent (Fast)
1'335 Retrieved from the TLCLComponent itself (Fast)

Instead of actual code :
2'919 Calls to WSRegisterClass (Slow) + 2'919 Retrieve WidgetSetClass (Fast)
lcl_V1.zip (8,629 bytes)
LCLComponent_V1.patch (36,090 bytes)   
Index: lcl/lclclasses.pp
===================================================================
--- lcl/lclclasses.pp	(revision 63021)
+++ lcl/lclclasses.pp	(working copy)
@@ -1,8 +1,8 @@
 { $Id$}
 {
  *****************************************************************************
- *                               lclclasses.pp                               * 
- *                               -------------                               * 
+ *                               lclclasses.pp                               *
+ *                               -------------                               *
  *                                                                           *
  *                                                                           *
  *****************************************************************************
@@ -20,6 +20,8 @@
 
 {$mode objfpc}{$H+}
 
+{ Add -dVerboseWSBrunoK switch to compile with $DEFINE VerboseWSBrunoK }
+
 interface
 
 uses
@@ -47,7 +49,9 @@
     class procedure WSRegisterClass; virtual;
     class function GetWSComponentClass(ASelf: TLCLComponent): TWSLCLComponentClass; virtual;
   public
+    {$IFDEF DebugLCLComponents}
     constructor Create(TheOwner: TComponent); override;
+    {$ENDIF}
     destructor Destroy; override;
     class function NewInstance: TObject; override;
     procedure RemoveAllHandlersOfObject(AnObject: TObject); virtual;
@@ -56,7 +60,7 @@
     property LCLRefCount: integer read FLCLRefCount;
     property WidgetSetClass: TWSLCLComponentClass read FWidgetSetClass;
   end;
-  
+
   { TLCLReferenceComponent }
 
   // A base class for all components having a handle
@@ -89,33 +93,99 @@
 uses
   InterfaceBase;
 
+const
+  cWSRegisterOffset : integer = 0; // Offset of WSRegisterClass in class
+                                   // virtual methods
+  cLCLComponentWSReg : CodePointer = nil; // Adress of TLCLComponent.WSRegisterClass
+
+type
+  TLCLComponentClass = class of TLCLComponent;
+
+function WSRegisterLCLComponent: boolean;
+begin
+  RegisterWSComponent(TLCLComponent, TWSLCLComponent);
+  Result := True;
+end;
+
 class procedure TLCLComponent.WSRegisterClass;
+const
+  Registered : boolean = False;
 begin
-  //
+  if Registered then
+    Exit;
+  WSRegisterLCLComponent;
+  Registered := True;
 end;
 
 // This method allows descendents to override the FWidgetSetClass
-class function TLCLComponent.GetWSComponentClass(ASelf: TLCLComponent): TWSLCLComponentClass;
+{ This method handles registration of the comonent in WSLVLClasses list of
+  components.
+  It is only called if there wasn't a direct or parent hit at the beginining of
+  NewInstance. }
+class function TLCLComponent.GetWSComponentClass(ASelf: TLCLComponent
+            ): TWSLCLComponentClass;
+  procedure UpdateOffset;
+  var
+    lWSRegisterProc : CodePointer;
+    lPPtrArray : PPointerArray;
+    I : integer;
+  begin
+    cLCLComponentWSReg := @TLCLComponent.WSRegisterClass;
+    lPPtrArray := Pointer(TLCLComponent);
+    I := 0;
+    while lPPtrArray^[i]<>cLCLComponentWSReg do
+      inc(i);
+    cWSRegisterOffset := I * SizeOf(Pointer);
+  end;
+var
+  lPSelfWSReg,
+  lPSelfParentWSReg : CodePointer;
+  lClassParent : TLCLComponentClass;
 begin
-  Result := FindWSComponentClass(Self);
+  if cWSRegisterOffset = 0 then begin
+    UpdateOffset;
+    { Always create the top node ! }
+    TLCLComponent.WSRegisterClass;
+  end;
 
-  if Result = nil then
-  begin
-    {$IFDEF VerboseLCL}
-    DebugLn(['TLCLComponent.NewInstance WARNING: missing FWidgetSetClass ',ClassName]);
-    {$ENDIF}
-    Result := TWSLCLComponent;
-  end;
+  WSRegisterClass;
+  Result := FindWSRegistered(Self);
+
+  if Result <> nil then
+    Exit;
+
+  lClassParent := TLCLComponentClass(ClassParent);
+  lPSelfWSReg := PCodePointer(Pointer(Self) + cWSRegisterOffset)^;
+  lPSelfParentWSReg := PCodePointer(Pointer(lClassParent) + cWSRegisterOffset)^;
+
+  { The Self.ComponentClass didn't register itself but the parent should now
+    be registered }
+  repeat
+    if lPSelfWSReg = lPSelfParentWSReg then begin
+      Result := FindWSRegistered(TComponentClass(lClassParent));
+      if Assigned(Result) then
+        Break
+      else
+        { Force creation of intermediate nodes for parent }
+        RegisterWSComponent(TComponentClass(lClassParent), nil, nil, True);
+    end
+    else begin
+      { Force creation of intermediate nodes for Self and a leaf node for Self }
+      RegisterWSComponent(Self, nil, nil, True);
+      Result := FindWSRegistered(Self);
+      Break;
+    end;
+  until False;
 end;
 
+{$IFDEF DebugLCLComponents}
 constructor TLCLComponent.Create(TheOwner: TComponent);
 begin
   inherited Create(TheOwner);
-  {$IFDEF DebugLCLComponents}
   //DebugLn('TLCLComponent.Create ',DbgSName(Self));
   DebugLCLComponents.MarkCreated(Self,DbgSName(Self));
-  {$ENDIF}
 end;
+{$ENDIF}
 
 destructor TLCLComponent.Destroy;
 begin
@@ -135,11 +205,37 @@
 end;
 
 class function TLCLComponent.NewInstance: TObject;
+var
+  lWidgetSetClass: TWSLCLComponentClass;
+  lClassParent : TLCLComponentClass;
 begin
   Result := inherited NewInstance;
-  WSRegisterClass;
 
+  { Test if directly inherits WSRegisterClass from its parent }
+  lClassParent := TLCLComponentClass(ClassParent);
+  if (PCodePointer(Pointer(Self)  + cWSRegisterOffset)^
+     = PCodePointer(Pointer(lClassParent) + cWSRegisterOffset)^)
+  then begin
+    { Retrieve WidgetSetClass from Parent }
+    lWidgetSetClass := FindWSRegistered(lClassParent);
+    if Assigned(lWidgetSetClass) then begin
+      TLCLComponent(Result).FWidgetSetClass := lWidgetSetClass;
+      Exit;
+    end;
+  end
+  else begin
+    { Look if already registered. If true set FWidgetSetClass and exit }
+    lWidgetSetClass := FindWSRegistered(Self);
+    if Assigned(lWidgetSetClass) then begin
+      TLCLComponent(Result).FWidgetSetClass := lWidgetSetClass;
+      {$IFDEF VerboseWSBrunoK} inc(cWSLCLDirectHit); {$ENDIF}
+      Exit;
+    end;
+  end;
+
+  { WSRegisterClass and manage WSLVLClasses list }
   TLCLComponent(Result).FWidgetSetClass := GetWSComponentClass(TLCLComponent(Result));
+  {$IFDEF VerboseWSBrunoK} inc(cWSLCLRegister); {$ENDIF}
 end;
 
 procedure TLCLComponent.RemoveAllHandlersOfObject(AnObject: TObject);
Index: lcl/widgetset/wslclclasses.pp
===================================================================
--- lcl/widgetset/wslclclasses.pp	(revision 63021)
+++ lcl/widgetset/wslclclasses.pp	(working copy)
@@ -22,9 +22,7 @@
 {off$DEFINE VerboseWSRegistration}
 {off$DEFINE VerboseWSRegistration_methods}
 {off$DEFINE VerboseWSRegistration_treedump}
-{$IFDEF VerboseWSRegistration_methods}
-{$DEFINE VerboseWSRegistration}
-{$ENDIF}
+{ Add -dVerboseWSBrunoK switch to compile with $DEFINE VerboseWSBrunoK }
 
 interface
 ////////////////////////////////////////////////////
@@ -93,6 +91,19 @@
 function GetWSLazDeviceAPIs: TWSObjectClass;
 procedure RegisterWSLazDeviceAPIs(const AWSObject: TWSObjectClass);
 
+// ~bk Search for already registered classes
+function FindWSRegistered(const AComponent: TComponentClass): TWSLCLComponentClass;
+
+{ Debug : Dump the WSClassesList nodes }
+{$IFDEF VerboseWSBrunoK}
+const
+  cWSLCLDirectHit : integer = 0;
+  cWSLCLParentHit : integer = 0;
+  cWSLCLRegister : integer = 0;
+
+procedure DumpWSClassesList;
+{$ENDIF}
+
 implementation
 
 uses
@@ -106,11 +117,12 @@
 type
   PClassNode = ^TClassNode;
   TClassNode = record
-    LCLClass: TComponentClass;
-    WSClass: TWSLCLComponentClass;
-    VClass: Pointer;
-    VClassName: ShortString;
-    VClassNew: Boolean; // Indicates that VClass=WSClass, VClass is not created during runtime
+    LCLClass: TComponentClass;     { Class of the created instances }
+    WSClass: TWSLCLComponentClass; { WidgetSet specific implementation class }
+    VClass: Pointer;               { Adjusted vmt table to handle WS virtual methods }
+    VClassName: ShortString;       { Class name attibuted when node was create }
+    VClassNew: Boolean;            { True Indicates that VClass=Parent.VClass.
+                                     When True VClass is not runtime created }
     Parent: PClassNode;
     Child: PClassNode;
     Sibling: PClassNode;
@@ -120,32 +132,58 @@
   // vmtAutoTable is something Delphi 2 and not used, we 'borrow' the vmt entry
   vmtWSPrivate = vmtAutoTable;
 
+
+type
+
+  { TWSClassesList }
+
+  // Holds list of already registered TWidgetSetClass'es so TLCLComponent.NewInstance
+  // can find faster the WidgetSetClass of the newinstance.
+
+  TWSClassesList = class(TFPList)
+  private
+    FLastFoundIdx: integer;
+    FLastFoundLCLClass: TComponentClass;
+    function FindWSClass(const AComponent: TComponentClass): TWSLCLComponentClass;
+    function Get(Index: integer): PClassNode; { inline; }
+    function Search(const aItem: TClass; Out Index: integer): boolean;
+    property Items[Index: integer]: PClassNode read Get; { write Put; default; }
+    {$IFDEF VerboseWSBrunoK} {$ENDIF}
+    {$IFDEF VerboseWSBrunoK}
+    procedure DumpNode(aN : integer; aPClassNode : PClassNode);
+    procedure DumpNodes;
+    {$ENDIF}
+  end;
+
 var
-  MComponentIndex: TStringList;
-  MWSRegisterIndex: TStringList;
+  WSClassesList: TWSClassesList = nil;
   WSLazAccessibleObjectClass: TWSObjectClass;
   WSLazDeviceAPIsClass: TWSObjectClass;
 
+function FindNodeParent(AComponent: TClass): PClassNode;
+var
+  idx: integer;
+begin
+  while AComponent <> nil do begin
+    if WSClassesList.Search(AComponent, idx) then begin
+      Result := PClassNode(WSClassesList[idx]);
+      Exit;
+    end;
+    AComponent := AComponent.ClassParent;
+  end;
+  Result := nil;
+end;
+
 function FindClassNode(const AComponent: TComponentClass): PClassNode;
 var
-  idx: Integer;
-  cls: TClass;
+  idx: integer;
 begin
-  if MWSRegisterIndex = nil then
-    DoInitialization;
-
   Result := nil;
-  cls := AComponent;
-  while cls <> nil do
-  begin
-    idx := MWSRegisterIndex.IndexOf(cls.ClassName);
-    if idx <> -1 then
-    begin
-      Result := PClassNode(MWSRegisterIndex.Objects[idx]);
-      Break;
-    end;
-    cls := cls.ClassParent;
+  if WSClassesList.Search(AComponent, idx) then begin
+    Result := WSClassesList[idx];
+    Exit;
   end;
+  Result := FindNodeParent(AComponent.ClassParent);
 end;
 
 function FindWSComponentClass(
@@ -187,57 +225,27 @@
   TPointerArray = packed array[0..9999999] of Pointer;
   PPointerArray = ^TPointerArray;
 
-// ANewRegistration - If true, VClass is not created during runtime,
-// but instead normal, Object Pascal class creation is used
-procedure RegisterWSComponent(const AComponent: TComponentClass;
-  const AWSComponent: TWSLCLComponentClass;
-  const AWSPrivate: TWSPrivateClass = nil;
-  const ANewRegistration: Boolean = False);
+function  GetClassNameP(aClassName:string) : Pointer;
+var
+  lLen: integer;
+  lShortStr : shortstring;
+begin
+  lShortStr := aClassName + #0;
+  lLen := Length(lShortStr);
+  SetLength(lShortStr,lLen-1);
+  Result := GetMem(lLen+1);
+  move(lShortStr, Result^, lLen + 2);
+end;
 
-  function GetNode(const AClass: TClass): PClassNode;
-  var
-    idx: Integer;
-    Name: String;
-  begin
-    if (AClass = nil)
-    or not (AClass.InheritsFrom(TLCLComponent))
-    then begin
-      Result := nil;
-      Exit;
-    end;
 
-    Name := AClass.ClassName;
-    idx := MComponentIndex.IndexOf(Name);
-    if idx = -1
-    then begin
-      New(Result);
-      Result^.LCLClass := TComponentClass(AClass);
-      Result^.WSClass := nil;
-      Result^.VClass := nil;
-      Result^.VClassName := '';
-      Result^.VClassNew := False;
-      Result^.Child := nil;
-      Result^.Parent := GetNode(AClass.ClassParent);
-      if Result^.Parent = nil
-      then begin
-        Result^.Sibling := nil;
-      end
-      else begin
-        Result^.Sibling := Result^.Parent^.Child;
-        Result^.Parent^.Child := Result;
-      end;
-      MComponentIndex.AddObject(Name, TObject(Result));
-    end
-    else begin
-      Result := PClassNode(MComponentIndex.Objects[idx]);
-    end;
-  end;
+procedure CreateVClass(const ANode: PClassNode;
+  const AWSPrivate: TWSPrivateClass = nil;
+  AOldPrivate: TClass = nil);
 
   function FindParentWSClassNode(const ANode: PClassNode): PClassNode;
   begin
     Result := ANode^.Parent;
-    while Result <> nil do
-    begin
+    while Result <> nil do begin
       if Result^.WSClass <> nil then Exit;
       Result := Result^.Parent;
     end;
@@ -247,177 +255,246 @@
   function FindCommonAncestor(const AClass1, AClass2: TClass): TClass;
   begin
     Result := AClass1;
-    if AClass2.InheritsFrom(Result)
-    then Exit;
-
+    if AClass2.InheritsFrom(Result) then Exit;
     Result := AClass2;
-    while Result <> nil do
-    begin
-      if AClass1.InheritsFrom(Result)
-      then Exit;
+    while Result <> nil do begin
+      if AClass1.InheritsFrom(Result) then Exit;
       Result := Result.ClassParent;
     end;
-
     Result := nil;
   end;
 
-  procedure CreateVClass(const ANode: PClassNode; AOldPrivate: TClass = nil);
-  var
-    ParentWSNode: PClassNode;
-    CommonClass: TClass;
-    Vvmt, Cvmt, Pvmt: PPointerArray;
-    Cmnt: PMethodNameTable;
-    SearchAddr: Pointer;
-    n, idx: Integer;
-    WSPrivate, OrgPrivate: TClass;
-    Processed: array of Boolean;
-    VvmtCount,
-    VvmtSize : Integer;
-    {$IFDEF VerboseWSRegistration}
-    Indent: String;
-    {$ENDIF}
-  begin
-    if AWSPrivate = nil
-    then WSPrivate := TWSPrivate
-    else WSPrivate := AWSPrivate;
+var
+  ParentWSNode: PClassNode;
+  CommonClass: TClass;
+  Vvmt, Cvmt, Pvmt: PPointerArray;
+  Cmnt: PMethodNameTable;
+  SearchAddr: Pointer;
+  n, idx: integer;
+  WSPrivate, OrgPrivate: TClass;
+  Processed: array of boolean;
+  VvmtCount, VvmtSize: integer;
+  {$IFDEF VerboseWSRegistration}
+  Indent: string;
+  {$ENDIF}
+begin
+  if AWSPrivate = nil then WSPrivate := TWSPrivate
+  else WSPrivate := AWSPrivate;
 
-    // Determine VMT count and size => http://wiki.freepascal.org/Compiler-generated_data_and_data_structures
-    VvmtCount := 0;
-    Vvmt := Pointer(ANode^.WSClass) + vmtMethodStart; // AWSComponent is equal to ANode^.WSClass;
-    while (Vvmt^[VvmtCount] <> nil) do
-      Inc(VvmtCount);
-    VvmtSize := vmtMethodStart + VvmtCount * SizeOf(Pointer);
+  // Determine VMT count and size => http://wiki.freepascal.org/Compiler-generated_data_and_data_structures
+  VvmtCount := 0;
+  Vvmt := Pointer(ANode^.WSClass) + vmtMethodStart;
+  // AWSComponent is equal to ANode^.WSClass;
+  while (Vvmt^[VvmtCount] <> nil) do
+    Inc(VvmtCount);                                         { ~bk 1 more for nil at end }
+  VvmtSize := vmtMethodStart + VvmtCount * SizeOf(Pointer) + SizeOf(Pointer);
+  if ANode^.VClass = nil then begin
+    ANode^.VClass := GetMem(VvmtSize);
+  end
+  else begin
+    // keep original WSPrivate (only when different than default class)
+    OrgPrivate := PClass(ANode^.VClass + vmtWSPrivate)^;
 
-    if ANode^.VClass = nil
-    then begin
-      ANode^.VClass := GetMem(VvmtSize)
-    end
-    else begin
-      // keep original WSPrivate (only when different than default class)
-      OrgPrivate := PClass(ANode^.VClass + vmtWSPrivate)^;
-      
-      if (OrgPrivate <> nil) and (OrgPrivate <> AOldPrivate) and OrgPrivate.InheritsFrom(WSPrivate)
-      then begin
-        {$IFDEF VerboseWSRegistration}
-        DebugLn('Keep org private: ', WSPrivate.ClassName, ' -> ', OrgPrivate.Classname);
-        {$ENDIF}
-        WSPrivate := OrgPrivate;
-      end;
-    end;
-
-    // Initially copy the WSClass
-    Move(Pointer(ANode^.WSClass)^, ANode^.VClass^, VvmtSize);
-
-    // Set WSPrivate class
-    ParentWSNode := FindParentWSClassNode(ANode);
-    if ParentWSNode = nil
-    then begin
-      // nothing to do
-      PClass(ANode^.VClass + vmtWSPrivate)^ := WSPrivate;
+    if (OrgPrivate <> nil) and (OrgPrivate <> AOldPrivate) and
+      OrgPrivate.InheritsFrom(WSPrivate) then begin
       {$IFDEF VerboseWSRegistration}
-      DebugLn('Virtual parent: nil, WSPrivate: ', PClass(ANode^.VClass + vmtWSPrivate)^.ClassName);
+      DebugLn('Keep org private: ', WSPrivate.ClassName, ' -> ', OrgPrivate.ClassName);
       {$ENDIF}
-      Exit;
+      WSPrivate := OrgPrivate;
     end;
+  end;
 
-    if WSPrivate = TWSPrivate
-    then begin
-      if ParentWSNode^.VClass = nil
-      then begin
-        DebugLN('[WARNING] Missing VClass for: ', ParentWSNode^.WSClass.ClassName);
-        PClass(ANode^.VClass + vmtWSPrivate)^ := TWSPrivate;
-      end
-      else PClass(ANode^.VClass + vmtWSPrivate)^ := PClass(ParentWSNode^.VClass + vmtWSPrivate)^;
-    end
-    else PClass(ANode^.VClass + vmtWSPrivate)^ := WSPrivate;
+  // Initially copy the WSClass
+  Move(Pointer(ANode^.WSClass)^, ANode^.VClass^, VvmtSize);
 
+  // Set WSPrivate class
+  ParentWSNode := FindParentWSClassNode(ANode);
+  if ParentWSNode = nil then begin
+    // nothing to do
+    PClass(ANode^.VClass + vmtWSPrivate)^ := WSPrivate;
     {$IFDEF VerboseWSRegistration}
-    DebugLn('Virtual parent: ', ParentWSNode^.WSClass.ClassName, ', WSPrivate: ', PClass(ANode^.VClass + vmtWSPrivate)^.ClassName);
+    DebugLn('Virtual parent: nil, WSPrivate: ', PClass(ANode^.VClass +
+      vmtWSPrivate)^.ClassName);
     {$ENDIF}
+    Exit;
+  end;
 
-    // Try to find the common ancestor
-    CommonClass := FindCommonAncestor(ANode^.WSClass, ParentWSNode^.WSClass);
-    {$IFDEF VerboseWSRegistration}
-    DebugLn('Common: ', CommonClass.ClassName);
-    Indent := '';
-    {$ENDIF}
+  if WSPrivate = TWSPrivate then begin
+    if ParentWSNode^.VClass = nil then begin
+      DebugLN('[WARNING] Missing VClass for: ', ParentWSNode^.WSClass.ClassName);
+      PClass(ANode^.VClass + vmtWSPrivate)^ := TWSPrivate;
+    end
+    else PClass(ANode^.VClass + vmtWSPrivate)^ :=
+        PClass(ParentWSNode^.VClass + vmtWSPrivate)^;
+  end
+  else PClass(ANode^.VClass + vmtWSPrivate)^ := WSPrivate;
 
-    Vvmt := ANode^.VClass + vmtMethodStart;
-    Pvmt := ParentWSNode^.VClass + vmtMethodStart;
-    SetLength(Processed, VvmtCount);
-    FillChar(Processed[0], SizeOf(Processed), 0);
+  {$IFDEF VerboseWSRegistration}
+  DebugLn('Virtual parent: ', ParentWSNode^.WSClass.ClassName,
+    ', WSPrivate: ', PClass(ANode^.VClass + vmtWSPrivate)^.ClassName);
+  {$ENDIF}
 
-    while CommonClass <> nil do
-    begin
-      Cmnt := PPointer(Pointer(CommonClass) + vmtMethodTable)^;
-      if Cmnt <> nil
-      then begin
+  // Try to find the common ancestor
+  CommonClass := FindCommonAncestor(ANode^.WSClass, ParentWSNode^.WSClass);
+  {$IFDEF VerboseWSRegistration}
+  DebugLn('Common: ', CommonClass.ClassName);
+  Indent := '';
+  {$ENDIF}
+
+  Vvmt := ANode^.VClass + vmtMethodStart;
+  Pvmt := ParentWSNode^.VClass + vmtMethodStart;
+  SetLength(Processed, VvmtCount);
+  FillChar(Processed[0], SizeOf(Processed), 0);
+
+  while CommonClass <> nil do begin
+    Cmnt := PPointer(Pointer(CommonClass) + vmtMethodTable)^;
+    if Cmnt <> nil then begin
+      {$IFDEF VerboseWSRegistration_methods}
+      DebugLn(Indent, '*', CommonClass.ClassName, ' method count: ',
+        IntToStr(Cmnt^.Count));
+      Indent := Indent + ' ';
+      {$ENDIF}
+
+      Cvmt := Pointer(CommonClass) + vmtMethodStart;
+      Assert(Cmnt^.Count < VvmtCount,
+        'MethodTable count is larger than determined VvmtCount');
+
+      // Loop through the VMT to see what is overridden
+      for n := 0 to Cmnt^.Count - 1 do begin
+        SearchAddr := Cmnt^.Entries[n].Addr;
         {$IFDEF VerboseWSRegistration_methods}
-        DebugLn(Indent, '*', CommonClass.Classname, ' method count: ', IntToStr(Cmnt^.Count));
-        Indent := Indent + ' ';
+        DebugLn('%sSearch: %s (%p)', [Indent, Cmnt^.Entries[n].Name^, SearchAddr]);
         {$ENDIF}
 
-        Cvmt := Pointer(CommonClass) + vmtMethodStart;
-        Assert(Cmnt^.Count < VvmtCount, 'MethodTable count is larger than determined VvmtCount');
+        for idx := 0 to VvmtCount - 1 do begin
+          if Cvmt^[idx] = SearchAddr then begin
+            {$IFDEF VerboseWSRegistration_methods}
+            DebugLn('%sFound at index: %d (v=%p p=%p)',
+              [Indent, idx, Vvmt^[idx], Pvmt^[idx]]);
+            {$ENDIF}
 
-        // Loop through the VMT to see what is overridden
-        for n := 0 to Cmnt^.Count - 1 do
-        begin
-          SearchAddr := Cmnt^.Entries[n].Addr;
-          {$IFDEF VerboseWSRegistration_methods}
-          DebugLn('%sSearch: %s (%p)', [Indent, Cmnt^.Entries[n].Name^, SearchAddr]);
-          {$ENDIF}
-
-          for idx := 0 to VvmtCount - 1 do
-          begin
-            if Cvmt^[idx] = SearchAddr
-            then begin
+            if Processed[idx] then begin
               {$IFDEF VerboseWSRegistration_methods}
-              DebugLn('%sFound at index: %d (v=%p p=%p)', [Indent, idx, Vvmt^[idx], Pvmt^[idx]]);
+              DebugLn(Indent, 'Processed -> skipping');
               {$ENDIF}
+              Break;
+            end;
+            Processed[idx] := True;
 
-              if Processed[idx]
-              then begin
-                {$IFDEF VerboseWSRegistration_methods}
-                DebugLn(Indent, 'Processed -> skipping');
-                {$ENDIF}
-                Break;
-              end;
-              Processed[idx] := True;
-
-              if  (Vvmt^[idx] = SearchAddr)  //original
+            if (Vvmt^[idx] = SearchAddr)  //original
               and (Pvmt^[idx] <> SearchAddr) //overridden by parent
-              then begin
-                {$IFDEF VerboseWSRegistration_methods}
-                DebugLn('%sUpdating %p -> %p', [Indent, Vvmt^[idx], Pvmt^[idx]]);
-                {$ENDIF}
-                Vvmt^[idx] := Pvmt^[idx];
-              end;
-
-              Break;
-            end;
-            if idx = VvmtCount - 1
             then begin
-              DebugLn('[WARNING] VMT entry "', Cmnt^.Entries[n].Name^, '" not found in "', CommonClass.ClassName, '"');
-              Break;
+              {$IFDEF VerboseWSRegistration_methods}
+              DebugLn('%sUpdating %p -> %p', [Indent, Vvmt^[idx], Pvmt^[idx]]);
+              {$ENDIF}
+              Vvmt^[idx] := Pvmt^[idx];
             end;
+
+            Break;
           end;
+          if idx = VvmtCount - 1 then begin
+            DebugLn('[WARNING] VMT entry "', Cmnt^.Entries[n].Name^,
+              '" not found in "', CommonClass.ClassName, '"');
+            Break;
+          end;
         end;
       end;
-      CommonClass := Commonclass.ClassParent;
     end;
+    CommonClass := Commonclass.ClassParent;
+  end;
 
-    // Adjust classname
-    ANode^.VClassName := '(V)' + ANode^.WSClass.ClassName;
-    PPointer(ANode^.VClass + vmtClassName)^ := @ANode^.VClassName;
-    // Adjust classparent
-    {$IF (FPC_FULLVERSION >= 30101)}
-    PPointer(ANode^.VClass + vmtParent)^ := @ParentWSNode^.WSClass;
-    {$ELSE}
-    PPointer(ANode^.VClass + vmtParent)^ := ParentWSNode^.WSClass;
-    {$ENDIF}
-    // Delete methodtable entry
-    PPointer(ANode^.VClass + vmtMethodTable)^ := nil;
+  // Adjust classname
+  ANode^.VClassName := '(V)' + ANode^.WSClass.ClassName;
+  PPointer(ANode^.VClass + vmtClassName)^ := @ANode^.VClassName;
+  // Adjust classparent
+  {$IF (FPC_FULLVERSION >= 30101)}
+  PPointer(ANode^.VClass + vmtParent)^ := @ParentWSNode^.WSClass;
+  {$ELSE}
+  PPointer(ANode^.VClass + vmtParent)^ := ParentWSNode^.WSClass;
+  {$ENDIF}
+  // Delete methodtable entry
+  PPointer(ANode^.VClass + vmtMethodTable)^ := nil;
+end;
+
+// ANewRegistration - If true, VClass is not created during runtime,
+// but instead normal, Object Pascal class creation is used
+procedure RegisterWSComponent(const AComponent: TComponentClass;
+  const AWSComponent: TWSLCLComponentClass;
+  const AWSPrivate: TWSPrivateClass = nil;
+  const ANewRegistration: Boolean = False);
+
+  { Get note is recursive, we want to detect if a new node may be an
+    un registered intermediate in the enacestor class tree }
+  function GetNode(const AClass: TClass; aParentGet: boolean; aLeaf: boolean): PClassNode;
+  var
+    idx: Integer;
+    OldCount: integer;
+    lParentNode : PClassNode;
+    lClassNode : TClassNode; { A temp local node to fake normal processing
+                               of a node that won't be stored aParentGet = 0
+                               and TWSLCLComponentClass = nil }
+    lInsertNode : boolean;   { Indicator that New(Result) has been requested }
+  begin
+    if (AClass = nil)
+      or not (AClass.InheritsFrom(TLCLComponent))
+    then begin
+      Result := nil;
+      Exit;
+    end;
+
+    if not WSClassesList.Search(AClass, idx) then begin
+      if not aParentGet and (AWSComponent = nil) then begin
+        lInsertNode := False;
+        Result := @lClassNode;
+      end
+      else begin
+        lInsertNode := True;
+        New(Result);
+      end;
+      Result^.LCLClass := TComponentClass(AClass);
+      Result^.WSClass := nil;
+      Result^.VClass := nil;
+      Result^.VClassName := '';
+      Result^.VClassNew := aParentGet;
+      Result^.Child := nil;
+      lParentNode := GetNode(AClass.ClassParent, True, False);
+      Result^.Parent := lParentNode;
+      { Unregistered Intermediate nodes are patched with the parent information }
+      if aParentGet then begin
+        Result^.WSClass := lParentNode^.WSClass;
+        Result^.VClass := lParentNode^.VClass;
+        PPointer(Result^.VClass + vmtWSPrivate)^ := PPointer(lParentNode^.VClass + vmtWSPrivate)^;
+        // Build a VClassName
+        if aLeaf then
+          { Node that has an empty WSRegisterClass procedure }
+          Result^.VClassName := '(L)' + Result^.WSClass.ClassName
+        else
+          { Internal node needed for tree consistency }
+          Result^.VClassName := '(I)' + Result^.WSClass.ClassName
+      end;
+      if lParentNode = nil then begin
+        Result^.Sibling := nil;
+        if aLeaf then
+          Result^.VClassName := '(ROOT)' + AClass.ClassName
+      end
+      else begin
+        if lInsertNode then begin
+          Result^.Sibling := lParentNode^.Child;
+          lParentNode^.Child := Result;
+        end
+        else
+          Result^.Sibling := nil;
+      end;
+      if lInsertNode then begin
+        WSClassesList.Search(aClass, idx);
+        WSClassesList.Insert(idx, Result);
+      end
+      else
+        Result := nil;
+    end
+    else begin
+      Result := WSClassesList[idx];
+    end;
   end;
 
   procedure UpdateChildren(const ANode: PClassNode; AOldPrivate: TClass);
@@ -432,7 +509,7 @@
         {$IFDEF VerboseWSRegistration}
         DebugLn('Update VClass for: ', Node^.WSClass.ClassName);
         {$ENDIF}
-        CreateVClass(Node, AOldPrivate);
+        CreateVClass(Node, AWSPrivate, AOldPrivate);
       end;
       UpdateChildren(Node, AOldPrivate);
       Node := Node^.Sibling;
@@ -442,34 +519,33 @@
 var
   Node: PClassNode;
   OldPrivate: TClass;
+  idx: Integer;
 begin
-  if MWSRegisterIndex = nil then
-    DoInitialization;
-  Node := GetNode(AComponent);
-  if Node = nil then Exit;
+  Node := GetNode(AComponent, False or ANewRegistration, True);
+  if Node = nil then // No node created
+    Exit;
 
-  if Node^.WSClass = nil
-  then MWSRegisterIndex.AddObject(AComponent.ClassName, TObject(Node));
-  Node^.WSClass := AWSComponent;
-
   if ANewRegistration then
-  begin
-    Node^.VClass := AWSComponent;
-    Node^.VClassNew := True;
     Exit;
-  end;
 
+  { If AWSComponent specified but node already exists, nothing more to do. }
+  if Assigned(AWSComponent) and (Node^.WSClass = AWSComponent) then
+    Exit;
+
+  Node^.WSClass := AWSComponent;
+
   // childclasses "inherit" the private from their parent
   // the child privates should only be updated when their private is still
   // the same as their parents
-  if Node^.VClass = nil
-  then OldPrivate := nil
-  else OldPrivate := PClass(Node^.VClass + vmtWSPrivate)^;
+  if Node^.VClass = nil then
+    OldPrivate := nil
+  else
+    OldPrivate := PClass(Node^.VClass + vmtWSPrivate)^;
 
   {$IFDEF VerboseWSRegistration}
   DebugLn('Create VClass for: ', AComponent.ClassName, ' -> ', Node^.WSClass.ClassName);
   {$ENDIF}
-  CreateVClass(Node);
+  CreateVClass(Node, AWSPrivate);
 
   // Since child classes may depend on us, recreate them
   UpdateChildren(Node, OldPrivate);
@@ -495,84 +571,167 @@
   WSLazDeviceAPIsClass := AWSObject;
 end;
 
-{ TWSLCLComponent }
+function FindWSRegistered(const AComponent: TComponentClass): TWSLCLComponentClass;
+begin
+  if not Assigned(WSClassesList) then
+    DoInitialization;
+  Result := WSClassesList.FindWSClass(AComponent);
+end;
 
-class function TWSLCLComponent.WSPrivate: TWSPrivateClass; //inline;
+{$IFDEF VerboseWSBrunoK}
+procedure DumpWSClassesList;
 begin
-  Result := TWSPrivateClass(PClass(Pointer(Self) + vmtWSPrivate)^);
+  WSClassesList.DumpNodes;
 end;
+{$ENDIF}
 
-{ TWSLCLHandleComponent }
+{ TWSClassesList }
 
-class procedure TWSLCLReferenceComponent.DestroyReference(AComponent: TComponent);
+function TWSClassesList.Get(Index: integer): PClassNode;
 begin
+  Result := PClassNode(inherited Get(Index));
 end;
 
-procedure DoInitialization;
+function TWSClassesList.FindWSClass(
+  const AComponent: TComponentClass): TWSLCLComponentClass;
+var
+  I: integer;
 begin
-  MComponentIndex := TStringList.Create;
-  MComponentIndex.Sorted := True;
-  MComponentIndex.Duplicates := dupError;
+  {$IFDEF VerboseWSBrunoK} Write('Searching ', AComponent.ClassName); {$ENDIF}
+  if Search(AComponent, i) then begin
+    Result := TWSLCLComponentClass(Items[i]^.VClass);
+    {$IFDEF VerboseWSBrunoK} WriteLn(' -> FOUND'); {$ENDIF}
+    Exit;
+  end;
+  {$IFDEF VerboseWSBrunoK} WriteLn(' -> NOT FOUND'); {$ENDIF}
+  Result := nil;
+end;
 
-  MWSRegisterIndex := TStringList.Create;
-  MWSRegisterIndex.Sorted := True;
-  MWSRegisterIndex.Duplicates := dupError;
+{ Searches a match for AComponent.ClassType. Returns index in items of
+  the matching AComponent or the next bigger one }
+function TWSClassesList.Search(const aItem: TClass; out Index: integer
+  ): boolean;
+const
+  cIndex: integer = 0;
+var
+  L, R: integer;
+  lLCLClass: TClass;
+  lPClassNode: PClassNode;
+begin
+  L := 0;
+  R := Count - 1;
+  // Use binary search.
+  if R >= 0 then begin
+    if Pointer(aItem) = Pointer(FLastFoundLCLClass) then begin
+      Index := FLastFoundIdx;
+      Exit(True);
+    end;
+    while (L <= R) do begin
+      Index := L + ((R - L) div 2);
+      lLCLClass := PClassNode(List^[Index])^.LCLClass;
+      if Pointer(aItem) < Pointer(lLCLClass) then
+        R := Index - 1
+      else begin
+        if aItem = lLCLClass then begin
+          FLastFoundIdx := Index;
+          FLastFoundLCLClass := TComponentClass(lLCLClass);
+          Exit(True);
+        end;
+        L := Index + 1;
+      end;
+    end;
+  end;
+  Index := L;
+  Result := False;
 end;
 
-{$ifdef VerboseWSRegistration_treedump}
-procedure DumpVTree;
-  procedure DumpNode(ANode: PClassNode; AIndent: String = '');
-  begin
-    if ANode = nil then Exit;
+{$IFDEF VerboseWSBrunoK}
+procedure TWSClassesList.DumpNode(aN: integer; aPClassNode: PClassNode);
+var
+  LCLClassClassName, lWSClassClassName, lVClassName, ParentVClassName: string;
+  lClassNode : PClassNode;
+begin
+  with aPClassNode^ do begin
+    if Assigned(LCLClass) then
+      LCLClassClassName := LCLClass.ClassName
+    else
+      LCLClassClassName := '???';
+    if Assigned(WSClass) then
+      lWSClassClassName := WSClass.ClassName
+    else
+      lWSClassClassName := '???';
+    if Assigned(VClass) then
+      lVClassName := TClass(VClass).ClassName
+    else
+      lVClassName := '???';
+    if Assigned(Parent) and  Assigned(PClassNode(Parent)^.WSClass) then
+      ParentVClassName := PClassNode(Parent)^.WSClass.ClassName
+    else
+      ParentVClassName := '???';
+    writeln(
+      aN, ';',
+      { DbgCreateSeq, ';', }
+      HexStr(aPClassNode), ';',
+      HexStr(LCLClass), ';',  // : TComponentClass;
+      LCLClassClassName, ';',
+      HexStr(WSClass), ';', // : TWSLCLComponentClass;
+      lWSClassClassName, ';',
+      HexStr(VClass), ';', // : Pointer;
+      VClassName, ';',
+      // VVmtCount, ';',
+      lVClassName, ';',
+      VClassNew, ';',    // : Boolean;
+      HexStr(Parent), ';', // Parent: PClassNode;
+      ParentVClassName, ';', // ShortString;
+      HexStr(Child), ';',   // Child: PClassNode;
+      HexStr(Sibling)  // Sibling: PClassNode;
+      );
+  end;
+end;
 
-    DbgOut(AIndent);
+procedure TWSClassesList.DumpNodes;
+var
+  i: integer;
+begin
+  WriteLn('n;',          // aN, ';',
+    { 'CreateSeq;',        // DbgCreateSeq, ';', }
+    'PClassNode;',        // Node
+    'LCLClass;',         // HexStr(LCLClass), ';',  // : TComponentClass;
+    'LCLClassName;',     // LCLClassClassName, ';',
+    'WSClass;',          // HexStr(WSClass), ';', // : TWSLCLComponentClass
+    'WSClassName;',      // lWSClassClassName, ';',
+    'VClass;',           // HexStr(VClass), ';', // : Pointer;
+    'VClassName;',       // VClassName
+  {  'VVmtCount', }      // VVmtCount, ';',
+    'VClassName;',       // lVClassName, ';',
+    'VClassNew;',        // VClassNew,           ';',  // : Boolean;
+    'Parent;',           // HexStr(Parent), ';', // Parent: PClassNode;
+    'Parent.Name;',      // ParentClassName, ';', // ShortString;
+    'Child;',            // HexStr(Child), ';',   // Child: PClassNode;
+    'Sibling'            // HexStr(Sibling)  // Sibling: PClassNode;
+    );
+  for i := 0 to Count - 1 do
+    DumpNode(i, PClassNode(Items[i]));
+end;
+{$ENDIF}
 
-    DbgOut('LCLClass=');
-    if ANode^.LCLClass = nil
-    then DbgOut('nil')
-    else DbgOut(ANode^.LCLClass.Classname);
+{ TWSLCLComponent }
 
-    DbgOut(' WSClass=');
-    if ANode^.WSClass = nil
-    then DbgOut('nil')
-    else DbgOut(ANode^.WSClass.Classname);
+class function TWSLCLComponent.WSPrivate: TWSPrivateClass; //inline;
+begin
+  Result := TWSPrivateClass(PClass(Pointer(Self) + vmtWSPrivate)^);
+end;
 
-    DbgOut(' VClass=');
-    if ANode^.VClass = nil
-    then DbgOut('nil')
-    else begin
-      DbgOut(TClass(ANode^.VClass).Classname);
-      DbgOut(' VClass.Parent=');
-      if TClass(ANode^.VClass).ClassParent = nil
-      then DbgOut('nil')
-      else DbgOut(TClass(ANode^.VClass).ClassParent.ClassName);
-      
-      DbgOut(' Private=');
-      if PClass(ANode^.VClass + vmtWSPrivate)^ = nil
-      then DbgOut('nil')
-      else DbgOut(PClass(ANode^.VClass + vmtWSPrivate)^.ClassName);
-    end;
+{ TWSLCLHandleComponent }
 
-    DbgOut(' VClassName=''', ANode^.VClassName, '''');
-    DebugLn;
+class procedure TWSLCLReferenceComponent.DestroyReference(AComponent: TComponent);
+begin
+end;
 
-    DumpNode(ANode^.Child, AIndent + ' ');
-
-    DumpNode(ANode^.Sibling, AIndent);
-  end;
-
-var
-  n: Integer;
-  Node: PClassNode;
+procedure DoInitialization;
 begin
-  for n := 0 to MComponentIndex.Count - 1 do
-  begin
-    Node := PClassNode(MComponentIndex.Objects[n]);
-    if Node^.Parent = nil
-    then DumpNode(Node);
-  end;
+  WSClassesList := TWSClassesList.Create;
 end;
-{$endif}
 
 procedure DoFinalization;
 var
@@ -579,19 +738,24 @@
   n: Integer;
   Node: PClassNode;
 begin
-  {$ifdef VerboseWSRegistration_treedump}
-  DumpVTree;
-  {$endif}
-
-  for n := 0 to MComponentIndex.Count - 1 do
+  {$IFDEF VerboseWSBrunoK}
+  WSClassesList.DumpNodes;
+  WriteLn;
+  WriteLn('cWSLCLDirectHit=', cWSLCLDirectHit,
+          ' cWSLCLParentHit=', cWSLCLParentHit,
+          ' cWSLCLRegister=', cWSLCLRegister);
+  {$ENDIF}
+  for n := 0 to WSClassesList.Count - 1 do
   begin
-    Node := PClassNode(MComponentIndex.Objects[n]);
+    Node := WSClassesList[n];
     if (Node^.VClass <> nil) and (not Node^.VClassNew) then
       Freemem(Node^.VClass);
     Dispose(Node);
   end;
-  FreeAndNil(MComponentIndex);
-  FreeAndNil(MWSRegisterIndex);
+  FreeAndNil(WSClassesList);
+  {$IFDEF VerboseWSBrunoK}
+  Write('Press enter to quit > '); ReadLn;
+  {$ENDIF}
 end;
 
 
LCLComponent_V1.patch (36,090 bytes)   

Juha Manninen

2020-07-18 23:38

developer   ~0124157

I haven't tested this yet. Some notes:

If I understand right the ZIP files are redundant. It is enough to upload a patch. Anybody can apply it and see whole source files.
Why is it split into 2 patch files (Registered.patch, LCLComponent_V1.patch)? All changes can be in one patch file.

Is the speed difference noticeable? Did you profile the code somehow?

BrunoK

2020-07-19 16:59

reporter   ~0124170

Last edited: 2020-07-19 17:00

View 2 revisions

> If I understand right the ZIP files are redundant. It is enough to upload a patch. Anybody can apply it and see whole source files.
Yes they are redundant.

> Why is it split into 2 patch files (Registered.patch, LCLComponent_V1.patch)? All changes can be in one patch file.
They are independent. You can apply one or the other one or both as you like.
- The Registered.patch just adds skipping inherited and calls to RegisterPropertyToSkip for the 3 units after their first registration. Once a class registers, its parent classes are already registered, it makes no sense to attempt to register the parent classes again via inherited every time newinstance is called. On the lazarus I used to test, (see above for numbers) in the current trunk, the WSREGISTERCLASS is uselessly called ~ 2'800 times. Cutting re-registration visibly (codewise) speeds things up.

- The LCLComponent_V1.patch changes the logic order of WSREGISTER class.
  It first attempts to find the WidgetSetClass for the new instance in the WSLCLClasses list WSClassesList.
  WSClassesList is ordered by TClassType (pointer) and that is undeniably faster than handling a list sorted by ClassName.
  Finding Self.ClassType or ClassParent's WidgetSetClass happens 96% times a TLCLComponent descendant is created.

  If the WidgetSetClass was not found, then WSREGISTERCLASS is called (4%) and some adjustments are done to the WSClassesList to take into account the fact some TLCLComponent's declare WSREGISTERCLASS but actually do not register anything (For ex. TCustomControl in win32) and use the inherited WidgetSetClass. To be able to use the parent WidgetSetClass it has to be stored (without a copy of the synthetized VMT) in the WidgetSetClass tree.

As for speed I think I sensed faster creation of tabs in the component palette that are created when switching tabs. Improvement should be more visible on slow machines and Frames with many fields.

BrunoK

2020-07-20 17:14

reporter   ~0124191

> Is the speed difference noticeable? Did you profile the code somehow?

Done :

Menu Tools + Options -> Cancel -> Quit

Trunk
=====
Total=2671
CPU speed 3.696 GHz
Total time in NewInstance=45.543 ms.

Trunk + Registered.patch
========================
Total=2671
CPU speed 3.696 GHz
Total time in NewInstance=21.307 ms.

LCLComponent_V1.patch
=====================
cWSLCLDirectHit=1005 cWSLCLParentHit=1602 cWSLCLRegister=65 Total=2672
CPU speed 3.696 GHz
Total time in NewInstance=1.611 ms.

LCLComponent_V1.patch + Registered.patch
========================================
cWSLCLDirectHit=1006 cWSLCLParentHit=1602 cWSLCLRegister=65 Total=2673
CPU speed 3.696 GHz
Total time in NewInstance=.997 ms.

Juha Manninen

2020-07-22 10:52

developer   ~0124223

It seems to work. I applied the patches in r63619. Thanks!

However this optimization tweaks the current VClass hack and must be considered temporary. The hack pokes the implementation details of virtual method table. Among other things it prevents LCL to compile with -CR flag.
The long term plan is to get rid of the hack. It has been discussed many times in Lazarus devel mailing list. It should be discussed in the public mailing list or in forum.
It could be implemented using a branch in one of Lazarus Git mirrors.
BrunoK, are you interested to work with it or at least discuss the choises?

BrunoK

2020-07-22 12:57

reporter   ~0124227

> Among other things it prevents LCL to compile with -CR flag.
This one seems tricky because there is a double inheritance tree that is not natural to Delphi/FPC. Anyway if something comes to mind I'll mention it in Lazarus » Forum » Programming » LCL.
I find using the mailing list unpractical.

Juha Manninen

2020-07-22 14:53

developer   ~0124229

> This one seems tricky because there is a double inheritance tree that is not natural to Delphi/FPC.

Exactly. It is not natural because it is a hack. A proper solution could use interfaces, RTTI or some proxy in-between class.

> Anyway if something comes to mind I'll mention it in Lazarus » Forum » Programming » LCL.

Ok, I will add a summary of ideas and code done so far. To be continued in the forum...
Resolving this one.

Martin Friebe

2020-07-29 01:22

manager   ~0124372

Last edited: 2020-07-29 01:36

View 2 revisions

I am reopening for some more discussion.
Sorry I am a bit late.

Reason
There are some issues caused, and there may be potential for more.

---

1) In NewInstance:
Calling FindWSRegistered before/instead GetWSComponentClass means that WSRegisterClass is not called. 0037435


2) Do we need to walk the VMT?
That always has some danger to it. Even though in this case it is unlikely. But it depends how well (future) fpc is at de-virtualization (it already can do that in some cases, using WPO).
If the method is de-virtualized, then its not in the table, and the loop runs forever.
Yes, as of today, not likely, but since there are alternatives, why go the "hackish way"?

pointer(TMethod(@self.ClassParent.WSRegisterClass).COde))
should give the parents address.
That could be compared.

3)
This one is unlikely (or could be prevented by documenting that WSRegisterClass must not be used in such way)

Also going directly to the parent might break, if ever a parent would register for its children (ore the other way round)
If:
- TFOO registers for WSFoo AND WsFooParent
=> FooParent has no WSRegisterClass and could be skipped incorrectly

If I understand the code correctly, then when a class gets searched the first time, entries are created for the class and each and every parent. (no gaps)
In that case, only the first search needs to search more than "self". A
No further search (per class) need to recurse in GetWSComponentClass.
Is skipping some parents, within that one-time-only recursion really that big a deal?

The difference is that a few more classes will be added into the list. But it does a binary search, this will hardly matter.


---
And, yes: I know there is pre-existing VMT walking (and modifying) code. Maybe one day it can go.....

Bart Broersma

2020-07-29 10:59

developer   ~0124379

Last edited: 2020-07-29 11:00

View 3 revisions

The changes in r63619 cause 0037435.

Juha Manninen

2020-07-29 11:26

developer   ~0124381

Martin, how would you fix the issues? You apparently studied the code thoroughly. In the worst case scenario we must revert the change but I hope it is not necessary. It has good ideas.

Martin Friebe

2020-07-29 12:03

manager   ~0124382

It is at
@BrunoK

The questions only cover a small part of the patch.

From code review (not tested)

reduce
TLCLComponent.NewInstance
to

begin
  Result := inherited NewInstance;
  TLCLComponent(Result).FWidgetSetClass := GetWSComponentClass(TLCLComponent(Result));
end;

The remainder is an optimization, that I doubt has much impact. (not measured myself)

------------------------
Not related to the issue, the code using "cWSRegisterOffset" can be rewritten in a much cleaner way (without any loss of optimization / rather even with a theoretical gain.

However I am doubtful this code is adding much speed gain.
It has a very tiny slight (probably just theoretical) risk of future breakage.

If indeed it gains relevant performance, it can be kept - but rewritten. Otherwise I would ask for it to go.

-------------------
There a big changes in WSLclClasse. I have not fully reviewed them, but I have not yet noted any issue. So they are unaffected by the 2 points above.

Martin Friebe

2020-07-29 12:24

manager   ~0124384

Ok, that alone does not fix it. Best if Bruno has a look.

I added rev 63666 => the list was only initialized, if you did a search before the first register. (And there should be no need to search the empty list)

Martin Friebe

2020-07-29 12:50

manager   ~0124388

I fixed the other issue in 63667. Old code for some reason registered FontDialog in a diff manner.

This diff, appears to stem from rev 55119
vclass: Starts prototype demonstrating how to eliminate vclass

I could not find other such calls within our svn code. I do not know about any other code.

---
I have not spent enough time to confirm, but it may well be that in
procedure RegisterWSComponent(const AComponent: TComponentClass;
                              const AWSComponent: TWSLCLComponentClass;
                              const AWSPrivate: TWSPrivateClass = nil;
                              const ANewRegistration: Boolean = False);

the value "ANewRegistration" has gotten a new purpose?
Since it now seems to be used for creating "fill entries for gaps"?

BrunoK

2020-07-29 14:02

reporter   ~0124392

> the value "ANewRegistration" has gotten a new purpose?
I have given it the purpose that I thought it meant. Previously it was always false and there were 2 lists. I concentrated both list into a single one so had to keep information on whether to free the synthesized VClass.

> Since it now seems to be used for creating "fill entries for gaps"?
Yes the WSClassList holds a tree with the following rules :
  VClass is only created when WS<WidgetSet><Control> calls RegisterWSComponent
  Leafs, for example, TButton that are just publishing properties of the parent TCustomButton use the ParentNode inherited VClass and do not create a VClass themselves (no change here).
  Internal nodes, that, like TCustomControl, are not RegisterWSComponent'ed get a internal PClassNode with full inheritance but no VClass member.

As for getting rid of the VClass it seems quite difficult since there is a artificial "WSPrivate" virtual field that is stored and must be modifiable (data segment). I was also after -CR flag, but I think it is not possible to implement it without changes (minor) to FPC. You get an idea of the changes I tried with some success in "https://forum.lazarus.freepascal.org/index.php/topic,50728.0.html"

Martin Friebe

2020-07-29 16:08

manager   ~0124398

Last edited: 2020-07-29 16:09

View 2 revisions

From a glance at svn blame, I think ANewRegistration was introduced for an (failed) attempt at removing VClass. And True was passed in for the font dialog.

----------------------
Anyway, the may questions now are:

In
TLCLComponent.NewInstance
TLCLComponent.GetWSComponentClass

Do we need to check ParentClass and skip it under some circumstances?
If it at best saves a few searches (binary searches, real quick) during the first (and only the first) time a class is instantiated.


If we need it, can we use
pointer(TMethod(@self.ClassParent.WSRegisterClass).COde))
instead of
procedure UpdateOffset; // search vmt index
?

IMHO the following draft should be enough

class function TLCLComponent.NewInstance: TObject;
var
  lWidgetSetClass: TWSLCLComponentClass;
begin
  Result := inherited NewInstance;

    { Look if already registered. If true set FWidgetSetClass and exit }
    lWidgetSetClass := FindWSRegistered(Self);
    if Assigned(lWidgetSetClass) then begin
      TLCLComponent(Result).FWidgetSetClass := lWidgetSetClass;
      {$IFDEF VerboseWSBrunoK} inc(cWSLCLDirectHit); {$ENDIF}
      Exit;
    end;

// not yet registered
  { WSRegisterClass and manage WSLVLClasses list }
  TLCLComponent(Result).FWidgetSetClass := GetWSComponentClass(TLCLComponent(Result));
  {$IFDEF VerboseWSBrunoK} inc(cWSLCLRegister); {$ENDIF}
end;


The search before calling registration should be ok.
I can't really find a plausible case where it would break something.

------------
Have to check the parent checking in GetWSComponentClass

Juha Manninen

2020-07-29 20:53

developer   ~0124402

Last edited: 2020-07-29 21:41

View 2 revisions

> ANewRegistration was introduced for an (failed) attempt at removing VClass.

What more, it was not a well designed addition. Procedure RegisterWSComponent did a very different thing when ANewRegistration was True.
I refactored it out into a new procedure. See r63670 and r63671.
Now that the font dialog got fixed, this new procedure (former ANewRegistration=True) is called only from class function TLCLComponent.GetWSComponentClass(). Nowhere else.

> I added rev 63666 => the list was only initialized, if you did a search before the first register.

@Martin, in what situation it was not initialized? Here locally I replaced your code with :
  Assert(Assigned(WSClassesList), 'RegisterWSComponent: WSClassesList=Nil');
and tested for some time. It has never triggered so far.

Martin Friebe

2020-07-29 23:45

manager   ~0124406

> the list was only initialized,
Actually in the current code, it is never. Because there always is a search first. I realized that later only.
(It happened when I tried to simplify NewInstance.)

But if I had further optimized it, and done the
  if cWSRegisterOffset = 0 then begin
first in
  NewInstance
then it would have broke too.

"cWSRegisterOffset = 0" means nothing was added yet, so I could skip the search, and go adding directly. (But adding a class, without ever have searched, will trigger the issue (kind of unexpected)

Martin Friebe

2020-08-02 15:12

manager   ~0124494

Last edited: 2020-08-02 15:14

View 2 revisions

I have uploaded a series of proposed changes.
https://github.com/User4martin/lazarus/compare/mfr-register-ws-class-search

1st commit)
As I indicated searching the parent class instead of self (based on the equality of the VMT entry for RegisterWSComponent) does not make sense.

- The Parent may equally be a miss, as RegisterWSComponent could be further up.
  Doing this "parent search" would require to do it in a loop, until the parent that actually has RegisterWSComponent is found.
  Such a loop is a linear search, better to hand it to the binary search in FindWSRegistered

- This may add a few nodes to WSClassesList:
  Not expensive in the light of a binary search.
  Removes an "if conditional" for all subsequent searches
  Improves readability

2nd commit)
WSRegisterClass is likely to register a parent class (TCustom....)
Searching after it without doing the "RegisterNewWSComp(Self)" is likely to be unsuccessful.
Also "RegisterNewWSComp(Self)" can return the result, at no extra cost.
And if the node exists, doing "RegisterNewWSComp(Self)" instead of "FindWSRegistered" is almost the same cost too.

3rd commit)
Optional.
Registration is only needed, if the WidgetSetClass is actually needed.
This is of no benefit for now. But if any LCLComponent in future decided that it does not need a WidgetSetClass (e.g. a custom dialog), then it could overwrite this.

Juha Manninen

2020-08-02 22:25

developer   ~0124519

I tested the GitHub branch. It seems to work.
BTW, my Assert() in RegisterWSComponent still works with it, WSClassesList is always assigned.
The patches reduce code which is always nice. I believe it got still faster, too. Please commit to Lazarus trunk at some point.

Martin Friebe

2020-08-03 00:40

manager   ~0124520

Will do in a few days... Well the first two commits. Moving to property, will not work for "RegisterPropertyToSkip" calls, they must be in NewInstance.

BrunoK

2020-08-04 10:19

reporter   ~0124537

Improved (I hope) patch on r63671.

LCLClasses : moved some code to WSLCLClasses where it should be handled in a better way.
WSLCLClasses : Managed call to WSRegisterClass. Some renaming of utility list and variables. Solves 0037407: Patch of r63619 breaks Lazarus startup, more tolerant to the way Registering is done.
Miscellaneous units : Added inherited WSRegisterClass / registered cuts to appropriate WSControl descendants.
LCL+WS+MiscComps.patch (26,851 bytes)   
Index: lcl/include/customcontrol.inc
===================================================================
--- lcl/include/customcontrol.inc	(revision 63672)
+++ lcl/include/customcontrol.inc	(working copy)
@@ -79,9 +79,14 @@
 end;
 
 class procedure TCustomControl.WSRegisterClass;
+const
+  Registered : boolean = False;
 begin
+  if Registered then
+    Exit;
   inherited WSRegisterClass;
   RegisterCustomControl;
+  Registered := True;
 end;
 
 {------------------------------------------------------------------------------
Index: lcl/include/scrollingwincontrol.inc
===================================================================
--- lcl/include/scrollingwincontrol.inc	(revision 63672)
+++ lcl/include/scrollingwincontrol.inc	(working copy)
@@ -231,9 +231,14 @@
 end;
 
 class procedure TScrollingWinControl.WSRegisterClass;
+const
+  Registered : boolean = False;
 begin
+  if Registered then
+    Exit;
   inherited WSRegisterClass;
   RegisterScrollingWinControl;
+  Registered := True;
 end;
 
 procedure TScrollingWinControl.ScrollBy(DeltaX, DeltaY: Integer);
Index: lcl/lclclasses.pp
===================================================================
--- lcl/lclclasses.pp	(revision 63672)
+++ lcl/lclclasses.pp	(working copy)
@@ -19,7 +19,7 @@
 
 {$mode objfpc}{$H+}
 
-{ Add -dVerboseWSBrunoK switch to compile with $DEFINE VerboseWSBrunoK }
+{.$DEFINE RDTSCBenchmarking}
 
 interface
 
@@ -87,15 +87,21 @@
 
 implementation
 
+{$IFDEF RDTSCBenchmarking}
 uses
-  InterfaceBase;
-
+  SysUtils,
+  uRDTSC in 'D:\fpc-laz\Lazarus\bk_test\LazForum\urdtsc.pas';
 const
-  cWSRegisterOffset : integer = 0; // Offset of WSRegisterClass in class virtual methods
-  cLCLComponentWSReg : CodePointer = nil; // Adress of TLCLComponent.WSRegisterClass
+  BenchmarkTotalTicks : QWord = 0;
 
-type
-  TLCLComponentClass = class of TLCLComponent;
+procedure OnWSLCLFinalize;
+begin
+  WriteLn;
+  Writeln(FormatFloat('CPU speed #0.000', 1 / (1000000 * CpuClockPeriod)) : 6,' GHz ');
+  Writeln('Total time in NewInstance=',RdtscElapsed(0, BenchmarkTotalTicks));
+  Write('Press enter to quit > '); ReadLn;
+end;
+{$ENDIF}
 
 function WSRegisterLCLComponent: boolean;
 begin
@@ -103,70 +109,28 @@
   Result := True;
 end;
 
+const
+  cLCLComponentRegistered : boolean = false;
+
 class procedure TLCLComponent.WSRegisterClass;
-const
-  Registered : boolean = False;
 begin
-  if Registered then
+  if cLCLComponentRegistered then
     Exit;
+  WSDoInitialization(@TLCLComponent.WSRegisterClass);
+  {$IFDEF RDTSCBenchmarking}
+  CheckCpuSpeed;
+  WSLCLClasses.OnFinalize := @OnWSLCLFinalize;
+  {$ENDIF}
   WSRegisterLCLComponent;
-  Registered := True;
+  cLCLComponentRegistered := True;
 end;
 
-procedure UpdateOffset;
-var
-  lWSRegisterProc : CodePointer;
-  lPPtrArray : PPointerArray;
-  I : integer;
-begin
-  cLCLComponentWSReg := @TLCLComponent.WSRegisterClass;
-  lPPtrArray := Pointer(TLCLComponent);
-  I := 0;
-  while lPPtrArray^[i]<>cLCLComponentWSReg do
-    inc(i);
-  cWSRegisterOffset := I * SizeOf(Pointer);
-end;
-
 { This method allows descendents to override the FWidgetSetClass, handles
   registration of the component in WSLVLClasses list of components. It is only
   called if there wasn't a direct or parent hit at the beginining of NewInstance. }
 class function TLCLComponent.GetWSComponentClass(ASelf: TLCLComponent): TWSLCLComponentClass;
-var
-  lPSelfWSReg,
-  lPSelfParentWSReg : CodePointer;
-  lClassParent : TLCLComponentClass;
 begin
-  if cWSRegisterOffset = 0 then begin
-    UpdateOffset;
-    TLCLComponent.WSRegisterClass;  { Always create the top node ! }
-  end;
-
-  WSRegisterClass;
   Result := FindWSRegistered(Self);
-  if Result <> nil then
-    Exit;
-
-  lClassParent := TLCLComponentClass(ClassParent);
-  lPSelfWSReg := PCodePointer(Pointer(Self) + cWSRegisterOffset)^;
-  lPSelfParentWSReg := PCodePointer(Pointer(lClassParent) + cWSRegisterOffset)^;
-
-  { Self.ComponentClass didn't register itself but the parent should now be registered }
-  repeat
-    if lPSelfWSReg = lPSelfParentWSReg then begin
-      Result := FindWSRegistered(TComponentClass(lClassParent));
-      if Assigned(Result) then
-        Break
-      else
-        { Force creation of intermediate nodes for parent }
-        RegisterNewWSComp(TComponentClass(lClassParent));
-    end
-    else begin
-      { Force creation of intermediate nodes for Self and a leaf node for Self }
-      RegisterNewWSComp(Self);
-      Result := FindWSRegistered(Self);
-      Break;
-    end;
-  until False;
 end;
 
 {$IFDEF DebugLCLComponents}
@@ -196,37 +160,21 @@
 end;
 
 class function TLCLComponent.NewInstance: TObject;
+{$IFDEF RDTSCBenchmarking}
 var
-  lWidgetSetClass: TWSLCLComponentClass;
-  lClassParent : TLCLComponentClass;
+  RDTSCStart, RDTSCStop : QWord;
+{$ENDIF}
 begin
   Result := inherited NewInstance;
-
-  { Test if directly inherits WSRegisterClass from its parent }
-  lClassParent := TLCLComponentClass(ClassParent);
-  if (PCodePointer(Pointer(Self)  + cWSRegisterOffset)^
-     = PCodePointer(Pointer(lClassParent) + cWSRegisterOffset)^)
-  then begin
-    { Retrieve WidgetSetClass from Parent }
-    lWidgetSetClass := FindWSRegistered(lClassParent);
-    if Assigned(lWidgetSetClass) then begin
-      TLCLComponent(Result).FWidgetSetClass := lWidgetSetClass;
-      Exit;
-    end;
-  end
-  else begin
-    { Look if already registered. If true set FWidgetSetClass and exit }
-    lWidgetSetClass := FindWSRegistered(Self);
-    if Assigned(lWidgetSetClass) then begin
-      TLCLComponent(Result).FWidgetSetClass := lWidgetSetClass;
-      {$IFDEF VerboseWSBrunoK} inc(cWSLCLDirectHit); {$ENDIF}
-      Exit;
-    end;
-  end;
-
-  { WSRegisterClass and manage WSLVLClasses list }
-  TLCLComponent(Result).FWidgetSetClass := GetWSComponentClass(TLCLComponent(Result));
-  {$IFDEF VerboseWSBrunoK} inc(cWSLCLRegister); {$ENDIF}
+  if not cLCLComponentRegistered then
+    TLCLComponent.WSRegisterClass; { Initialize WSLCLClasses }
+  {$IFDEF RDTSCBenchmarking} RDTSCStart := CPUTickStamp; {$ENDIF}
+  TLCLComponent(Result).FWidgetSetClass := {WSLCLClasses.}GetWidgetSet(Self);
+  {$IFDEF RDTSCBenchmarking}
+  RDTSCStop := CPUTickStamp;
+  BenchmarkTotalTicks := (BenchmarkTotalTicks + RDTSCStop) - RDTSCStart
+                          - CPUTickStampCost;
+  {$ENDIF}
 end;
 
 procedure TLCLComponent.RemoveAllHandlersOfObject(AnObject: TObject);
Index: lcl/widgetset/wslclclasses.pp
===================================================================
--- lcl/widgetset/wslclclasses.pp	(revision 63672)
+++ lcl/widgetset/wslclclasses.pp	(working copy)
@@ -21,7 +21,11 @@
 {off$DEFINE VerboseWSRegistration}
 {off$DEFINE VerboseWSRegistration_methods}
 {off$DEFINE VerboseWSRegistration_treedump}
-{ Add -dVerboseWSBrunoK switch to compile with $DEFINE VerboseWSBrunoK }
+{.$DEFINE VerboseWSBrunoK }
+{.$DEFINE RDTSCBenchmarking}       { Must match LCLClasses define }
+{.$DEFINE Enable_Check_object_ext} { Reserved for versions of FPC with callback
+                                     to handle Classtype mismatch due to double
+                                     inheritance of TWS<Class> on -CR failure }
 
 interface
 ////////////////////////////////////////////////////
@@ -79,7 +83,7 @@
   InheritFromClass: TWSLCLComponentClass): Boolean;
 procedure RegisterWSComponent(AComponent: TComponentClass;
   AWSComponent: TWSLCLComponentClass; AWSPrivate: TWSPrivateClass = nil);
-procedure RegisterNewWSComp(AComponent: TComponentClass);
+
 // Only for non-TComponent based objects
 function GetWSLazAccessibleObject: TWSObjectClass;
 procedure RegisterWSLazAccessibleObject(const AWSObject: TWSObjectClass);
@@ -86,26 +90,32 @@
 function GetWSLazDeviceAPIs: TWSObjectClass;
 procedure RegisterWSLazDeviceAPIs(const AWSObject: TWSObjectClass);
 
-// ~bk Search for already registered classes
+// Search for already registered classes and if not existing
 function FindWSRegistered(const AComponent: TComponentClass): TWSLCLComponentClass;
+function GetWidgetSet(aComponent: TComponentClass): TWSLCLComponentClass;
+procedure WSDoInitialization(aWSRegisterProc : CodePointer);
 
-{ Debug : Dump the WSClassesList nodes }
+{ Debug : Dump the LCLClassesList nodes }
 {$IFDEF VerboseWSBrunoK}
-const
-  cWSLCLDirectHit : integer = 0;
-  cWSLCLParentHit : integer = 0;
-  cWSLCLRegister : integer = 0;
-
 procedure DumpWSClassesList;
 {$ENDIF}
 
+{$IFDEF RDTSCBenchmarking}
+const
+  OnFinalize : procedure = nil; // ~bk
+{$ENDIF}
+
 implementation
 
 uses
   LCLClasses;
 
-procedure DoInitialization; forward;
+procedure DoRegisterWidgetSet(aComponent: TComponentClass); forward;
+{$IFDEF Enable_Check_object_ext}
+function  laz_check_object_ext(vmt, expvmt : pointer) : boolean; forward;
+{$ENDIF Enable_Check_object_ext}
 
+
 ////////////////////////////////////////////////////
 // Registration code
 ////////////////////////////////////////////////////
@@ -114,45 +124,66 @@
   TClassNode = record
     LCLClass: TComponentClass;     { Class of the created instances }
     WSClass: TWSLCLComponentClass; { WidgetSet specific implementation class }
+    WSProtoClass: TClass;          { 'Lateral' parent prototype of WSClass,
+                                     needed for -CR }
     VClass: Pointer;               { Adjusted vmt table to handle WS virtual methods }
-    VClassName: ShortString;       { Class name attibuted when node was create }
+    VClassName: ShortString;       { Class name attibuted when node was created }
     VClassNew: Boolean;            { True Indicates that VClass=Parent.VClass.
                                      When True VClass is not runtime created }
     Parent: PClassNode;
     Child: PClassNode;
     Sibling: PClassNode;
+    {$IFDEF VerboseWSBrunoK} DbgCreateSeq : integer; {$ENDIF}
   end;
 
 const
   // vmtAutoTable is something Delphi 2 and not used, we 'borrow' the vmt entry
   vmtWSPrivate = vmtAutoTable;
+{$IFDEF VerboseWSBrunoK}
+  cWSLCLDirectHit : integer = 0;
+  cWSLCLParentHit : integer = 0;
+  cWSLCLRegister : integer = 0;
+{$ENDIF}
 
 type
 
-  { TWSClassesList }
+  { TRegClassesList }
 
   // Holds list of already registered TWidgetSetClass'es so TLCLComponent.NewInstance
   // can find faster the WidgetSetClass of the newinstance.
 
-  TWSClassesList = class(TFPList)
+  TRegClassesList = class(TFPList)
   private
+    FName : string;
+    FFieldOffset: integer;
     FLastFoundIdx: integer;
-    FLastFoundLCLClass: TComponentClass;
+    FLastFoundClass: TComponentClass;
+    {$IFDEF VerboseWSBrunoK}
+    FDbgCreateSeq : integer;
+    {$ENDIF}
     function FindWSClass(const AComponent: TComponentClass): TWSLCLComponentClass;
-    function Get(Index: integer): PClassNode; inline;
+    function Get(Index: integer): PClassNode;
     function Search(const aItem: TClass; Out Index: integer): boolean;
     property Items[Index: integer]: PClassNode read Get; { write Put; default; }
-    {$IFDEF VerboseWSBrunoK} {$ENDIF}
     {$IFDEF VerboseWSBrunoK}
+    procedure Insert(aIndex: Integer; aItem: Pointer);
     procedure DumpNode(aN : integer; aPClassNode : PClassNode);
     procedure DumpNodes;
     {$ENDIF}
+  public
+    constructor Create(aName : string; aFieldOffset : pointer);
   end;
 
 var
-  WSClassesList: TWSClassesList = nil;
+  LCLClassesList: TRegClassesList = nil;  { PClassNode's sorted by TLCLComponentClass
+                                            including internal and leaf nodes }
+  WSVClassesList: TRegClassesList = nil;  { PClassNode's sorted by TWSLCLComponentClass
+                                            Only nodes that have a synthetized vmt }
   WSLazAccessibleObjectClass: TWSObjectClass;
   WSLazDeviceAPIsClass: TWSObjectClass;
+const
+  cWSRegisterOffset : integer = 0; // Offset of WSRegisterClass in TLCLComponent
+                                   // virtual methods table
 
 function FindNodeParent(AComponent: TClass): PClassNode;
 var
@@ -159,8 +190,8 @@
   idx: integer;
 begin
   while AComponent <> nil do begin
-    if WSClassesList.Search(AComponent, idx) then
-      Exit(PClassNode(WSClassesList[idx]));
+    if LCLClassesList.Search(AComponent, idx) then
+      Exit(PClassNode(LCLClassesList[idx]));
     AComponent := AComponent.ClassParent;
   end;
   Result := nil;
@@ -171,8 +202,8 @@
   idx: integer;
 begin
   Result := nil;
-  if WSClassesList.Search(AComponent, idx) then
-    Exit(WSClassesList[idx]);
+  if LCLClassesList.Search(AComponent, idx) then
+    Exit(LCLClassesList[idx]);
   Result := FindNodeParent(AComponent.ClassParent);
 end;
 
@@ -213,19 +244,6 @@
 
   TPointerArray = packed array[0..9999999] of Pointer;
   PPointerArray = ^TPointerArray;
-{
-function GetClassNameP(aClassName:string) : Pointer;
-var
-  lLen: integer;
-  lShortStr : shortstring;
-begin
-  lShortStr := aClassName + #0;
-  lLen := Length(lShortStr);
-  SetLength(lShortStr,lLen-1);
-  Result := GetMem(lLen+1);
-  move(lShortStr, Result^, lLen + 2);
-end;
-}
 
 function FindParentWSClassNode(const ANode: PClassNode): PClassNode;
 begin
@@ -409,7 +427,6 @@
                        aParentGet: boolean; aLeaf: boolean): PClassNode;
 var
   idx: Integer;
-  OldCount: integer;
   lParentNode : PClassNode;
   lClassNode : TClassNode; { A temp local node to fake normal processing
                              of a node that won't be stored aParentGet = 0
@@ -419,7 +436,7 @@
   if (AClass = nil) or not (AClass.InheritsFrom(TLCLComponent)) then
     Exit(nil);
 
-  if not WSClassesList.Search(AClass, idx) then
+  if not LCLClassesList.Search(AClass, idx) then
   begin
     lInsertNode := aParentGet or Assigned(AWSComponent);
     if lInsertNode then
@@ -428,6 +445,7 @@
       Result := @lClassNode;
     Result^.LCLClass := TComponentClass(AClass);
     Result^.WSClass := nil;
+    Result^.WSProtoClass := nil;
     Result^.VClass := nil;
     Result^.VClassName := '';
     Result^.VClassNew := aParentGet;
@@ -438,6 +456,7 @@
     if aParentGet then
     begin
       Result^.WSClass := lParentNode^.WSClass;
+      Result^.WSProtoClass := lParentNode^.WSProtoClass;
       Result^.VClass := lParentNode^.VClass;
       PPointer(Result^.VClass + vmtWSPrivate)^ := PPointer(lParentNode^.VClass + vmtWSPrivate)^;
       // Build a VClassName
@@ -461,14 +480,14 @@
       Result^.Sibling := nil;
     if lInsertNode then
     begin
-      WSClassesList.Search(aClass, idx);
-      WSClassesList.Insert(idx, Result);
+      LCLClassesList.Search(aClass, idx);
+      LCLClassesList.Insert(idx, Result);
     end
     else
       Result := nil;
   end
   else
-    Result := WSClassesList[idx];
+    Result := LCLClassesList[idx];
 end;
 
 // Create VClass at runtime
@@ -498,9 +517,18 @@
   Node: PClassNode;
   OldPrivate: TClass;
   idx: Integer;
+  lClassParent : TComponentClass;
 begin
-  if not Assigned(WSClassesList) then
-    DoInitialization;
+  { Handle irregular WSRegisterClass/RegisterWSComponent (bug #0037407) }
+  if cWSRegisterOffset = 0 then
+    with TLCLComponent.Create(nil) do
+      Free;
+  if AComponent <> TLCLComponent then begin
+    lClassParent := TComponentClass(AComponent.ClassParent);
+    if not LCLClassesList.Search(lClassParent, idx) then
+      DoRegisterWidgetSet(lClassParent);
+  end;
+
   Node := GetPClassNode(AComponent, AWSComponent, False, True);
   if Node = nil then // No node created
     Exit;
@@ -507,7 +535,9 @@
   { If AWSComponent specified but node already exists, nothing more to do. }
   if Assigned(AWSComponent) and (Node^.WSClass = AWSComponent) then
     Exit;
+
   Node^.WSClass := AWSComponent;
+  Node^.WSProtoClass := AWSComponent.ClassParent;
 
   // childclasses "inherit" the private from their parent
   // the child privates should only be updated when their private is still
@@ -522,17 +552,15 @@
   {$ENDIF}
   CreateVClass(Node, AWSPrivate);
 
+  { Save synthetized class to list sorted by VClass. Allows finding the
+    WSProtoClass link for -CR analysis in laz_check_object_ext function }
+  if not WSVClassesList.Search(TClass(Node^.VClass), idx) then
+    WSVClassesList.Insert(idx, Node);
+
   // Since child classes may depend on us, recreate them
   UpdateChildren(Node, OldPrivate);
 end;
 
-// Do not create VClass at runtime but use normal Object Pascal class creation.
-procedure RegisterNewWSComp(AComponent: TComponentClass);
-begin
-  Assert(Assigned(WSClassesList), 'RegisterNewWSComp: WSClassesList=Nil');
-  GetPClassNode(AComponent, Nil, True, True);
-end;
-
 function GetWSLazAccessibleObject: TWSObjectClass;
 begin
   Result := WSLazAccessibleObjectClass;
@@ -555,32 +583,124 @@
 
 function FindWSRegistered(const AComponent: TComponentClass): TWSLCLComponentClass;
 begin
-  if not Assigned(WSClassesList) then
-    DoInitialization;
-  Result := WSClassesList.FindWSClass(AComponent);
+  if Assigned(LCLClassesList) then
+    Result := LCLClassesList.FindWSClass(AComponent)
+  else
+    Result := nil;
 end;
 
+type
+  WSRegisterMethod = procedure of object;
+
+{ Call all needed inherited WSRegisterClass from the top most unregistered
+  to the aComponent.WSREgistewrClass procedure }
+procedure DoRegisterWidgetSet(aComponent: TComponentClass);
+var
+  lClassParent : tclass;
+  lPSelfWSReg,
+  lPSelfParentWSReg : CodePointer;
+  lRegisterClassMethod : WSRegisterMethod; // Handling of class call in vmt
+  lIdx : integer;
+begin
+  if aComponent<>TLCLComponent then begin
+    lClassParent := aComponent.ClassParent;
+    if not LCLClassesList.Search(lClassParent,  lIdx) then
+      DoRegisterWidgetSet(TComponentClass(lClassParent));
+  end;
+  lPSelfWSReg := PCodePointer(Pointer(aComponent)  + cWSRegisterOffset)^;
+  lPSelfParentWSReg := PCodePointer(Pointer(lClassParent) + cWSRegisterOffset)^;
+  if (aComponent=TLCLComponent)
+     or (lPSelfWSReg <> lPSelfParentWSReg)
+  then begin
+    { Do the registration }
+    TMethod(lRegisterClassMethod).Code := PCodePointer(Pointer(aComponent)  + cWSRegisterOffset)^;
+    TMethod(lRegisterClassMethod).Data := aComponent;
+    lRegisterClassMethod;
+  end;
+
+  { Succesfully registered }
+  if LCLClassesList.Search(aComponent, lIdx) then
+    Exit;
+
+  { Self.ComponentClass didn't register itself but the parent should now be registered }
+  if lPSelfWSReg = lPSelfParentWSReg then begin
+    if not LCLClassesList.Search(lClassParent, lIdx) then
+      { Force creation of intermediate nodes and leaf for parent }
+      GetPClassNode(lClassParent, Nil, True, True);
+  end
+  else
+    { Force creation of intermediate nodes for Self and a leaf node for Self }
+    GetPClassNode(AComponent, Nil, True, True);
+end;
+
+{ Retrieves the WidgetSet for aComponent. If it isn't yet registerd, handle
+  all requested registration }
+function GetWidgetSet(aComponent: TComponentClass): TWSLCLComponentClass;
+var
+  lClassParent : tclass;
+  lPass : integer;
+begin
+  lPass := 0;
+  repeat
+    { Test if directly inherits WSRegisterClass from its parent }
+    lClassParent := aComponent.ClassParent;
+    if (PCodePointer(Pointer(aComponent)  + cWSRegisterOffset)^
+       = PCodePointer(Pointer(lClassParent) + cWSRegisterOffset)^)
+    then begin
+      { Retrieve WidgetSetClass from Parent }
+      Result := LCLClassesList.FindWSClass(TComponentClass(lClassParent));
+      if Assigned(Result) then begin
+        {$IFDEF VerboseWSBrunoK} inc(cWSLCLParentHit); {$ENDIF}
+        Break;
+      end;
+    end
+    else begin
+      { Look if already registered. If true set FWidgetSetClass and exit }
+      Result := FindWSRegistered(aComponent);
+      if Assigned(Result) then begin
+        {$IFDEF VerboseWSBrunoK} inc(cWSLCLDirectHit); {$ENDIF}
+        Break;
+      end;
+    end;
+    if lPass > 0 then // Class did not correctly register, return nil
+      Break;
+    {$IFDEF VerboseWSBrunoK} inc(cWSLCLRegister); {$ENDIF}
+    DoRegisterWidgetSet(aComponent);
+    Inc(lPass);
+  until False;
+end;
+
 {$IFDEF VerboseWSBrunoK}
 procedure DumpWSClassesList;
 begin
-  WSClassesList.DumpNodes;
+  LCLClassesList.DumpNodes;
 end;
 {$ENDIF}
 
-{ TWSClassesList }
+{ TRegClassesList }
 
-function TWSClassesList.Get(Index: integer): PClassNode;
+function TRegClassesList.Get(Index: integer): PClassNode;
 begin
   Result := PClassNode(inherited Get(Index));
 end;
 
-function TWSClassesList.FindWSClass(const AComponent: TComponentClass): TWSLCLComponentClass;
+function TRegClassesList.FindWSClass(const AComponent: TComponentClass): TWSLCLComponentClass;
 var
   I: integer;
+  {$IFDEF VerboseWSBrunoK} lLastIndex : integer; {$ENDIF}
 begin
-  {$IFDEF VerboseWSBrunoK} Write('Searching ', AComponent.ClassName); {$ENDIF}
+  {$IFDEF VerboseWSBrunoK}
+  Write('Searching ', AComponent.ClassName);
+  lLastIndex := FLastFoundIdx;
+  {$ENDIF}
   if Search(AComponent, i) then begin
-    {$IFDEF VerboseWSBrunoK} WriteLn(' -> FOUND'); {$ENDIF}
+    {$IFDEF VerboseWSBrunoK}
+    Write(' -> FOUND');
+    if i = lLastIndex then
+      WriteLn(' : direct hit')
+    else
+      WriteLn;
+    {$ENDIF}
     Exit(TWSLCLComponentClass(Items[i]^.VClass));
   end;
   {$IFDEF VerboseWSBrunoK} WriteLn(' -> NOT FOUND'); {$ENDIF}
@@ -589,31 +709,28 @@
 
 { Searches a match for AComponent.ClassType. Returns index in items of
   the matching AComponent or the next bigger one }
-function TWSClassesList.Search(const aItem: TClass; out Index: integer): boolean;
-const
-  cIndex: integer = 0;
+function TRegClassesList.Search(const aItem: TClass; out Index: integer): boolean;
 var
   L, R: integer;
-  lLCLClass: TClass;
-  lPClassNode: PClassNode;
+  lClass: TClass;
 begin
   L := 0;
   R := Count - 1;
   // Use binary search.
   if R >= 0 then begin
-    if Pointer(aItem) = Pointer(FLastFoundLCLClass) then begin
+    if (Pointer(aItem) = Pointer(FLastFoundClass)) then begin
       Index := FLastFoundIdx;
       Exit(True);
     end;
     while (L <= R) do begin
       Index := L + ((R - L) div 2);
-      lLCLClass := PClassNode(List^[Index])^.LCLClass;
-      if Pointer(aItem) < Pointer(lLCLClass) then
+      lClass := TClass(PPointer(Pointer(List^[Index])+FFieldOffset)^);
+      if Pointer(aItem) < Pointer(lClass) then
         R := Index - 1
       else begin
-        if aItem = lLCLClass then begin
+        if aItem = lClass then begin
           FLastFoundIdx := Index;
-          FLastFoundLCLClass := TComponentClass(lLCLClass);
+          FLastFoundClass := TComponentClass(lClass);
           Exit(True);
         end;
         L := Index + 1;
@@ -625,7 +742,14 @@
 end;
 
 {$IFDEF VerboseWSBrunoK}
-procedure TWSClassesList.DumpNode(aN: integer; aPClassNode: PClassNode);
+procedure TRegClassesList.Insert(aIndex: Integer; aItem: Pointer);
+begin
+  PClassNode(aItem)^.DbgCreateSeq := FDbgCreateSeq;
+  inc(FDbgCreateSeq);
+  inherited Insert(aIndex, aItem);
+end;
+
+procedure TRegClassesList.DumpNode(aN: integer; aPClassNode: PClassNode);
 var
   LCLClassClassName, lWSClassClassName, lVClassName, ParentVClassName: string;
   lClassNode : PClassNode;
@@ -649,10 +773,11 @@
       ParentVClassName := '???';
     writeln(
       aN, ';',
-      { DbgCreateSeq, ';', }
+      DbgCreateSeq, ';',
       HexStr(aPClassNode), ';',
       HexStr(LCLClass), ';',  // : TComponentClass;
       LCLClassClassName, ';',
+      WSProtoClass.ClassName, ';',
       HexStr(WSClass), ';', // : TWSLCLComponentClass;
       lWSClassClassName, ';',
       HexStr(VClass), ';', // : Pointer;
@@ -668,15 +793,19 @@
   end;
 end;
 
-procedure TWSClassesList.DumpNodes;
+procedure TRegClassesList.DumpNodes;
 var
   i: integer;
 begin
+  WriteLn(FName, ' tree');
+  i := length(FName)+length(' tree');
+  WriteLn(StringOfChar('=', i));
   WriteLn('n;',          // aN, ';',
-    { 'CreateSeq;',        // DbgCreateSeq, ';', }
+    'CreateSeq;',        // DbgCreateSeq, ';',
     'PClassNode;',        // Node
     'LCLClass;',         // HexStr(LCLClass), ';',  // : TComponentClass;
     'LCLClassName;',     // LCLClassClassName, ';',
+    'WSProtoClass;',
     'WSClass;',          // HexStr(WSClass), ';', // : TWSLCLComponentClass
     'WSClassName;',      // lWSClassClassName, ';',
     'VClass;',           // HexStr(VClass), ';', // : Pointer;
@@ -694,6 +823,13 @@
 end;
 {$ENDIF}
 
+constructor TRegClassesList.Create(aName: string; aFieldOffset: pointer);
+begin
+  inherited Create;
+  FName := aName;
+  FFieldOffset:=Integer(aFieldOffset);
+end;
+
 { TWSLCLComponent }
 
 class function TWSLCLComponent.WSPrivate: TWSPrivateClass;
@@ -707,9 +843,21 @@
 begin
 end;
 
-procedure DoInitialization;
+procedure WSDoInitialization(aWSRegisterProc: CodePointer);
+var
+  lPPtrArray : PPointerArray;
+  I : integer;
 begin
-  WSClassesList := TWSClassesList.Create;
+  lPPtrArray := Pointer(TLCLComponent);
+  I := 0;
+  while lPPtrArray^[i]<>aWSRegisterProc do
+    inc(i);
+  cWSRegisterOffset := I * SizeOf(Pointer);
+  LCLClassesList := TRegClassesList.Create('LCLClassesList', @PClassNode(nil)^.LCLClass);
+  WSVClassesList := TRegClassesList.Create('WSVClassesList', @PClassNode(nil)^.VClass);
+  {$IFDEF Enable_Check_object_ext}
+  system.LazarusCRCallback := @laz_check_object_ext;
+  {$ENDIF Enable_Check_object_ext}
 end;
 
 procedure DoFinalization;
@@ -718,25 +866,48 @@
   Node: PClassNode;
 begin
   {$IFDEF VerboseWSBrunoK}
-  WSClassesList.DumpNodes;
+  WSVClassesList.DumpNodes;
+  LCLClassesList.DumpNodes;
   WriteLn;
   WriteLn('cWSLCLDirectHit=', cWSLCLDirectHit,
           ' cWSLCLParentHit=', cWSLCLParentHit,
           ' cWSLCLRegister=', cWSLCLRegister);
   {$ENDIF}
-  for n := 0 to WSClassesList.Count - 1 do
+  for n := 0 to LCLClassesList.Count - 1 do
   begin
-    Node := WSClassesList[n];
+    Node := LCLClassesList[n];
     if (Node^.VClass <> nil) and (not Node^.VClassNew) then
       Freemem(Node^.VClass);
     Dispose(Node);
   end;
-  FreeAndNil(WSClassesList);
+  FreeAndNil(LCLClassesList);
+  FreeAndNil(WSVClassesList);
   {$IFDEF VerboseWSBrunoK}
   Write('Press enter to quit > '); ReadLn;
   {$ENDIF}
+  {$IFDEF RDTSCBenchmarking}
+  if Assigned(OnFinalize) then
+    OnFinalize; // Collect timing data
+  {$ENDIF RDTSCBenchmarking}
 end;
 
+{$IFDEF Enable_Check_object_ext}
+{ Extend class type verification to handle the double inheritance of the
+  TWSLCLComponents. If the component TWS<Widget><WSLCLClass> is found,
+  check that its 'lateral' component in the TWS<Class> tree matches
+  inheritence constraints. }
+function laz_check_object_ext(vmt, expvmt: pointer) : Boolean;
+var
+  idx : integer;
+  lComponentClass : TComponentClass;
+begin
+  Result := WSVClassesList.Search(TComponentClass(vmt), idx);
+  if Result then begin
+    lComponentClass := TComponentClass(PClassNode(WSVClassesList[idx])^.WSProtoClass);
+    Result := lComponentClass.InheritsFrom(TClass(expvmt));
+  end;
+end;
+{$ENDIF Enable_Check_object_ext}
 
 finalization
   DoFinalization;
LCL+WS+MiscComps.patch (26,851 bytes)   

Martin Friebe

2020-08-04 13:31

manager   ~0124541

I applied part so far. I am trying to get through the rest.

What advantage does it bring to move the code to WsLCLClasses?
And then "hide" the call to WSRegisterClass, behind an on the fly build codepointer?

Since this is code that calls protected methods, it clearly wants to stay in TLCLComponent.

BrunoK

2020-08-04 14:48

reporter   ~0124542

Last edited: 2020-08-04 15:12

View 2 revisions

Martin : HOLD ON A SECOND WITH MY LATEST PATCH IT SEEMS TO HAVE A BUG !

{ Edit out :
Because I consider WSLCLClasses.DoRegisterWidgetSet called in RegisterWSComponent, when processing 0037407 like issues, to belong there.
Except for creating TLCLComponent in that unit I consider that WSLCLClasses methods should not call LCLClasses methods that then would have to be made public. Not good encapsulation (in my point of view).
All the low level stuff in WSLCLClasses and initializing WSLCLClasses requested once from topmost TLCLComponent.WSRegisterClass through its NewInstance method.
}

Martin Friebe

2020-08-04 16:08

manager   ~0124549

I just went through the work, of splitting your patch into
- changes to live code
- renames
- benchmarks and ifdef
  https://github.com/User4martin/lazarus/compare/Branch_1871a0f4
=> just so I can get a look at the actual live code changes without other stuff obscuring them ...

I will look at the remaining changes in that patch, now that they can be inspected
-------------------

About 0037407 / patched in 63636: RegisterWSComponent was already in WSLCLClasses, and still is?

However your patch moves the call to "WSRegisterClass" from TLCLComponent.GetWSComponentClass into WSLCLClasses (and obscures it, to (hack?) access to protected)
The call to WSRegisterClass belongs into TLCLComponent.

IMHO TLCLComponent should be responsible for (never mind in which of TLCLComponent's methods)

  TLCLComponent(Result).FWidgetSetClass := GetWSComponentClass(TLCLComponent(Result));
  if TLCLComponent(Result).FWidgetSetClass = nil then begin
     WSRegisterClass;
     TLCLComponent(Result).FWidgetSetClass := GetWSComponentClass(TLCLComponent(Result));
  end;

If needs must (but I really see no advantage)
  TLCLComponent(Result).FWidgetSetClass := GetWSComponentClassAndCallRegister(TLCLComponent(Result), @WSRegisterClass);
passing a reference to WSRegisterClass, so it can be called from WSLCLClasses.

But definitely not "TMethod(lRegisterClassMethod).Code := " to circumvent the protected layer.

Note that any "IFDEF VerlboseBrunoK" or other IFDEF code may indeed be better in the other unit. But that is debugging code. It should under no circumstances influence how the live code is structured. So I am ignoring all IFDEF code.

----------------
I had no feedback on why there should be the parentclass lookups.

So I cmmited the code removing them.
Otherwise they would have had to be changed, to the code that did not need the VMT access/search (see all my previous comments on this)

Martin Friebe

2020-08-04 17:41

manager   ~0124554

If you edit your patch, can you keep it split for the different topics (see my split above)?

It is much harder to read a patch that does several independent things.

Martin Friebe

2020-08-04 17:45

manager   ~0124555

>>> $DEFINE Enable_Check_object_ext // Reserved for versions of FPC with callback to handle Classtype mismatch due to double inheritance of TWS<Class> on -CR failure }

I believe such an fpc version does not, and will not exist?
Then such code does not need to be added.

Anyway, the goal should be to get rid of the entire VMT building code.....

BrunoK

2020-08-04 18:20

reporter   ~0124557

Martin,

first re patch not working Bruno 2020-08-04 14:48 -> it was a problem of WriteLn with -WG and mix up of standard / debug lazarus versions. So my lazarus works again.

> But definitely not "TMethod(lRegisterClassMethod).Code := " to circumvent the protected layer.
OK for me to not circumvent and move these back to LCLClasses. A bit less obfuscated this way.

> I had no feedback on why there should be the parentclass lookups.
Because using parentclass ((V) or (I) or maybe even (L) nodes ) instead of creating a leaf that can already obtain all the information through parentclass node inheritance seems logical. The (L) node is specifically for cases where the widget has a WSRegisterClass method that actually does not call the WSLCLClasses RegisterWSComponent method and thus does not get added to LCLClassesList where it is absolutely necessary to have a node. I find there is no need to build a node for a component that just publishes properties of a parent class.

Q : Is it possible to get a zip of both LCLClasses and WSLCLClasses in the version that you consider the current status because I'm now quite lost as of which parts of the code we are talking about, what does your code look like now.

Shuffling some code from WSLCLClasses back to LCLClasses does not cause me any problem if it makes things more manageable.

BrunoK

2020-08-04 18:45

reporter   ~0124558

>>> $DEFINE Enable_Check_object_ext // Reserved for versions of FPC with callback to handle Classtype mismatch due to double >inheritance of TWS<Class> on -CR failure }

>> I believe such an fpc version does not, and will not exist?
>> Then such code does not need to be added.
Well it does on my machine. A very minor change to FPC 3.0.x. For the code see https://forum.lazarus.freepascal.org/index.php/topic,50728.0.html#msg371763

>> Anyway, the goal should be to get rid of the entire VMT building code.....
Except for very much complicating and doing rewrite of lots of code I think it was a good idea from the initial developers. I have turned that in all possible direction. The conclusion is what counts is that the Widgetset specific code is checked by the compiler against the TWS<ControlClass> definitions (prototype). But at runtime, the final Widget set implementation must be adjusted to have the correct synthetized parent vmt, thus breaking the -CR. It migth be possible to patch the code segment but that would not be very 'civilized'.
This mechanism is also used by .\designer\jitforms.pp. I was analysing this one because it is now (after minor adjustments) the first code causing a -CR error.

Martin Friebe

2020-08-04 19:11

manager   ~0124559

I committed the changes I proposed. So you can "svn up".
Also includes your "done = true" fixes.
The other changes from your patch had still questions, (the renames I kept on hold, in case they cause merge conflicts).

As for "works in your local fpc", not helping. IIRC Sven made it clear it was never going into the official code base.
So its not needed in LCL either.
What could be done, is disable the check, everywhere where it actually fails {$whatever off}. Then the rest of the LCL will work with -CR.


There is no immediate plan to start changing the VMT building code. No good idea has stricken yet.
But the self build classes a full of traps (IIRC).
- "inherited" is resolved at compile time => it does not work as expected.
- Current solution
  class procedure TWin32WSCustomListView.SetFont(const AWinControl: TWinControl; const AFont: TFont);
    // call inherited SetFont; need to do it this way,
    // because the compile time ancestor class is TWSCustomListView
    TWSWinControlClass(ClassParent).SetFont(AWinControl, AFont);
  But then "self" is no longer what it was in the caller. Calling other virtual methods, will ignore the correct inheritance....
  *If* SetFont would call SetColor, it would not go to "class procedure TWin32WSCustomListView.SetColor(const AWinControl: TWinControl);"

Martin Friebe

2020-08-04 19:22

manager   ~0124560

Last edited: 2020-08-04 20:09

View 4 revisions

On the ParentClass.

I did propose an alternative implementation, that does not need to walk the vmt. (but otherwise archives exactly the same, at the same speed).

On top of that existing proposal, it would be nice if the repeated code (the check is done in various locations) could be done in one place.
Due to the "protected" visibility it has to be it TLclComponent, and can not be moved.

Yes, it will save some memory. Well except for TForm, TFrame were the user "TForm1" adds one more level of inheritance.
That is why I said, it would need to be a loop.
But then, it would slow things down (at least Big O wise / I did not benchmark myself). Because iterating the parents is a linear search. It will have to add at least equal or even more time, than the time potentially saved in the binary search of the sorted list (when that list is kept a few entries smaller).

And if we are counting cpu cycles: Even adding only the "if" for the one parent check, it is a gamble on the branch predictor, and may depending on exact cpu save or loose time.

This is not accounting for the time it takes to create those entries => that is a one off time. The search is done for each instance, so usually far more often.


-----------------
General note on "need for speed"

I am generally in favour of speeding code up. But the gains have to bu matched with the cost.

If that parent lookup saves 1 or 2 cpu cycles, it may not be worth it. We are talking about components with an OS handle. Many of them visibly with the need of being painted.
On most OS those actions will take time.
For an application to create and destroy those components in the thousands is unlikely (if not impossible).
Saving a few ticks on the overall lifetime of the app is still great. But not so much, if it complicates the code to much....

How much of a saving do we actually talk about? (E.g. 1 Form, with 20 buttons )

Timed, if the code for the check is refactored into "function CanUseParentWSClass: boolean; inline" or "function FindClassForGettingWSClass: TLclComponentClass; inline"

BrunoK

2020-08-09 12:32

reporter   ~0124690

Embarrassing programming error : TWSClassesList.Search might return wrong index after an TWSClassesList.Insert.
LCL+WSLCLClassesOn63704.patch (3,918 bytes)   
Index: lcl/lclclasses.pp
===================================================================
--- lcl/lclclasses.pp	(revision 63698)
+++ lcl/lclclasses.pp	(working copy)
@@ -19,7 +19,7 @@
 
 {$mode objfpc}{$H+}
 
-{ Add -dVerboseWSBrunoK switch to compile with $DEFINE VerboseWSBrunoK }
+{.$DEFINE VerboseWSBrunoK }
 
 interface
 
Index: lcl/widgetset/wslclclasses.pp
===================================================================
--- lcl/widgetset/wslclclasses.pp	(revision 63698)
+++ lcl/widgetset/wslclclasses.pp	(working copy)
@@ -21,7 +21,7 @@
 {off$DEFINE VerboseWSRegistration}
 {off$DEFINE VerboseWSRegistration_methods}
 {off$DEFINE VerboseWSRegistration_treedump}
-{ Add -dVerboseWSBrunoK switch to compile with $DEFINE VerboseWSBrunoK }
+{.$DEFINE VerboseWSBrunoK }
 
 interface
 ////////////////////////////////////////////////////
@@ -137,10 +137,13 @@
   TWSClassesList = class(TFPList)
   private
     FLastFoundIdx: integer;
-    FLastFoundLCLClass: TComponentClass;
+    FLastFoundClass: TClass;
+    constructor Create;
     function FindWSClass(const AComponent: TComponentClass): TWSLCLComponentClass;
     function Get(Index: integer): PClassNode; inline;
+    procedure Insert(aIndex: Integer; aItem: Pointer);
     function Search(const aItem: TClass; Out Index: integer): boolean;
+    procedure UpdatLastFound(aClass: TClass; aIndex: integer);
     property Items[Index: integer]: PClassNode read Get; { write Put; default; }
     {$IFDEF VerboseWSBrunoK} {$ENDIF}
     {$IFDEF VerboseWSBrunoK}
@@ -577,9 +580,9 @@
 
 { TWSClassesList }
 
-function TWSClassesList.Get(Index: integer): PClassNode;
+constructor TWSClassesList.Create;
 begin
-  Result := PClassNode(inherited Get(Index));
+  FLastFoundClass:=TClass(High(UIntPtr));
 end;
 
 function TWSClassesList.FindWSClass(const AComponent: TComponentClass): TWSLCLComponentClass;
@@ -595,6 +598,17 @@
   Result := nil;
 end;
 
+function TWSClassesList.Get(Index: integer): PClassNode;
+begin
+  Result := PClassNode(inherited Get(Index));
+end;
+
+procedure TWSClassesList.Insert(aIndex: Integer; aItem: Pointer);
+begin
+  inherited Insert(aIndex, aItem);
+  UpdatLastFound(TClass(aItem), aIndex);
+end;
+
 { Searches a match for AComponent.ClassType. Returns index in items of
   the matching AComponent or the next bigger one }
 function TWSClassesList.Search(const aItem: TClass; out Index: integer): boolean;
@@ -603,29 +617,25 @@
 var
   L, R: integer;
   lLCLClass: TClass;
-  lPClassNode: PClassNode;
 begin
+  if aItem = FLastFoundClass then begin
+    Index := FLastFoundIdx;
+    Exit(True);
+  end;
   L := 0;
   R := Count - 1;
   // Use binary search.
-  if R >= 0 then begin
-    if Pointer(aItem) = Pointer(FLastFoundLCLClass) then begin
-      Index := FLastFoundIdx;
-      Exit(True);
-    end;
-    while (L <= R) do begin
-      Index := L + ((R - L) div 2);
-      lLCLClass := PClassNode(List^[Index])^.LCLClass;
-      if Pointer(aItem) < Pointer(lLCLClass) then
-        R := Index - 1
-      else begin
-        if aItem = lLCLClass then begin
-          FLastFoundIdx := Index;
-          FLastFoundLCLClass := TComponentClass(lLCLClass);
-          Exit(True);
-        end;
-        L := Index + 1;
+  while (L <= R) do begin
+    Index := L + ((R - L) div 2);
+    lLCLClass := PClassNode(List^[Index])^.LCLClass;
+    if Pointer(aItem) < Pointer(lLCLClass) then
+      R := Index - 1
+    else begin
+      if aItem = lLCLClass then begin
+        UpdatLastFound(lLCLClass, Index);
+        Exit(True);
       end;
+      L := Index + 1;
     end;
   end;
   Index := L;
@@ -632,6 +642,12 @@
   Result := False;
 end;
 
+procedure TWSClassesList.UpdatLastFound(aClass: TClass; aIndex: integer);
+begin
+  FLastFoundClass := TComponentClass(aClass);
+  FLastFoundIdx := aIndex;
+end;
+
 {$IFDEF VerboseWSBrunoK}
 procedure TWSClassesList.DumpNode(aN: integer; aPClassNode: PClassNode);
 var
LCL+WSLCLClassesOn63704.patch (3,918 bytes)   

Martin Friebe

2020-08-09 17:16

manager   ~0124697

I applied the patch.

There is something that I spotted: Your implementation of the binary search has a flaw.

You have "if aItem = lLCLClass then begin" inside the loop.
That is you do one extra compare in each iteration of the loop. That is not needed.

You should search until R and L meet, and then check if the found entry is the desired entry.
That reduces the loop from currently 3 comparisons ("while" and "if aitem< .." and "if aitem = ") to only 2 comparisons. Therefore the loop will become faster.

BrunoK

2020-08-09 19:11

reporter   ~0124702

Martin 0124697

I think equality must be tested because otherwise we do not know what item is equal, is it [R+1] or [index].

But of course your are wellcome to correct that.

Issue History

Date Modified Username Field Change
2020-07-15 13:54 BrunoK New Issue
2020-07-15 13:54 BrunoK File Added: LCLComponent.patch
2020-07-15 13:54 BrunoK File Added: lcl.zip
2020-07-15 13:54 BrunoK File Added: Registered.patch
2020-07-16 12:20 BrunoK Note Added: 0124084
2020-07-16 12:20 BrunoK File Added: lcl_V1.zip
2020-07-16 12:20 BrunoK File Added: LCLComponent_V1.patch
2020-07-18 23:38 Juha Manninen Note Added: 0124157
2020-07-19 16:59 BrunoK Note Added: 0124170
2020-07-19 17:00 BrunoK Note Edited: 0124170 View Revisions
2020-07-20 17:14 BrunoK Note Added: 0124191
2020-07-22 10:36 Juha Manninen Assigned To => Juha Manninen
2020-07-22 10:36 Juha Manninen Status new => assigned
2020-07-22 10:52 Juha Manninen Status assigned => feedback
2020-07-22 10:52 Juha Manninen LazTarget => -
2020-07-22 10:52 Juha Manninen Note Added: 0124223
2020-07-22 12:57 BrunoK Note Added: 0124227
2020-07-22 12:57 BrunoK Status feedback => assigned
2020-07-22 14:53 Juha Manninen Status assigned => resolved
2020-07-22 14:53 Juha Manninen Resolution open => fixed
2020-07-22 14:53 Juha Manninen Fixed in Revision => r63619
2020-07-22 14:53 Juha Manninen Note Added: 0124229
2020-07-23 08:16 Juha Manninen Relationship added related to 0037407
2020-07-29 00:54 Martin Friebe Relationship added related to 0037435
2020-07-29 01:22 Martin Friebe Status resolved => assigned
2020-07-29 01:22 Martin Friebe Resolution fixed => open
2020-07-29 01:22 Martin Friebe Note Added: 0124372
2020-07-29 01:36 Martin Friebe Note Edited: 0124372 View Revisions
2020-07-29 10:59 Bart Broersma Note Added: 0124379
2020-07-29 11:00 Bart Broersma Note Edited: 0124379 View Revisions
2020-07-29 11:00 Bart Broersma Note Edited: 0124379 View Revisions
2020-07-29 11:26 Juha Manninen Note Added: 0124381
2020-07-29 12:03 Martin Friebe Note Added: 0124382
2020-07-29 12:24 Martin Friebe Note Added: 0124384
2020-07-29 12:50 Martin Friebe Note Added: 0124388
2020-07-29 14:02 BrunoK Note Added: 0124392
2020-07-29 16:08 Martin Friebe Note Added: 0124398
2020-07-29 16:09 Martin Friebe Note Edited: 0124398 View Revisions
2020-07-29 20:53 Juha Manninen Note Added: 0124402
2020-07-29 21:41 Juha Manninen Note Edited: 0124402 View Revisions
2020-07-29 23:45 Martin Friebe Note Added: 0124406
2020-08-02 15:12 Martin Friebe Note Added: 0124494
2020-08-02 15:14 Martin Friebe Note Edited: 0124494 View Revisions
2020-08-02 22:25 Juha Manninen Note Added: 0124519
2020-08-03 00:40 Martin Friebe Note Added: 0124520
2020-08-04 10:19 BrunoK Note Added: 0124537
2020-08-04 10:19 BrunoK File Added: LCL+WS+MiscComps.patch
2020-08-04 13:28 Martin Friebe Assigned To Juha Manninen => Martin Friebe
2020-08-04 13:31 Martin Friebe Note Added: 0124541
2020-08-04 14:48 BrunoK Note Added: 0124542
2020-08-04 15:12 BrunoK Note Edited: 0124542 View Revisions
2020-08-04 16:08 Martin Friebe Note Added: 0124549
2020-08-04 17:41 Martin Friebe Note Added: 0124554
2020-08-04 17:45 Martin Friebe Note Added: 0124555
2020-08-04 18:20 BrunoK Note Added: 0124557
2020-08-04 18:45 BrunoK Note Added: 0124558
2020-08-04 19:11 Martin Friebe Note Added: 0124559
2020-08-04 19:22 Martin Friebe Note Added: 0124560
2020-08-04 19:24 Martin Friebe Note Edited: 0124560 View Revisions
2020-08-04 19:35 Martin Friebe Note Edited: 0124560 View Revisions
2020-08-04 20:09 Martin Friebe Note Edited: 0124560 View Revisions
2020-08-09 12:32 BrunoK Note Added: 0124690
2020-08-09 12:32 BrunoK File Added: LCL+WSLCLClassesOn63704.patch
2020-08-09 17:16 Martin Friebe Note Added: 0124697
2020-08-09 19:11 BrunoK Note Added: 0124702