paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-07 16:28:22 +02:00
Code Issues Packages Projects Releases Wiki Activity

* interface wrapper generation moved to cgobj

Browse Source 
* generate interface wrappers after the module is parsed
This commit is contained in:
peter 2005-01-24 22:08:32 +00:00
parent cce697bed8
commit e820bc93f2
18 changed files with 563 additions and 823 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
compiler/cgobj.pas
View File

@ -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

189
compiler/i386/cgcpu.pas
View File

@ -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

8
compiler/i386/cpunode.pas
View File

@ -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

267
compiler/i386/n386obj.pas
View File

@ -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
}

48
compiler/ncgutil.pas
View File

@ -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

118
compiler/nobj.pas
View File

@ -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

8
compiler/pdecl.pas
View File

@ -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

15
compiler/pmodules.pas
View File

@ -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

87
compiler/powerpc/cgcpu.pas
View File

@ -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

8
compiler/powerpc/cpunode.pas
View File

@ -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

190
compiler/powerpc/nppcobj.pas
View File

@ -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
}

58
compiler/sparc/cgcpu.pas
View File

@ -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

8
compiler/sparc/cpunode.pas
View File

@ -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

122
compiler/sparc/ncpuobj.pas
View File

@ -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
}

36
compiler/symdef.pas
View File

@ -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

57
compiler/x86_64/cgcpu.pas
View File

@ -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

8
compiler/x86_64/cpunode.pas
View File

@ -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

117
compiler/x86_64/nx64obj.pas
View File

@ -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
}