diff --git a/compiler/cgobj.pas b/compiler/cgobj.pas index 89c5f14394..1109d80e59 100644 --- a/compiler/cgobj.pas +++ b/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 diff --git a/compiler/i386/cgcpu.pas b/compiler/i386/cgcpu.pas index 307fa58017..e95d9e67fb 100644 --- a/compiler/i386/cgcpu.pas +++ b/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 diff --git a/compiler/i386/cpunode.pas b/compiler/i386/cpunode.pas index 4e78479a06..fdffaa9b0e 100644 --- a/compiler/i386/cpunode.pas +++ b/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 diff --git a/compiler/i386/n386obj.pas b/compiler/i386/n386obj.pas deleted file mode 100644 index 2c945fb5f4..0000000000 --- a/compiler/i386/n386obj.pas +++ /dev/null @@ -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 - -} diff --git a/compiler/ncgutil.pas b/compiler/ncgutil.pas index 8d0f8ee63d..20eb00810f 100644 --- a/compiler/ncgutil.pas +++ b/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 diff --git a/compiler/nobj.pas b/compiler/nobj.pas index 0564aeafb5..f9f7839563 100644 --- a/compiler/nobj.pas +++ b/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 diff --git a/compiler/pdecl.pas b/compiler/pdecl.pas index e9599d4e30..d835d96047 100644 --- a/compiler/pdecl.pas +++ b/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 diff --git a/compiler/pmodules.pas b/compiler/pmodules.pas index e47d832143..2accaaaa93 100644 --- a/compiler/pmodules.pas +++ b/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 diff --git a/compiler/powerpc/cgcpu.pas b/compiler/powerpc/cgcpu.pas index 52a8d43976..a30de7639f 100644 --- a/compiler/powerpc/cgcpu.pas +++ b/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 diff --git a/compiler/powerpc/cpunode.pas b/compiler/powerpc/cpunode.pas index 7832488885..f7351ea927 100644 --- a/compiler/powerpc/cpunode.pas +++ b/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 diff --git a/compiler/powerpc/nppcobj.pas b/compiler/powerpc/nppcobj.pas deleted file mode 100644 index 3b8763375f..0000000000 --- a/compiler/powerpc/nppcobj.pas +++ /dev/null @@ -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 - -} diff --git a/compiler/sparc/cgcpu.pas b/compiler/sparc/cgcpu.pas index 85789ad402..22dd5ef988 100644 --- a/compiler/sparc/cgcpu.pas +++ b/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 diff --git a/compiler/sparc/cpunode.pas b/compiler/sparc/cpunode.pas index 1aa6ea705d..940ae050b8 100644 --- a/compiler/sparc/cpunode.pas +++ b/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 diff --git a/compiler/sparc/ncpuobj.pas b/compiler/sparc/ncpuobj.pas deleted file mode 100644 index a84914cbd4..0000000000 --- a/compiler/sparc/ncpuobj.pas +++ /dev/null @@ -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 -} diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 1ee202876e..bcf8101d26 100644 --- a/compiler/symdef.pas +++ b/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 diff --git a/compiler/x86_64/cgcpu.pas b/compiler/x86_64/cgcpu.pas index f7c5c2bd46..34ec0a5b04 100644 --- a/compiler/x86_64/cgcpu.pas +++ b/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 diff --git a/compiler/x86_64/cpunode.pas b/compiler/x86_64/cpunode.pas index 89016fccd5..9a5addc164 100644 --- a/compiler/x86_64/cpunode.pas +++ b/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 diff --git a/compiler/x86_64/nx64obj.pas b/compiler/x86_64/nx64obj.pas deleted file mode 100644 index be1e76e43b..0000000000 --- a/compiler/x86_64/nx64obj.pas +++ /dev/null @@ -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 -}