paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-01 14:10:57 +01:00
Code Issues Packages Projects Releases Wiki Activity

* made most constant and mem handling processor independent

Browse Source
This commit is contained in:
Jonas Maebe 2001-09-30 16:17:17 +00:00
parent a40c2b8dd0
commit 39f67208a8
8 changed files with 1067 additions and 808 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
compiler/cgobj.pas
View File

@ -128,6 +128,8 @@ unit cgobj;
procedure a_load_ref_reg(list : taasmoutput;size : tcgsize;const ref : treference;register : tregister);virtual; abstract;
procedure a_load_reg_reg(list : taasmoutput;size : tcgsize;reg1,reg2 : tregister);virtual; abstract;
procedure a_load_loc_reg(list : taasmoutput;size : tcgsize;const loc: tlocation; reg : tregister);
procedure a_load_loc_ref(list : taasmoutput;size : tcgsize;const loc: tlocation; const ref : treference);
procedure a_load_sym_ofs_reg(list: taasmoutput; const sym: tasmsymbol; ofs: longint; reg: tregister);virtual; abstract;
{ basic arithmetic operations }
@ -1264,6 +1266,43 @@ unit cgobj;
end;
end;
procedure tcg.a_load_loc_ref(list : taasmoutput;size : tcgsize;const loc: tlocation; const ref : treference);
var
tmpreg: tregister;
begin
case loc.loc of
LOC_REFERENCE,LOC_MEM:
begin
{$ifdef i386}
case size of
OS_8,OS_S8:
tmpreg := reg32toreg8(getregister32);
OS_16,OS_S16:
tmpreg := reg32toreg16(get_scratch_reg(list));
else
tmpreg := get_scratch_reg(list);
end;
{$else i386}
tmpreg := get_scratch_reg(list);
{$endif i386}
a_load_ref_reg(list,size,loc.reference,tmpreg);
a_load_reg_ref(list,size,tmpreg,ref);
{$ifdef i386}
if not (size in [OS_32,OS_S32]) then
ungetregister(tmpreg)
else
{$endif i386}
free_scratch_reg(list,tmpreg);
end;
LOC_REGISTER,LOC_CREGISTER:
a_load_reg_ref(list,size,loc.register,ref);
else
internalerror(200109302);
end;
end;
procedure tcg.a_op_const_ref(list : taasmoutput; Op: TOpCG; size: TCGSize; a: AWord; const ref: TReference);
@ -1452,7 +1491,10 @@ finalization
end.
{
$Log$
Revision 1.2 2001-09-28 20:39:32 jonas
Revision 1.3 2001-09-30 16:17:17 jonas
* made most constant and mem handling processor independent
Revision 1.2 2001/09/28 20:39:32 jonas
* changed all flow control structures (except for exception handling
related things) to processor independent code (in new ncgflw unit)
+ generic cgobj unit which contains lots of code generator helpers with

31
compiler/i386/cgcpu.pas
View File

@ -59,6 +59,7 @@ unit cgcpu;
procedure a_load_reg_ref(list : taasmoutput; size: tcgsize; reg : tregister;const ref : treference);override;
procedure a_load_ref_reg(list : taasmoutput;size : tcgsize;const ref : treference;reg : tregister);override;
procedure a_load_reg_reg(list : taasmoutput;size : tcgsize;reg1,reg2 : tregister);override;
procedure a_load_sym_ofs_reg(list: taasmoutput; const sym: tasmsymbol; ofs: longint; reg: tregister); override;
{ comparison operations }
procedure a_cmp_const_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;reg : tregister;
@ -130,8 +131,25 @@ unit cgcpu;
procedure tcg386.a_param_ref(list : taasmoutput;size : tcgsize;const r : treference;nr : longint);
var
tmpreg: tregister;
begin
runerror(211);
case size of
OS_8,OS_S8,OS_16,OS_S16:
begin
tmpreg := get_scratch_reg(list);
a_load_ref_reg(list,size,r,tmpreg);
if target_info.alignment.paraalign = 2 then
list.concat(taicpu.op_reg(A_PUSH,S_W,makereg16(tmpreg)))
else
list.concat(taicpu.op_reg(A_PUSH,S_L,tmpreg));
end;
OS_32,OS_S32:
list.concat(taicpu.op_ref(A_PUSH,S_L,newreference(r)));
else
internalerror(200109301);
end;
end;
@ -232,6 +250,12 @@ unit cgcpu;
end;
procedure tcg386.a_load_sym_ofs_reg(list: taasmoutput; const sym: tasmsymbol; ofs: longint; reg: tregister);
begin
list.concat(taicpu.op_sym_ofs_reg(A_MOV,S_L,sym,ofs,reg));
end;
procedure tcg386.a_op_const_reg(list : taasmoutput; Op: TOpCG; a: AWord; reg: TRegister);
var
@ -684,7 +708,10 @@ begin
end.
{
$Log$
Revision 1.2 2001-09-29 21:32:19 jonas
Revision 1.3 2001-09-30 16:17:18 jonas
* made most constant and mem handling processor independent
Revision 1.2 2001/09/29 21:32:19 jonas
* fixed bug in a_load_reg_reg + implemented a_call
Revision 1.1 2001/09/28 20:39:33 jonas

7
compiler/i386/cpunode.pas
View File

@ -29,7 +29,7 @@ unit cpunode;
implementation
uses
ncgbas,ncgflw,ncgcnv,
ncgbas,ncgflw,ncgcnv,ncgmem,ncgcon,
n386ld,n386add,n386cal,n386con,n386flw,n386mat,n386mem,
n386set,n386inl,n386opt,
{ this not really a node }
@ -38,7 +38,10 @@ unit cpunode;
end.
{
$Log$
Revision 1.6 2001-09-29 21:32:47 jonas
Revision 1.7 2001-09-30 16:17:18 jonas
* made most constant and mem handling processor independent
Revision 1.6 2001/09/29 21:32:47 jonas
* almost all second pass typeconvnode helpers are now processor independent
* fixed converting boolean to int64/qword
* fixed register allocation bugs which could cause internalerror 10

441
compiler/i386/n386con.pas
View File

@ -27,41 +27,18 @@ unit n386con;
interface
uses
node,ncon;
node,ncon,ncgcon;
type
ti386realconstnode = class(trealconstnode)
ti386realconstnode = class(tcgrealconstnode)
function pass_1 : tnode;override;
procedure pass_2;override;
end;
ti386ordconstnode = class(tordconstnode)
procedure pass_2;override;
end;
ti386pointerconstnode = class(tpointerconstnode)
procedure pass_2;override;
end;
ti386stringconstnode = class(tstringconstnode)
procedure pass_2;override;
end;
ti386setconstnode = class(tsetconstnode)
procedure pass_2;override;
end;
ti386nilnode = class(tnilnode)
procedure pass_2;override;
end;
implementation
uses
globtype,widestr,systems,
verbose,globals,
symconst,symdef,aasm,types,
systems,
temp_gen,
cpubase,
cga,tgcpu;
@ -83,14 +60,6 @@ implementation
end;
procedure ti386realconstnode.pass_2;
const
floattype2ait:array[tfloattype] of tait=
(ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit);
var
hp1 : tai;
lastlabel : tasmlabel;
realait : tait;
begin
if (value_real=1.0) then
@ -106,413 +75,19 @@ implementation
inc(fpuvaroffset);
end
else
begin
lastlabel:=nil;
realait:=floattype2ait[tfloatdef(resulttype.def).typ];
{ const already used ? }
if not assigned(lab_real) then
begin
{ tries to find an old entry }
hp1:=tai(Consts.first);
while assigned(hp1) do
begin
if hp1.typ=ait_label then
lastlabel:=tai_label(hp1).l
else
begin
if (hp1.typ=realait) and (lastlabel<>nil) then
begin
if(
((realait=ait_real_32bit) and (tai_real_32bit(hp1).value=value_real)) or
((realait=ait_real_64bit) and (tai_real_64bit(hp1).value=value_real)) or
((realait=ait_real_80bit) and (tai_real_80bit(hp1).value=value_real)) or
((realait=ait_comp_64bit) and (tai_comp_64bit(hp1).value=value_real))
) then
begin
{ found! }
lab_real:=lastlabel;
break;
end;
end;
lastlabel:=nil;
end;
hp1:=tai(hp1.next);
end;
{ :-(, we must generate a new entry }
if not assigned(lab_real) then
begin
getdatalabel(lastlabel);
lab_real:=lastlabel;
if (cs_create_smart in aktmoduleswitches) then
Consts.concat(Tai_cut.Create);
Consts.concat(Tai_label.Create(lastlabel));
case realait of
ait_real_32bit :
Consts.concat(Tai_real_32bit.Create(value_real));
ait_real_64bit :
Consts.concat(Tai_real_64bit.Create(value_real));
ait_real_80bit :
Consts.concat(Tai_real_80bit.Create(value_real));
ait_comp_64bit :
Consts.concat(Tai_comp_64bit.Create(value_real));
else
internalerror(10120);
end;
end;
end;
reset_reference(location.reference);
location.reference.symbol:=lab_real;
location.loc:=LOC_MEM;
end;
inherited pass_2;
end;
{*****************************************************************************
TI386ORDCONSTNODE
*****************************************************************************}
procedure ti386ordconstnode.pass_2;
var
l : tasmlabel;
begin
location.loc:=LOC_MEM;
if is_64bitint(resulttype.def) then
begin
getdatalabel(l);
if (cs_create_smart in aktmoduleswitches) then
Consts.concat(Tai_cut.Create);
Consts.concat(Tai_label.Create(l));
Consts.concat(Tai_const.Create_32bit(longint(lo(value))));
Consts.concat(Tai_const.Create_32bit(longint(hi(value))));
reset_reference(location.reference);
location.reference.symbol:=l;
end
else
begin
{ non int64 const. behaves as a memory reference }
location.reference.is_immediate:=true;
location.reference.offset:=longint(value);
end;
end;
{*****************************************************************************
TI386POINTERCONSTNODE
*****************************************************************************}
procedure ti386pointerconstnode.pass_2;
begin
{ an integer const. behaves as a memory reference }
location.loc:=LOC_MEM;
location.reference.is_immediate:=true;
location.reference.offset:=longint(value);
end;
{*****************************************************************************
Ti386STRINGCONSTNODE
*****************************************************************************}
procedure ti386stringconstnode.pass_2;
var
hp1 : tai;
l1,l2,
lastlabel : tasmlabel;
pc : pchar;
same_string : boolean;
l,j,
i,mylength : longint;
begin
{ for empty ansistrings we could return a constant 0 }
if is_ansistring(resulttype.def) and
(len=0) then
begin
location.loc:=LOC_MEM;
location.reference.is_immediate:=true;
location.reference.offset:=0;
exit;
end;
{ const already used ? }
lastlabel:=nil;
if not assigned(lab_str) then
begin
if is_shortstring(resulttype.def) then
mylength:=len+2
else
mylength:=len+1;
{ widestrings can't be reused yet }
if not(is_widestring(resulttype.def)) then
begin
{ tries to found an old entry }
hp1:=tai(Consts.first);
while assigned(hp1) do
begin
if hp1.typ=ait_label then
lastlabel:=tai_label(hp1).l
else
begin
{ when changing that code, be careful that }
{ you don't use typed consts, which are }
{ are also written to consts }
{ currently, this is no problem, because }
{ typed consts have no leading length or }
{ they have no trailing zero }
if (hp1.typ=ait_string) and (lastlabel<>nil) and
(tai_string(hp1).len=mylength) then
begin
same_string:=true;
{ if shortstring then check the length byte first and
set the start index to 1 }
if is_shortstring(resulttype.def) then
begin
if len<>ord(tai_string(hp1).str[0]) then
same_string:=false;
j:=1;
end
else
j:=0;
{ don't check if the length byte was already wrong }
if same_string then
begin
for i:=0 to len do
begin
if tai_string(hp1).str[j]<>value_str[i] then
begin
same_string:=false;
break;
end;
inc(j);
end;
end;
{ found ? }
if same_string then
begin
lab_str:=lastlabel;
{ create a new entry for ansistrings, but reuse the data }
if (st_type in [st_ansistring,st_widestring]) then
begin
getdatalabel(l2);
Consts.concat(Tai_label.Create(l2));
Consts.concat(Tai_const_symbol.Create(lab_str));
{ return the offset of the real string }
lab_str:=l2;
end;
break;
end;
end;
lastlabel:=nil;
end;
hp1:=tai(hp1.next);
end;
end;
{ :-(, we must generate a new entry }
if not assigned(lab_str) then
begin
getdatalabel(lastlabel);
lab_str:=lastlabel;
if (cs_create_smart in aktmoduleswitches) then
Consts.concat(Tai_cut.Create);
Consts.concat(Tai_label.Create(lastlabel));
{ generate an ansi string ? }
case st_type of
st_ansistring:
begin
{ an empty ansi string is nil! }
if len=0 then
Consts.concat(Tai_const.Create_32bit(0))
else
begin
getdatalabel(l1);
getdatalabel(l2);
Consts.concat(Tai_label.Create(l2));
Consts.concat(Tai_const_symbol.Create(l1));
Consts.concat(Tai_const.Create_32bit(len));
Consts.concat(Tai_const.Create_32bit(len));
Consts.concat(Tai_const.Create_32bit(-1));
Consts.concat(Tai_label.Create(l1));
getmem(pc,len+2);
move(value_str^,pc^,len);
pc[len]:=#0;
{ to overcome this problem we set the length explicitly }
{ with the ending null char }
Consts.concat(Tai_string.Create_length_pchar(pc,len+1));
{ return the offset of the real string }
lab_str:=l2;
end;
end;
st_widestring:
begin
{ an empty wide string is nil! }
if len=0 then
Consts.concat(Tai_const.Create_32bit(0))
else
begin
getdatalabel(l1);
getdatalabel(l2);
Consts.concat(Tai_label.Create(l2));
Consts.concat(Tai_const_symbol.Create(l1));
{ we use always UTF-16 coding for constants }
{ at least for now }
{ Consts.concat(Tai_const.Create_8bit(2)); }
Consts.concat(Tai_const.Create_32bit(len));
Consts.concat(Tai_const.Create_32bit(len));
Consts.concat(Tai_const.Create_32bit(-1));
Consts.concat(Tai_label.Create(l1));
for i:=0 to len-1 do
Consts.concat(Tai_const.Create_16bit(pcompilerwidestring(value_str)^.data[i]));
{ return the offset of the real string }
lab_str:=l2;
end;
end;
st_shortstring:
begin
{ truncate strings larger than 255 chars }
if len>255 then
l:=255
else
l:=len;
{ also length and terminating zero }
getmem(pc,l+3);
move(value_str^,pc[1],l+1);
pc[0]:=chr(l);
{ to overcome this problem we set the length explicitly }
{ with the ending null char }
pc[l+1]:=#0;
Consts.concat(Tai_string.Create_length_pchar(pc,l+2));
end;
end;
end;
end;
reset_reference(location.reference);
location.reference.symbol:=lab_str;
location.loc:=LOC_MEM;
end;
{*****************************************************************************
TI386SETCONSTNODE
*****************************************************************************}
procedure ti386setconstnode.pass_2;
var
hp1 : tai;
lastlabel : tasmlabel;
i : longint;
neededtyp : tait;
begin
{ small sets are loaded as constants }
if tsetdef(resulttype.def).settype=smallset then
begin
location.loc:=LOC_MEM;
location.reference.is_immediate:=true;
location.reference.offset:=plongint(value_set)^;
exit;
end;
if tsetdef(resulttype.def).settype=smallset then
neededtyp:=ait_const_32bit
else
neededtyp:=ait_const_8bit;
lastlabel:=nil;
{ const already used ? }
if not assigned(lab_set) then
begin
{ tries to found an old entry }
hp1:=tai(Consts.first);
while assigned(hp1) do
begin
if hp1.typ=ait_label then
lastlabel:=tai_label(hp1).l
else
begin
if (lastlabel<>nil) and (hp1.typ=neededtyp) then
begin
if (hp1.typ=ait_const_8bit) then
begin
{ compare normal set }
i:=0;
while assigned(hp1) and (i<32) do
begin
if tai_const(hp1).value<>value_set^[i] then
break;
inc(i);
hp1:=tai(hp1.next);
end;
if i=32 then
begin
{ found! }
lab_set:=lastlabel;
break;
end;
{ leave when the end of consts is reached, so no
hp1.next is done }
if not assigned(hp1) then
break;
end
else
begin
{ compare small set }
if plongint(value_set)^=tai_const(hp1).value then
begin
{ found! }
lab_set:=lastlabel;
break;
end;
end;
end;
lastlabel:=nil;
end;
hp1:=tai(hp1.next);
end;
{ :-(, we must generate a new entry }
if not assigned(lab_set) then
begin
getdatalabel(lastlabel);
lab_set:=lastlabel;
if (cs_create_smart in aktmoduleswitches) then
Consts.concat(Tai_cut.Create);
Consts.concat(Tai_label.Create(lastlabel));
if tsetdef(resulttype.def).settype=smallset then
begin
move(value_set^,i,sizeof(longint));
Consts.concat(Tai_const.Create_32bit(i));
end
else
begin
for i:=0 to 31 do
Consts.concat(Tai_const.Create_8bit(value_set^[i]));
end;
end;
end;
reset_reference(location.reference);
location.reference.symbol:=lab_set;
location.loc:=LOC_MEM;
end;
{*****************************************************************************
TI386NILNODE
*****************************************************************************}
procedure ti386nilnode.pass_2;
begin
location.loc:=LOC_MEM;
location.reference.is_immediate:=true;
location.reference.offset:=0;
end;
begin
crealconstnode:=ti386realconstnode;
cordconstnode:=ti386ordconstnode;
cpointerconstnode:=ti386pointerconstnode;
cstringconstnode:=ti386stringconstnode;
csetconstnode:=ti386setconstnode;
cnilnode:=ti386nilnode;
end.
{
$Log$
Revision 1.10 2001-08-26 13:36:57 florian
Revision 1.11 2001-09-30 16:17:17 jonas
* made most constant and mem handling processor independent
Revision 1.10 2001/08/26 13:36:57 florian
* some cg reorganisation
* some PPC updates

387
compiler/i386/n386mem.pas
View File

@ -27,22 +27,14 @@ unit n386mem;
interface
uses
node,nmem;
node,nmem,ncgmem;
type
ti386loadvmtnode = class(tloadvmtnode)
procedure pass_2;override;
end;
ti386hnewnode = class(thnewnode)
procedure pass_2;override;
end;
ti386newnode = class(tnewnode)
procedure pass_2;override;
end;
ti386hdisposenode = class(thdisposenode)
ti386addrnode = class(tcgaddrnode)
procedure pass_2;override;
end;
@ -50,19 +42,7 @@ interface
procedure pass_2;override;
end;
ti386addrnode = class(taddrnode)
procedure pass_2;override;
end;
ti386doubleaddrnode = class(tdoubleaddrnode)
procedure pass_2;override;
end;
ti386derefnode = class(tderefnode)
procedure pass_2;override;
end;
ti386subscriptnode = class(tsubscriptnode)
ti386derefnode = class(tcgderefnode)
procedure pass_2;override;
end;
@ -70,55 +50,20 @@ interface
procedure pass_2;override;
end;
ti386selfnode = class(tselfnode)
procedure pass_2;override;
end;
ti386withnode = class(twithnode)
procedure pass_2;override;
end;
implementation
uses
{$ifdef delphi}
sysutils,
{$else}
strings,
{$endif}
{$ifdef GDB}
gdb,
{$endif GDB}
globtype,systems,
cutils,verbose,globals,
symconst,symbase,symtype,symdef,symsym,symtable,aasm,types,
symconst,symtype,symdef,symsym,symtable,aasm,types,
cgbase,temp_gen,pass_2,
pass_1,nld,ncon,nadd,
cpubase,cpuasm,
cga,tgcpu,n386util;
{*****************************************************************************
TI386LOADNODE
*****************************************************************************}
procedure ti386loadvmtnode.pass_2;
begin
location.register:=getregister32;
emit_sym_ofs_reg(A_MOV,
S_L,newasmsymbol(tobjectdef(tclassrefdef(resulttype.def).pointertype.def).vmt_mangledname),0,
location.register);
end;
{*****************************************************************************
TI386HNEWNODE
*****************************************************************************}
procedure ti386hnewnode.pass_2;
begin
end;
{*****************************************************************************
TI386NEWNODE
*****************************************************************************}
@ -167,35 +112,17 @@ implementation
{*****************************************************************************
TI386HDISPOSENODE
TI386ADDRNODE
*****************************************************************************}
procedure ti386hdisposenode.pass_2;
begin
secondpass(left);
if codegenerror then
exit;
reset_reference(location.reference);
case left.location.loc of
LOC_REGISTER:
location.reference.index:=left.location.register;
LOC_CREGISTER:
begin
location.reference.index:=getregister32;
emit_reg_reg(A_MOV,S_L,
left.location.register,
location.reference.index);
end;
LOC_MEM,LOC_REFERENCE :
begin
del_reference(left.location.reference);
location.reference.index:=getregister32;
emit_ref_reg(A_MOV,S_L,newreference(left.location.reference),
location.reference.index);
end;
end;
end;
procedure ti386addrnode.pass_2;
begin
inherited pass_2;
{ for use of other segments }
if left.location.reference.segment<>R_NO then
location.segment:=left.location.reference.segment;
end;
{*****************************************************************************
TI386SIMPLENEWDISPOSENODE
@ -257,97 +184,14 @@ implementation
end;
{*****************************************************************************
TI386ADDRNODE
*****************************************************************************}
procedure ti386addrnode.pass_2;
begin
secondpass(left);
{ when loading procvar we do nothing with this node, so load the
location of left }
if nf_procvarload in flags then
begin
set_location(location,left.location);
exit;
end;
location.loc:=LOC_REGISTER;
del_reference(left.location.reference);
location.register:=getregister32;
{@ on a procvar means returning an address to the procedure that
is stored in it.}
{ yes but left.symtableentry can be nil
for example on self !! }
{ symtableentry can be also invalid, if left is no tree node }
if (m_tp_procvar in aktmodeswitches) and
(left.nodetype=loadn) and
assigned(tloadnode(left).symtableentry) and
(tloadnode(left).symtableentry.typ=varsym) and
(tvarsym(tloadnode(left).symtableentry).vartype.def.deftype=procvardef) then
emit_ref_reg(A_MOV,S_L,
newreference(left.location.reference),
location.register)
else
emit_ref_reg(A_LEA,S_L,
newreference(left.location.reference),
location.register);
{ for use of other segments }
if left.location.reference.segment<>R_NO then
location.segment:=left.location.reference.segment;
end;
{*****************************************************************************
TI386DOUBLEADDRNODE
*****************************************************************************}
procedure ti386doubleaddrnode.pass_2;
begin
secondpass(left);
location.loc:=LOC_REGISTER;
del_reference(left.location.reference);
location.register:=getregister32;
emit_ref_reg(A_LEA,S_L,
newreference(left.location.reference),
location.register);
end;
{*****************************************************************************
TI386DEREFNODE
*****************************************************************************}
procedure ti386derefnode.pass_2;
var
hr : tregister;
begin
secondpass(left);
reset_reference(location.reference);
case left.location.loc of
LOC_REGISTER:
location.reference.base:=left.location.register;
LOC_CREGISTER:
begin
{ ... and reserve one for the pointer }
hr:=getregister32;
emit_reg_reg(A_MOV,S_L,left.location.register,hr);
location.reference.base:=hr;
end;
else
begin
{ free register }
del_reference(left.location.reference);
{ ...and reserve one for the pointer }
hr:=getregister32;
emit_ref_reg(
A_MOV,S_L,newreference(left.location.reference),
hr);
location.reference.base:=hr;
end;
end;
begin
inherited pass_2;
if tpointerdef(left.resulttype.def).is_far then
location.reference.segment:=R_FS;
if not tpointerdef(left.resulttype.def).is_far and
@ -361,57 +205,6 @@ implementation
end;
{*****************************************************************************
TI386SUBSCRIPTNODE
*****************************************************************************}
procedure ti386subscriptnode.pass_2;
var
hr : tregister;
begin
secondpass(left);
if codegenerror then
exit;
{ classes and interfaces must be dereferenced implicit }
if is_class_or_interface(left.resulttype.def) then
begin
reset_reference(location.reference);
case left.location.loc of
LOC_REGISTER:
location.reference.base:=left.location.register;
LOC_CREGISTER:
begin
{ ... and reserve one for the pointer }
hr:=getregister32;
emit_reg_reg(A_MOV,S_L,left.location.register,hr);
location.reference.base:=hr;
end;
else
begin
{ free register }
del_reference(left.location.reference);
{ ... and reserve one for the pointer }
hr:=getregister32;
emit_ref_reg(
A_MOV,S_L,newreference(left.location.reference),
hr);
location.reference.base:=hr;
end;
end;
end
else if is_interfacecom(left.resulttype.def) then
begin
gettempintfcomreference(location.reference);
emit_mov_loc_ref(left.location,location.reference,S_L,false);
end
else
set_location(location,left.location);
inc(location.reference.offset,vs.address);
end;
{*****************************************************************************
TI386VECNODE
*****************************************************************************}
@ -898,164 +691,20 @@ implementation
end;
end;
{*****************************************************************************
TI386SELFNODE
*****************************************************************************}
procedure ti386selfnode.pass_2;
begin
reset_reference(location.reference);
getexplicitregister32(R_ESI);
if (resulttype.def.deftype=classrefdef) or
is_class(resulttype.def) then
location.register:=R_ESI
else
location.reference.base:=R_ESI;
end;
{*****************************************************************************
TI386WITHNODE
*****************************************************************************}
procedure ti386withnode.pass_2;
var
usetemp,with_expr_in_temp : boolean;
{$ifdef GDB}
withstartlabel,withendlabel : tasmlabel;
pp : pchar;
mangled_length : longint;
const
withlevel : longint = 0;
{$endif GDB}
begin
if assigned(left) then
begin
secondpass(left);
if left.location.reference.segment<>R_NO then
message(parser_e_no_with_for_variable_in_other_segments);
new(withreference);
usetemp:=false;
if (left.nodetype=loadn) and
(tloadnode(left).symtable=aktprocsym.definition.localst) then
begin
{ for locals use the local storage }
withreference^:=left.location.reference;
include(flags,nf_islocal);
end
else
{ call can have happend with a property }
if is_class_or_interface(left.resulttype.def) then
begin
getexplicitregister32(R_EDI);
emit_mov_loc_reg(left.location,R_EDI);
usetemp:=true;
end
else
begin
getexplicitregister32(R_EDI);
emit_lea_loc_reg(left.location,R_EDI,false);
usetemp:=true;
end;
release_loc(left.location);
{ if the with expression is stored in a temp }
{ area we must make it persistent and shouldn't }
{ release it (FK) }
if (left.location.loc in [LOC_MEM,LOC_REFERENCE]) and
istemp(left.location.reference) then
begin
normaltemptopersistant(left.location.reference.offset);
with_expr_in_temp:=true;
end
else
with_expr_in_temp:=false;
{ if usetemp is set the value must be in %edi }
if usetemp then
begin
gettempofsizereference(4,withreference^);
normaltemptopersistant(withreference^.offset);
{ move to temp reference }
emit_reg_ref(A_MOV,S_L,R_EDI,newreference(withreference^));
ungetregister32(R_EDI);
{$ifdef GDB}
if (cs_debuginfo in aktmoduleswitches) then
begin
inc(withlevel);
getaddrlabel(withstartlabel);
getaddrlabel(withendlabel);
emitlab(withstartlabel);
withdebugList.concat(Tai_stabs.Create(strpnew(
'"with'+tostr(withlevel)+':'+tostr(symtablestack.getnewtypecount)+
'=*'+tstoreddef(left.resulttype.def).numberstring+'",'+
tostr(N_LSYM)+',0,0,'+tostr(withreference^.offset))));
mangled_length:=length(aktprocsym.definition.mangledname);
getmem(pp,mangled_length+50);
strpcopy(pp,'192,0,0,'+withstartlabel.name);
if (target_info.use_function_relative_addresses) then
begin
strpcopy(strend(pp),'-');
strpcopy(strend(pp),aktprocsym.definition.mangledname);
end;
withdebugList.concat(Tai_stabn.Create(strnew(pp)));
end;
{$endif GDB}
end;
{ right can be optimize out !!! }
if assigned(right) then
secondpass(right);
if usetemp then
begin
ungetpersistanttemp(withreference^.offset);
{$ifdef GDB}
if (cs_debuginfo in aktmoduleswitches) then
begin
emitlab(withendlabel);
strpcopy(pp,'224,0,0,'+withendlabel.name);
if (target_info.use_function_relative_addresses) then
begin
strpcopy(strend(pp),'-');
strpcopy(strend(pp),aktprocsym.definition.mangledname);
end;
withdebugList.concat(Tai_stabn.Create(strnew(pp)));
freemem(pp,mangled_length+50);
dec(withlevel);
end;
{$endif GDB}
end;
if with_expr_in_temp then
ungetpersistanttemp(left.location.reference.offset);
dispose(withreference);
withreference:=nil;
end;
end;
begin
cloadvmtnode:=ti386loadvmtnode;
chnewnode:=ti386hnewnode;
cnewnode:=ti386newnode;
chdisposenode:=ti386hdisposenode;
csimplenewdisposenode:=ti386simplenewdisposenode;
caddrnode:=ti386addrnode;
cdoubleaddrnode:=ti386doubleaddrnode;
cderefnode:=ti386derefnode;
csubscriptnode:=ti386subscriptnode;
cvecnode:=ti386vecnode;
cselfnode:=ti386selfnode;
cwithnode:=ti386withnode;
end.
{
$Log$
Revision 1.16 2001-08-30 20:13:57 peter
Revision 1.17 2001-09-30 16:17:17 jonas
* made most constant and mem handling processor independent
Revision 1.16 2001/08/30 20:13:57 peter
* rtti/init table updates
* rttisym for reusable global rtti/init info
* support published for interfaces

21
compiler/i386/tgcpu.pas
View File

@ -56,6 +56,7 @@ interface
procedure testregisters32;
{$endif TEMPREGDEBUG}
function getregister32 : tregister;
function getaddressregister: tregister;
procedure ungetregister32(r : tregister);
{ tries to allocate the passed register, if possible }
function getexplicitregister32(r : tregister) : tregister;
@ -64,6 +65,8 @@ interface
procedure ungetregistermmx(r : tregister);
{$endif SUPPORT_MMX}
function isaddressregister(reg: tregister): boolean;
procedure ungetregister(r : tregister);
procedure cleartempgen;
@ -480,6 +483,12 @@ implementation
end;
{$endif SUPPORT_MMX}
function isaddressregister(reg: tregister): boolean;
begin
isaddressregister := true;
end;
procedure del_reference(const ref : treference);
begin
@ -589,6 +598,13 @@ implementation
{$endif TEMPREGDEBUG}
end;
function getaddressregister: tregister;
begin
getaddressregister := getregister32;
end;
function getexplicitregister32(r : tregister) : tregister;
begin
@ -674,7 +690,10 @@ begin
end.
{
$Log$
Revision 1.5 2001-08-26 13:37:03 florian
Revision 1.6 2001-09-30 16:17:18 jonas
* made most constant and mem handling processor independent
Revision 1.5 2001/08/26 13:37:03 florian
* some cg reorganisation
* some PPC updates

493
compiler/ncgcon.pas Normal file
View File

@ -0,0 +1,493 @@
{
$Id$
Copyright (c) 1998-2000 by Florian Klaempfl
Generate assembler for constant nodes which are the same for
all (most) processors
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 ncgcon;
{$i defines.inc}
interface
uses
node,ncon;
type
tcgrealconstnode = class(trealconstnode)
procedure pass_2;override;
end;
tcgordconstnode = class(tordconstnode)
procedure pass_2;override;
end;
tcgpointerconstnode = class(tpointerconstnode)
procedure pass_2;override;
end;
tcgstringconstnode = class(tstringconstnode)
procedure pass_2;override;
end;
tcgsetconstnode = class(tsetconstnode)
procedure pass_2;override;
end;
tcgnilnode = class(tnilnode)
procedure pass_2;override;
end;
implementation
uses
globtype,widestr,systems,
verbose,globals,
symconst,symdef,aasm,types,
temp_gen,
cpubase,
tgcpu;
{*****************************************************************************
TCGREALCONSTNODE
*****************************************************************************}
procedure tcgrealconstnode.pass_2;
{ I suppose the parser/pass_1 must make sure the generated real }
{ constants are actually supported by the target processor? (JM) }
const
floattype2ait:array[tfloattype] of tait=
(ait_real_32bit,ait_real_64bit,ait_real_80bit,ait_comp_64bit);
var
hp1 : tai;
lastlabel : tasmlabel;
realait : tait;
begin
lastlabel:=nil;
realait:=floattype2ait[tfloatdef(resulttype.def).typ];
{ const already used ? }
if not assigned(lab_real) then
begin
{ tries to find an old entry }
hp1:=tai(Consts.first);
while assigned(hp1) do
begin
if hp1.typ=ait_label then
lastlabel:=tai_label(hp1).l
else
begin
if (hp1.typ=realait) and (lastlabel<>nil) then
begin
if(
((realait=ait_real_32bit) and (tai_real_32bit(hp1).value=value_real)) or
((realait=ait_real_64bit) and (tai_real_64bit(hp1).value=value_real)) or
((realait=ait_real_80bit) and (tai_real_80bit(hp1).value=value_real)) or
((realait=ait_comp_64bit) and (tai_comp_64bit(hp1).value=value_real))
) then
begin
{ found! }
lab_real:=lastlabel;
break;
end;
end;
lastlabel:=nil;
end;
hp1:=tai(hp1.next);
end;
{ :-(, we must generate a new entry }
if not assigned(lab_real) then
begin
getdatalabel(lastlabel);
lab_real:=lastlabel;
if (cs_create_smart in aktmoduleswitches) then
Consts.concat(Tai_cut.Create);
Consts.concat(Tai_label.Create(lastlabel));
case realait of
ait_real_32bit :
Consts.concat(Tai_real_32bit.Create(value_real));
ait_real_64bit :
Consts.concat(Tai_real_64bit.Create(value_real));
ait_real_80bit :
Consts.concat(Tai_real_80bit.Create(value_real));
ait_comp_64bit :
Consts.concat(Tai_comp_64bit.Create(value_real));
else
internalerror(10120);
end;
end;
end;
reset_reference(location.reference);
location.reference.symbol:=lab_real;
location.loc:=LOC_MEM;
end;
{*****************************************************************************
TCGORDCONSTNODE
*****************************************************************************}
procedure tcgordconstnode.pass_2;
var
l : tasmlabel;
begin
location.loc:=LOC_MEM;
{ still needs to be made more generic (and optimal), this is for }
{ when Peter implements LOC_ORDCONST (JM) }
if is_64bitint(resulttype.def) then
begin
getdatalabel(l);
if (cs_create_smart in aktmoduleswitches) then
Consts.concat(Tai_cut.Create);
Consts.concat(Tai_label.Create(l));
Consts.concat(Tai_const.Create_32bit(longint(lo(value))));
Consts.concat(Tai_const.Create_32bit(longint(hi(value))));
reset_reference(location.reference);
location.reference.symbol:=l;
end
else
begin
{ non int64 const. behaves as a memory reference }
location.reference.is_immediate:=true;
location.reference.offset:=longint(value);
end;
end;
{*****************************************************************************
TCGPOINTERCONSTNODE
*****************************************************************************}
procedure tcgpointerconstnode.pass_2;
begin
{ an integer const. behaves as a memory reference }
location.loc:=LOC_MEM;
location.reference.is_immediate:=true;
location.reference.offset:=longint(value);
end;
{*****************************************************************************
TCGSTRINGCONSTNODE
*****************************************************************************}
procedure tcgstringconstnode.pass_2;
var
hp1 : tai;
l1,l2,
lastlabel : tasmlabel;
pc : pchar;
same_string : boolean;
l,j,
i,mylength : longint;
begin
{ for empty ansistrings we could return a constant 0 }
if is_ansistring(resulttype.def) and
(len=0) then
begin
location.loc:=LOC_MEM;
location.reference.is_immediate:=true;
location.reference.offset:=0;
exit;
end;
{ const already used ? }
lastlabel:=nil;
if not assigned(lab_str) then
begin
if is_shortstring(resulttype.def) then
mylength:=len+2
else
mylength:=len+1;
{ widestrings can't be reused yet }
if not(is_widestring(resulttype.def)) then
begin
{ tries to found an old entry }
hp1:=tai(Consts.first);
while assigned(hp1) do
begin
if hp1.typ=ait_label then
lastlabel:=tai_label(hp1).l
else
begin
{ when changing that code, be careful that }
{ you don't use typed consts, which are }
{ are also written to consts }
{ currently, this is no problem, because }
{ typed consts have no leading length or }
{ they have no trailing zero }
if (hp1.typ=ait_string) and (lastlabel<>nil) and
(tai_string(hp1).len=mylength) then
begin
same_string:=true;
{ if shortstring then check the length byte first and
set the start index to 1 }
if is_shortstring(resulttype.def) then
begin
if len<>ord(tai_string(hp1).str[0]) then
same_string:=false;
j:=1;
end
else
j:=0;
{ don't check if the length byte was already wrong }
if same_string then
begin
for i:=0 to len do
begin
if tai_string(hp1).str[j]<>value_str[i] then
begin
same_string:=false;
break;
end;
inc(j);
end;
end;
{ found ? }
if same_string then
begin
lab_str:=lastlabel;
{ create a new entry for ansistrings, but reuse the data }
if (st_type in [st_ansistring,st_widestring]) then
begin
getdatalabel(l2);
Consts.concat(Tai_label.Create(l2));
Consts.concat(Tai_const_symbol.Create(lab_str));
{ return the offset of the real string }
lab_str:=l2;
end;
break;
end;
end;
lastlabel:=nil;
end;
hp1:=tai(hp1.next);
end;
end;
{ :-(, we must generate a new entry }
if not assigned(lab_str) then
begin
getdatalabel(lastlabel);
lab_str:=lastlabel;
if (cs_create_smart in aktmoduleswitches) then
Consts.concat(Tai_cut.Create);
Consts.concat(Tai_label.Create(lastlabel));
{ generate an ansi string ? }
case st_type of
st_ansistring:
begin
{ an empty ansi string is nil! }
if len=0 then
Consts.concat(Tai_const.Create_32bit(0))
else
begin
getdatalabel(l1);
getdatalabel(l2);
Consts.concat(Tai_label.Create(l2));
Consts.concat(Tai_const_symbol.Create(l1));
Consts.concat(Tai_const.Create_32bit(len));
Consts.concat(Tai_const.Create_32bit(len));
Consts.concat(Tai_const.Create_32bit(-1));
Consts.concat(Tai_label.Create(l1));
getmem(pc,len+2);
move(value_str^,pc^,len);
pc[len]:=#0;
{ to overcome this problem we set the length explicitly }
{ with the ending null char }
Consts.concat(Tai_string.Create_length_pchar(pc,len+1));
{ return the offset of the real string }
lab_str:=l2;
end;
end;
st_widestring:
begin
{ an empty wide string is nil! }
if len=0 then
Consts.concat(Tai_const.Create_32bit(0))
else
begin
getdatalabel(l1);
getdatalabel(l2);
Consts.concat(Tai_label.Create(l2));
Consts.concat(Tai_const_symbol.Create(l1));
{ we use always UTF-16 coding for constants }
{ at least for now }
{ Consts.concat(Tai_const.Create_8bit(2)); }
Consts.concat(Tai_const.Create_32bit(len));
Consts.concat(Tai_const.Create_32bit(len));
Consts.concat(Tai_const.Create_32bit(-1));
Consts.concat(Tai_label.Create(l1));
for i:=0 to len-1 do
Consts.concat(Tai_const.Create_16bit(pcompilerwidestring(value_str)^.data[i]));
{ return the offset of the real string }
lab_str:=l2;
end;
end;
st_shortstring:
begin
{ truncate strings larger than 255 chars }
if len>255 then
l:=255
else
l:=len;
{ also length and terminating zero }
getmem(pc,l+3);
move(value_str^,pc[1],l+1);
pc[0]:=chr(l);
{ to overcome this problem we set the length explicitly }
{ with the ending null char }
pc[l+1]:=#0;
Consts.concat(Tai_string.Create_length_pchar(pc,l+2));
end;
end;
end;
end;
reset_reference(location.reference);
location.reference.symbol:=lab_str;
location.loc:=LOC_MEM;
end;
{*****************************************************************************
TCGSETCONSTNODE
*****************************************************************************}
procedure tcgsetconstnode.pass_2;
var
hp1 : tai;
lastlabel : tasmlabel;
i : longint;
neededtyp : tait;
begin
{ small sets are loaded as constants }
if tsetdef(resulttype.def).settype=smallset then
begin
location.loc:=LOC_MEM;
location.reference.is_immediate:=true;
location.reference.offset:=plongint(value_set)^;
exit;
end;
neededtyp:=ait_const_8bit;
lastlabel:=nil;
{ const already used ? }
if not assigned(lab_set) then
begin
{ tries to found an old entry }
hp1:=tai(Consts.first);
while assigned(hp1) do
begin
if hp1.typ=ait_label then
lastlabel:=tai_label(hp1).l
else
begin
if (lastlabel<>nil) and (hp1.typ=neededtyp) then
begin
if (hp1.typ=ait_const_8bit) then
begin
{ compare normal set }
i:=0;
while assigned(hp1) and (i<32) do
begin
if tai_const(hp1).value<>value_set^[i] then
break;
inc(i);
hp1:=tai(hp1.next);
end;
if i=32 then
begin
{ found! }
lab_set:=lastlabel;
break;
end;
{ leave when the end of consts is reached, so no
hp1.next is done }
if not assigned(hp1) then
break;
end
else
begin
{ compare small set }
if plongint(value_set)^=tai_const(hp1).value then
begin
{ found! }
lab_set:=lastlabel;
break;
end;
end;
end;
lastlabel:=nil;
end;
hp1:=tai(hp1.next);
end;
{ :-(, we must generate a new entry }
if not assigned(lab_set) then
begin
getdatalabel(lastlabel);
lab_set:=lastlabel;
if (cs_create_smart in aktmoduleswitches) then
Consts.concat(Tai_cut.Create);
Consts.concat(Tai_label.Create(lastlabel));
if tsetdef(resulttype.def).settype=smallset then
begin
move(value_set^,i,sizeof(longint));
Consts.concat(Tai_const.Create_32bit(i));
end
else
begin
for i:=0 to 31 do
Consts.concat(Tai_const.Create_8bit(value_set^[i]));
end;
end;
end;
reset_reference(location.reference);
location.reference.symbol:=lab_set;
location.loc:=LOC_MEM;
end;
{*****************************************************************************
TCGNILNODE
*****************************************************************************}
procedure tcgnilnode.pass_2;
begin
location.loc:=LOC_MEM;
location.reference.is_immediate:=true;
location.reference.offset:=0;
end;
begin
crealconstnode:=tcgrealconstnode;
cordconstnode:=tcgordconstnode;
cpointerconstnode:=tcgpointerconstnode;
cstringconstnode:=tcgstringconstnode;
csetconstnode:=tcgsetconstnode;
cnilnode:=tcgnilnode;
end.
{
$Log$
Revision 1.1 2001-09-30 16:17:17 jonas
* made most constant and mem handling processor independent
}

451
compiler/ncgmem.pas Normal file
View File

@ -0,0 +1,451 @@
{
$Id$
Copyright (c) 1998-2000 by Florian Klaempfl
Generate assembler for memory related nodes which are
the same for all (most?) processors
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 ncgmem;
{$i defines.inc}
interface
uses
node,nmem;
type
tcgloadvmtnode = class(tloadvmtnode)
procedure pass_2;override;
end;
tcghnewnode = class(thnewnode)
procedure pass_2;override;
end;
tcghdisposenode = class(thdisposenode)
procedure pass_2;override;
end;
tcgaddrnode = class(taddrnode)
procedure pass_2;override;
end;
tcgdoubleaddrnode = class(tdoubleaddrnode)
procedure pass_2;override;
end;
tcgderefnode = class(tderefnode)
procedure pass_2;override;
end;
tcgsubscriptnode = class(tsubscriptnode)
procedure pass_2;override;
end;
tcgselfnode = class(tselfnode)
procedure pass_2;override;
end;
tcgwithnode = class(twithnode)
procedure pass_2;override;
end;
implementation
uses
{$ifdef delphi}
sysutils,
{$else}
strings,
{$endif}
{$ifdef GDB}
gdb,
{$endif GDB}
globtype,systems,
cutils,verbose,globals,
symconst,symbase,symdef,symsym,aasm,
cgbase,temp_gen,pass_2,
nld,ncon,nadd,
cpubase,cgobj,cgcpu,
cga,tgcpu;
{*****************************************************************************
TCGLOADNODE
*****************************************************************************}
procedure tcgloadvmtnode.pass_2;
begin
location.register:=getregister32;
cg.a_load_sym_ofs_reg(exprasmlist,
newasmsymbol(tobjectdef(tclassrefdef(resulttype.def).pointertype.def).vmt_mangledname),
0,location.register);
end;
{*****************************************************************************
TCGHNEWNODE
*****************************************************************************}
procedure tcghnewnode.pass_2;
begin
end;
{*****************************************************************************
TCGHDISPOSENODE
*****************************************************************************}
procedure tcghdisposenode.pass_2;
begin
secondpass(left);
if codegenerror then
exit;
{ is this already set somewhere else? It wasn't present in the }
{ original i386 code either (JM) }
{ location.loc := LOC_REFERENCE; }
reset_reference(location.reference);
case left.location.loc of
LOC_REGISTER:
begin
if not isaddressregister(left.location.register) then
begin
ungetregister(left.location.register);
location.reference.index := getaddressregister;
cg.a_load_reg_reg(exprasmlist,OS_ADDR,left.location.register,
location.reference.index);
end
else
location.reference.index := left.location.register;
end;
LOC_CREGISTER,LOC_MEM,LOC_REFERENCE:
begin
del_location(left.location);
location.reference.index:=getaddressregister;
cg.a_load_loc_reg(exprasmlist,OS_ADDR,left.location,
location.reference.index);
end;
end;
end;
{*****************************************************************************
TCGADDRNODE
*****************************************************************************}
procedure tcgaddrnode.pass_2;
begin
secondpass(left);
{ when loading procvar we do nothing with this node, so load the
location of left }
if nf_procvarload in flags then
begin
set_location(location,left.location);
exit;
end;
location.loc:=LOC_REGISTER;
del_reference(left.location.reference);
location.register:=getaddressregister;
{@ on a procvar means returning an address to the procedure that
is stored in it.}
{ yes but left.symtableentry can be nil
for example on self !! }
{ symtableentry can be also invalid, if left is no tree node }
if (m_tp_procvar in aktmodeswitches) and
(left.nodetype=loadn) and
assigned(tloadnode(left).symtableentry) and
(tloadnode(left).symtableentry.typ=varsym) and
(tvarsym(tloadnode(left).symtableentry).vartype.def.deftype=procvardef) then
cg.a_load_ref_reg(exprasmlist,OS_ADDR,left.location.reference,
location.register)
else
cg.a_loadaddress_ref_reg(exprasmlist,left.location.reference,
location.register);
end;
{*****************************************************************************
TCGDOUBLEADDRNODE
*****************************************************************************}
procedure tcgdoubleaddrnode.pass_2;
begin
secondpass(left);
location.loc:=LOC_REGISTER;
del_reference(left.location.reference);
location.register:=getaddressregister;
cg.a_loadaddress_ref_reg(exprasmlist,left.location.reference,
location.register);
end;
{*****************************************************************************
TCGDEREFNODE
*****************************************************************************}
procedure tcgderefnode.pass_2;
begin
secondpass(left);
reset_reference(location.reference);
case left.location.loc of
LOC_REGISTER:
begin
if not isaddressregister(left.location.register) then
begin
ungetregister(left.location.register);
location.reference.base := getaddressregister;
cg.a_load_reg_reg(exprasmlist,OS_ADDR,left.location.register,
location.reference.base);
end
else
location.reference.base := left.location.register;
end;
LOC_CREGISTER,LOC_MEM,LOC_REFERENCE:
begin
del_location(left.location);
location.reference.base:=getaddressregister;
cg.a_load_loc_reg(exprasmlist,OS_ADDR,left.location,
location.reference.base);
end;
end;
{ still needs generic checkpointer() support! }
end;
{*****************************************************************************
TCGSUBSCRIPTNODE
*****************************************************************************}
procedure tcgsubscriptnode.pass_2;
begin
secondpass(left);
if codegenerror then
exit;
{ classes and interfaces must be dereferenced implicit }
if is_class_or_interface(left.resulttype.def) then
begin
reset_reference(location.reference);
case left.location.loc of
LOC_REGISTER:
begin
if not isaddressregister(left.location.register) then
begin
ungetregister(left.location.register);
location.reference.base := getaddressregister;
cg.a_load_reg_reg(exprasmlist,OS_ADDR,
left.location.register,location.reference.base);
end
else
location.reference.base := left.location.register;
end;
LOC_CREGISTER,LOC_MEM,LOC_REFERENCE:
begin
del_location(left.location);
location.reference.base:=getaddressregister;
cg.a_load_loc_reg(exprasmlist,OS_ADDR,left.location,
location.reference.base);
end;
end;
end
else if is_interfacecom(left.resulttype.def) then
begin
gettempintfcomreference(location.reference);
cg.a_load_loc_ref(exprasmlist,OS_ADDR,left.location,
location.reference);
end
else
set_location(location,left.location);
{ is this already set somewhere else? It wasn't present in the }
{ original i386 code either (JM) }
{ location.loc := LOC_REFERENCE; }
inc(location.reference.offset,vs.address);
end;
{*****************************************************************************
TCGSELFNODE
*****************************************************************************}
procedure tcgselfnode.pass_2;
begin
reset_reference(location.reference);
getexplicitregister32(SELF_POINTER);
if (resulttype.def.deftype=classrefdef) or
is_class(resulttype.def) then
begin
location.loc := LOC_CREGISTER;
location.register:=SELF_POINTER;
end
else
begin
location.loc := LOC_REFERENCE;
location.reference.base:=SELF_POINTER;
end;
end;
{*****************************************************************************
TCGWITHNODE
*****************************************************************************}
procedure tcgwithnode.pass_2;
var
tmpreg: tregister;
usetemp,with_expr_in_temp : boolean;
{$ifdef GDB}
withstartlabel,withendlabel : tasmlabel;
pp : pchar;
mangled_length : longint;
const
withlevel : longint = 0;
{$endif GDB}
begin
if assigned(left) then
begin
secondpass(left);
{$ifdef i386}
if left.location.reference.segment<>R_NO then
message(parser_e_no_with_for_variable_in_other_segments);
{$endif i386}
new(withreference);
usetemp:=false;
if (left.nodetype=loadn) and
(tloadnode(left).symtable=aktprocsym.definition.localst) then
begin
{ for locals use the local storage }
withreference^:=left.location.reference;
include(flags,nf_islocal);
end
else
{ call can have happend with a property }
begin
tmpreg := cg.get_scratch_reg(exprasmlist);
usetemp:=true;
if is_class_or_interface(left.resulttype.def) then
cg.a_load_loc_reg(exprasmlist,OS_ADDR,left.location,tmpreg)
else
cg.a_loadaddress_ref_reg(exprasmlist,
left.location.reference,tmpreg);
end;
del_location(left.location);
{ if the with expression is stored in a temp }
{ area we must make it persistent and shouldn't }
{ release it (FK) }
if (left.location.loc in [LOC_MEM,LOC_REFERENCE]) and
istemp(left.location.reference) then
begin
normaltemptopersistant(left.location.reference.offset);
with_expr_in_temp:=true;
end
else
with_expr_in_temp:=false;
{ if usetemp is set the value must be in tmpreg }
if usetemp then
begin
gettempofsizereference(target_info.size_of_pointer,
withreference^);
normaltemptopersistant(withreference^.offset);
{ move to temp reference }
cg.a_load_reg_ref(exprasmlist,OS_ADDR,tmpreg,withreference^);
cg.free_scratch_reg(exprasmlist,tmpreg);
{$ifdef GDB}
if (cs_debuginfo in aktmoduleswitches) then
begin
inc(withlevel);
getaddrlabel(withstartlabel);
getaddrlabel(withendlabel);
emitlab(withstartlabel);
withdebugList.concat(Tai_stabs.Create(strpnew(
'"with'+tostr(withlevel)+':'+tostr(symtablestack.getnewtypecount)+
'=*'+tstoreddef(left.resulttype.def).numberstring+'",'+
tostr(N_LSYM)+',0,0,'+tostr(withreference^.offset))));
mangled_length:=length(aktprocsym.definition.mangledname);
getmem(pp,mangled_length+50);
strpcopy(pp,'192,0,0,'+withstartlabel.name);
if (target_info.use_function_relative_addresses) then
begin
strpcopy(strend(pp),'-');
strpcopy(strend(pp),aktprocsym.definition.mangledname);
end;
withdebugList.concat(Tai_stabn.Create(strnew(pp)));
end;
{$endif GDB}
end;
{ right can be optimize out !!! }
if assigned(right) then
secondpass(right);
if usetemp then
begin
ungetpersistanttemp(withreference^.offset);
{$ifdef GDB}
if (cs_debuginfo in aktmoduleswitches) then
begin
emitlab(withendlabel);
strpcopy(pp,'224,0,0,'+withendlabel.name);
if (target_info.use_function_relative_addresses) then
begin
strpcopy(strend(pp),'-');
strpcopy(strend(pp),aktprocsym.definition.mangledname);
end;
withdebugList.concat(Tai_stabn.Create(strnew(pp)));
freemem(pp,mangled_length+50);
dec(withlevel);
end;
{$endif GDB}
end;
if with_expr_in_temp then
ungetpersistanttemp(left.location.reference.offset);
dispose(withreference);
withreference:=nil;
end;
end;
begin
cloadvmtnode:=tcgloadvmtnode;
chnewnode:=tcghnewnode;
chdisposenode:=tcghdisposenode;
caddrnode:=tcgaddrnode;
cdoubleaddrnode:=tcgdoubleaddrnode;
cderefnode:=tcgderefnode;
csubscriptnode:=tcgsubscriptnode;
cselfnode:=tcgselfnode;
cwithnode:=tcgwithnode;
end.
{
$Log$
Revision 1.1 2001-09-30 16:17:17 jonas
* made most constant and mem handling processor independent
}