* interface wrapper generation moved to cgobj

  * generate interface wrappers after the module is parsed

compiler/cgobj.pas

@@ -414,6 +414,8 @@ unit cgobj;
              @param(usedinproc Registers which are used in the code of this routine)
           }
           procedure g_restore_standard_registers(list:Taasmoutput);virtual;
+          procedure g_intf_wrapper(list: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);virtual;abstract;
+          procedure g_adjust_self_value(list:taasmoutput;procdef: tprocdef;ioffset: aint);virtual;
        end;
 
 {$ifndef cpu64bit}
@@ -488,7 +490,7 @@ implementation
 
     uses
        globals,options,systems,
-       verbose,defutil,paramgr,
+       verbose,defutil,paramgr,symsym,
        tgobj,cutils,procinfo;
 
     const
@@ -1982,6 +1984,38 @@ implementation
       end;
 
 
+    procedure tcg.g_adjust_self_value(list:taasmoutput;procdef: tprocdef;ioffset: aint);
+      var
+        hsym : tsym;
+        href : treference;
+        paraloc : tcgparalocation;
+      begin
+        { calculate the parameter info for the procdef }
+        if not procdef.has_paraloc_info then
+          begin
+            procdef.requiredargarea:=paramanager.create_paraloc_info(procdef,callerside);
+            procdef.has_paraloc_info:=true;
+          end;
+        hsym:=tsym(procdef.parast.search('self'));
+        if not(assigned(hsym) and
+               (hsym.typ=paravarsym)) then
+          internalerror(200305251);
+        paraloc:=tparavarsym(hsym).paraloc[callerside].location^;
+        case paraloc.loc of
+          LOC_REGISTER:
+            cg.a_op_const_reg(list,OP_SUB,paraloc.size,ioffset,paraloc.register);
+          LOC_REFERENCE:
+            begin
+               { offset in the wrapper needs to be adjusted for the stored
+                 return address }
+               reference_reset_base(href,paraloc.reference.index,paraloc.reference.offset+sizeof(aint));
+               cg.a_op_const_ref(list,OP_SUB,paraloc.size,ioffset,href);
+            end
+          else
+            internalerror(200309189);
+        end;
+      end;
+
 {*****************************************************************************
                                     TCG64
 *****************************************************************************}
@@ -2031,7 +2065,11 @@ finalization
 end.
 {
   $Log$
-  Revision 1.190  2005-01-20 17:47:01  peter
+  Revision 1.191  2005-01-24 22:08:32  peter
+    * interface wrapper generation moved to cgobj
+    * generate interface wrappers after the module is parsed
+
+  Revision 1.190  2005/01/20 17:47:01  peter
     * remove copy_value_on_stack and a_param_copy_ref
 
   Revision 1.189  2005/01/20 16:38:45  peter

compiler/i386/cgcpu.pas

@@ -31,7 +31,7 @@ unit cgcpu;
        cgbase,cgobj,cg64f32,cgx86,
        aasmbase,aasmtai,aasmcpu,
        cpubase,parabase,cgutils,
-       symconst
+       symconst,symdef
        ;
 
     type
@@ -49,6 +49,7 @@ unit cgcpu;
         procedure g_exception_reason_save(list : taasmoutput; const href : treference);override;
         procedure g_exception_reason_save_const(list : taasmoutput; const href : treference; a: aint);override;
         procedure g_exception_reason_load(list : taasmoutput; const href : treference);override;
+        procedure g_intf_wrapper(list: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);override;
      end;
 
       tcg64f386 = class(tcg64f32)
@@ -64,7 +65,7 @@ unit cgcpu;
 
     uses
        globals,verbose,systems,cutils,
-       paramgr,procinfo,
+       paramgr,procinfo,fmodule,
        rgcpu,rgx86;
 
     function use_push(const cgpara:tcgpara):boolean;
@@ -430,6 +431,184 @@ unit cgcpu;
       end;
 
 
+
+    procedure tcg386.g_intf_wrapper(list: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);
+      {
+      possible calling conventions:
+                    default stdcall cdecl pascal register
+      default(0):      OK     OK    OK(1)  OK       OK
+      virtual(2):      OK     OK    OK(3)  OK       OK
+
+      (0):
+          set self parameter to correct value
+          jmp mangledname
+
+      (1): The code is the following
+           set self parameter to correct value
+           call mangledname
+           set self parameter to interface value
+
+      (2): The wrapper code use %eax to reach the virtual method address
+           set self to correct value
+           move self,%eax
+           mov  0(%eax),%eax ; load vmt
+           jmp  vmtoffs(%eax) ; method offs
+
+      (3): The wrapper code use %eax to reach the virtual method address
+           set self to correct value
+           move self,%eax
+           mov  0(%eax),%eax ; load vmt
+           jmp  vmtoffs(%eax) ; method offs
+           set self parameter to interface value
+
+
+      (4): Virtual use values pushed on stack to reach the method address
+           so the following code be generated:
+           set self to correct value
+           push %ebx ; allocate space for function address
+           push %eax
+           mov  self,%eax
+           mov  0(%eax),%eax ; load vmt
+           mov  vmtoffs(%eax),eax ; method offs
+           mov  %eax,4(%esp)
+           pop  %eax
+           ret  0; jmp the address
+
+      }
+
+        procedure getselftoeax(offs: longint);
+        var
+          href : treference;
+          selfoffsetfromsp : longint;
+        begin
+          { mov offset(%esp),%eax }
+          if (procdef.proccalloption<>pocall_register) then
+            begin
+              { framepointer is pushed for nested procs }
+              if procdef.parast.symtablelevel>normal_function_level then
+                selfoffsetfromsp:=2*sizeof(aint)
+              else
+                selfoffsetfromsp:=sizeof(aint);
+              reference_reset_base(href,NR_ESP,selfoffsetfromsp+offs);
+              cg.a_load_ref_reg(list,OS_ADDR,OS_ADDR,href,NR_EAX);
+            end;
+        end;
+
+        procedure loadvmttoeax;
+        var
+          href : treference;
+        begin
+          { mov  0(%eax),%eax ; load vmt}
+          reference_reset_base(href,NR_EAX,0);
+          cg.a_load_ref_reg(list,OS_ADDR,OS_ADDR,href,NR_EAX);
+        end;
+
+        procedure op_oneaxmethodaddr(op: TAsmOp);
+        var
+          href : treference;
+        begin
+          if (procdef.extnumber=$ffff) then
+            Internalerror(200006139);
+          { call/jmp  vmtoffs(%eax) ; method offs }
+          reference_reset_base(href,NR_EAX,procdef._class.vmtmethodoffset(procdef.extnumber));
+          list.concat(taicpu.op_ref(op,S_L,href));
+        end;
+
+        procedure loadmethodoffstoeax;
+        var
+          href : treference;
+        begin
+          if (procdef.extnumber=$ffff) then
+            Internalerror(200006139);
+          { mov vmtoffs(%eax),%eax ; method offs }
+          reference_reset_base(href,NR_EAX,procdef._class.vmtmethodoffset(procdef.extnumber));
+          cg.a_load_ref_reg(list,OS_ADDR,OS_ADDR,href,NR_EAX);
+        end;
+
+      var
+        lab : tasmsymbol;
+        make_global : boolean;
+        href : treference;
+      begin
+        if procdef.proctypeoption<>potype_none then
+          Internalerror(200006137);
+        if not assigned(procdef._class) or
+           (procdef.procoptions*[po_classmethod, po_staticmethod,
+             po_methodpointer, po_interrupt, po_iocheck]<>[]) then
+          Internalerror(200006138);
+        if procdef.owner.symtabletype<>objectsymtable then
+          Internalerror(200109191);
+
+        make_global:=false;
+        if (not current_module.is_unit) or
+           (cs_create_smart in aktmoduleswitches) or
+           (af_smartlink_sections in target_asm.flags) or
+           (procdef.owner.defowner.owner.symtabletype=globalsymtable) then
+          make_global:=true;
+
+        if make_global then
+         List.concat(Tai_symbol.Createname_global(labelname,AT_FUNCTION,0))
+        else
+         List.concat(Tai_symbol.Createname(labelname,AT_FUNCTION,0));
+
+        { set param1 interface to self  }
+        g_adjust_self_value(list,procdef,ioffset);
+
+        { case 1 or 2 }
+        if (procdef.proccalloption in clearstack_pocalls) then
+          begin
+            if po_virtualmethod in procdef.procoptions then
+              begin
+                { case 2 }
+                getselftoeax(0);
+                loadvmttoeax;
+                op_oneaxmethodaddr(A_CALL);
+              end
+            else
+              begin
+                { case 1 }
+                cg.a_call_name(list,procdef.mangledname);
+              end;
+            { restore param1 value self to interface }
+            g_adjust_self_value(list,procdef,-ioffset);
+          end
+        else if po_virtualmethod in procdef.procoptions then
+          begin
+            if (procdef.proccalloption=pocall_register) then
+              begin
+                { case 4 }
+                list.concat(taicpu.op_reg(A_PUSH,S_L,NR_EBX)); { allocate space for address}
+                list.concat(taicpu.op_reg(A_PUSH,S_L,NR_EAX));
+                getselftoeax(8);
+                loadvmttoeax;
+                loadmethodoffstoeax;
+                { mov %eax,4(%esp) }
+                reference_reset_base(href,NR_ESP,4);
+                list.concat(taicpu.op_reg_ref(A_MOV,S_L,NR_EAX,href));
+                { pop  %eax }
+                list.concat(taicpu.op_reg(A_POP,S_L,NR_EAX));
+                { ret  ; jump to the address }
+                list.concat(taicpu.op_none(A_RET,S_L));
+              end
+            else
+              begin
+                { case 3 }
+                getselftoeax(0);
+                loadvmttoeax;
+                op_oneaxmethodaddr(A_JMP);
+              end;
+          end
+        { case 0 }
+        else
+          begin
+            lab:=objectlibrary.newasmsymbol(procdef.mangledname,AB_EXTERNAL,AT_FUNCTION);
+            list.concat(taicpu.op_sym(A_JMP,S_NO,lab));
+          end;
+
+        List.concat(Tai_symbol_end.Createname(labelname));
+      end;
+
+
 { ************* 64bit operations ************ }
 
     procedure tcg64f386.get_64bit_ops(op:TOpCG;var op1,op2:TAsmOp);
@@ -564,7 +743,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.63  2005-01-18 22:19:20  peter
+  Revision 1.64  2005-01-24 22:08:32  peter
+    * interface wrapper generation moved to cgobj
+    * generate interface wrappers after the module is parsed
+
+  Revision 1.63  2005/01/18 22:19:20  peter
     * multiple location support for i386 a_param_ref
     * remove a_param_copy_ref for i386
 

compiler/i386/cpunode.pas

@@ -53,8 +53,6 @@ unit cpunode;
        n386mem,
        n386set,
        n386inl,
-       { this not really a node }
-       n386obj,
        n386mat,
        n386cnv
        ;
@@ -62,7 +60,11 @@ unit cpunode;
 end.
 {
   $Log$
-  Revision 1.21  2004-06-20 08:55:31  florian
+  Revision 1.22  2005-01-24 22:08:32  peter
+    * interface wrapper generation moved to cgobj
+    * generate interface wrappers after the module is parsed
+
+  Revision 1.21  2004/06/20 08:55:31  florian
     * logs truncated
 
   Revision 1.20  2004/02/22 12:04:04  florian

compiler/i386/n386obj.pas

@@ -1,267 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2002 by Kovacs Attila Zoltan
-
-    Generate i386 assembly wrapper code interface implementor objects
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit n386obj;
-
-{$i fpcdefs.inc}
-
-interface
-
-
-implementation
-
-uses
-  systems,
-  verbose,globals,globtype,
-  aasmbase,aasmtai,
-  symconst,symdef,
-  fmodule,
-  nobj,
-  cpubase,
-  cga,cgutils,cgobj;
-
-   type
-     ti386classheader=class(tclassheader)
-     protected
-       procedure cgintfwrapper(asmlist: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);override;
-     end;
-
-{
-possible calling conventions:
-              default stdcall cdecl pascal register
-default(0):      OK     OK    OK(1)  OK       OK
-virtual(2):      OK     OK    OK(3)  OK       OK
-
-(0):
-    set self parameter to correct value
-    jmp mangledname
-
-(1): The code is the following
-     set self parameter to correct value
-     call mangledname
-     set self parameter to interface value
-
-(2): The wrapper code use %eax to reach the virtual method address
-     set self to correct value
-     move self,%eax
-     mov  0(%eax),%eax ; load vmt
-     jmp  vmtoffs(%eax) ; method offs
-
-(3): The wrapper code use %eax to reach the virtual method address
-     set self to correct value
-     move self,%eax
-     mov  0(%eax),%eax ; load vmt
-     jmp  vmtoffs(%eax) ; method offs
-     set self parameter to interface value
-
-
-(4): Virtual use values pushed on stack to reach the method address
-     so the following code be generated:
-     set self to correct value
-     push %ebx ; allocate space for function address
-     push %eax
-     mov  self,%eax
-     mov  0(%eax),%eax ; load vmt
-     mov  vmtoffs(%eax),eax ; method offs
-     mov  %eax,4(%esp)
-     pop  %eax
-     ret  0; jmp the address
-
-}
-
-function getselfoffsetfromsp(procdef: tprocdef): longint;
-begin
-  { framepointer is pushed for nested procs }
-  if procdef.parast.symtablelevel>normal_function_level then
-    getselfoffsetfromsp:=2*sizeof(aint)
-  else
-    getselfoffsetfromsp:=sizeof(aint);
-end;
-
-
-procedure ti386classheader.cgintfwrapper(asmlist: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);
-
-  procedure getselftoeax(offs: longint);
-  var
-    href : treference;
-  begin
-    { mov offset(%esp),%eax }
-    if (procdef.proccalloption<>pocall_register) then
-      begin
-        reference_reset_base(href,NR_ESP,getselfoffsetfromsp(procdef)+offs);
-        cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,href,NR_EAX);
-      end;
-  end;
-
-  procedure loadvmttoeax;
-  var
-    href : treference;
-  begin
-    { mov  0(%eax),%eax ; load vmt}
-    reference_reset_base(href,NR_EAX,0);
-    cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,href,NR_EAX);
-  end;
-
-  procedure op_oneaxmethodaddr(op: TAsmOp);
-  var
-    href : treference;
-  begin
-    if (procdef.extnumber=$ffff) then
-      Internalerror(200006139);
-    { call/jmp  vmtoffs(%eax) ; method offs }
-    reference_reset_base(href,NR_EAX,procdef._class.vmtmethodoffset(procdef.extnumber));
-    emit_ref(op,S_L,href);
-  end;
-
-  procedure loadmethodoffstoeax;
-  var
-    href : treference;
-  begin
-    if (procdef.extnumber=$ffff) then
-      Internalerror(200006139);
-    { mov vmtoffs(%eax),%eax ; method offs }
-    reference_reset_base(href,NR_EAX,procdef._class.vmtmethodoffset(procdef.extnumber));
-    cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,href,NR_EAX);
-  end;
-
-var
-  oldexprasmlist: TAAsmoutput;
-  lab : tasmsymbol;
-  make_global : boolean;
-  href : treference;
-begin
-  if procdef.proctypeoption<>potype_none then
-    Internalerror(200006137);
-  if not assigned(procdef._class) or
-     (procdef.procoptions*[po_classmethod, po_staticmethod,
-       po_methodpointer, po_interrupt, po_iocheck]<>[]) then
-    Internalerror(200006138);
-  if procdef.owner.symtabletype<>objectsymtable then
-    Internalerror(200109191);
-
-  oldexprasmlist:=exprasmlist;
-  exprasmlist:=asmlist;
-
-  make_global:=false;
-  if (not current_module.is_unit) or
-     (cs_create_smart in aktmoduleswitches) or
-     (af_smartlink_sections in target_asm.flags) or
-     (procdef.owner.defowner.owner.symtabletype=globalsymtable) then
-    make_global:=true;
-
-  if make_global then
-   exprasmList.concat(Tai_symbol.Createname_global(labelname,AT_FUNCTION,0))
-  else
-   exprasmList.concat(Tai_symbol.Createname(labelname,AT_FUNCTION,0));
-
-  { set param1 interface to self  }
-  adjustselfvalue(procdef,ioffset);
-
-  { case 1 or 2 }
-  if (procdef.proccalloption in clearstack_pocalls) then
-    begin
-      if po_virtualmethod in procdef.procoptions then
-        begin
-          { case 2 }
-          getselftoeax(0);
-          loadvmttoeax;
-          op_oneaxmethodaddr(A_CALL);
-        end
-      else
-        begin
-          { case 1 }
-          cg.a_call_name(exprasmlist,procdef.mangledname);
-        end;
-      { restore param1 value self to interface }
-      adjustselfvalue(procdef,-ioffset);
-    end
-  else if po_virtualmethod in procdef.procoptions then
-    begin
-      if (procdef.proccalloption=pocall_register) then
-        begin
-          { case 4 }
-          emit_reg(A_PUSH,S_L,NR_EBX); { allocate space for address}
-          emit_reg(A_PUSH,S_L,NR_EAX);
-          getselftoeax(8);
-          loadvmttoeax;
-          loadmethodoffstoeax;
-          { mov %eax,4(%esp) }
-          reference_reset_base(href,NR_ESP,4);
-          emit_reg_ref(A_MOV,S_L,NR_EAX,href);
-          { pop  %eax }
-          emit_reg(A_POP,S_L,NR_EAX);
-          { ret  ; jump to the address }
-          emit_none(A_RET,S_L);
-        end
-      else
-        begin
-          { case 3 }
-          getselftoeax(0);
-          loadvmttoeax;
-          op_oneaxmethodaddr(A_JMP);
-        end;
-    end
-  { case 0 }
-  else
-    begin
-      lab:=objectlibrary.newasmsymbol(procdef.mangledname,AB_EXTERNAL,AT_FUNCTION);
-      emit_sym(A_JMP,S_NO,lab);
-    end;
-
-  exprasmList.concat(Tai_symbol_end.Createname(labelname));
-
-  exprasmlist:=oldexprasmlist;
-end;
-
-
-initialization
-  cclassheader:=ti386classheader;
-end.
-{
-  $Log$
-  Revision 1.36  2004-10-31 21:45:03  peter
-    * generic tlocation
-    * move tlocation to cgutils
-
-  Revision 1.35  2004/10/24 20:01:08  peter
-    * remove saveregister calling convention
-
-  Revision 1.34  2004/06/20 08:55:31  florian
-    * logs truncated
-
-  Revision 1.33  2004/06/16 20:07:10  florian
-    * dwarf branch merged
-
-  Revision 1.32.2.2  2004/05/01 16:02:10  peter
-    * POINTER_SIZE replaced with sizeof(aint)
-    * aint,aword,tconst*int moved to globtype
-
-  Revision 1.32.2.1  2004/04/08 18:33:22  peter
-    * rewrite of TAsmSection
-
-  Revision 1.32  2004/03/02 00:36:33  olle
-    * big transformation of Tai_[const_]Symbol.Create[data]name*
-
-  Revision 1.31  2004/02/27 13:42:52  olle
-    + added Tai_symbol_end
-
-}

compiler/ncgutil.pas

@@ -71,6 +71,7 @@ interface
     procedure gen_load_return_value(list:TAAsmoutput);
 
     procedure gen_external_stub(list:taasmoutput;pd:tprocdef;const externalname:string);
+    procedure gen_intf_wrappers(list:taasmoutput;st:tsymtable);
 
    {#
       Allocate the buffers for exception management and setjmp environment.
@@ -2362,10 +2363,55 @@ implementation
          end;
       end;
 
+
+
+    procedure gen_intf_wrapper(list:taasmoutput;_class:tobjectdef);
+      var
+        rawdata: taasmoutput;
+        i,j,
+        proccount : longint;
+        tmps : string;
+      begin
+        for i:=1 to _class.implementedinterfaces.count do
+          begin
+            { only if implemented by this class }
+            if _class.implementedinterfaces.implindex(i)=i then
+              begin
+                proccount:=_class.implementedinterfaces.implproccount(i);
+                for j:=1 to proccount do
+                  begin
+                    tmps:=make_mangledname('WRPR',_class.owner,_class.objname^+'_$_'+
+                      _class.implementedinterfaces.interfaces(i).objname^+'_$_'+
+                      tostr(j)+'_$_'+_class.implementedinterfaces.implprocs(i,j).mangledname);
+                    { create wrapper code }
+                    cg.g_intf_wrapper(list,_class.implementedinterfaces.implprocs(i,j),tmps,_class.implementedinterfaces.ioffsets(i));
+                  end;
+              end;
+          end;
+      end;
+
+
+    procedure gen_intf_wrappers(list:taasmoutput;st:tsymtable);
+      var
+        def : tstoreddef;
+      begin
+        def:=tstoreddef(st.defindex.first);
+        while assigned(def) do
+          begin
+            if is_class(def) then
+              gen_intf_wrapper(list,tobjectdef(def));
+            def:=tstoreddef(def.indexnext);
+          end;
+      end;
+
 end.
 {
   $Log$
-  Revision 1.257  2005-01-20 17:47:01  peter
+  Revision 1.258  2005-01-24 22:08:32  peter
+    * interface wrapper generation moved to cgobj
+    * generate interface wrappers after the module is parsed
+
+  Revision 1.257  2005/01/20 17:47:01  peter
     * remove copy_value_on_stack and a_param_copy_ref
 
   Revision 1.256  2005/01/20 16:38:45  peter

compiler/nobj.pas

@@ -97,20 +97,13 @@ interface
       private
         { interface tables }
         function  gintfgetvtbllabelname(intfindex: integer): string;
-        procedure gintfcreatevtbl(intfindex: integer; rawdata,rawcode: TAAsmoutput);
+        procedure gintfcreatevtbl(intfindex: integer; rawdata: TAAsmoutput);
         procedure gintfgenentry(intfindex, contintfindex: integer; rawdata: TAAsmoutput);
-        procedure gintfoptimizevtbls(implvtbl : plongintarray);
+        procedure gintfoptimizevtbls;
         procedure gintfwritedata;
         function  gintfgetcprocdef(proc: tprocdef;const name: string): tprocdef;
         procedure gintfdoonintf(intf: tobjectdef; intfindex: longint);
         procedure gintfwalkdowninterface(intf: tobjectdef; intfindex: longint);
-      protected
-        { adjusts the self value with ioffset when casting a interface
-          to a class
-        }
-        procedure adjustselfvalue(procdef: tprocdef;ioffset: aint);virtual;
-        { generates the wrapper for a call to a method via an interface }
-        procedure cgintfwrapper(asmlist: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);virtual;abstract;
       public
         constructor create(c:tobjectdef);
         destructor destroy;override;
@@ -131,11 +124,6 @@ interface
         procedure writeinterfaceids;
       end;
 
-      tclassheaderclass=class of tclassheader;
-
-    var
-      cclassheader : tclassheaderclass;
-
 
 implementation
 
@@ -867,7 +855,7 @@ implementation
       end;
 
 
-    procedure tclassheader.gintfcreatevtbl(intfindex: integer; rawdata,rawcode: TAAsmoutput);
+    procedure tclassheader.gintfcreatevtbl(intfindex: integer; rawdata: TAAsmoutput);
       var
         implintf: timplementedinterfaces;
         curintf: tobjectdef;
@@ -888,8 +876,6 @@ implementation
             tmps:=make_mangledname('WRPR',_class.owner,_class.objname^+'_$_'+curintf.objname^+'_$_'+
               tostr(i)+'_$_'+
               implintf.implprocs(intfindex,i).mangledname);
-            { create wrapper code }
-            cgintfwrapper(rawcode,implintf.implprocs(intfindex,i),tmps,implintf.ioffsets(intfindex));
             { create reference }
             rawdata.concat(Tai_const.Createname(tmps,AT_FUNCTION,0));
           end;
@@ -941,21 +927,24 @@ implementation
       end;
 
 
-    procedure tclassheader.gintfoptimizevtbls(implvtbl : plongintarray);
+    procedure tclassheader.gintfoptimizevtbls;
       type
         tcompintfentry = record
           weight: longint;
           compintf: longint;
         end;
         { Max 1000 interface in the class header interfaces it's enough imho }
-        tcompintfs = packed array[1..1000] of tcompintfentry;
+        tcompintfs = array[1..1000] of tcompintfentry;
         pcompintfs = ^tcompintfs;
-        tequals    = packed array[1..1000] of longint;
+        tequals    = array[1..1000] of longint;
         pequals    = ^tequals;
+        timpls    = array[1..1000] of longint;
+        pimpls    = ^timpls;
       var
         max: longint;
         equals: pequals;
         compats: pcompintfs;
+        impls: pimpls;
         w,i,j,k: longint;
         cij: boolean;
         cji: boolean;
@@ -965,8 +954,10 @@ implementation
           Internalerror(200006135);
         getmem(compats,sizeof(tcompintfentry)*max);
         getmem(equals,sizeof(longint)*max);
+        getmem(impls,sizeof(longint)*max);
         fillchar(compats^,sizeof(tcompintfentry)*max,0);
         fillchar(equals^,sizeof(longint)*max,0);
+        fillchar(impls^,sizeof(longint)*max,0);
         { ismergepossible is a containing relation
           meaning of ismergepossible(a,b,w) =
           if implementorfunction map of a is contained implementorfunction map of b
@@ -1007,7 +998,7 @@ implementation
           end;
         { Reset, no replacements by default }
         for i:=1 to max do
-          implvtbl[i]:=i;
+          impls^[i]:=i;
         { Replace vtbls when equal or compat, repeat
           until there are no replacements possible anymore. This is
           needed for the cases like:
@@ -1018,38 +1009,36 @@ implementation
           k:=0;
           for i:=1 to max do
             begin
-              if compats^[implvtbl[i]].compintf<>0 then
-                implvtbl[i]:=compats^[implvtbl[i]].compintf
-              else if equals^[implvtbl[i]]<>0 then
-                implvtbl[i]:=equals^[implvtbl[i]]
+              if compats^[impls^[i]].compintf<>0 then
+                impls^[i]:=compats^[impls^[i]].compintf
+              else if equals^[impls^[i]]<>0 then
+                impls^[i]:=equals^[impls^[i]]
               else
                 inc(k);
             end;
         until k=max;
-        freemem(compats,sizeof(tcompintfentry)*max);
-        freemem(equals,sizeof(longint)*max);
+        { Update the implindex }
+        for i:=1 to max do
+          _class.implementedinterfaces.setimplindex(i,impls^[i]);
+        freemem(compats);
+        freemem(equals);
+        freemem(impls);
       end;
 
 
     procedure tclassheader.gintfwritedata;
       var
-        rawdata,rawcode: taasmoutput;
-        impintfindexes: plongintarray;
-        max: longint;
-        i: longint;
+        rawdata: taasmoutput;
+        max,i,j : smallint;
       begin
         max:=_class.implementedinterfaces.count;
-        getmem(impintfindexes,(max+1)*sizeof(longint));
-
-        gintfoptimizevtbls(impintfindexes);
 
         rawdata:=TAAsmOutput.Create;
-        rawcode:=TAAsmOutput.Create;
         dataSegment.concat(Tai_const.Create_16bit(max));
         { Two pass, one for allocation and vtbl creation }
         for i:=1 to max do
           begin
-            if impintfindexes[i]=i then { if implement itself }
+            if _class.implementedinterfaces.implindex(i)=i then { if implement itself }
               begin
                 { allocate a pointer in the object memory }
                 with tobjectsymtable(_class.symtable) do
@@ -1059,21 +1048,19 @@ implementation
                     inc(datasize,sizeof(aint));
                   end;
                 { write vtbl }
-                gintfcreatevtbl(i,rawdata,rawcode);
+                gintfcreatevtbl(i,rawdata);
               end;
           end;
         { second pass: for fill interfacetable and remained ioffsets }
         for i:=1 to max do
           begin
-            if impintfindexes[i]<>i then
-              _class.implementedinterfaces.setioffsets(i,_class.implementedinterfaces.ioffsets(impintfindexes[i]));
-            gintfgenentry(i,impintfindexes[i],rawdata);
+            j:=_class.implementedinterfaces.implindex(i);
+            if j<>i then
+              _class.implementedinterfaces.setioffsets(i,_class.implementedinterfaces.ioffsets(j));
+            gintfgenentry(i,j,rawdata);
           end;
         dataSegment.concatlist(rawdata);
         rawdata.free;
-        codeSegment.concatlist(rawcode);
-        rawcode.free;
-        freemem(impintfindexes,(max+1)*sizeof(longint));
       end;
 
 
@@ -1179,8 +1166,10 @@ implementation
         objectlibrary.getdatalabel(intftable);
         dataSegment.concat(tai_align.create(const_align(sizeof(aint))));
         dataSegment.concat(Tai_label.Create(intftable));
+        { Optimize interface tables to reuse wrappers }
+        gintfoptimizevtbls;
+        { Write interface tables }
         gintfwritedata;
-        _class.implementedinterfaces.clearimplprocs; { release temporary information }
         genintftable:=intftable;
       end;
 
@@ -1376,45 +1365,14 @@ implementation
       end;
 
 
-  procedure tclassheader.adjustselfvalue(procdef: tprocdef;ioffset: aint);
-    var
-      hsym : tsym;
-      href : treference;
-      paraloc : tcgparalocation;
-    begin
-      { calculate the parameter info for the procdef }
-      if not procdef.has_paraloc_info then
-        begin
-          procdef.requiredargarea:=paramanager.create_paraloc_info(procdef,callerside);
-          procdef.has_paraloc_info:=true;
-        end;
-      hsym:=tsym(procdef.parast.search('self'));
-      if not(assigned(hsym) and
-             (hsym.typ=paravarsym)) then
-        internalerror(200305251);
-      paraloc:=tparavarsym(hsym).paraloc[callerside].location^;
-      case paraloc.loc of
-        LOC_REGISTER:
-          cg.a_op_const_reg(exprasmlist,OP_SUB,paraloc.size,ioffset,paraloc.register);
-        LOC_REFERENCE:
-          begin
-             { offset in the wrapper needs to be adjusted for the stored
-               return address }
-             reference_reset_base(href,paraloc.reference.index,paraloc.reference.offset+sizeof(aint));
-             cg.a_op_const_ref(exprasmlist,OP_SUB,paraloc.size,ioffset,href);
-          end
-        else
-          internalerror(200309189);
-      end;
-    end;
-
-
-initialization
-  cclassheader:=tclassheader;
 end.
 {
   $Log$
-  Revision 1.86  2005-01-10 20:41:55  peter
+  Revision 1.87  2005-01-24 22:08:32  peter
+    * interface wrapper generation moved to cgobj
+    * generate interface wrappers after the module is parsed
+
+  Revision 1.86  2005/01/10 20:41:55  peter
     * write realname for published methods
 
   Revision 1.85  2005/01/09 15:05:29  peter

compiler/pdecl.pas

@@ -531,7 +531,7 @@ implementation
                   begin
                     if not(oo_is_forward in objectoptions) then
                       begin
-                        ch:=cclassheader.create(tobjectdef(tt.def));
+                        ch:=tclassheader.create(tobjectdef(tt.def));
                         { generate and check virtual methods, must be done
                           before RTTI is written }
                         ch.genvmt;
@@ -668,7 +668,11 @@ implementation
 end.
 {
   $Log$
-  Revision 1.93  2005-01-20 16:38:45  peter
+  Revision 1.94  2005-01-24 22:08:32  peter
+    * interface wrapper generation moved to cgobj
+    * generate interface wrappers after the module is parsed
+
+  Revision 1.93  2005/01/20 16:38:45  peter
     * load jmp_buf_size from system unit
 
   Revision 1.92  2004/11/16 20:32:40  peter

compiler/pmodules.pas

@@ -39,7 +39,7 @@ implementation
        symconst,symbase,symtype,symdef,symsym,symtable,
        aasmtai,aasmcpu,aasmbase,
        cgbase,cgobj,
-       nbas,
+       nbas,ncgutil,
        link,assemble,import,export,gendef,ppu,comprsrc,
        cresstr,procinfo,
        dwarf,
@@ -1227,6 +1227,10 @@ implementation
          write_gdb_info;
 {$endif GDB}
 
+         { generate wrappers for interfaces }
+         gen_intf_wrappers(codesegment,current_module.globalsymtable);
+         gen_intf_wrappers(codesegment,current_module.localsymtable);
+
          { generate a list of threadvars }
          InsertThreadvars;
 
@@ -1527,6 +1531,9 @@ implementation
          write_gdb_info;
 {$endif GDB}
 
+         { generate wrappers for interfaces }
+         gen_intf_wrappers(codesegment,current_module.localsymtable);
+
          { generate a list of threadvars }
          InsertThreadvars;
 
@@ -1595,7 +1602,11 @@ implementation
 end.
 {
   $Log$
-  Revision 1.180  2005-01-19 22:19:41  peter
+  Revision 1.181  2005-01-24 22:08:32  peter
+    * interface wrapper generation moved to cgobj
+    * generate interface wrappers after the module is parsed
+
+  Revision 1.180  2005/01/19 22:19:41  peter
     * unit mapping rewrite
     * new derefmap added
 

compiler/powerpc/cgcpu.pas

@@ -27,7 +27,7 @@ unit cgcpu;
   interface
 
     uses
-       globtype,symtype,
+       globtype,symtype,symdef,
        cgbase,cgobj,
        aasmbase,aasmcpu,aasmtai,
        cpubase,cpuinfo,cgutils,cg64f32,rgcpu,
@@ -97,6 +97,7 @@ unit cgcpu;
 
         procedure a_jmp_cond(list : taasmoutput;cond : TOpCmp;l: tasmlabel);
 
+        procedure g_intf_wrapper(list: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);override;
       private
 
         (* NOT IN USE: *)
@@ -155,7 +156,7 @@ const
 
     uses
        globals,verbose,systems,cutils,
-       symconst,symdef,symsym,
+       symconst,symsym,fmodule,
        rgobj,tgobj,cpupi,procinfo,paramgr;
 
 
@@ -253,13 +254,13 @@ const
                       { the following is only for AIX abi systems, but the }
                       { conditions should never be true for SYSV (if they  }
                       { are, there is a bug in cpupara)                    }
-                      
+
                       { update: this doesn't work yet (we have to shift     }
                       { right again in ncgutil when storing the parameters, }
                       { and additionally Apple's documentation seems to be  }
                       { wrong, in that these values are always kept in the  }
                       { lower bytes of the registers                        }
-                      
+
 {
                       if (paraloc.composite) and
                          (sizeleft <= 2) and
@@ -2012,6 +2013,78 @@ const
       end;
 
 
+    procedure tcgppc.g_intf_wrapper(list: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);
+
+        procedure loadvmttor11;
+        var
+          href : treference;
+        begin
+          reference_reset_base(href,NR_R3,0);
+          cg.a_load_ref_reg(list,OS_ADDR,OS_ADDR,href,NR_R11);
+        end;
+
+        procedure op_onr11methodaddr;
+        var
+          href : treference;
+        begin
+          if (procdef.extnumber=$ffff) then
+            Internalerror(200006139);
+          { call/jmp  vmtoffs(%eax) ; method offs }
+          reference_reset_base(href,NR_R11,procdef._class.vmtmethodoffset(procdef.extnumber));
+          if not((longint(href.offset) >= low(smallint)) and
+                 (longint(href.offset) <= high(smallint))) then
+            begin
+              list.concat(taicpu.op_reg_reg_const(A_ADDIS,NR_R11,NR_R11,
+                smallint((href.offset shr 16)+ord(smallint(href.offset and $ffff) < 0))));
+              href.offset := smallint(href.offset and $ffff);
+            end;
+          list.concat(taicpu.op_reg_ref(A_LWZ,NR_R11,href));
+          list.concat(taicpu.op_reg(A_MTCTR,NR_R11));
+          list.concat(taicpu.op_none(A_BCTR));
+        end;
+
+      var
+        lab : tasmsymbol;
+        make_global : boolean;
+        href : treference;
+      begin
+        if procdef.proctypeoption<>potype_none then
+          Internalerror(200006137);
+        if not assigned(procdef._class) or
+           (procdef.procoptions*[po_classmethod, po_staticmethod,
+             po_methodpointer, po_interrupt, po_iocheck]<>[]) then
+          Internalerror(200006138);
+        if procdef.owner.symtabletype<>objectsymtable then
+          Internalerror(200109191);
+
+        make_global:=false;
+        if (not current_module.is_unit) or
+           (cs_create_smart in aktmoduleswitches) or
+           (procdef.owner.defowner.owner.symtabletype=globalsymtable) then
+          make_global:=true;
+
+        if make_global then
+          List.concat(Tai_symbol.Createname_global(labelname,AT_FUNCTION,0))
+        else
+          List.concat(Tai_symbol.Createname(labelname,AT_FUNCTION,0));
+
+        { set param1 interface to self  }
+        g_adjust_self_value(list,procdef,ioffset);
+
+        { case 4 }
+        if po_virtualmethod in procdef.procoptions then
+          begin
+            loadvmttor11;
+            op_onr11methodaddr;
+          end
+        { case 0 }
+        else
+          list.concat(taicpu.op_sym(A_B,objectlibrary.newasmsymbol(procdef.mangledname,AB_EXTERNAL,AT_FUNCTION)));
+
+        List.concat(Tai_symbol_end.Createname(labelname));
+      end;
+
+
 {***************** This is private property, keep out! :) *****************}
 
     function tcgppc.issimpleref(const ref: treference): boolean;
@@ -2347,7 +2420,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.192  2005-01-13 22:02:40  jonas
+  Revision 1.193  2005-01-24 22:08:32  peter
+    * interface wrapper generation moved to cgobj
+    * generate interface wrappers after the module is parsed
+
+  Revision 1.192  2005/01/13 22:02:40  jonas
     * r2 can be used by the register allocator under Darwin
     * merged the initialisations of the fpu register allocator for AIX and
       SYSV

compiler/powerpc/cpunode.pas

@@ -43,8 +43,6 @@ unit cpunode;
        nppcset,
        nppcinl,
 //       nppcopt,
-       { this not really a node }
-       nppcobj,
        nppcmat,
        nppccnv,
        nppcld
@@ -53,7 +51,11 @@ unit cpunode;
 end.
 {
   $Log$
-  Revision 1.19  2004-06-20 08:55:32  florian
+  Revision 1.20  2005-01-24 22:08:32  peter
+    * interface wrapper generation moved to cgobj
+    * generate interface wrappers after the module is parsed
+
+  Revision 1.19  2004/06/20 08:55:32  florian
     * logs truncated
 
   Revision 1.18  2004/03/02 17:32:12  florian

compiler/powerpc/nppcobj.pas

@@ -1,190 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2002 by Kovacs Attila Zoltan
-
-    Generate powerpc assembly wrapper code interface implementor objects
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit nppcobj;
-
-{$i fpcdefs.inc}
-
-interface
-
-
-implementation
-
-uses
-  systems,
-  verbose,globals,globtype,
-  aasmbase,aasmtai,aasmcpu,
-  symconst,symdef,
-  fmodule,
-  nobj,
-  cpuinfo,cpubase,
-  cgutils,cgobj;
-
-   type
-     tppcclassheader=class(tclassheader)
-     protected
-       procedure cgintfwrapper(asmlist: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);override;
-     end;
-
-{
-possible calling conventions:
-              default stdcall cdecl pascal register saveregisters
-default(0):      OK     OK    OK(1)  OK       OK          OK
-virtual(2):      OK     OK    OK(3)  OK       OK          OK(4)
-
-(0):
-    set self parameter to correct value
-    jmp mangledname
-
-(1): The code is the following
-     set self parameter to correct value
-     call mangledname
-     set self parameter to interface value
-
-(2): The wrapper code use %eax to reach the virtual method address
-     set self to correct value
-     move self,%eax
-     mov  0(%eax),%eax ; load vmt
-     jmp  vmtoffs(%eax) ; method offs
-
-(3): The wrapper code use %eax to reach the virtual method address
-     set self to correct value
-     move self,%eax
-     mov  0(%eax),%eax ; load vmt
-     jmp  vmtoffs(%eax) ; method offs
-     set self parameter to interface value
-
-
-(4): Virtual use eax to reach the method address so the following code be generated:
-     set self to correct value
-     push %ebx ; allocate space for function address
-     push %eax
-     mov  self,%eax
-     mov  0(%eax),%eax ; load vmt
-     mov  vmtoffs(%eax),eax ; method offs
-     mov  %eax,4(%esp)
-     pop  %eax
-     ret  0; jmp the address
-
-}
-
-procedure tppcclassheader.cgintfwrapper(asmlist: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);
-
-  procedure loadvmttor11;
-  var
-    href : treference;
-  begin
-    reference_reset_base(href,NR_R3,0);
-    cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,href,NR_R11);
-  end;
-
-  procedure op_onr11methodaddr;
-  var
-    href : treference;
-  begin
-    if (procdef.extnumber=$ffff) then
-      Internalerror(200006139);
-    { call/jmp  vmtoffs(%eax) ; method offs }
-    reference_reset_base(href,NR_R11,procdef._class.vmtmethodoffset(procdef.extnumber));
-    if not((longint(href.offset) >= low(smallint)) and
-           (longint(href.offset) <= high(smallint))) then
-      begin
-        asmlist.concat(taicpu.op_reg_reg_const(A_ADDIS,NR_R11,NR_R11,
-          smallint((href.offset shr 16)+ord(smallint(href.offset and $ffff) < 0))));
-        href.offset := smallint(href.offset and $ffff);
-      end;
-    asmlist.concat(taicpu.op_reg_ref(A_LWZ,NR_R11,href));
-    asmlist.concat(taicpu.op_reg(A_MTCTR,NR_R11));
-    asmlist.concat(taicpu.op_none(A_BCTR));
-  end;
-
-var
-  oldexprasmlist: TAAsmoutput;
-  lab : tasmsymbol;
-  make_global : boolean;
-  href : treference;
-begin
-  if procdef.proctypeoption<>potype_none then
-    Internalerror(200006137);
-  if not assigned(procdef._class) or
-     (procdef.procoptions*[po_classmethod, po_staticmethod,
-       po_methodpointer, po_interrupt, po_iocheck]<>[]) then
-    Internalerror(200006138);
-  if procdef.owner.symtabletype<>objectsymtable then
-    Internalerror(200109191);
-
-  oldexprasmlist:=exprasmlist;
-  exprasmlist:=asmlist;
-
-  make_global:=false;
-  if (not current_module.is_unit) or
-     (cs_create_smart in aktmoduleswitches) or
-     (procdef.owner.defowner.owner.symtabletype=globalsymtable) then
-    make_global:=true;
-
-  if make_global then
-   exprasmList.concat(Tai_symbol.Createname_global(labelname,AT_FUNCTION,0))
-  else
-   exprasmList.concat(Tai_symbol.Createname(labelname,AT_FUNCTION,0));
-
-  { set param1 interface to self  }
-  adjustselfvalue(procdef,ioffset);
-
-  { case 4 }
-  if po_virtualmethod in procdef.procoptions then
-    begin
-      loadvmttor11;
-      op_onr11methodaddr;
-    end
-  { case 0 }
-  else
-    asmlist.concat(taicpu.op_sym(A_B,objectlibrary.newasmsymbol(procdef.mangledname,AB_EXTERNAL,AT_FUNCTION)));
-
-  exprasmList.concat(Tai_symbol_end.Createname(labelname));
-
-  exprasmlist:=oldexprasmlist;
-end;
-
-
-initialization
-  cclassheader:=tppcclassheader;
-end.
-{
-  $Log$
-  Revision 1.7  2004-06-20 08:55:32  florian
-    * logs truncated
-
-  Revision 1.6  2004/03/02 00:36:33  olle
-    * big transformation of Tai_[const_]Symbol.Create[data]name*
-
-  Revision 1.5  2004/02/27 13:42:56  olle
-    + added Tai_symbol_end
-
-  Revision 1.4  2004/02/27 10:21:05  florian
-    * top_symbol killed
-    + refaddr to treference added
-    + refsymbol to treference added
-    * top_local stuff moved to an extra record to save memory
-    + aint introduced
-    * tppufile.get/putint64/aint implemented
-
-}

compiler/sparc/cgcpu.pas

@@ -31,7 +31,7 @@ interface
        cgbase,cgutils,cgobj,cg64f32,
        aasmbase,aasmtai,aasmcpu,
        cpubase,cpuinfo,
-       node,symconst,SymType,
+       node,symconst,SymType,symdef,
        rgcpu;
 
     type
@@ -89,6 +89,7 @@ interface
         procedure g_concatcopy(list : taasmoutput;const source,dest : treference;len : aint);override;
         procedure g_concatcopy_unaligned(list : taasmoutput;const source,dest : treference;len : aint);override;
         procedure g_concatcopy_move(list : taasmoutput;const source,dest : treference;len : aint);
+        procedure g_intf_wrapper(list: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);override;
       end;
 
       TCg64Sparc=class(tcg64f32)
@@ -120,7 +121,7 @@ implementation
 
   uses
     globals,verbose,systems,cutils,
-    symdef,paramgr,
+    paramgr,fmodule,
     tgobj,
     procinfo,cpupi;
 
@@ -1256,6 +1257,53 @@ implementation
       end;
 
 
+    procedure tcgsparc.g_intf_wrapper(list: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);
+      var
+        make_global : boolean;
+        href : treference;
+      begin
+        if procdef.proctypeoption<>potype_none then
+          Internalerror(200006137);
+        if not assigned(procdef._class) or
+           (procdef.procoptions*[po_classmethod, po_staticmethod,
+             po_methodpointer, po_interrupt, po_iocheck]<>[]) then
+          Internalerror(200006138);
+        if procdef.owner.symtabletype<>objectsymtable then
+          Internalerror(200109191);
+
+        make_global:=false;
+        if (not current_module.is_unit) or
+           (procdef.owner.defowner.owner.symtabletype=globalsymtable) then
+          make_global:=true;
+
+        if make_global then
+          List.concat(Tai_symbol.Createname_global(labelname,AT_FUNCTION,0))
+        else
+          List.concat(Tai_symbol.Createname(labelname,AT_FUNCTION,0));
+
+        { set param1 interface to self  }
+        g_adjust_self_value(list,procdef,ioffset);
+
+        if po_virtualmethod in procdef.procoptions then
+          begin
+            if (procdef.extnumber=$ffff) then
+              Internalerror(200006139);
+            { mov  0(%rdi),%rax ; load vmt}
+            reference_reset_base(href,NR_O0,0);
+            cg.a_load_ref_reg(list,OS_ADDR,OS_ADDR,href,NR_L0);
+            { jmp *vmtoffs(%eax) ; method offs }
+            reference_reset_base(href,NR_L0,procdef._class.vmtmethodoffset(procdef.extnumber));
+            list.concat(taicpu.op_ref_reg(A_LD,href,NR_L1));
+            list.concat(taicpu.op_reg(A_JMP,NR_L1));
+          end
+        else
+          list.concat(taicpu.op_sym(A_BA,objectlibrary.newasmsymbol(procdef.mangledname,AB_EXTERNAL,AT_FUNCTION)));
+        { Delay slot }
+        list.Concat(TAiCpu.Op_none(A_NOP));
+
+        List.concat(Tai_symbol_end.Createname(labelname));
+      end;
+
 {****************************************************************************
                                TCG64Sparc
 ****************************************************************************}
@@ -1410,7 +1458,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.102  2005-01-23 17:14:21  florian
+  Revision 1.103  2005-01-24 22:08:32  peter
+    * interface wrapper generation moved to cgobj
+    * generate interface wrappers after the module is parsed
+
+  Revision 1.102  2005/01/23 17:14:21  florian
     + optimized code generation on sparc
     + some stuff for pic code on sparc added
 

compiler/sparc/cpunode.pas

@@ -32,14 +32,18 @@ implementation
 
   uses
     ncgbas,ncgflw,ncgcnv,ncgld,ncgmem,ncgcon,ncgset,
-    ncpuadd,ncpucall,ncpumat,ncpuinln,ncpucnv,ncpuobj,ncpuset,
+    ncpuadd,ncpucall,ncpumat,ncpuinln,ncpucnv,ncpuset,
     { this not really a node }
     rgcpu;
 
 end.
 {
     $Log$
-    Revision 1.11  2004-10-30 22:01:11  florian
+    Revision 1.12  2005-01-24 22:08:33  peter
+      * interface wrapper generation moved to cgobj
+      * generate interface wrappers after the module is parsed
+
+    Revision 1.11  2004/10/30 22:01:11  florian
       * jmp table code generation for case statement on sparc
 
     Revision 1.10  2004/06/20 08:55:32  florian

compiler/sparc/ncpuobj.pas

@@ -1,122 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2004 by Kovacs Attila Zoltan and Florian Klaempfl
-
-    Generate sparc assembly wrapper code interface implementor objects
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit ncpuobj;
-
-{$i fpcdefs.inc}
-
-  interface
-
-
-  implementation
-
-    uses
-      systems,
-      verbose,globals,globtype,
-      aasmbase,aasmtai,aasmcpu,
-      symconst,symdef,
-      fmodule,
-      nobj,
-      cpuinfo,cpubase,
-      cgutils,cgobj;
-
-    type
-      tsparcclassheader=class(tclassheader)
-      protected
-        procedure cgintfwrapper(asmlist: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);override;
-      end;
-
-
-    procedure tsparcclassheader.cgintfwrapper(asmlist: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);
-      var
-        oldexprasmlist: TAAsmoutput;
-        make_global : boolean;
-        href : treference;
-      begin
-        if procdef.proctypeoption<>potype_none then
-          Internalerror(200006137);
-        if not assigned(procdef._class) or
-           (procdef.procoptions*[po_classmethod, po_staticmethod,
-             po_methodpointer, po_interrupt, po_iocheck]<>[]) then
-          Internalerror(200006138);
-        if procdef.owner.symtabletype<>objectsymtable then
-          Internalerror(200109191);
-
-        make_global:=false;
-        if (not current_module.is_unit) or
-           (procdef.owner.defowner.owner.symtabletype=globalsymtable) then
-          make_global:=true;
-
-        oldexprasmlist:=exprasmlist;
-        exprasmlist:=asmlist;
-
-        if make_global then
-          exprasmList.concat(Tai_symbol.Createname_global(labelname,AT_FUNCTION,0))
-        else
-          exprasmList.concat(Tai_symbol.Createname(labelname,AT_FUNCTION,0));
-
-        { set param1 interface to self  }
-        adjustselfvalue(procdef,ioffset);
-
-        if po_virtualmethod in procdef.procoptions then
-          begin
-            if (procdef.extnumber=$ffff) then
-              Internalerror(200006139);
-            { mov  0(%rdi),%rax ; load vmt}
-            reference_reset_base(href,NR_O0,0);
-            cg.a_load_ref_reg(asmlist,OS_ADDR,OS_ADDR,href,NR_L0);
-            { jmp *vmtoffs(%eax) ; method offs }
-            reference_reset_base(href,NR_L0,procdef._class.vmtmethodoffset(procdef.extnumber));
-            asmlist.concat(taicpu.op_ref_reg(A_LD,href,NR_L1));
-            asmlist.concat(taicpu.op_reg(A_JMP,NR_L1));
-          end
-        else
-          asmlist.concat(taicpu.op_sym(A_BA,objectlibrary.newasmsymbol(procdef.mangledname,AB_EXTERNAL,AT_FUNCTION)));
-        { Delay slot }
-        asmlist.Concat(TAiCpu.Op_none(A_NOP));
-
-        exprasmList.concat(Tai_symbol_end.Createname(labelname));
-
-        exprasmlist:=oldexprasmlist;
-      end;
-
-
-initialization
-  cclassheader:=tsparcclassheader;
-end.
-{
-  $Log$
-  Revision 1.2  2004-06-16 20:07:11  florian
-    * dwarf branch merged
-
-  Revision 1.1.2.4  2004/05/14 16:17:25  florian
-    * the interface wrappers are called before save, so they must use o0 for self
-
-  Revision 1.1.2.3  2004/05/13 20:58:47  florian
-    * fixed register addressed jumps in interface wrappers
-
-  Revision 1.1.2.2  2004/05/13 20:10:38  florian
-    * released variant and interface support
-
-  Revision 1.1.2.1  2004/05/13 19:41:10  florian
-    + ncpuobj added
-}

compiler/symdef.pas

@@ -253,7 +253,7 @@ interface
          intf         : tobjectdef;
          intfderef    : tderef;
          ioffset      : longint;
-         implintf     : longint;
+         implindex    : longint;
          namemappings : tdictionary;
          procdefs     : TIndexArray;
          constructor create(aintf: tobjectdef);
@@ -338,6 +338,8 @@ interface
           function  interfacesderef(intfindex: longint): tderef;
           function  ioffsets(intfindex: longint): longint;
           procedure setioffsets(intfindex,iofs:longint);
+          function  implindex(intfindex:longint):longint;
+          procedure setimplindex(intfindex,implidx:longint);
           function  searchintf(def: tdef): longint;
           procedure addintf(def: tdef);
 
@@ -350,7 +352,6 @@ interface
           procedure addmappings(intfindex: longint; const name, newname: string);
           function  getmappings(intfindex: longint; const name: string; var nextexist: pointer): string;
 
-          procedure clearimplprocs;
           procedure addimplproc(intfindex: longint; procdef: tprocdef);
           function  implproccount(intfindex: longint): longint;
           function  implprocs(intfindex: longint; procindex: longint): tprocdef;
@@ -6056,6 +6057,18 @@ implementation
         timplintfentry(finterfaces.search(intfindex)).ioffset:=iofs;
       end;
 
+    function timplementedinterfaces.implindex(intfindex:longint):longint;
+      begin
+        checkindex(intfindex);
+        result:=timplintfentry(finterfaces.search(intfindex)).implindex;
+      end;
+
+    procedure timplementedinterfaces.setimplindex(intfindex,implidx:longint);
+      begin
+        checkindex(intfindex);
+        timplintfentry(finterfaces.search(intfindex)).implindex:=implidx;
+      end;
+
     function  timplementedinterfaces.searchintf(def: tdef): longint;
       var
         i: longint;
@@ -6149,19 +6162,6 @@ implementation
           getmappings:='';
       end;
 
-    procedure timplementedinterfaces.clearimplprocs;
-      var
-        i: longint;
-      begin
-        for i:=1 to count do
-          with timplintfentry(finterfaces.search(i)) do
-            begin
-              if assigned(procdefs) then
-                procdefs.free;
-              procdefs:=nil;
-            end;
-      end;
-
     procedure timplementedinterfaces.addimplproc(intfindex: longint; procdef: tprocdef);
       begin
         checkindex(intfindex);
@@ -6367,7 +6367,11 @@ implementation
 end.
 {
   $Log$
-  Revision 1.290  2005-01-19 22:19:41  peter
+  Revision 1.291  2005-01-24 22:08:32  peter
+    * interface wrapper generation moved to cgobj
+    * generate interface wrappers after the module is parsed
+
+  Revision 1.290  2005/01/19 22:19:41  peter
     * unit mapping rewrite
     * new derefmap added
 

compiler/x86_64/cgcpu.pas

@@ -30,12 +30,14 @@ unit cgcpu;
        cgbase,cgobj,cgx86,
        aasmbase,aasmtai,aasmcpu,
        cpubase,cpuinfo,cpupara,parabase,
+       symdef,
        node,symconst,rgx86,procinfo;
 
     type
       tcgx86_64 = class(tcgx86)
         procedure init_register_allocators;override;
         procedure g_proc_exit(list : taasmoutput;parasize:longint;nostackframe:boolean);override;
+        procedure g_intf_wrapper(list: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);override;
       end;
 
 
@@ -43,7 +45,7 @@ unit cgcpu;
 
     uses
        globtype,globals,verbose,systems,cutils,
-       symdef,symsym,defutil,paramgr,
+       symsym,defutil,paramgr,fmodule,cgutils,
        rgobj,tgobj,rgcpu;
 
 
@@ -87,6 +89,53 @@ unit cgcpu;
         list.concat(Taicpu.Op_none(A_RET,S_NO));
       end;
 
+
+    procedure tcgx86_64.g_intf_wrapper(list: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);
+      var
+        make_global : boolean;
+        href : treference;
+      begin
+        if procdef.proctypeoption<>potype_none then
+          Internalerror(200006137);
+        if not assigned(procdef._class) or
+           (procdef.procoptions*[po_classmethod, po_staticmethod,
+             po_methodpointer, po_interrupt, po_iocheck]<>[]) then
+          Internalerror(200006138);
+        if procdef.owner.symtabletype<>objectsymtable then
+          Internalerror(200109191);
+
+        make_global:=false;
+        if (not current_module.is_unit) or
+           (procdef.owner.defowner.owner.symtabletype=globalsymtable) then
+          make_global:=true;
+
+        if make_global then
+          List.concat(Tai_symbol.Createname_global(labelname,AT_FUNCTION,0))
+        else
+          List.concat(Tai_symbol.Createname(labelname,AT_FUNCTION,0));
+
+        { set param1 interface to self  }
+        g_adjust_self_value(list,procdef,ioffset);
+
+        if po_virtualmethod in procdef.procoptions then
+          begin
+            if (procdef.extnumber=$ffff) then
+              Internalerror(200006139);
+            { mov  0(%rdi),%rax ; load vmt}
+            reference_reset_base(href,NR_RDI,0);
+            cg.a_load_ref_reg(list,OS_ADDR,OS_ADDR,href,NR_RAX);
+            { jmp *vmtoffs(%eax) ; method offs }
+            reference_reset_base(href,NR_RAX,procdef._class.vmtmethodoffset(procdef.extnumber));
+            list.concat(taicpu.op_ref_reg(A_MOV,S_Q,href,NR_RAX));
+            list.concat(taicpu.op_reg(A_JMP,S_Q,NR_RAX));
+          end
+        else
+          list.concat(taicpu.op_sym(A_JMP,S_NO,objectlibrary.newasmsymbol(procdef.mangledname,AB_EXTERNAL,AT_FUNCTION)));
+
+        List.concat(Tai_symbol_end.Createname(labelname));
+      end;
+
+
 begin
   cg:=tcgx86_64.create;
 {$ifndef cpu64bit}
@@ -95,7 +144,11 @@ begin
 end.
 {
   $Log$
-  Revision 1.19  2004-11-01 17:44:27  florian
+  Revision 1.20  2005-01-24 22:08:33  peter
+    * interface wrapper generation moved to cgobj
+    * generate interface wrappers after the module is parsed
+
+  Revision 1.19  2004/11/01 17:44:27  florian
     * cg64f64 isn't used anymore
 
   Revision 1.18  2004/10/24 20:01:08  peter

compiler/x86_64/cpunode.pas

@@ -45,8 +45,6 @@ unit cpunode;
        ncgopt,
        // n386con,n386flw,n386mat,n386mem,
        // n386set,n386inl,n386opt,
-       { this not really a node }
-       nx64obj,
        { the cpu specific node units must be used after the generic ones to
          get the correct class pointer }
        nx86set,
@@ -60,7 +58,11 @@ unit cpunode;
 end.
 {
   $Log$
-  Revision 1.10  2004-06-20 08:55:32  florian
+  Revision 1.11  2005-01-24 22:08:33  peter
+    * interface wrapper generation moved to cgobj
+    * generate interface wrappers after the module is parsed
+
+  Revision 1.10  2004/06/20 08:55:32  florian
     * logs truncated
 
   Revision 1.9  2004/06/16 20:07:11  florian

compiler/x86_64/nx64obj.pas

@@ -1,117 +0,0 @@
-{
-    $Id$
-    Copyright (c) 1998-2002 by Kovacs Attila Zoltan
-
-    Generate i386 assembly wrapper code interface implementor objects
-
-    This program is free software; you can redistribute it and/or modify
-    it under the terms of the GNU General Public License as published by
-    the Free Software Foundation; either version 2 of the License, or
-    (at your option) any later version.
-
-    This program is distributed in the hope that it will be useful,
-    but WITHOUT ANY WARRANTY; without even the implied warranty of
-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-    GNU General Public License for more details.
-
-    You should have received a copy of the GNU General Public License
-    along with this program; if not, write to the Free Software
-    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
-}
-unit nx64obj;
-
-{$i fpcdefs.inc}
-
-interface
-
-
-implementation
-
-uses
-  systems,
-  verbose,globals,globtype,
-  aasmbase,aasmtai,aasmcpu,
-  symconst,symdef,
-  fmodule,
-  nobj,
-  cpuinfo,cpubase,
-  cgutils,cgobj;
-
-   type
-     tx8664classheader=class(tclassheader)
-     protected
-       procedure cgintfwrapper(asmlist: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);override;
-     end;
-
-
-procedure tx8664classheader.cgintfwrapper(asmlist: TAAsmoutput; procdef: tprocdef; const labelname: string; ioffset: longint);
-var
-  oldexprasmlist: TAAsmoutput;
-  make_global : boolean;
-  href : treference;
-begin
-  if procdef.proctypeoption<>potype_none then
-    Internalerror(200006137);
-  if not assigned(procdef._class) or
-     (procdef.procoptions*[po_classmethod, po_staticmethod,
-       po_methodpointer, po_interrupt, po_iocheck]<>[]) then
-    Internalerror(200006138);
-  if procdef.owner.symtabletype<>objectsymtable then
-    Internalerror(200109191);
-
-  make_global:=false;
-  if (not current_module.is_unit) or
-     (procdef.owner.defowner.owner.symtabletype=globalsymtable) then
-    make_global:=true;
-
-  oldexprasmlist:=exprasmlist;
-  exprasmlist:=asmlist;
-
-  if make_global then
-    exprasmList.concat(Tai_symbol.Createname_global(labelname,AT_FUNCTION,0))
-  else
-    exprasmList.concat(Tai_symbol.Createname(labelname,AT_FUNCTION,0));
-
-  { set param1 interface to self  }
-  adjustselfvalue(procdef,ioffset);
-
-  if po_virtualmethod in procdef.procoptions then
-    begin
-      if (procdef.extnumber=$ffff) then
-        Internalerror(200006139);
-      { mov  0(%rdi),%rax ; load vmt}
-      reference_reset_base(href,NR_RDI,0);
-      cg.a_load_ref_reg(asmlist,OS_ADDR,OS_ADDR,href,NR_RAX);
-      { jmp *vmtoffs(%eax) ; method offs }
-      reference_reset_base(href,NR_RAX,procdef._class.vmtmethodoffset(procdef.extnumber));
-      asmlist.concat(taicpu.op_ref_reg(A_MOV,S_Q,href,NR_RAX));
-      asmlist.concat(taicpu.op_reg(A_JMP,S_Q,NR_RAX));
-    end
-  else
-    asmlist.concat(taicpu.op_sym(A_JMP,S_NO,objectlibrary.newasmsymbol(procdef.mangledname,AB_EXTERNAL,AT_FUNCTION)));
-
-  exprasmList.concat(Tai_symbol_end.Createname(labelname));
-
-  exprasmlist:=oldexprasmlist;
-end;
-
-
-initialization
-  cclassheader:=tx8664classheader;
-end.
-{
-  $Log$
-  Revision 1.2  2004-06-16 20:07:11  florian
-    * dwarf branch merged
-
-  Revision 1.1.2.3  2004/05/10 21:28:35  peter
-    * section_smartlink enabled for gas under linux
-
-  Revision 1.1.2.2  2004/04/29 21:54:29  florian
-    * interface wrappers fixed
-
-  Revision 1.1.2.1  2004/04/22 21:14:34  peter
-    * nx64obj added, untested
-}