Merged revisions 3068,3070,3114 via svnmerge from

svn+ssh://[email protected]/FPC/svn/fpc/branches/linker/compiler

r3068 | peter | 2006-03-28 15:02:06 +0100 (Tue, 28 Mar 2006) | 2 lines

  * Add new TFPHashList and TFPHashObjectList

r3070 | peter | 2006-03-29 07:39:04 +0100 (Wed, 29 Mar 2006) | 2 lines

  * fix compile

r3114 | peter | 2006-04-01 23:47:50 +0100 (Sat, 01 Apr 2006) | 3 lines

  * remove debug writelns
  * enable vtable optimizer with -Xv

git-svn-id: trunk@3116 -

compiler/cclasses.pas

@@ -48,17 +48,18 @@ interface
        end;
 
 {*******************************************************
-     TFPObjectList (From rtl/objpas/classes/classesh.inc)
+      TFPList (From rtl/objpas/classes/classesh.inc)
 ********************************************************}
 
 const
-   MaxListSize = Maxint div 16;
    SListIndexError = 'List index exceeds bounds (%d)';
    SListCapacityError = 'The maximum list capacity is reached (%d)';
    SListCountError = 'List count too large (%d)';
 type
    EListError = class(Exception);
 
+const
+  MaxListSize = Maxint div 16;
 type
   PPointerList = ^TPointerList;
   TPointerList = array[0..MaxListSize - 1] of Pointer;
@@ -103,6 +104,7 @@ type
     property List: PPointerList read FList;
   end;
 
+
 {*******************************************************
         TFPObjectList (From fcl/inc/contnrs.pp)
 ********************************************************}
@@ -150,6 +152,125 @@ type
     property List: TFPList read FList;
   end;
 
+type
+  THashItem=record
+    HashValue : LongWord;
+    StrIndex  : Integer;
+    NextIndex : Integer;
+    Data      : Pointer;
+  end;
+
+const
+  MaxHashListSize = Maxint div 16;
+  MaxHashStrSize  = Maxint;
+  MaxHashTableSize = Maxint div 4;
+  MaxItemsPerHash = 3;
+
+type
+  PHashItemList = ^THashItemList;
+  THashItemList = array[0..MaxHashListSize - 1] of THashItem;
+  PHashTable = ^THashTable;
+  THashTable = array[0..MaxHashTableSize - 1] of Integer;
+
+  TFPHashList = class(TObject)
+  private
+    { ItemList }
+    FHashList     : PHashItemList;
+    FCount,
+    FCapacity : Integer;
+    { Hash }
+    FHashTable    : PHashTable;
+    FHashCapacity : Integer;
+    { Strings }
+    FStrs     : PChar;
+    FStrCount,
+    FStrCapacity : Integer;
+  protected
+    function Get(Index: Integer): Pointer;
+    procedure SetCapacity(NewCapacity: Integer);
+    procedure SetCount(NewCount: Integer);
+    Procedure RaiseIndexError(Index : Integer);
+    function  AddStr(const s:string): Integer;
+    procedure AddToHashTable(Index: Integer);
+    procedure StrExpand(MinIncSize:Integer);
+    procedure SetStrCapacity(NewCapacity: Integer);
+    procedure SetHashCapacity(NewCapacity: Integer);
+  public
+    constructor Create;
+    destructor Destroy; override;
+    function Add(const AName:string;Item: Pointer): Integer;
+    procedure Clear;
+    function NameOfIndex(Index: Integer): String;
+    procedure Delete(Index: Integer);
+    class procedure Error(const Msg: string; Data: PtrInt);
+    function Expand: TFPHashList;
+    function Extract(item: Pointer): Pointer;
+    function IndexOf(Item: Pointer): Integer;
+    function Find(const s:string): Pointer;
+    function Remove(Item: Pointer): Integer;
+    procedure Pack;
+    procedure ShowStatistics;
+    procedure ForEachCall(proc2call:TListCallback;arg:pointer);
+    procedure ForEachCall(proc2call:TListStaticCallback;arg:pointer);
+    property Capacity: Integer read FCapacity write SetCapacity;
+    property Count: Integer read FCount write SetCount;
+    property Items[Index: Integer]: Pointer read Get; default;
+    property List: PHashItemList read FHashList;
+  end;
+
+
+{*******************************************************
+        TFPHashObjectList (From fcl/inc/contnrs.pp)
+********************************************************}
+
+  TFPHashObjectList = class;
+
+  TFPHashObject = class
+  private
+    FOwner : TFPHashObjectList;
+    FIndex : Integer;
+  protected
+    function GetName:string;
+  public
+    constructor Create(HashObjectList:TFPHashObjectList;const s:string);
+    property Name:string read GetName;
+  end;
+
+  TFPHashObjectList = class(TObject)
+  private
+    FFreeObjects : Boolean;
+    FHashList: TFPHashList;
+    function GetCount: integer;
+    procedure SetCount(const AValue: integer);
+  protected
+    function GetItem(Index: Integer): TObject;
+    procedure SetCapacity(NewCapacity: Integer);
+    function GetCapacity: integer;
+  public
+    constructor Create(FreeObjects : boolean = True);
+    destructor Destroy; override;
+    procedure Clear;
+    function Add(const AName:string;AObject: TObject): Integer;
+    function NameOfIndex(Index: Integer): String;
+    procedure Delete(Index: Integer);
+    function Expand: TFPHashObjectList;
+    function Extract(Item: TObject): TObject;
+    function Remove(AObject: TObject): Integer;
+    function IndexOf(AObject: TObject): Integer;
+    function Find(const s:string): TObject;
+    function FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt: Integer): Integer;
+    procedure Pack;
+    procedure ShowStatistics;
+    procedure ForEachCall(proc2call:TObjectListCallback;arg:pointer);
+    procedure ForEachCall(proc2call:TObjectListStaticCallback;arg:pointer);
+    property Capacity: Integer read GetCapacity write SetCapacity;
+    property Count: Integer read GetCount write SetCount;
+    property OwnsObjects: Boolean read FFreeObjects write FFreeObjects;
+    property Items[Index: Integer]: TObject read GetItem; default;
+    property List: TFPHashList read FHashList;
+  end;
+
+
 {********************************************
                 TLinkedList
 ********************************************}
@@ -947,6 +1068,543 @@ begin
 end;
 
 
+{*****************************************************************************
+                            TFPHashList
+*****************************************************************************}
+
+    function FPHash1(const s:string):LongWord;
+      Var
+        g : LongWord;
+        p,pmax : pchar;
+      begin
+        result:=0;
+        p:=@s[1];
+        pmax:=@s[length(s)+1];
+        while (p<pmax) do
+          begin
+            result:=result shl 4 + LongWord(p^);
+            g:=result and LongWord($F0000000);
+            if g<>0 then
+              result:=result xor (g shr 24) xor g;
+            inc(p);
+          end;
+        If result=0 then
+          result:=$ffffffff;
+      end;
+
+    function FPHash(const s:string):LongWord;
+      Var
+        p,pmax : pchar;
+      begin
+        result:=0;
+        p:=@s[1];
+        pmax:=@s[length(s)+1];
+        while (p<pmax) do
+          begin
+            result:=((result shl 5) - result) xor LongWord(P^);
+            inc(p);
+          end;
+      end;
+
+
+procedure TFPHashList.RaiseIndexError(Index : Integer);
+begin
+  Error(SListIndexError, Index);
+end;
+
+
+function TFPHashList.Get(Index: Integer): Pointer;
+begin
+  If (Index < 0) or (Index >= FCount) then
+    RaiseIndexError(Index);
+  Result:=FHashList^[Index].Data;
+end;
+
+
+function TFPHashList.NameOfIndex(Index: Integer): String;
+begin
+  If (Index < 0) or (Index >= FCount) then
+    RaiseIndexError(Index);
+  Result:=PShortString(@FStrs[FHashList^[Index].StrIndex])^;
+end;
+
+
+function TFPHashList.Extract(item: Pointer): Pointer;
+var
+  i : Integer;
+begin
+  result := nil;
+  i := IndexOf(item);
+  if i >= 0 then
+   begin
+     Result := item;
+     Delete(i);
+   end;
+end;
+
+
+procedure TFPHashList.SetCapacity(NewCapacity: Integer);
+begin
+  If (NewCapacity < FCount) or (NewCapacity > MaxHashListSize) then
+     Error (SListCapacityError, NewCapacity);
+  if NewCapacity = FCapacity then
+    exit;
+  ReallocMem(FHashList, NewCapacity*SizeOf(THashItem));
+  FCapacity := NewCapacity;
+end;
+
+
+procedure TFPHashList.SetCount(NewCount: Integer);
+begin
+  if (NewCount < 0) or (NewCount > MaxHashListSize)then
+    Error(SListCountError, NewCount);
+  If NewCount > FCount then
+    begin
+      If NewCount > FCapacity then
+        SetCapacity(NewCount);
+      If FCount < NewCount then
+        FillChar(FHashList^[FCount], (NewCount-FCount) div Sizeof(THashItem), 0);
+    end;
+  FCount := Newcount;
+end;
+
+
+procedure TFPHashList.SetStrCapacity(NewCapacity: Integer);
+begin
+  If (NewCapacity < FStrCount) or (NewCapacity > MaxHashStrSize) then
+     Error (SListCapacityError, NewCapacity);
+  if NewCapacity = FStrCapacity then
+    exit;
+  ReallocMem(FStrs, NewCapacity);
+  FStrCapacity := NewCapacity;
+end;
+
+
+procedure TFPHashList.SetHashCapacity(NewCapacity: Integer);
+var
+  i : Integer;
+begin
+  If (NewCapacity < 1) then
+    Error (SListCapacityError, NewCapacity);
+  if FHashCapacity=NewCapacity then
+    exit;
+  FHashCapacity:=NewCapacity;
+  ReallocMem(FHashTable, FHashCapacity*sizeof(Integer));
+  { Rehash }
+  FillDword(FHashTable^,FHashCapacity,LongWord(-1));
+  For i:=0 To FCount-1 Do
+    AddToHashTable(i);
+end;
+
+
+constructor TFPHashList.Create;
+begin
+  SetHashCapacity(1);
+end;
+
+
+destructor TFPHashList.Destroy;
+begin
+  Clear;
+  if assigned(FHashTable) then
+    FreeMem(FHashTable);
+  inherited Destroy;
+end;
+
+
+function TFPHashList.AddStr(const s:string): Integer;
+var
+  Len : Integer;
+begin
+  len:=length(s)+1;
+  if FStrCount+Len >= FStrCapacity then
+    StrExpand(Len);
+  System.Move(s[0],FStrs[FStrCount],Len);
+  result:=FStrCount;
+  inc(FStrCount,Len);
+end;
+
+
+procedure TFPHashList.AddToHashTable(Index: Integer);
+var
+  HashIndex : Integer;
+begin
+  with FHashList^[Index] do
+    begin
+      if not assigned(Data) then
+        exit;
+      HashIndex:=HashValue mod LongWord(FHashCapacity);
+      NextIndex:=FHashTable^[HashIndex];
+      FHashTable^[HashIndex]:=Index;
+    end;
+end;
+
+
+function TFPHashList.Add(const AName:string;Item: Pointer): Integer;
+begin
+  if FCount = FCapacity then
+    Expand;
+  with FHashList^[FCount] do
+    begin
+      HashValue:=FPHash(AName);
+      Data:=Item;
+      StrIndex:=AddStr(AName);
+    end;
+  AddToHashTable(FCount);
+  Result := FCount;
+  inc(FCount);
+end;
+
+procedure TFPHashList.Clear;
+begin
+  if Assigned(FHashList) then
+    begin
+      FCount:=0;
+      SetCapacity(0);
+      FHashList := nil;
+    end;
+  SetHashCapacity(1);
+  if Assigned(FStrs) then
+    begin
+      FStrCount:=0;
+      SetStrCapacity(0);
+      FStrs := nil;
+    end;
+end;
+
+procedure TFPHashList.Delete(Index: Integer);
+begin
+  If (Index<0) or (Index>=FCount) then
+    Error (SListIndexError, Index);
+  FHashList^[Index].Data:=nil;
+end;
+
+class procedure TFPHashList.Error(const Msg: string; Data: PtrInt);
+begin
+  Raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
+end;
+
+function TFPHashList.Expand: TFPHashList;
+var
+  IncSize : Longint;
+begin
+  Result := Self;
+  if FCount < FCapacity then
+    exit;
+  IncSize := 4;
+  if FCapacity > 127 then
+    Inc(IncSize, FCapacity shr 2)
+  else if FCapacity > 8 then
+    inc(IncSize,8)
+  else if FCapacity > 3 then
+    inc(IncSize,4);
+  SetCapacity(FCapacity + IncSize);
+  { Maybe expand hash also }
+  if FCount>FHashCapacity*MaxItemsPerHash then
+    SetHashCapacity(FCount div MaxItemsPerHash);
+end;
+
+procedure TFPHashList.StrExpand(MinIncSize:Integer);
+var
+  IncSize : Longint;
+begin
+  if FStrCount+MinIncSize < FStrCapacity then
+    exit;
+  IncSize := 64+MinIncSize;
+  if FStrCapacity > 255 then
+    Inc(IncSize, FStrCapacity shr 2);
+  SetStrCapacity(FStrCapacity + IncSize);
+end;
+
+function TFPHashList.IndexOf(Item: Pointer): Integer;
+begin
+  Result := 0;
+  while(Result < FCount) and (FHashList^[Result].Data <> Item) do Result := Result + 1;
+  If Result = FCount  then Result := -1;
+end;
+
+function TFPHashList.Find(const s:string): Pointer;
+var
+  CurrHash : LongWord;
+  Index,
+  HashIndex : Integer;
+  Len,
+  LastChar  : Char;
+begin
+  CurrHash:=FPHash(s);
+  HashIndex:=CurrHash mod LongWord(FHashCapacity);
+  Index:=FHashTable^[HashIndex];
+  Len:=Char(Length(s));
+  LastChar:=s[Byte(Len)];
+  while Index<>-1 do
+    begin
+      with FHashList^[Index] do
+        begin
+          if assigned(Data) and
+             (HashValue=CurrHash) and
+             (Len=FStrs[StrIndex]) and
+             (LastChar=FStrs[StrIndex+Byte(Len)]) and
+             (s=PShortString(@FStrs[StrIndex])^) then
+            begin
+              Result:=Data;
+              exit;
+            end;
+          Index:=NextIndex;
+        end;
+    end;
+  Result:=nil;
+end;
+
+function TFPHashList.Remove(Item: Pointer): Integer;
+begin
+  Result := IndexOf(Item);
+  If Result <> -1 then
+    Self.Delete(Result);
+end;
+
+procedure TFPHashList.Pack;
+begin
+  SetCapacity(FCount);
+  SetStrCapacity(FStrCount);
+end;
+
+
+procedure TFPHashList.ShowStatistics;
+var
+  HashMean,
+  HashStdDev : Double;
+  Index,
+  i,j : Integer;
+begin
+  { Calculate Mean and StdDev }
+  HashMean:=0;
+  HashStdDev:=0;
+  for i:=0 to FHashCapacity-1 do
+    begin
+      j:=0;
+      Index:=FHashTable^[i];
+      while (Index<>-1) do
+        begin
+          inc(j);
+          Index:=FHashList^[Index].NextIndex;
+        end;
+      HashMean:=HashMean+j;
+      HashStdDev:=HashStdDev+Sqr(j);
+    end;
+  HashMean:=HashMean/FHashCapacity;
+  HashStdDev:=(HashStdDev-FHashCapacity*Sqr(HashMean));
+  If FHashCapacity>1 then
+    HashStdDev:=Sqrt(HashStdDev/(FHashCapacity-1))
+  else
+    HashStdDev:=0;
+  { Print info to stdout }
+  Writeln('HashSize   : ',FHashCapacity);
+  Writeln('HashMean   : ',HashMean:1:4);
+  Writeln('HashStdDev : ',HashStdDev:1:4);
+  Writeln('ListSize   : ',FCount,'/',FCapacity);
+  Writeln('StringSize : ',FStrCount,'/',FStrCapacity);
+end;
+
+
+procedure TFPHashList.ForEachCall(proc2call:TListCallback;arg:pointer);
+var
+  i : integer;
+  p : pointer;
+begin
+  For I:=0 To Count-1 Do
+    begin
+      p:=FHashList^[i].Data;
+      if assigned(p) then
+        proc2call(p,arg);
+    end;
+end;
+
+
+procedure TFPHashList.ForEachCall(proc2call:TListStaticCallback;arg:pointer);
+var
+  i : integer;
+  p : pointer;
+begin
+  For I:=0 To Count-1 Do
+    begin
+      p:=FHashList^[i].Data;
+      if assigned(p) then
+        proc2call(p,arg);
+    end;
+end;
+
+
+{*****************************************************************************
+                               TFPHashObject
+*****************************************************************************}
+
+constructor TFPHashObject.Create(HashObjectList:TFPHashObjectList;const s:string);
+begin
+  FOwner:=HashObjectList;
+  FIndex:=HashObjectList.Add(s,Self);
+end;
+
+
+function TFPHashObject.GetName:string;
+begin
+  Result:=FOwner.NameOfIndex(FIndex);
+end;
+
+
+{*****************************************************************************
+            TFPHashObjectList (Copied from rtl/objpas/classes/lists.inc)
+*****************************************************************************}
+
+constructor TFPHashObjectList.Create(FreeObjects : boolean = True);
+begin
+  inherited Create;
+  FHashList := TFPHashList.Create;
+  FFreeObjects := Freeobjects;
+end;
+
+destructor TFPHashObjectList.Destroy;
+begin
+  if (FHashList <> nil) then
+  begin
+    Clear;
+    FHashList.Destroy;
+  end;
+  inherited Destroy;
+end;
+
+procedure TFPHashObjectList.Clear;
+var
+  i: integer;
+begin
+  if FFreeObjects then
+    for i := 0 to FHashList.Count - 1 do
+      TObject(FHashList[i]).Free;
+  FHashList.Clear;
+end;
+
+function TFPHashObjectList.GetCount: integer;
+begin
+  Result := FHashList.Count;
+end;
+
+procedure TFPHashObjectList.SetCount(const AValue: integer);
+begin
+  if FHashList.Count <> AValue then
+    FHashList.Count := AValue;
+end;
+
+function TFPHashObjectList.GetItem(Index: Integer): TObject;
+begin
+  Result := TObject(FHashList[Index]);
+end;
+
+procedure TFPHashObjectList.SetCapacity(NewCapacity: Integer);
+begin
+  FHashList.Capacity := NewCapacity;
+end;
+
+function TFPHashObjectList.GetCapacity: integer;
+begin
+  Result := FHashList.Capacity;
+end;
+
+function TFPHashObjectList.Add(const AName:string;AObject: TObject): Integer;
+begin
+  Result := FHashList.Add(AName,AObject);
+end;
+
+function TFPHashObjectList.NameOfIndex(Index: Integer): String;
+begin
+  Result := FHashList.NameOfIndex(Index);
+end;
+
+procedure TFPHashObjectList.Delete(Index: Integer);
+begin
+  if OwnsObjects then
+    TObject(FHashList[Index]).Free;
+  FHashList.Delete(Index);
+end;
+
+function TFPHashObjectList.Expand: TFPHashObjectList;
+begin
+  FHashList.Expand;
+  Result := Self;
+end;
+
+function TFPHashObjectList.Extract(Item: TObject): TObject;
+begin
+  Result := TObject(FHashList.Extract(Item));
+end;
+
+function TFPHashObjectList.Remove(AObject: TObject): Integer;
+begin
+  Result := IndexOf(AObject);
+  if (Result <> -1) then
+  begin
+    if OwnsObjects then
+      TObject(FHashList[Result]).Free;
+    FHashList.Delete(Result);
+  end;
+end;
+
+function TFPHashObjectList.IndexOf(AObject: TObject): Integer;
+begin
+  Result := FHashList.IndexOf(Pointer(AObject));
+end;
+
+
+function TFPHashObjectList.Find(const s:string): TObject;
+begin
+  result:=TObject(FHashList.Find(s));
+end;
+
+
+function TFPHashObjectList.FindInstanceOf(AClass: TClass; AExact: Boolean; AStartAt : Integer): Integer;
+var
+  I : Integer;
+begin
+  I:=AStartAt;
+  Result:=-1;
+  If AExact then
+    while (I<Count) and (Result=-1) do
+      If Items[i].ClassType=AClass then
+        Result:=I
+      else
+        Inc(I)
+  else
+    while (I<Count) and (Result=-1) do
+      If Items[i].InheritsFrom(AClass) then
+        Result:=I
+      else
+        Inc(I);
+end;
+
+
+procedure TFPHashObjectList.Pack;
+begin
+  FHashList.Pack;
+end;
+
+
+procedure TFPHashObjectList.ShowStatistics;
+begin
+  FHashList.ShowStatistics;
+end;
+
+
+procedure TFPHashObjectList.ForEachCall(proc2call:TObjectListCallback;arg:pointer);
+begin
+  FHashList.ForEachCall(TListCallBack(proc2call),arg);
+end;
+
+
+procedure TFPHashObjectList.ForEachCall(proc2call:TObjectListStaticCallback;arg:pointer);
+begin
+  FHashList.ForEachCall(TListStaticCallBack(proc2call),arg);
+end;
+
+
+
 {****************************************************************************
                              TLinkedListItem
  ****************************************************************************}

compiler/globals.pas

@@ -2258,7 +2258,7 @@ end;
         initmodeswitches:=fpcmodeswitches;
         initlocalswitches:=[cs_check_io,cs_typed_const_writable];
         initmoduleswitches:=[cs_extsyntax,cs_implicit_exceptions];
-        initglobalswitches:=[cs_check_unit_name,cs_link_static{$ifdef INTERNALLINKER},cs_link_internal,cs_link_map{$endif}];
+        initglobalswitches:=[cs_check_unit_name,cs_link_static{$ifdef INTERNALLINKER},cs_link_internal{$endif}];
         initoptimizerswitches:=[];
         initsourcecodepage:='8859-1';
         initpackenum:=4;

compiler/globtype.pas

@@ -133,7 +133,8 @@ than 255 characters. That's why using Ansi Strings}
          cs_asm_regalloc,cs_asm_tempalloc,cs_asm_nodes,
          { linking }
          cs_link_extern,cs_link_static,cs_link_smart,cs_link_shared,cs_link_deffile,
-         cs_link_strip,cs_link_staticflag,cs_link_on_target,cs_link_internal,
+         cs_link_strip,cs_link_staticflag,cs_link_on_target,cs_link_internal,cs_link_opt_vtable,
+         cs_link_opt_used_sections,
          cs_link_map,cs_link_pthread
        );
        tglobalswitches = set of tglobalswitch;

compiler/ogbase.pas

@@ -1119,7 +1119,6 @@ implementation
     procedure TExeVTable.AddChild(vt:TExeVTable);
       begin
         ChildList.Add(vt);
-writeln(ExeSymbol.Name,'-',vt.ExeSymbol.Name);
       end;
 
 
@@ -1163,7 +1162,6 @@ writeln(ExeSymbol.Name,'-',vt.ExeSymbol.Name);
         CheckIdx(VTableIdx);
         if EntryArray[VTableIdx].Used then
           exit;
-writeln(ExeSymbol.Name,'(',VTableIdx,')');
         { Restore relocation if available }
         if assigned(EntryArray[VTableIdx].ObjRelocation) then
           begin
@@ -1600,19 +1598,22 @@ writeln(ExeSymbol.Name,'(',VTableIdx,')');
                   VTENTRY and VTINHERIT symbols }
                 if objsym.bind=AB_LOCAL then
                   begin
-                    hs:=objsym.name;
-                    if (hs[1]='V') then
+                    if cs_link_opt_vtable in aktglobalswitches then
                       begin
-                        if Copy(hs,1,5)='VTREF' then
+                        hs:=objsym.name;
+                        if (hs[1]='V') then
                           begin
-                            if not assigned(objsym.ObjSection.VTRefList) then
-                              objsym.ObjSection.VTRefList:=TFPObjectList.Create(false);
-                            objsym.ObjSection.VTRefList.Add(objsym);
-                          end
-                        else if Copy(hs,1,7)='VTENTRY' then
-                          VTEntryList.Add(objsym)
-                        else if Copy(hs,1,9)='VTINHERIT' then
-                          VTInheritList.Add(objsym);
+                            if Copy(hs,1,5)='VTREF' then
+                              begin
+                                if not assigned(objsym.ObjSection.VTRefList) then
+                                  objsym.ObjSection.VTRefList:=TFPObjectList.Create(false);
+                                objsym.ObjSection.VTRefList.Add(objsym);
+                              end
+                            else if Copy(hs,1,7)='VTENTRY' then
+                              VTEntryList.Add(objsym)
+                            else if Copy(hs,1,9)='VTINHERIT' then
+                              VTInheritList.Add(objsym);
+                          end;
                       end;
                     continue;
                   end;
@@ -1697,7 +1698,8 @@ writeln(ExeSymbol.Name,'(',VTableIdx,')');
           Comment(V_Error,'Entrypoint '+EntryName+' not defined');
 
         { Generate VTable tree }
-        BuildVTableTree(VTInheritList,VTEntryList);
+        if cs_link_opt_vtable in aktglobalswitches then
+          BuildVTableTree(VTInheritList,VTEntryList);
         VTInheritList.Free;
         VTEntryList.Free;
       end;
@@ -2085,23 +2087,26 @@ writeln(ExeSymbol.Name,'(',VTableIdx,')');
               DoReloc(TObjRelocation(objsec.ObjRelocations[i]));
 
             { Process Virtual Entry calls }
-            for i:=0 to objsec.VTRefList.count-1 do
+            if cs_link_opt_vtable in aktglobalswitches then
               begin
-                objsym:=TObjSymbol(objsec.VTRefList[i]);
-                hs:=objsym.name;
-                Delete(hs,1,Pos('_',hs));
-                k:=Pos('$$',hs);
-                if k=0 then
-                  internalerror(200603314);
-                vtableexesym:=texesymbol(FExeSymbolDict.search(Copy(hs,1,k-1)));
-                val(Copy(hs,k+2,length(hs)-k-1),vtableidx,code);
-                if (code<>0) then
-                  internalerror(200603317);
-                if not assigned(vtableexesym) then
-                  internalerror(200603315);
-                if not assigned(vtableexesym.vtable) then
-                  internalerror(200603316);
-                DoVTableRef(vtableexesym.vtable,vtableidx);
+                for i:=0 to objsec.VTRefList.count-1 do
+                  begin
+                    objsym:=TObjSymbol(objsec.VTRefList[i]);
+                    hs:=objsym.name;
+                    Delete(hs,1,Pos('_',hs));
+                    k:=Pos('$$',hs);
+                    if k=0 then
+                      internalerror(200603314);
+                    vtableexesym:=texesymbol(FExeSymbolDict.search(Copy(hs,1,k-1)));
+                    val(Copy(hs,k+2,length(hs)-k-1),vtableidx,code);
+                    if (code<>0) then
+                      internalerror(200603317);
+                    if not assigned(vtableexesym) then
+                      internalerror(200603315);
+                    if not assigned(vtableexesym.vtable) then
+                      internalerror(200603316);
+                    DoVTableRef(vtableexesym.vtable,vtableidx);
+                  end;
               end;
           end;
         ObjSectionWorkList.Free;

compiler/options.pas

@@ -1251,6 +1251,13 @@ begin
                     'c' : Cshared:=TRUE;
                     't' :
                       include(initglobalswitches,cs_link_staticflag);
+                    'v' :
+                      begin
+                        If UnsetBool(More, j) then
+                          exclude(initglobalswitches,cs_link_opt_vtable)
+                        else
+                          include(initglobalswitches,cs_link_opt_vtable);
+                      end;
                     'D' :
                       begin
                         def_system_macro('FPC_LINK_DYNAMIC');