paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-19 05:09:07 +02:00
Code Issues Packages Projects Releases Wiki Activity

* moved more routines from cga/n386util

Browse Source
This commit is contained in:
peter 2002-04-25 20:16:38 +00:00
parent 6bbaa14daf
commit cc8c4d7093
17 changed files with 2148 additions and 3550 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
compiler/cg64f32.pas
View File

@ -22,10 +22,10 @@
****************************************************************************
}
{# This unit implements the code generation for 64 bit int arithmethics on
{# This unit implements the code generation for 64 bit int arithmethics on
32 bit processors. All 32-bit processors should use this class as
the base code generator class instead of tcg.
}
}
unit cg64f32;
{$i defines.inc}
@ -39,7 +39,7 @@ unit cg64f32;
node,symtype;
type
{# Defines all the methods required on 32-bit processors
{# Defines all the methods required on 32-bit processors
to handle 64-bit integers. All 32-bit processors should
create derive a class of this type instead of @var(tcg).
}
@ -384,10 +384,10 @@ unit cg64f32;
var
tmpref: treference;
begin
a_param_ref(list,OS_32,r,nr);
tmpref := r;
inc(tmpref.offset,4);
a_param_ref(list,OS_32,tmpref,nr+1);
a_param_ref(list,OS_32,tmpref,nr);
a_param_ref(list,OS_32,r,nr+1);
end;
@ -591,7 +591,10 @@ begin
end.
{
$Log$
Revision 1.8 2002-04-21 15:28:51 carl
Revision 1.9 2002-04-25 20:16:38 peter
* moved more routines from cga/n386util
Revision 1.8 2002/04/21 15:28:51 carl
* a_jmp_cond -> a_jmp_always
Revision 1.7 2002/04/07 13:21:18 carl

32
compiler/cgbase.pas
View File

@ -41,21 +41,21 @@ unit cgbase;
const
{# bitmask indicating if the procedure uses asm }
pi_uses_asm = $1;
pi_uses_asm = $1;
{# bitmask indicating if the procedure is exported by an unit }
pi_is_global = $2;
pi_is_global = $2;
{# bitmask indicating if the procedure does a call }
pi_do_call = $4;
pi_do_call = $4;
{# bitmask indicating if the procedure is an operator }
pi_operator = $8;
pi_operator = $8;
{# bitmask indicating if the procedure is an external C function }
pi_c_import = $10;
pi_c_import = $10;
{# bitmask indicating if the procedure has a try statement = no register optimization }
pi_uses_exceptions = $20;
{# bitmask indicating if the procedure is declared as @var(assembler), don't optimize}
pi_is_assembler = $40;
pi_is_assembler = $40;
{# bitmask indicating if the procedure contains data which needs to be finalized }
pi_needs_implicit_finally = $80;
pi_needs_implicit_finally = $80;
type
pprocinfo = ^tprocinfo;
@ -77,7 +77,7 @@ unit cgbase;
{# parameter offset in stack }
para_offset : longint;
{# some collected informations about the procedure
{# some collected informations about the procedure
see pi_xxxx above }
flags : longint;
@ -449,6 +449,13 @@ implementation
result := tfloat2tcgsize[tfloatdef(def).typ];
recorddef :
result:=int_cgsize(def.size);
arraydef :
begin
if not is_special_array(def) then
result := int_cgsize(def.size)
else
result := OS_NO;
end;
else
begin
{ undefined size }
@ -464,9 +471,9 @@ implementation
result := OS_8;
2 :
result := OS_16;
4 :
3,4 :
result := OS_32;
8 :
5..8 :
result := OS_64;
else
result:=OS_NO;
@ -517,7 +524,10 @@ begin
end.
{
$Log$
Revision 1.12 2002-04-21 15:28:06 carl
Revision 1.13 2002-04-25 20:16:38 peter
* moved more routines from cga/n386util
Revision 1.12 2002/04/21 15:28:06 carl
- remove duplicate constants
- move some constants to cginfo

420
compiler/cgobj.pas
View File

@ -85,22 +85,11 @@ unit cgobj;
{************************************************}
{ code generation for subroutine entry/exit code }
{ initilizes data of type t }
{ if is_already_ref is true then the routines assumes }
{ that r points to the data to initialize }
procedure g_initialize(list : taasmoutput;t : tdef;const ref : treference;is_already_ref : boolean);
{ finalizes data of type t }
{ if is_already_ref is true then the routines assumes }
{ that r points to the data to finalizes }
procedure g_finalize(list : taasmoutput;t : tdef;const ref : treference;is_already_ref : boolean);
{ helper routines }
procedure g_initialize_data(list : taasmoutput;p : tsym);
procedure g_incr_data(list : taasmoutput;p : tsym);
procedure g_finalize_data(list : taasmoutput;p : tnamedindexitem);
procedure g_copyvalueparas(list : taasmoutput;p : tnamedindexitem);
procedure g_finalizetempansistrings(list : taasmoutput);
procedure g_entrycode(alist : TAAsmoutput;make_global:boolean;
stackframe:longint;
@ -110,11 +99,6 @@ unit cgobj;
procedure g_exitcode(list : taasmoutput;parasize : longint;
nostackframe,inlined : boolean);
{ string helper routines }
procedure g_decrstrref(list : taasmoutput;const ref : treference;t : tdef);
procedure g_removetemps(list : taasmoutput;p : tlinkedlist);
{ passing parameters, per default the parameter is pushed }
{ nr gives the number of the parameter (enumerated from }
{ left to right), this allows to move the parameter to }
@ -202,6 +186,7 @@ unit cgobj;
procedure a_load_reg_reg(list : taasmoutput;size : tcgsize;reg1,reg2 : tregister);virtual; abstract;
procedure a_load_reg_loc(list : taasmoutput;size : tcgsize;reg : tregister;const loc: tlocation);
procedure a_load_ref_reg(list : taasmoutput;size : tcgsize;const ref : treference;register : tregister);virtual; abstract;
procedure a_load_ref_ref(list : taasmoutput;size : tcgsize;const sref : treference;const dref : treference);virtual;
procedure a_load_loc_reg(list : taasmoutput;const loc: tlocation; reg : tregister);
procedure a_load_loc_ref(list : taasmoutput;const loc: tlocation; const ref : treference);
procedure a_load_sym_ofs_reg(list: taasmoutput; const sym: tasmsymbol; ofs: longint; reg: tregister);virtual; abstract;
@ -217,6 +202,7 @@ unit cgobj;
procedure a_loadmm_reg_reg(list: taasmoutput; reg1, reg2: tregister); virtual; abstract;
procedure a_loadmm_ref_reg(list: taasmoutput; const ref: treference; reg: tregister); virtual; abstract;
procedure a_loadmm_reg_ref(list: taasmoutput; reg: tregister; const ref: treference); virtual; abstract;
procedure a_parammm_reg(list: taasmoutput; reg: tregister); virtual; abstract;
{ basic arithmetic operations }
{ note: for operators which require only one argument (not, neg), use }
@ -295,13 +281,6 @@ unit cgobj;
}
procedure g_profilecode(list : taasmoutput);virtual;
{# Emits the call to the stack checking routine of
the runtime library. The default behavior
does not need to be modified, as it is generic
for all platforms.
}
procedure g_stackcheck(list : taasmoutput;stackframesize : longint);virtual;
procedure g_maybe_loadself(list : taasmoutput);virtual; abstract;
{# This should emit the opcode to copy len bytes from the source
to destination, if loadref is true, it assumes that it first must load
@ -317,6 +296,30 @@ unit cgobj;
}
procedure g_concatcopy(list : taasmoutput;const source,dest : treference;len : aword;delsource,loadref : boolean);virtual; abstract;
{# This should emit the opcode to a shortrstring from the source
to destination, if loadref is true, it assumes that it first must load
the source address from the memory location where
source points to.
@param(source Source reference of copy)
@param(dest Destination reference of copy)
@param(delsource Indicates if the source reference's resources should be freed)
@param(loadref Is the source reference a pointer to the actual source (TRUE), is it the actual source address (FALSE))
}
procedure g_copyshortstring(list : taasmoutput;const source,dest : treference;len:byte;delsource,loadref : boolean);
procedure g_incrrefcount(list : taasmoutput;t: tdef; const ref: treference);
procedure g_decrrefcount(list : taasmoutput;t: tdef; const ref: treference);
procedure g_initialize(list : taasmoutput;t : tdef;const ref : treference;loadref : boolean);
procedure g_finalize(list : taasmoutput;t : tdef;const ref : treference;loadref : boolean);
{# Emits the call to the stack checking routine of
the runtime library. The default behavior
does not need to be modified, as it is generic
for all platforms.
}
procedure g_stackcheck(list : taasmoutput;stackframesize : longint);virtual;
{# Generates range checking code. It is to note
that this routine does not need to be overriden,
@ -492,124 +495,10 @@ unit cgobj;
free_scratch_reg(list,hr);
end;
procedure tcg.g_stackcheck(list : taasmoutput;stackframesize : longint);
begin
a_param_const(list,OS_32,stackframesize,1);
a_call_name(list,'FPC_STACKCHECK',0);
end;
{*****************************************************************************
String helper routines
*****************************************************************************}
procedure tcg.g_removetemps(list : taasmoutput;p : tlinkedlist);
(*
var
hp : ptemptodestroy;
pushedregs : tpushed;
*)
begin
(*
hp:=ptemptodestroy(p^.first);
if not(assigned(hp)) then
exit;
tg.pushusedregisters(pushedregs,$ff);
while assigned(hp) do
begin
if is_ansistring(hp^.typ) then
begin
g_decrstrref(list,hp^.address,hp^.typ);
tg.ungetiftemp(hp^.address);
end;
hp:=ptemptodestroy(hp^.next);
end;
tg.popusedregisters(pushedregs);
*)
runerror(211);
end;
procedure tcg.g_decrstrref(list : taasmoutput;const ref : treference;t : tdef);
{ var
pushedregs : tpushedsaved; }
begin
(*
tg.pushusedregisters(pushedregs,$ff);
a_param_ref_addr(list,ref,1);
if is_ansistring(t) then
a_call_name(list,'FPC_ANSISTR_DECR_REF',0)
else if is_widestring(t) then
a_call_name(list,'FPC_WIDESTR_DECR_REF',0)
else internalerror(58993);
tg.popusedregisters(pushedregs);
*)
runerror(211);
end;
{*****************************************************************************
Code generation for subroutine entry- and exit code
*****************************************************************************}
{ initilizes data of type t }
{ if is_already_ref is true then the routines assumes }
{ that r points to the data to initialize }
procedure tcg.g_initialize(list : taasmoutput;t : tdef;const ref : treference;is_already_ref : boolean);
{ var
hr : treference; }
begin
(*
if is_ansistring(t) or
is_widestring(t) then
a_load_const_ref(list,OS_8,0,ref)
else
begin
reset_reference(hr);
hr.symbol:=t^.get_inittable_label;
a_param_ref_addr(list,hr,2);
if is_already_ref then
a_param_ref(list,OS_ADDR,ref,1)
else
a_param_ref_addr(list,ref,1);
a_call_name(list,'FPC_INITIALIZE',0);
end;
*)
runerror(211);
end;
procedure tcg.g_finalize(list : taasmoutput;t : tdef;const ref : treference;is_already_ref : boolean);
{ var
r : treference; }
begin
(*
if is_ansistring(t) or
is_widestring(t) then
begin
g_decrstrref(list,ref,t);
end
else
begin
reset_reference(r);
r.symbol:=t^.get_inittable_label;
a_param_ref_addr(list,r,2);
if is_already_ref then
a_paramaddr_ref(list,ref,1)
else
a_param_ref_addr(list,ref,1);
a_call_name(list,'FPC_FINALIZE',0);
end;
*)
runerror(211);
end;
{ generates the code for initialisation of local data }
procedure tcg.g_initialize_data(list : taasmoutput;p : tsym);
@ -733,37 +622,7 @@ unit cgobj;
begin
cg^.g_copyvalueparas(_list,s);
end;
*)
procedure tcg.g_finalizetempansistrings(list : taasmoutput);
(*
var
hp : ptemprecord;
hr : treference;
*)
begin
(*
hp:=tg.templist;
while assigned(hp) do
begin
if hp^.temptype in [tt_ansistring,tt_freeansistring] then
begin
procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
reset_reference(hr);
hr.base:=procinfo^.framepointer;
hr.offset:=hp^.pos;
a_param_ref_addr(list,hr,1);
a_call_name(list,'FPC_ANSISTR_DECR_REF',0);
end;
hp:=hp^.next;
end;
*)
runerror(211);
end;
(*
procedure _finalize_data(s : tnamedindexitem);{$ifndef FPC}far;{$endif}
begin
@ -1185,10 +1044,37 @@ unit cgobj;
****************************************************************************}
procedure tcg.a_load_ref_ref(list : taasmoutput;size : tcgsize;const sref : treference;const dref : treference);
var
tmpreg: tregister;
begin
{$ifdef i386}
{ the following is done with defines to avoid a speed penalty, }
{ since all this is only necessary for the 80x86 (because EDI }
{ doesn't have an 8bit component which is directly addressable) }
if size in [OS_8,OS_S8] then
tmpreg := rg.getregisterint(exprasmlist)
else
{$endif i386}
tmpreg := get_scratch_reg(list);
tmpreg:=rg.makeregsize(tmpreg,size);
a_load_ref_reg(list,size,sref,tmpreg);
a_load_reg_ref(list,size,tmpreg,dref);
{$ifdef i386}
if size in [OS_8,OS_S8] then
rg.ungetregister(exprasmlist,tmpreg)
else
{$endif i386}
free_scratch_reg(list,tmpreg);
end;
procedure tcg.a_load_const_ref(list : taasmoutput;size : tcgsize;a : aword;const ref : treference);
var
tmpreg: tregister;
var
tmpreg: tregister;
begin
tmpreg := get_scratch_reg(list);
@ -1197,21 +1083,6 @@ unit cgobj;
free_scratch_reg(list,tmpreg);
end;
procedure tcg.a_load_loc_reg(list : taasmoutput;const loc: tlocation; reg : tregister);
begin
case loc.loc of
LOC_REFERENCE,LOC_CREFERENCE:
a_load_ref_reg(list,loc.size,loc.reference,reg);
LOC_REGISTER,LOC_CREGISTER:
a_load_reg_reg(list,loc.size,loc.register,reg);
LOC_CONSTANT:
a_load_const_reg(list,loc.size,loc.value,reg);
else
internalerror(200109092);
end;
end;
procedure tcg.a_load_const_loc(list : taasmoutput;a : aword;const loc: tlocation);
begin
@ -1239,34 +1110,28 @@ unit cgobj;
end;
procedure tcg.a_load_loc_ref(list : taasmoutput;const loc: tlocation; const ref : treference);
var
tmpreg: tregister;
procedure tcg.a_load_loc_reg(list : taasmoutput;const loc: tlocation; reg : tregister);
begin
case loc.loc of
LOC_REFERENCE,LOC_CREFERENCE:
begin
{$ifdef i386}
{ the following is done with defines to avoid a speed penalty, }
{ since all this is only necessary for the 80x86 (because EDI }
{ doesn't have an 8bit component which is directly addressable) }
if loc.size in [OS_8,OS_S8] then
tmpreg := rg.getregisterint(exprasmlist)
else
{$endif i386}
tmpreg := get_scratch_reg(list);
tmpreg:=rg.makeregsize(tmpreg,loc.size);
a_load_ref_reg(list,loc.size,loc.reference,tmpreg);
a_load_reg_ref(list,loc.size,tmpreg,ref);
{$ifdef i386}
if loc.size in [OS_8,OS_S8] then
rg.ungetregister(exprasmlist,tmpreg)
else
{$endif i386}
free_scratch_reg(list,tmpreg);
end;
a_load_ref_reg(list,loc.size,loc.reference,reg);
LOC_REGISTER,LOC_CREGISTER:
a_load_reg_reg(list,loc.size,loc.register,reg);
LOC_CONSTANT:
a_load_const_reg(list,loc.size,loc.value,reg);
else
internalerror(200109092);
end;
end;
procedure tcg.a_load_loc_ref(list : taasmoutput;const loc: tlocation; const ref : treference);
begin
case loc.loc of
LOC_REFERENCE,LOC_CREFERENCE:
a_load_ref_ref(list,loc.size,loc.reference,ref);
LOC_REGISTER,LOC_CREGISTER:
a_load_reg_ref(list,loc.size,loc.register,ref);
LOC_CONSTANT:
@ -1516,8 +1381,132 @@ unit cgobj;
end;
procedure tcg.g_rangecheck(list: taasmoutput; const p: tnode;
const todef: tdef);
function tcg.reg_cgsize(const reg: tregister) : tcgsize;
begin
reg_cgsize := OS_INT;
end;
procedure tcg.g_copyshortstring(list : taasmoutput;const source,dest : treference;len:byte;delsource,loadref : boolean);
begin
a_paramaddr_ref(list,dest,3);
if loadref then
a_param_ref(list,OS_ADDR,source,2)
else
a_paramaddr_ref(list,source,2);
if delsource then
reference_release(list,source);
a_param_const(list,OS_INT,len,1);
a_call_name(list,'FPC_SHORTSTR_COPY',0);
g_maybe_loadself(list);
end;
procedure tcg.g_incrrefcount(list : taasmoutput;t: tdef; const ref: treference);
var
href : treference;
pushedregs : tpushedsaved;
decrfunc : string;
begin
rg.saveusedregisters(list,pushedregs,all_registers);
if is_interfacecom(t) then
decrfunc:='FPC_INTF_INCR_REF'
else if is_ansistring(t) then
decrfunc:='FPC_ANSISTR_INCR_REF'
else if is_widestring(t) then
decrfunc:='FPC_WIDESTR_INCR_REF'
else
decrfunc:='';
{ call the special decr function or the generic decref }
if decrfunc<>'' then
cg.a_param_ref(list,OS_ADDR,ref,1)
else
begin
reference_reset_symbol(href,tstoreddef(t).get_rtti_label(initrtti),0);
a_paramaddr_ref(list,href,2);
a_paramaddr_ref(list,ref,1);
decrfunc:='FPC_ADDREF';
end;
rg.saveregvars(exprasmlist,all_registers);
a_call_name(list,decrfunc,0);
rg.restoreusedregisters(list,pushedregs);
end;
procedure tcg.g_decrrefcount(list : taasmoutput;t: tdef; const ref: treference);
var
href : treference;
pushedregs : tpushedsaved;
decrfunc : string;
begin
rg.saveusedregisters(list,pushedregs,all_registers);
if is_interfacecom(t) then
decrfunc:='FPC_INTF_DECR_REF'
else if is_ansistring(t) then
decrfunc:='FPC_ANSISTR_DECR_REF'
else if is_widestring(t) then
decrfunc:='FPC_WIDESTR_DECR_REF'
else
decrfunc:='';
{ call the special decr function or the generic decref }
if decrfunc<>'' then
cg.a_paramaddr_ref(list,ref,1)
else
begin
reference_reset_symbol(href,tstoreddef(t).get_rtti_label(initrtti),0);
a_paramaddr_ref(list,href,2);
a_paramaddr_ref(list,ref,1);
decrfunc:='FPC_DECREF';
end;
rg.saveregvars(exprasmlist,all_registers);
a_call_name(list,decrfunc,0);
rg.restoreusedregisters(list,pushedregs);
end;
procedure tcg.g_initialize(list : taasmoutput;t : tdef;const ref : treference;loadref : boolean);
var
href : treference;
begin
if is_ansistring(t) or
is_widestring(t) or
is_interfacecom(t) then
a_load_const_ref(list,OS_ADDR,0,ref)
else
begin
reference_reset_symbol(href,tstoreddef(t).get_rtti_label(initrtti),0);
a_paramaddr_ref(list,href,2);
if loadref then
a_param_ref(list,OS_ADDR,ref,1)
else
a_paramaddr_ref(list,ref,1);
a_call_name(list,'FPC_INITIALIZE',0);
end;
end;
procedure tcg.g_finalize(list : taasmoutput;t : tdef;const ref : treference;loadref : boolean);
var
href : treference;
begin
if is_ansistring(t) or
is_widestring(t) or
is_interfacecom(t) then
g_decrrefcount(list,t,ref)
else
begin
reference_reset_symbol(href,tstoreddef(t).get_rtti_label(initrtti),0);
a_paramaddr_ref(list,href,2);
if loadref then
a_param_ref(list,OS_ADDR,ref,1)
else
a_paramaddr_ref(list,ref,1);
a_call_name(list,'FPC_FINALIZE',0);
end;
end;
procedure tcg.g_rangecheck(list: taasmoutput; const p: tnode;const todef: tdef);
{ generate range checking code for the value at location p. The type }
{ type used is checked against todefs ranges. fromdef (p.resulttype.def) }
{ is the original type used at that location. When both defs are equal }
@ -1633,9 +1622,11 @@ unit cgobj;
end;
function tcg.reg_cgsize(const reg: tregister) : tcgsize;
procedure tcg.g_stackcheck(list : taasmoutput;stackframesize : longint);
begin
reg_cgsize := OS_INT;
a_param_const(list,OS_32,stackframesize,1);
a_call_name(list,'FPC_STACKCHECK',0);
end;
@ -1645,7 +1636,10 @@ finalization
end.
{
$Log$
Revision 1.17 2002-04-22 16:30:05 peter
Revision 1.18 2002-04-25 20:16:38 peter
* moved more routines from cga/n386util
Revision 1.17 2002/04/22 16:30:05 peter
* fixed @methodpointer
Revision 1.16 2002/04/21 15:25:30 carl

369
compiler/i386/cga.pas
View File

@ -35,7 +35,6 @@ interface
are written into temps for later release PM }
function def_opsize(p1:tdef):topsize;
function def2def_opsize(p1,p2:tdef):topsize;
function def_getreg(p1:tdef):tregister;
procedure emitlab(var l : tasmlabel);
@ -60,33 +59,17 @@ interface
procedure emit_sym(i : tasmop;s : topsize;op : tasmsymbol);
procedure emit_sym_ofs(i : tasmop;s : topsize;op : tasmsymbol;ofs : longint);
procedure emit_sym_ofs_reg(i : tasmop;s : topsize;op : tasmsymbol;ofs:longint;reg : tregister);
procedure emit_sym_ofs_ref(i : tasmop;s : topsize;op : tasmsymbol;ofs:longint;const ref : treference);
procedure emitcall(const routine:string);
procedure emit_push_mem_size(const t: treference; size: longint);
{ remove non regvar registers in loc from regs (in the format }
{ pushusedregisters uses) }
procedure remove_non_regvars_from_loc(const t: tlocation; var regs: tregisterset);
procedure emit_pushw_loc(const t:tlocation);
procedure emit_push_lea_loc(const t:tlocation;freetemp:boolean);
procedure copyshortstring(const dref,sref : treference;len : byte;
loadref, del_sref: boolean);
procedure finalize(t : tdef;const ref : treference;is_already_ref : boolean);
procedure incrstringref(t : tdef;const ref : treference);
procedure decrstringref(t : tdef;const ref : treference);
procedure push_int(l : longint);
procedure emit_push_mem(const ref : treference);
procedure emitpushreferenceaddr(const ref : treference);
procedure incrcomintfref(t: tdef; const ref: treference);
procedure decrcomintfref(t: tdef; const ref: treference);
procedure maybe_loadself;
procedure emitloadord2reg(const location:Tlocation;orddef:torddef;destreg:Tregister;delloc:boolean);
procedure concatcopy(source,dest : treference;size : longint;delsource : boolean;loadref:boolean);
@ -169,42 +152,6 @@ implementation
end;
function def2def_opsize(p1,p2:tdef):topsize;
var
o1 : topsize;
begin
case p1.size of
1 : o1:=S_B;
2 : o1:=S_W;
4 : o1:=S_L;
{ I don't know if we need it (FK) }
8 : o1:=S_L;
else
internalerror(130820002);
end;
if assigned(p2) then
begin
case p2.size of
1 : o1:=S_B;
2 : begin
if o1=S_B then
o1:=S_BW
else
o1:=S_W;
end;
4,8:
begin
case o1 of
S_B : o1:=S_BL;
S_W : o1:=S_WL;
end;
end;
end;
end;
def2def_opsize:=o1;
end;
function def_getreg(p1:tdef):tregister;
begin
def_getreg:=rg.makeregsize(rg.getregisterint(exprasmlist),int_cgsize(p1.size));
@ -310,11 +257,6 @@ implementation
exprasmList.concat(Taicpu.Op_sym_ofs_reg(i,s,op,ofs,reg));
end;
procedure emit_sym_ofs_ref(i : tasmop;s : topsize;op : tasmsymbol;ofs:longint;const ref : treference);
begin
exprasmList.concat(Taicpu.Op_sym_ofs_ref(i,s,op,ofs,ref));
end;
procedure emitcall(const routine:string);
begin
exprasmList.concat(Taicpu.Op_sym(A_CALL,S_NO,newasmsymbol(routine)));
@ -349,193 +291,8 @@ implementation
end;
end;
procedure emit_pushw_loc(const t:tlocation);
var
opsize : topsize;
begin
case t.loc of
LOC_REGISTER,
LOC_CREGISTER : begin
if aktalignment.paraalign=4 then
exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_L,rg.makeregsize(t.register,OS_32)))
else
exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_W,rg.makeregsize(t.register,OS_16)));
end;
LOC_CONSTANT : begin
if aktalignment.paraalign=4 then
opsize:=S_L
else
opsize:=S_W;
exprasmList.concat(Taicpu.Op_const(A_PUSH,opsize,t.value));
end;
LOC_CREFERENCE,
LOC_REFERENCE : begin
if aktalignment.paraalign=4 then
opsize:=S_L
else
opsize:=S_W;
exprasmList.concat(Taicpu.Op_ref(A_PUSH,opsize,t.reference));
end;
else
internalerror(200203213);
end;
location_release(exprasmlist,t);
location_freetemp(exprasmlist,t);
end;
procedure emit_push_lea_loc(const t:tlocation;freetemp:boolean);
begin
case t.loc of
LOC_CREFERENCE,
LOC_REFERENCE : begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_LEA,S_L,t.reference,R_EDI);
exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_L,R_EDI));
rg.ungetregisterint(exprasmlist,R_EDI);
end;
else
internalerror(200203218);
end;
location_release(exprasmlist,t);
if freetemp then
location_freetemp(exprasmlist,t);
end;
procedure emit_push_mem_size(const t: treference; size: longint);
var
s: topsize;
begin
if size < 4 then
begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
case size of
1: s := S_BL;
2: s := S_WL;
else internalerror(200008071);
end;
exprasmList.concat(Taicpu.Op_ref_reg(A_MOVZX,s,t,R_EDI));
if aktalignment.paraalign=4 then
exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_L,R_EDI))
else
exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_W,R_DI));
rg.ungetregisterint(exprasmlist,R_EDI);
end
end;
{*****************************************************************************
Emit String Functions
*****************************************************************************}
procedure incrcomintfref(t: tdef; const ref: treference);
var
pushedregs : tpushedsaved;
begin
rg.saveusedregisters(exprasmlist,pushedregs,all_registers);
emit_ref(A_PUSH,S_L,ref);
rg.saveregvars(exprasmlist,all_registers);
if is_interfacecom(t) then
emitcall('FPC_INTF_INCR_REF')
else
internalerror(1859);
rg.restoreusedregisters(exprasmlist,pushedregs);
end;
procedure decrcomintfref(t: tdef; const ref: treference);
var
pushedregs : tpushedsaved;
begin
rg.saveusedregisters(exprasmlist,pushedregs,all_registers);
emitpushreferenceaddr(ref);
rg.saveregvars(exprasmlist,all_registers);
if is_interfacecom(t) then
begin
emitcall('FPC_INTF_DECR_REF');
end
else internalerror(1859);
rg.restoreusedregisters(exprasmlist,pushedregs);
end;
procedure copyshortstring(const dref,sref : treference;len : byte;
loadref, del_sref: boolean);
begin
emitpushreferenceaddr(dref);
{ if it's deleted right before it's used, the optimizer can move }
{ the reg deallocations to the right places (JM) }
if del_sref then
reference_release(exprasmlist,sref);
if loadref then
emit_push_mem(sref)
else
emitpushreferenceaddr(sref);
push_int(len);
emitcall('FPC_SHORTSTR_COPY');
maybe_loadself;
end;
{$ifdef unused}
procedure copylongstring(const dref,sref : treference;len : longint;loadref:boolean);
begin
emitpushreferenceaddr(dref);
if loadref then
emit_push_mem(sref)
else
emitpushreferenceaddr(sref);
push_int(len);
rg.saveregvars(exprasmlist,all_registers);
emitcall('FPC_LONGSTR_COPY');
maybe_loadself;
end;
{$endif unused}
procedure incrstringref(t : tdef;const ref : treference);
var
pushedregs : tpushedsaved;
begin
rg.saveusedregisters(exprasmlist,pushedregs,all_registers);
emitpushreferenceaddr(ref);
rg.saveregvars(exprasmlist,all_registers);
if is_ansistring(t) then
begin
emitcall('FPC_ANSISTR_INCR_REF');
end
else if is_widestring(t) then
begin
emitcall('FPC_WIDESTR_INCR_REF');
end
else internalerror(1859);
rg.restoreusedregisters(exprasmlist,pushedregs);
end;
procedure decrstringref(t : tdef;const ref : treference);
var
pushedregs : tpushedsaved;
begin
rg.saveusedregisters(exprasmlist,pushedregs,all_registers);
emitpushreferenceaddr(ref);
rg.saveregvars(exprasmlist,all_registers);
if is_ansistring(t) then
begin
emitcall('FPC_ANSISTR_DECR_REF');
end
else if is_widestring(t) then
begin
emitcall('FPC_WIDESTR_DECR_REF');
end
else internalerror(1859);
rg.restoreusedregisters(exprasmlist,pushedregs);
end;
{*****************************************************************************
Emit Push Functions
*****************************************************************************}
@ -952,65 +709,6 @@ implementation
end;
end;
{ initilizes data of type t }
{ if is_already_ref is true then the routines assumes }
{ that r points to the data to initialize }
procedure initialize(t : tdef;const ref : treference;is_already_ref : boolean);
var
hr : treference;
begin
if is_ansistring(t) or
is_widestring(t) or
is_interfacecom(t) then
begin
emit_const_ref(A_MOV,S_L,0,ref);
end
else
begin
reference_reset(hr);
hr.symbol:=tstoreddef(t).get_rtti_label(initrtti);
emitpushreferenceaddr(hr);
if is_already_ref then
exprasmList.concat(Taicpu.Op_ref(A_PUSH,S_L,ref))
else
emitpushreferenceaddr(ref);
emitcall('FPC_INITIALIZE');
end;
end;
{ finalizes data of type t }
{ if is_already_ref is true then the routines assumes }
{ that r points to the data to finalizes }
procedure finalize(t : tdef;const ref : treference;is_already_ref : boolean);
var
r : treference;
begin
if is_ansistring(t) or
is_widestring(t) then
begin
decrstringref(t,ref);
end
else if is_interfacecom(t) then
begin
decrcomintfref(t,ref);
end
else
begin
reference_reset(r);
r.symbol:=tstoreddef(t).get_rtti_label(initrtti);
emitpushreferenceaddr(r);
if is_already_ref then
exprasmList.concat(Taicpu.Op_ref(A_PUSH,S_L,ref))
else
emitpushreferenceaddr(ref);
emitcall('FPC_FINALIZE');
end;
end;
{ generates the code for initialisation of local data }
procedure initialize_data(p : tnamedindexitem);
@ -1036,7 +734,7 @@ implementation
begin
hr.symbol:=newasmsymbol(tvarsym(p).mangledname);
end;
initialize(tvarsym(p).vartype.def,hr,false);
cg.g_initialize(exprasmlist,tvarsym(p).vartype.def,hr,false);
end;
end;
@ -1064,23 +762,7 @@ implementation
else
hrv.offset:=tvarsym(p).address+procinfo^.para_offset;
if is_ansistring(tvarsym(p).vartype.def) or
is_widestring(tvarsym(p).vartype.def) then
begin
incrstringref(tvarsym(p).vartype.def,hrv)
end
else if is_interfacecom(tvarsym(p).vartype.def) then
begin
incrcomintfref(tvarsym(p).vartype.def,hrv)
end
else
begin
reference_reset(hr);
hr.symbol:=tstoreddef(tvarsym(p).vartype.def).get_rtti_label(initrtti);
emitpushreferenceaddr(hr);
emitpushreferenceaddr(hrv);
emitcall('FPC_ADDREF');
end;
cg.g_incrrefcount(exprasmlist,tvarsym(p).vartype.def,hrv);
end
else if (tvarsym(p).varspez=vs_out) then
begin
@ -1089,20 +771,16 @@ implementation
hrv.offset:=tvarsym(p).address+procinfo^.para_offset;
rg.getexplicitregisterint(exprasmlist,R_EDI);
exprasmList.concat(Taicpu.Op_ref_reg(A_MOV,S_L,hrv,R_EDI));
reference_reset(hr);
hr.base:=R_EDI;
initialize(tvarsym(p).vartype.def,hr,false);
reference_reset_base(hr,R_EDI,0);
cg.g_initialize(exprasmlist,tvarsym(p).vartype.def,hr,false);
end;
end;
end;
{ generates the code for decrementing the reference count of parameters }
procedure final_paras(p : tnamedindexitem);
var
hrv : treference;
hr: treference;
begin
if (tsym(p).typ=varsym) and
not is_class(tvarsym(p).vartype.def) and
@ -1119,23 +797,7 @@ implementation
else
hrv.offset:=tvarsym(p).address+procinfo^.para_offset;
if is_ansistring(tvarsym(p).vartype.def) or
is_widestring(tvarsym(p).vartype.def) then
begin
decrstringref(tvarsym(p).vartype.def,hrv)
end
else if is_interfacecom(tvarsym(p).vartype.def) then
begin
decrcomintfref(tvarsym(p).vartype.def,hrv)
end
else
begin
reference_reset(hr);
hr.symbol:=tstoreddef(tvarsym(p).vartype.def).get_rtti_label(initrtti);
emitpushreferenceaddr(hr);
emitpushreferenceaddr(hrv);
emitcall('FPC_DECREF');
end;
cg.g_decrrefcount(exprasmlist,tvarsym(p).vartype.def,hrv);
end;
end;
end;
@ -1165,7 +827,7 @@ implementation
else
hr.symbol:=newasmsymbol(tvarsym(p).mangledname);
end;
finalize(tvarsym(p).vartype.def,hr,false);
cg.g_finalize(exprasmlist,tvarsym(p).vartype.def,hr,false);
end;
end;
@ -1294,7 +956,7 @@ implementation
begin
reference_reset_base(href1,procinfo^.framepointer,tvarsym(p).address+procinfo^.para_offset);
reference_reset_base(href2,procinfo^.framepointer,-tvarsym(p).localvarsym.address+tvarsym(p).localvarsym.owner.address_fixup);
copyshortstring(href2,href1,tstringdef(tvarsym(p).vartype.def).len,true,false);
cg.g_copyshortstring(exprasmlist,href1,href2,tstringdef(tvarsym(p).vartype.def).len,false,true);
end
else
begin
@ -1582,10 +1244,8 @@ implementation
(aktprocdef.rettype.def.needs_inittable) then
begin
procinfo^.flags:=procinfo^.flags or pi_needs_implicit_finally;
reference_reset(r);
r.offset:=procinfo^.return_offset;
r.base:=procinfo^.framepointer;
initialize(aktprocdef.rettype.def,r,ret_in_param(aktprocdef.rettype.def));
reference_reset_base(r,procinfo^.framepointer,procinfo^.return_offset);
cg.g_initialize(exprasmlist,aktprocdef.rettype.def,r,ret_in_param(aktprocdef.rettype.def));
end;
{ initialisize local data like ansistrings }
@ -1956,10 +1616,8 @@ implementation
((aktprocdef.rettype.def.deftype<>objectdef) or
not is_class(aktprocdef.rettype.def)) then
begin
reference_reset(hr);
hr.offset:=procinfo^.return_offset;
hr.base:=procinfo^.framepointer;
finalize(aktprocdef.rettype.def,hr,ret_in_param(aktprocdef.rettype.def));
reference_reset_base(hr,procinfo^.framepointer,procinfo^.return_offset);
cg.g_finalize(exprasmlist,aktprocdef.rettype.def,hr,ret_in_param(aktprocdef.rettype.def));
end;
emitcall('FPC_RERAISE');
@ -2301,7 +1959,10 @@ implementation
end.
{
$Log$
Revision 1.26 2002-04-21 15:29:53 carl
Revision 1.27 2002-04-25 20:16:39 peter
* moved more routines from cga/n386util
Revision 1.26 2002/04/21 15:29:53 carl
* changeregsize -> rg.makeregsize
Revision 1.25 2002/04/20 21:37:07 carl

39
compiler/i386/cgcpu.pas
View File

@ -76,6 +76,7 @@ unit cgcpu;
procedure a_loadmm_reg_reg(list: taasmoutput; reg1, reg2: tregister); override;
procedure a_loadmm_ref_reg(list: taasmoutput; const ref: treference; reg: tregister); override;
procedure a_loadmm_reg_ref(list: taasmoutput; reg: tregister; const ref: treference); override;
procedure a_parammm_reg(list: taasmoutput; reg: tregister); override;
{ comparison operations }
procedure a_cmp_const_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;reg : tregister;
@ -106,13 +107,14 @@ unit cgcpu;
procedure a_op64_const_ref(list : taasmoutput;op:TOpCG;valuelosrc,valuehisrc:AWord;const ref : treference);override;
procedure g_concatcopy(list : taasmoutput;const source,dest : treference;len : aword; delsource,loadref : boolean);override;
procedure g_maybe_loadself(list : taasmoutput); override;
class function reg_cgsize(const reg: tregister): tcgsize; override;
private
procedure a_jmp_cond(list : taasmoutput;cond : TOpCmp;l: tasmlabel);
procedure a_jmp_cond(list : taasmoutput;cond : TOpCmp;l: tasmlabel);
procedure get_64bit_ops(op:TOpCG;var op1,op2:TAsmOp);
procedure sizes2load(s1 : tcgsize;s2 : topsize; var op: tasmop; var s3: topsize);
@ -159,9 +161,9 @@ unit cgcpu;
{ currently does nothing }
procedure tcg386.a_jmp_always(list : taasmoutput;l: tasmlabel);
procedure tcg386.a_jmp_always(list : taasmoutput;l: tasmlabel);
begin
a_jmp_cond(list, OC_NONE, l);
a_jmp_cond(list, OC_NONE, l);
end;
{ we implement the following routines because otherwise we can't }
@ -412,6 +414,16 @@ unit cgcpu;
end;
procedure tcg386.a_parammm_reg(list: taasmoutput; reg: tregister);
var
href : treference;
begin
list.concat(taicpu.op_const_reg(A_SUB,S_L,8,R_ESP));
reference_reset_base(href,R_ESP,0);
list.concat(taicpu.op_reg_ref(A_MOVQ,S_NO,reg,href));
end;
procedure tcg386.a_op_const_reg(list : taasmoutput; Op: TOpCG; a: AWord; reg: TRegister);
var
@ -1060,6 +1072,22 @@ unit cgcpu;
end;
procedure tcg386.g_maybe_loadself(list : taasmoutput);
var
oldlist: taasmoutput;
begin
if list <> exprasmlist then
begin
oldlist := exprasmlist;
exprasmlist := list;
end;
cga.maybe_loadself;
if list <> exprasmlist then
list := oldlist;
end;
function tcg386.reg_cgsize(const reg: tregister): tcgsize;
const
regsize_2_cgsize: array[S_B..S_L] of tcgsize = (OS_8,OS_16,OS_32);
@ -1199,7 +1227,10 @@ begin
end.
{
$Log$
Revision 1.13 2002-04-21 15:31:05 carl
Revision 1.14 2002-04-25 20:16:40 peter
* moved more routines from cga/n386util
Revision 1.13 2002/04/21 15:31:05 carl
* changeregsize -> rg.makeregsize
+ a_jmp_always added

33
compiler/i386/n386add.pas
View File

@ -356,24 +356,15 @@ interface
{ the tempstring can also come from a typeconversion }
{ or a function result, so simply check for a }
{ temp of 256 bytes(JM) }
if not(tg.istemp(left.location.reference) and
(tg.getsizeoftemp(left.location.reference) = 256)) and
not(nf_use_strconcat in flags) then
begin
{ can only reference be }
{ string in register would be funny }
{ therefore produce a temporary string }
tg.gettempofsizereference(exprasmlist,256,href);
copyshortstring(href,left.location.reference,255,false,true);
{ release the registers }
{ done by copyshortstring now (JM) }
{ del_reference(left.location.reference); }
tg.ungetiftemp(exprasmlist,left.location.reference);
cg.g_copyshortstring(exprasmlist,left.location.reference,href,255,true,false);
{ location is released by copyshortstring }
location_freetemp(exprasmlist,left.location);
{ does not hurt: }
location_reset(left.location,LOC_CREFERENCE,def_cgsize(resulttype.def));
left.location.reference:=href;
end;
@ -386,15 +377,14 @@ interface
{ because emitpushreferenceaddr doesn't need extra }
{ registers) (JM) }
regstopush := all_registers;
remove_non_regvars_from_loc(right.location,
regstopush);
remove_non_regvars_from_loc(right.location,regstopush);
rg.saveusedregisters(exprasmlist,pushedregs,regstopush);
{ push the maximum possible length of the result }
{ push the maximum possible length of the result }
emitpushreferenceaddr(left.location.reference);
{ the optimizer can more easily put the }
{ deallocations in the right place if it happens }
{ too early than when it happens too late (if }
{ the pushref needs a "lea (..),edi; push edi") }
{ the optimizer can more easily put the }
{ deallocations in the right place if it happens }
{ too early than when it happens too late (if }
{ the pushref needs a "lea (..),edi; push edi") }
location_release(exprasmlist,right.location);
emitpushreferenceaddr(right.location.reference);
rg.saveregvars(exprasmlist,regstopush);
@ -1584,7 +1574,10 @@ begin
end.
{
$Log$
Revision 1.33 2002-04-05 15:09:13 jonas
Revision 1.34 2002-04-25 20:16:40 peter
* moved more routines from cga/n386util
Revision 1.33 2002/04/05 15:09:13 jonas
* fixed web bug 1915
Revision 1.32 2002/04/04 19:06:10 peter

119
compiler/i386/n386cal.pas
View File

@ -198,7 +198,7 @@ implementation
assigned(defcoll.paratype.def) and
not is_class(defcoll.paratype.def) and
defcoll.paratype.def.needs_inittable then
finalize(defcoll.paratype.def,left.location.reference,false);
cg.g_finalize(exprasmlist,defcoll.paratype.def,left.location.reference,false);
inc(pushedparasize,4);
if inlined then
begin
@ -325,6 +325,7 @@ implementation
push_size : longint;
{$endif OPTALIGN}
pop_allowed : boolean;
release_edi : boolean;
constructorfailed : tasmlabel;
label
@ -344,12 +345,12 @@ implementation
if is_widestring(resulttype.def) then
begin
tg.gettempwidestringreference(exprasmlist,refcountedtemp);
decrstringref(resulttype.def,refcountedtemp);
cg.g_decrrefcount(exprasmlist,resulttype.def,refcountedtemp);
end
else if is_ansistring(resulttype.def) then
begin
tg.gettempansistringreference(exprasmlist,refcountedtemp);
decrstringref(resulttype.def,refcountedtemp);
cg.g_decrrefcount(exprasmlist,resulttype.def,refcountedtemp);
end;
if (procdefinition.proccalloption in [pocall_cdecl,pocall_cppdecl,pocall_stdcall]) then
@ -482,37 +483,8 @@ implementation
else
pop_esp:=false;
{$endif OPTALIGN}
if (not is_void(resulttype.def)) and
ret_in_param(resulttype.def) then
begin
funcretref.symbol:=nil;
{$ifdef test_dest_loc}
if dest_loc_known and (dest_loc_tree=p) and
(dest_loc.loc in [LOC_REFERENCE,LOC_MEM]) then
begin
funcretref:=dest_loc.reference;
if assigned(dest_loc.reference.symbol) then
funcretref.symbol:=stringdup(dest_loc.reference.symbol^);
in_dest_loc:=true;
end
else
{$endif test_dest_loc}
if inlined then
begin
reference_reset(funcretref);
funcretref.offset:=tg.gettempofsizepersistant(exprasmlist,resulttype.def.size);
funcretref.base:=procinfo^.framepointer;
{$ifdef extdebug}
Comment(V_debug,'function return value is at offset '
+tostr(funcretref.offset));
exprasmlist.concat(tai_asm_comment.create(
strpnew('function return value is at offset '
+tostr(funcretref.offset))));
{$endif extdebug}
end
else
tg.gettempofsizereference(exprasmlist,resulttype.def.size,funcretref);
end;
{ Push parameters }
if assigned(params) then
begin
{ be found elsewhere }
@ -533,31 +505,66 @@ implementation
(procdefinition.proccalloption in [pocall_cdecl,pocall_cppdecl]),
para_alignment,para_offset);
end;
{ Allocate return value for inlined routines }
if inlined then
inlinecode.retoffset:=tg.gettempofsizepersistant(exprasmlist,Align(resulttype.def.size,aktalignment.paraalign));
{ Allocate return value when returned in argument }
if ret_in_param(resulttype.def) then
begin
{ This must not be counted for C code
complex return address is removed from stack
by function itself ! }
if assigned(funcretrefnode) then
begin
secondpass(funcretrefnode);
if codegenerror then
exit;
if (funcretrefnode.location.loc<>LOC_REFERENCE) then
internalerror(200204246);
funcretref:=funcretrefnode.location.reference;
end
else
begin
if inlined then
begin
reference_reset(funcretref);
funcretref.offset:=tg.gettempofsizepersistant(exprasmlist,resulttype.def.size);
funcretref.base:=procinfo^.framepointer;
{$ifdef extdebug}
Comment(V_debug,'function return value is at offset '
+tostr(funcretref.offset));
exprasmlist.concat(tai_asm_comment.create(
strpnew('function return value is at offset '
+tostr(funcretref.offset))));
{$endif extdebug}
end
else
tg.gettempofsizereference(exprasmlist,resulttype.def.size,funcretref);
end;
{ This must not be counted for C code
complex return address is removed from stack
by function itself ! }
{$ifdef OLD_C_STACK}
inc(pushedparasize,4); { lets try without it PM }
inc(pushedparasize,4); { lets try without it PM }
{$endif not OLD_C_STACK}
if inlined then
begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_LEA,S_L,funcretref,R_EDI);
reference_reset_base(href,procinfo^.framepointer,inlinecode.retoffset);
emit_reg_ref(A_MOV,S_L,R_EDI,href);
rg.ungetregisterint(exprasmlist,R_EDI);
end
else
emitpushreferenceaddr(funcretref);
if inlined then
begin
hregister:=cg.get_scratch_reg(exprasmlist);
cg.a_loadaddr_ref_reg(exprasmlist,funcretref,hregister);
reference_reset_base(href,procinfo^.framepointer,inlinecode.retoffset);
cg.a_load_reg_ref(exprasmlist,OS_ADDR,hregister,href);
cg.free_scratch_reg(exprasmlist,hregister);
end
else
cg.a_paramaddr_ref(exprasmlist,funcretref,-1);
end;
{ procedure variable ? }
{ procedure variable or normal function call ? }
if inlined or
(right=nil) then
(right=nil) then
begin
{ Normal function call }
{ overloaded operator has no symtable }
{ push self }
if assigned(symtableproc) and
@ -912,6 +919,7 @@ implementation
{ also class methods }
{ Here it is quite tricky because it also depends }
{ on the methodpointer PM }
release_edi:=false;
rg.getexplicitregisterint(exprasmlist,R_ESI);
if assigned(aktprocdef) then
begin
@ -938,6 +946,7 @@ implementation
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_MOV,S_L,href,R_EDI);
reference_reset_base(href,R_EDI,0);
release_edi:=true;
end;
end
else
@ -974,7 +983,8 @@ implementation
end;
end;
emit_ref(A_CALL,S_NO,href);
rg.ungetregisterint(exprasmlist,R_EDI);
if release_edi then
rg.ungetregisterint(exprasmlist,R_EDI);
end
else if not inlined then
begin
@ -1290,7 +1300,7 @@ implementation
begin
{ data which must be finalized ? }
if (resulttype.def.needs_inittable) then
finalize(resulttype.def,location.reference,false);
cg.g_finalize(exprasmlist,resulttype.def,location.reference,false);
{ release unused temp }
tg.ungetiftemp(exprasmlist,location.reference)
end
@ -1482,7 +1492,10 @@ begin
end.
{
$Log$
Revision 1.47 2002-04-21 19:02:07 peter
Revision 1.48 2002-04-25 20:16:40 peter
* moved more routines from cga/n386util
Revision 1.47 2002/04/21 19:02:07 peter
* removed newn and disposen nodes, the code is now directly
inlined from pexpr
* -an option that will write the secondpass nodes to the .s file, this

156
compiler/i386/n386ld.pas
View File

@ -47,7 +47,7 @@ implementation
uses
systems,
verbose,globals,
cutils,verbose,globals,
symconst,symtype,symdef,symsym,symtable,aasm,types,
cginfo,cgbase,pass_2,
nmem,ncon,ncnv,
@ -64,7 +64,6 @@ implementation
symtabletype : tsymtabletype;
i : longint;
href : treference;
s : tasmsymbol;
newsize : tcgsize;
popeax : boolean;
begin
@ -382,15 +381,12 @@ implementation
procedure ti386assignmentnode.pass_2;
var
regs_to_push: tregisterset;
otlabel,hlabel,oflabel : tasmlabel;
fputyp : tfloattype;
loc : tloc;
href : treference;
ai : taicpu;
releaseright,
pushed : boolean;
regspushed : tpushedsaved;
cgsize : tcgsize;
begin
@ -493,82 +489,58 @@ implementation
exit;
end;
loc:=left.location.loc;
releaseright:=true;
if left.resulttype.def.deftype=stringdef then
{ shortstring assignments are handled separately }
if is_shortstring(left.resulttype.def) then
begin
if is_ansistring(left.resulttype.def) or
is_widestring(left.resulttype.def) then
begin
{ before pushing any parameter, we have to save all used }
{ registers, but before that we have to release the }
{ registers of that node to save uneccessary pushed }
{ so be careful, if you think you can optimize that code (FK) }
{
we can get here only in the following situations
for the right node:
- empty constant string
- char
}
{ nevertheless, this has to be changed, because otherwise the }
{ register is released before it's contents are pushed -> }
{ problems with the optimizer (JM) }
{ Find out which registers have to be pushed (JM) }
regs_to_push := all_registers;
remove_non_regvars_from_loc(right.location,regs_to_push);
remove_non_regvars_from_loc(left.location,regs_to_push);
{ And push them (JM) }
rg.saveusedregisters(exprasmlist,regspushed,regs_to_push);
location_release(exprasmlist,right.location);
cg.a_param_loc(exprasmlist,right.location,2);
location_release(exprasmlist,left.location);
cg.a_paramaddr_ref(exprasmlist,left.location.reference,1);
rg.saveregvars(exprasmlist,all_registers);
if is_ansistring(left.resulttype.def) then
emitcall('FPC_ANSISTR_ASSIGN')
else
emitcall('FPC_WIDESTR_ASSIGN');
maybe_loadself;
rg.restoreusedregisters(exprasmlist,regspushed);
location_freetemp(exprasmlist,right.location);
end
else if is_shortstring(left.resulttype.def) and
not (nf_concat_string in flags) then
begin
if is_ansistring(right.resulttype.def) then
begin
if (right.nodetype=stringconstn) and
(tstringconstnode(right).len=0) then
{ empty constant string }
if (right.nodetype=stringconstn) and
(tstringconstnode(right).len=0) then
begin
emit_const_ref(A_MOV,S_B,0,left.location.reference);
end
{ char loading }
else if is_char(right.resulttype.def) then
begin
if right.nodetype=ordconstn then
emit_const_ref(A_MOV,S_W,tordconstnode(right).value*256+1,left.location.reference)
else
begin
if (right.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
begin
emit_const_ref(A_MOV,S_B,0,left.location.reference);
location_release(exprasmlist,left.location);
href := left.location.reference;
emit_const_ref(A_MOV,S_B,1,href);
inc(href.offset,1);
emit_reg_ref(A_MOV,S_B,rg.makeregsize(right.location.register,OS_8),href);
end
else
loadansi2short(right,left);
end
else
begin
{ we do not need destination anymore }
location_release(exprasmlist,left.location);
{del_reference(right.location.reference);
done in loadshortstring }
loadshortstring(right,left);
location_freetemp(exprasmlist,right.location);
end;
end
else if is_longstring(left.resulttype.def) then
begin
internalerror(200105261);
end
else
begin
{ its the only thing we have to do }
location_release(exprasmlist,right.location);
end
end
else if is_interfacecom(left.resulttype.def) then
begin
loadinterfacecom(self);
{ not so elegant (goes better with extra register }
begin
{ not "movl", because then we may read past the }
{ end of the heap! "movw" would be ok too, but }
{ I don't think that would be faster (JM) }
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_MOVZX,S_BL,right.location.reference,R_EDI);
emit_const_reg(A_SHL,S_L,8,R_EDI);
emit_const_reg(A_OR,S_L,1,R_EDI);
emit_reg_ref(A_MOV,S_W,R_DI,left.location.reference);
rg.ungetregisterint(exprasmlist,R_EDI);
end;
end;
end
else
internalerror(200204249);
end
else
begin
releaseright:=true;
case right.location.loc of
LOC_CONSTANT :
begin
@ -581,7 +553,7 @@ implementation
LOC_REFERENCE,
LOC_CREFERENCE :
begin
case loc of
case left.location.loc of
LOC_CREGISTER :
begin
cgsize:=def_cgsize(left.resulttype.def);
@ -608,16 +580,12 @@ implementation
{ this would be a problem }
if not(left.resulttype.def.needs_inittable) then
internalerror(3457);
{ increment source reference counter }
reference_reset_symbol(href,tstoreddef(right.resulttype.def).get_rtti_label(initrtti),0);
cg.a_paramaddr_ref(exprasmlist,href,2);
cg.a_paramaddr_ref(exprasmlist,right.location.reference,1);
emitcall('FPC_ADDREF');
{ increment source reference counter, this is
useless for string constants}
if right.nodetype<>stringconstn then
cg.g_incrrefcount(exprasmlist,right.resulttype.def,right.location.reference);
{ decrement destination reference counter }
reference_reset_symbol(href,tstoreddef(left.resulttype.def).get_rtti_label(initrtti),0);
cg.a_paramaddr_ref(exprasmlist,href,2);
cg.a_paramaddr_ref(exprasmlist,left.location.reference,1);
emitcall('FPC_DECREF');
cg.g_decrrefcount(exprasmlist,left.resulttype.def,left.location.reference);
end;
concatcopy(right.location.reference,
@ -633,7 +601,7 @@ implementation
LOC_CMMXREGISTER,
LOC_MMXREGISTER:
begin
if loc=LOC_CMMXREGISTER then
if left.location.loc=LOC_CMMXREGISTER then
emit_reg_reg(A_MOVQ,S_NO,right.location.register,left.location.register)
else
emit_reg_ref(A_MOVQ,S_NO,right.location.register,left.location.reference);
@ -680,9 +648,8 @@ implementation
if codegenerror then
exit;
cg.a_load_const_loc(exprasmlist,1,left.location);
location_release(exprasmlist,left.location);
emitjmp(C_None,hlabel);
if not(left.location.loc in [LOC_CREGISTER{$ifdef SUPPORT_MMX},LOC_CMMXREGISTER{$endif SUPPORT_MMX}]) then
location_release(exprasmlist,left.location);
{ generate the leftnode for the false case }
emitlab(falselabel);
pushed:=maybe_push(left.registers32,right,false);
@ -696,11 +663,11 @@ implementation
end;
LOC_FLAGS :
begin
if loc=LOC_CREGISTER then
if left.location.loc=LOC_CREGISTER then
cg.g_flags2reg(exprasmlist,right.location.resflags,left.location.register)
else
begin
if not(loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
if not(left.location.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
internalerror(200203273);
ai:=Taicpu.Op_ref(A_Setcc,S_B,left.location.reference);
ai.SetCondition(flags_to_cond(right.location.resflags));
@ -709,14 +676,12 @@ implementation
end;
end;
{ we don't need the locations anymore. Only for
CREGISTER we need to keep the new location available }
if releaseright then
location_release(exprasmlist,right.location);
if not(left.location.loc in [LOC_CREGISTER{$ifdef SUPPORT_MMX},LOC_CMMXREGISTER{$endif SUPPORT_MMX}]) then
location_release(exprasmlist,left.location);
end;
if releaseright then
location_release(exprasmlist,right.location);
location_release(exprasmlist,left.location);
truelabel:=otlabel;
falselabel:=oflabel;
end;
@ -779,7 +744,10 @@ begin
end.
{
$Log$
Revision 1.38 2002-04-22 16:30:06 peter
Revision 1.39 2002-04-25 20:16:40 peter
* moved more routines from cga/n386util
Revision 1.38 2002/04/22 16:30:06 peter
* fixed @methodpointer
Revision 1.37 2002/04/21 15:36:13 carl

21
compiler/i386/n386opt.pas
View File

@ -42,7 +42,7 @@ type
implementation
uses pass_1, types, htypechk, cginfo, cgbase, cpubase, cga,
tgobj, aasm, ncnv, ncon, pass_2, symdef, rgobj;
tgobj, aasm, ncnv, ncon, pass_2, symdef, rgobj, cgobj;
{*****************************************************************************
@ -95,10 +95,10 @@ begin
not(nf_use_strconcat in flags) then
begin
tg.gettempofsizereference(exprasmlist,256,href);
copyshortstring(href,left.location.reference,255,false,true);
{ release the registers }
tg.ungetiftemp(exprasmlist,left.location.reference);
{ does not hurt: }
cg.g_copyshortstring(exprasmlist,left.location.reference,href,255,true,false);
{ location is released by copyshortstring }
location_freetemp(exprasmlist,left.location);
{ return temp reference }
location_reset(left.location,LOC_CREFERENCE,def_cgsize(resulttype.def));
left.location.reference:=href;
end;
@ -203,10 +203,10 @@ begin
not(nf_use_strconcat in flags) then
begin
tg.gettempofsizereference(exprasmlist,256,href);
copyshortstring(href,left.location.reference,255,false,true);
cg.g_copyshortstring(exprasmlist,left.location.reference,href,255,true,false);
{ release the registers }
tg.ungetiftemp(exprasmlist,left.location.reference);
{ does not hurt: }
location_freetemp(exprasmlist,left.location);
{ return temp reference }
location_reset(left.location,LOC_CREFERENCE,def_cgsize(resulttype.def));
left.location.reference:=href;
end;
@ -242,7 +242,10 @@ end.
{
$Log$
Revision 1.11 2002-04-21 15:36:40 carl
Revision 1.12 2002-04-25 20:16:40 peter
* moved more routines from cga/n386util
Revision 1.11 2002/04/21 15:36:40 carl
* changeregsize -> rg.makeregsize
Revision 1.10 2002/04/15 19:44:21 peter

34
compiler/i386/n386set.pas
View File

@ -510,30 +510,13 @@ implementation
end
else
begin
if not(left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
begin
pleftreg := rg.getexplicitregisterint(exprasmlist,R_EDI);
opsize := def2def_opsize(left.resulttype.def,u32bittype.def);
if opsize = S_L then
emit_ref_reg(A_MOV,opsize,left.location.reference,pleftreg)
else
emit_ref_reg(A_MOVZX,opsize,left.location.reference,pleftreg);
location_freetemp(exprasmlist,left.location);
location_release(exprasmlist,left.location);
end
if (left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
pleftreg:=rg.makeregsize(left.location.register,OS_INT)
else
begin
pleftreg := rg.makeregsize(left.location.register,OS_INT);
opsize := def2def_opsize(left.resulttype.def,u32bittype.def);
if opsize <> S_L then
begin
{ this will change left, even if it's a LOC_CREGISTER, but }
{ that doesn't matter: if left is an 8 bit def, then the }
{ upper 24 bits are undefined, so we can zero them without }
{ any problem (JM) }
cg.a_load_reg_reg(exprasmlist,left.location.size,left.location.register,pleftreg);
end;
end;
pleftreg:=rg.getexplicitregisterint(exprasmlist,R_EDI);
cg.a_load_loc_reg(exprasmlist,left.location,pleftreg);
location_freetemp(exprasmlist,left.location);
location_release(exprasmlist,left.location);
emit_reg_ref(A_BT,S_L,pleftreg,right.location.reference);
rg.ungetregister(exprasmlist,pleftreg);
location_release(exprasmlist,right.location);
@ -1036,7 +1019,10 @@ begin
end.
{
$Log$
Revision 1.25 2002-04-21 19:02:07 peter
Revision 1.26 2002-04-25 20:16:40 peter
* moved more routines from cga/n386util
Revision 1.25 2002/04/21 19:02:07 peter
* removed newn and disposen nodes, the code is now directly
inlined from pexpr
* -an option that will write the secondpass nodes to the .s file, this

877
compiler/i386/n386util.pas
View File

@ -38,14 +38,8 @@ interface
{$ifdef TEMPS_NOT_PUSH}
procedure restorefromtemp(p : tnode;isint64 : boolean);
{$endif TEMPS_NOT_PUSH}
procedure pushsetelement(p : tnode);
procedure push_value_para(p:tnode;inlined,is_cdecl:boolean;
para_offset:longint;alignment : longint);
procedure loadshortstring(source,dest : tnode);
procedure loadlongstring(p:tbinarynode);
procedure loadansi2short(source,dest : tnode);
procedure loadwide2short(source,dest : tnode);
procedure loadinterfacecom(p: tbinarynode);
procedure emitoverflowcheck(p:tnode);
procedure firstcomplex(p : tbinarynode);
@ -302,510 +296,172 @@ implementation
{$endif TEMPS_NOT_PUSH}
procedure pushsetelement(p : tnode);
begin
{ copy the element on the stack, slightly complicated }
if p.nodetype=ordconstn then
begin
if aktalignment.paraalign=4 then
exprasmList.concat(Taicpu.Op_const(A_PUSH,S_L,tordconstnode(p).value))
else
exprasmList.concat(Taicpu.Op_const(A_PUSH,S_W,tordconstnode(p).value));
end
else
begin
case p.location.loc of
LOC_REGISTER,
LOC_CREGISTER :
begin
if aktalignment.paraalign=4 then
exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_L,rg.makeregsize(p.location.register,OS_16)))
else
exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_W,rg.makeregsize(p.location.register,OS_32)));
rg.ungetregisterint(exprasmlist,p.location.register);
end;
else
begin
{ you can't push more bytes than the size of the element, }
{ because this may cross a page boundary and you'll get a }
{ sigsegv (JM) }
emit_push_mem_size(p.location.reference,1);
reference_release(exprasmlist,p.location.reference);
end;
end;
end;
end;
procedure push_value_para(p:tnode;inlined,is_cdecl:boolean;
para_offset:longint;alignment : longint);
var
tempreference : treference;
r : treference;
opsize : topsize;
href : treference;
hreg : tregister;
sizetopush,
size : longint;
hlabel : tasmlabel;
cgsize : tcgsize;
begin
case p.location.loc of
LOC_REGISTER,
LOC_CREGISTER:
begin
cgsize:=def_cgsize(p.resulttype.def);
if cgsize in [OS_64,OS_S64] then
begin
inc(pushedparasize,8);
if inlined then
begin
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
tcg64f32(cg).a_load64_loc_ref(exprasmlist,p.location,r);
end
else
tcg64f32(cg).a_param64_loc(exprasmlist,p.location,-1);
end
else
begin
{ save old register }
hreg:=p.location.register;
{ update register to use to match alignment }
case cgsize of
OS_8,OS_S8 :
begin
if alignment=4 then
cgsize:=OS_32
else
cgsize:=OS_16;
end;
OS_16,OS_S16 :
begin
if alignment=4 then
cgsize:=OS_32;
end;
end;
p.location.register:=rg.makeregsize(p.location.register,cgsize);
inc(pushedparasize,alignment);
if inlined then
begin
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
cg.a_load_loc_ref(exprasmlist,p.location,r);
end
else
cg.a_param_loc(exprasmlist,p.location,-1);
{ restore old register }
p.location.register:=hreg;
end;
location_release(exprasmlist,p.location);
end;
LOC_CONSTANT :
begin
cgsize:=def_cgsize(p.resulttype.def);
if cgsize in [OS_64,OS_S64] then
begin
inc(pushedparasize,8);
if inlined then
begin
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
tcg64f32(cg).a_load64_loc_ref(exprasmlist,p.location,r);
end
else
tcg64f32(cg).a_param64_loc(exprasmlist,p.location,-1);
end
else
begin
case cgsize of
OS_8,OS_S8 :
begin
if alignment=4 then
cgsize:=OS_32
else
cgsize:=OS_16
end;
OS_16,OS_S16 :
begin
if alignment=4 then
cgsize:=OS_32;
end;
end;
inc(pushedparasize,alignment);
if inlined then
begin
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
cg.a_load_loc_ref(exprasmlist,p.location,r);
end
else
cg.a_param_loc(exprasmlist,p.location,-1);
end;
location_release(exprasmlist,p.location);
end;
LOC_FPUREGISTER,
LOC_CFPUREGISTER:
begin
size:=align(tfloatdef(p.resulttype.def).size,alignment);
inc(pushedparasize,size);
if not inlined then
emit_const_reg(A_SUB,S_L,size,R_ESP);
{ Move flags and jump in register to make it less complex }
if p.location.loc in [LOC_FLAGS,LOC_JUMP] then
location_force_reg(p.location,def_cgsize(p.resulttype.def),false);
{ Handle Floating point types differently }
if p.resulttype.def.deftype=floatdef then
begin
case p.location.loc of
LOC_FPUREGISTER,
LOC_CFPUREGISTER:
begin
size:=align(tfloatdef(p.resulttype.def).size,alignment);
inc(pushedparasize,size);
if not inlined then
emit_const_reg(A_SUB,S_L,size,R_ESP);
{$ifdef GDB}
if (cs_debuginfo in aktmoduleswitches) and
(exprasmList.first=exprasmList.last) then
exprasmList.concat(Tai_force_line.Create);
if (cs_debuginfo in aktmoduleswitches) and
(exprasmList.first=exprasmList.last) then
exprasmList.concat(Tai_force_line.Create);
{$endif GDB}
{ this is the easiest case for inlined !! }
if inlined then
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize)
else
reference_reset_base(r,R_ESP,0);
{ this is the easiest case for inlined !! }
if inlined then
reference_reset_base(href,procinfo^.framepointer,para_offset-pushedparasize)
else
reference_reset_base(href,R_ESP,0);
cg.a_loadfpu_reg_ref(exprasmlist,
def_cgsize(p.resulttype.def),p.location.register,r);
end;
LOC_REFERENCE,LOC_CREFERENCE:
begin
tempreference:=p.location.reference;
reference_release(exprasmlist,p.location.reference);
case p.resulttype.def.deftype of
enumdef,
orddef :
begin
case p.resulttype.def.size of
8 : begin
inc(pushedparasize,8);
if inlined then
begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_MOV,S_L,tempreference,R_EDI);
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_EDI,r));
inc(tempreference.offset,4);
emit_ref_reg(A_MOV,S_L,tempreference,R_EDI);
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize+4);
exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_EDI,r));
rg.ungetregisterint(exprasmlist,R_EDI);
end
else
begin
inc(tempreference.offset,4);
emit_push_mem(tempreference);
dec(tempreference.offset,4);
emit_push_mem(tempreference);
end;
end;
4 : begin
inc(pushedparasize,4);
if inlined then
begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_MOV,S_L,tempreference,R_EDI);
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_EDI,r));
rg.ungetregisterint(exprasmlist,R_EDI);
end
else
emit_push_mem(tempreference);
end;
1,2 : begin
if alignment=4 then
begin
opsize:=S_L;
hreg:=R_EDI;
inc(pushedparasize,4);
end
else
begin
opsize:=S_W;
hreg:=R_DI;
inc(pushedparasize,2);
end;
if inlined then
begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_MOV,opsize,tempreference,hreg);
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,opsize,hreg,r));
rg.ungetregisterint(exprasmlist,R_EDI);
end
else
emit_push_mem_size(tempreference,p.resulttype.def.size);
end;
else
internalerror(234231);
end;
end;
floatdef :
begin
case tfloatdef(p.resulttype.def).typ of
s32real :
begin
inc(pushedparasize,4);
if inlined then
begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_MOV,S_L,tempreference,R_EDI);
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_EDI,r));
rg.ungetregisterint(exprasmlist,R_EDI);
end
else
emit_push_mem(tempreference);
end;
s64real,
s64comp :
begin
inc(pushedparasize,4);
inc(tempreference.offset,4);
if inlined then
begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_MOV,S_L,tempreference,R_EDI);
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_EDI,r));
rg.ungetregisterint(exprasmlist,R_EDI);
end
else
emit_push_mem(tempreference);
inc(pushedparasize,4);
dec(tempreference.offset,4);
if inlined then
begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_MOV,S_L,tempreference,R_EDI);
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_EDI,r));
rg.ungetregisterint(exprasmlist,R_EDI);
end
else
emit_push_mem(tempreference);
end;
s80real :
begin
inc(pushedparasize,4);
if alignment=4 then
inc(tempreference.offset,8)
else
inc(tempreference.offset,6);
if inlined then
begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_MOV,S_L,tempreference,R_EDI);
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_EDI,r));
rg.ungetregisterint(exprasmlist,R_EDI);
end
else
emit_push_mem(tempreference);
dec(tempreference.offset,4);
inc(pushedparasize,4);
if inlined then
begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_MOV,S_L,tempreference,R_EDI);
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_EDI,r));
rg.ungetregisterint(exprasmlist,R_EDI);
end
else
emit_push_mem(tempreference);
if alignment=4 then
begin
opsize:=S_L;
hreg:=R_EDI;
inc(pushedparasize,4);
dec(tempreference.offset,4);
end
else
begin
opsize:=S_W;
hreg:=R_DI;
inc(pushedparasize,2);
dec(tempreference.offset,2);
end;
if inlined then
begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_MOV,opsize,tempreference,hreg);
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,opsize,hreg,r));
rg.ungetregisterint(exprasmlist,R_EDI);
end
else
exprasmList.concat(Taicpu.Op_ref(A_PUSH,opsize,tempreference));
end;
end;
end;
pointerdef,
procvardef,
classrefdef:
begin
cg.a_loadfpu_reg_ref(exprasmlist,
def_cgsize(p.resulttype.def),p.location.register,href);
end;
LOC_REFERENCE,
LOC_CREFERENCE :
begin
sizetopush:=align(p.resulttype.def.size,alignment);
tempreference:=p.location.reference;
inc(tempreference.offset,sizetopush);
while (sizetopush>0) do
begin
if sizetopush>=4 then
begin
cgsize:=OS_32;
inc(pushedparasize,4);
dec(tempreference.offset,4);
dec(sizetopush,4);
end
else
begin
cgsize:=OS_16;
inc(pushedparasize,2);
dec(tempreference.offset,2);
dec(sizetopush,2);
end;
if inlined then
begin
reference_reset_base(href,procinfo^.framepointer,para_offset-pushedparasize);
cg.a_load_ref_ref(exprasmlist,cgsize,tempreference,href);
end
else
cg.a_param_ref(exprasmlist,cgsize,tempreference,-1);
end;
end;
else
internalerror(200204243);
end;
end
else
begin
{ call by value open array ? }
if is_cdecl and
push_addr_param(p.resulttype.def) then
begin
if not (p.location.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
internalerror(200204241);
{ push on stack }
size:=align(p.resulttype.def.size,alignment);
inc(pushedparasize,size);
emit_const_reg(A_SUB,S_L,size,R_ESP);
reference_reset_base(href,R_ESP,0);
cg.g_concatcopy(exprasmlist,p.location.reference,href,size,false,false);
end
else
begin
case p.location.loc of
LOC_CONSTANT,
LOC_REGISTER,
LOC_CREGISTER,
LOC_REFERENCE,
LOC_CREFERENCE :
begin
cgsize:=def_cgsize(p.resulttype.def);
if cgsize in [OS_64,OS_S64] then
begin
inc(pushedparasize,8);
if inlined then
begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_MOV,S_L,tempreference,R_EDI);
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,S_L,R_EDI,r));
rg.ungetregisterint(exprasmlist,R_EDI);
end
begin
reference_reset_base(href,procinfo^.framepointer,para_offset-pushedparasize);
tcg64f32(cg).a_load64_loc_ref(exprasmlist,p.location,href);
end
else
emit_push_mem(tempreference);
end;
arraydef,
recorddef,
stringdef,
setdef,
objectdef :
begin
{ even some structured types are 32 bit }
if is_widestring(p.resulttype.def) or
is_ansistring(p.resulttype.def) or
is_smallset(p.resulttype.def) or
((p.resulttype.def.deftype in [recorddef,arraydef]) and
(
(p.resulttype.def.deftype<>arraydef) or not
(tarraydef(p.resulttype.def).IsConstructor or
tarraydef(p.resulttype.def).isArrayOfConst or
is_open_array(p.resulttype.def))
) and
(p.resulttype.def.size<=4)
) or
is_class(p.resulttype.def) or
is_interface(p.resulttype.def) then
begin
if (p.resulttype.def.size>2) or
((alignment=4) and (p.resulttype.def.size>0)) then
begin
inc(pushedparasize,4);
if inlined then
begin
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
concatcopy(tempreference,r,4,false,false);
end
else
emit_push_mem(tempreference);
end
else
begin
if p.resulttype.def.size>0 then
begin
inc(pushedparasize,2);
if inlined then
begin
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
concatcopy(tempreference,r,2,false,false);
end
else
exprasmList.concat(Taicpu.Op_ref(A_PUSH,S_W,tempreference));
end;
end;
end
{ call by value open array ? }
else if is_cdecl then
begin
{ push on stack }
size:=align(p.resulttype.def.size,alignment);
inc(pushedparasize,size);
emit_const_reg(A_SUB,S_L,size,R_ESP);
reference_reset_base(r,R_ESP,0);
concatcopy(tempreference,r,size,false,false);
end
tcg64f32(cg).a_param64_loc(exprasmlist,p.location,-1);
end
else
begin
case cgsize of
OS_8,OS_S8 :
begin
if alignment=4 then
cgsize:=OS_32
else
cgsize:=OS_16;
end;
OS_16,OS_S16 :
begin
if alignment=4 then
cgsize:=OS_32;
end;
end;
{ update register to use to match alignment }
if p.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
begin
hreg:=p.location.register;
p.location.register:=rg.makeregsize(p.location.register,cgsize);
end;
inc(pushedparasize,alignment);
if inlined then
begin
reference_reset_base(href,procinfo^.framepointer,para_offset-pushedparasize);
cg.a_load_loc_ref(exprasmlist,p.location,href);
end
else
internalerror(8954);
end;
else
CGMessage(cg_e_illegal_expression);
end;
end;
LOC_JUMP:
begin
getlabel(hlabel);
if alignment=4 then
begin
opsize:=S_L;
inc(pushedparasize,4);
end
else
begin
opsize:=S_W;
inc(pushedparasize,2);
end;
emitlab(truelabel);
if inlined then
begin
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
emit_const_ref(A_MOV,opsize,1,r);
end
else
exprasmList.concat(Taicpu.Op_const(A_PUSH,opsize,1));
emitjmp(C_None,hlabel);
emitlab(falselabel);
if inlined then
begin
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
emit_const_ref(A_MOV,opsize,0,r);
end
else
exprasmList.concat(Taicpu.Op_const(A_PUSH,opsize,0));
emitlab(hlabel);
end;
LOC_FLAGS:
begin
if alignment=4 then
begin
opsize:=S_L;
hreg:=R_EAX;
inc(pushedparasize,4);
end
else
begin
opsize:=S_W;
hreg:=R_AX;
inc(pushedparasize,2);
end;
if not(R_EAX in rg.unusedregsint) then
begin
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_reg_reg(A_MOV,S_L,R_EAX,R_EDI);
cg.a_param_loc(exprasmlist,p.location,-1);
{ restore old register }
if p.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
p.location.register:=hreg;
end;
location_release(exprasmlist,p.location);
end;
cg.g_flags2reg(exprasmlist,p.location.resflags,hreg);
if inlined then
begin
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
exprasmList.concat(Taicpu.Op_reg_ref(A_MOV,opsize,hreg,r));
end
else
exprasmList.concat(Taicpu.Op_reg(A_PUSH,opsize,hreg));
if not(R_EAX in rg.unusedregsint) then
begin
emit_reg_reg(A_MOV,S_L,R_EDI,R_EAX);
rg.ungetregisterint(exprasmlist,R_EDI);
end;
end;
{$ifdef SUPPORT_MMX}
LOC_MMXREGISTER,
LOC_CMMXREGISTER:
begin
inc(pushedparasize,8); { was missing !!! (PM) }
emit_const_reg(
A_SUB,S_L,8,R_ESP);
{$ifdef GDB}
if (cs_debuginfo in aktmoduleswitches) and
(exprasmList.first=exprasmList.last) then
exprasmList.concat(Tai_force_line.Create);
{$endif GDB}
if inlined then
LOC_MMXREGISTER,
LOC_CMMXREGISTER:
begin
reference_reset_base(r,procinfo^.framepointer,para_offset-pushedparasize);
exprasmList.concat(Taicpu.Op_reg_ref(A_MOVQ,S_NO,
p.location.register,r));
end
else
begin
reference_reset_base(r,R_ESP,0);
exprasmList.concat(Taicpu.Op_reg_ref(
A_MOVQ,S_NO,p.location.register,r));
end;
end;
inc(pushedparasize,8);
if inlined then
begin
reference_reset_base(href,procinfo^.framepointer,para_offset-pushedparasize);
cg.a_loadmm_reg_ref(exprasmlist,p.location.register,href);
end
else
cg.a_parammm_reg(exprasmlist,p.location.register);
end;
{$endif SUPPORT_MMX}
end;
else
internalerror(200204241);
end;
end;
end;
end;
{*****************************************************************************
@ -871,246 +527,13 @@ implementation
p.swaped:=false; do not modify }
end;
{*****************************************************************************
Emit Functions
*****************************************************************************}
procedure push_shortstring_length(p:tnode);
var
hightree : tnode;
srsym : tsym;
begin
if is_open_string(p.resulttype.def) then
begin
srsym:=searchsymonlyin(tloadnode(p).symtable,'high'+tvarsym(tloadnode(p).symtableentry).name);
hightree:=cloadnode.create(tvarsym(srsym),tloadnode(p).symtable);
firstpass(hightree);
secondpass(hightree);
push_value_para(hightree,false,false,0,4);
hightree.free;
hightree:=nil;
end
else
begin
push_int(tstringdef(p.resulttype.def).len);
end;
end;
{*****************************************************************************
String functions
*****************************************************************************}
procedure loadshortstring(source,dest : tnode);
{
Load a string, handles stringdef and orddef (char) types
}
var
href: treference;
begin
case source.resulttype.def.deftype of
stringdef:
begin
if (source.nodetype=stringconstn) and
(str_length(source)=0) then
emit_const_ref(A_MOV,S_B,0,dest.location.reference)
else
begin
emitpushreferenceaddr(dest.location.reference);
emitpushreferenceaddr(source.location.reference);
push_shortstring_length(dest);
emitcall('FPC_SHORTSTR_COPY');
maybe_loadself;
end;
end;
orddef:
begin
if source.nodetype=ordconstn then
emit_const_ref(
A_MOV,S_W,tordconstnode(source).value*256+1,dest.location.reference)
else
begin
if (source.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
begin
href := dest.location.reference;
emit_const_ref(A_MOV,S_B,1,href);
inc(href.offset,1);
emit_reg_ref(A_MOV,S_B,rg.makeregsize(source.location.register,OS_8),href);
end
else
{ not so elegant (goes better with extra register }
begin
{ not "movl", because then we may read past the }
{ end of the heap! "movw" would be ok too, but }
{ I don't think that would be faster (JM) }
rg.getexplicitregisterint(exprasmlist,R_EDI);
emit_ref_reg(A_MOVZX,S_BL,source.location.reference,R_EDI);
emit_const_reg(A_SHL,S_L,8,R_EDI);
emit_const_reg(A_OR,S_L,1,R_EDI);
emit_reg_ref(A_MOV,S_W,R_DI,dest.location.reference);
rg.ungetregisterint(exprasmlist,R_EDI);
end;
location_release(exprasmlist,source.location);
end;
end;
else
CGMessage(type_e_mismatch);
end;
end;
procedure loadlongstring(p:tbinarynode);
{
Load a string, handles stringdef and orddef (char) types
}
var
r : treference;
begin
case p.right.resulttype.def.deftype of
stringdef:
begin
if (p.right.nodetype=stringconstn) and
(str_length(p.right)=0) then
emit_const_ref(A_MOV,S_L,0,p.left.location.reference)
else
begin
emitpushreferenceaddr(p.left.location.reference);
emitpushreferenceaddr(p.right.location.reference);
push_shortstring_length(p.left);
emitcall('FPC_LONGSTR_COPY');
maybe_loadself;
end;
end;
orddef:
begin
emit_const_ref(A_MOV,S_L,1,p.left.location.reference);
r:=p.left.location.reference;
inc(r.offset,4);
if p.right.nodetype=ordconstn then
emit_const_ref(A_MOV,S_B,tordconstnode(p.right).value,r)
else
begin
case p.right.location.loc of
LOC_REGISTER,LOC_CREGISTER:
emit_reg_ref(A_MOV,S_B,p.right.location.register,r);
LOC_CREFERENCE,LOC_REFERENCE:
begin
if not(R_EAX in rg.unusedregsint) then
emit_reg(A_PUSH,S_L,R_EAX);
emit_ref_reg(A_MOV,S_B,p.right.location.reference,R_AL);
emit_reg_ref(A_MOV,S_B,R_AL,r);
if not(R_EAX in rg.unusedregsint) then
emit_reg(A_POP,S_L,R_EAX);
end
else
internalerror(20799);
end;
location_release(exprasmlist,p.right.location);
end;
end;
else
CGMessage(type_e_mismatch);
end;
end;
procedure loadansi2short(source,dest : tnode);
var
pushed : tpushedsaved;
regs_to_push: tregisterset;
begin
{ Find out which registers have to be pushed (JM) }
regs_to_push := all_registers;
remove_non_regvars_from_loc(source.location,regs_to_push);
{ Push them (JM) }
rg.saveusedregisters(exprasmlist,pushed,regs_to_push);
location_freetemp(exprasmlist,source.location);
location_release(exprasmlist,source.location);
cg.a_param_loc(exprasmlist,source.location,1);
push_shortstring_length(dest);
emitpushreferenceaddr(dest.location.reference);
rg.saveregvars(exprasmlist,all_registers);
emitcall('FPC_ANSISTR_TO_SHORTSTR');
rg.restoreusedregisters(exprasmlist,pushed);
maybe_loadself;
end;
procedure loadwide2short(source,dest : tnode);
var
pushed : tpushedsaved;
regs_to_push: tregisterset;
begin
{ Find out which registers have to be pushed (JM) }
regs_to_push := all_registers;
remove_non_regvars_from_loc(source.location,regs_to_push);
{ Push them (JM) }
rg.saveusedregisters(exprasmlist,pushed,regs_to_push);
location_freetemp(exprasmlist,source.location);
location_release(exprasmlist,source.location);
cg.a_param_loc(exprasmlist,source.location,1);
push_shortstring_length(dest);
emitpushreferenceaddr(dest.location.reference);
rg.saveregvars(exprasmlist,all_registers);
emitcall('FPC_WIDESTR_TO_SHORTSTR');
rg.restoreusedregisters(exprasmlist,pushed);
maybe_loadself;
end;
procedure loadinterfacecom(p: tbinarynode);
{
copies an com interface from n.right to n.left, we
assume, that both sides are com interface, firstassignement have
to take care of that, an com interface can't be a register variable
}
var
pushed : tpushedsaved;
ungettemp : boolean;
begin
{ before pushing any parameter, we have to save all used }
{ registers, but before that we have to release the }
{ registers of that node to save uneccessary pushed }
{ so be careful, if you think you can optimize that code (FK) }
{ nevertheless, this has to be changed, because otherwise the }
{ register is released before it's contents are pushed -> }
{ problems with the optimizer (JM) }
reference_release(exprasmlist,p.left.location.reference);
ungettemp:=false;
case p.right.location.loc of
LOC_REGISTER,LOC_CREGISTER:
begin
rg.saveusedregisters(exprasmlist,pushed, all_registers - [p.right.location.register]);
exprasmList.concat(Taicpu.Op_reg(A_PUSH,S_L,p.right.location.register));
end;
LOC_REFERENCE,LOC_CREFERENCE:
begin
rg.saveusedregisters(exprasmlist,pushed, all_registers
- [p.right.location.reference.base]
- [p.right.location.reference.index]);
emit_push_mem(p.right.location.reference);
ungettemp:=true;
end;
end;
location_release(exprasmlist,p.right.location);
emitpushreferenceaddr(p.left.location.reference);
location_release(exprasmlist,p.left.location);
rg.saveregvars(exprasmlist,all_registers);
emitcall('FPC_INTF_ASSIGN');
maybe_loadself;
rg.restoreusedregisters(exprasmlist,pushed);
if ungettemp then
location_release(exprasmlist,p.right.location);
end;
end.
{
$Log$
Revision 1.34 2002-04-21 15:39:41 carl
Revision 1.35 2002-04-25 20:16:40 peter
* moved more routines from cga/n386util
Revision 1.34 2002/04/21 15:39:41 carl
* changeregsize -> rg.makeregsize
Revision 1.33 2002/04/20 21:37:07 carl

3293
compiler/ncal.pas
View File

File diff suppressed because it is too large Load Diff

87
compiler/ncnv.pas
View File

@ -549,9 +549,8 @@ implementation
stringpara := ccallparanode.create(left,nil);
left := nil;
{ hen converting to shortstrings, we have to pass high(destination) too }
if (tstringdef(resulttype.def).string_typ =
st_shortstring) then
{ when converting to shortstrings, we have to pass high(destination) too }
if (tstringdef(resulttype.def).string_typ = st_shortstring) then
stringpara.right := ccallparanode.create(cinlinenode.create(
in_high_x,false,self.getcopy),nil);
@ -1531,6 +1530,8 @@ implementation
function tisnode.det_resulttype:tnode;
var
paras: tcallparanode;
begin
result:=nil;
resulttypepass(left);
@ -1556,6 +1557,15 @@ implementation
end
else
CGMessage(type_e_mismatch);
{ call fpc_do_is helper }
paras := ccallparanode.create(
left,
ccallparanode.create(
right,nil));
result := ccallnode.createintern('fpc_do_is',paras);
left := nil;
right := nil;
end
else if is_interface(right.resulttype.def) then
begin
@ -1577,6 +1587,15 @@ implementation
end
else
CGMessage(type_e_mismatch);
{ call fpc_do_is helper }
paras := ccallparanode.create(
left,
ccallparanode.create(
right,nil));
result := ccallnode.createintern('fpc_do_is',paras);
left := nil;
right := nil;
end
else
CGMessage(type_e_mismatch);
@ -1586,27 +1605,14 @@ implementation
function tisnode.pass_1 : tnode;
var
paras: tcallparanode;
begin
if (right.resulttype.def.deftype=classrefdef) then
begin
paras := ccallparanode.create(left,ccallparanode.create(right,nil));
left := nil;
right := nil;
result := ccallnode.createintern('fpc_do_is',paras);
firstpass(result);
end
else
result:=nil;
internalerror(200204254);
result:=nil;
end;
{ dummy pass_2, it will never be called, but we need one since }
{ you can't instantiate an abstract class }
procedure tisnode.pass_2;
begin
end;
@ -1623,6 +1629,8 @@ implementation
function tasnode.det_resulttype:tnode;
var
paras : tcallparanode;
begin
result:=nil;
resulttypepass(right);
@ -1648,7 +1656,15 @@ implementation
end
else
CGMessage(type_e_mismatch);
resulttype:=tclassrefdef(right.resulttype.def).pointertype;
{ call fpc_do_as helper }
paras := ccallparanode.create(
left,
ccallparanode.create(
right,nil));
result := ccallnode.createinternres('fpc_do_as',paras,tclassrefdef(right.resulttype.def).pointertype);
left := nil;
right := nil;
end
else if is_interface(right.resulttype.def) then
begin
@ -1670,7 +1686,15 @@ implementation
end
else
CGMessage(type_e_mismatch);
resulttype:=right.resulttype;
{ call fpc_do_as helper }
paras := ccallparanode.create(
left,
ccallparanode.create(
right,nil));
result := ccallnode.createinternres('fpc_do_as',paras,right.resulttype);
left := nil;
right := nil;
end
else
CGMessage(type_e_mismatch);
@ -1678,29 +1702,15 @@ implementation
function tasnode.pass_1 : tnode;
var
paras: tcallparanode;
begin
if (right.resulttype.def.deftype=classrefdef) then
begin
paras := ccallparanode.create(left,ccallparanode.create(right,nil));
left := nil;
right := nil;
result := ccallnode.createinternres('fpc_do_as',paras,
resulttype);
firstpass(result);
end
else
result:=nil;
internalerror(200204252);
result:=nil;
end;
{ dummy pass_2, it will never be called, but we need one since }
{ you can't instantiate an abstract class }
procedure tasnode.pass_2;
begin
end;
@ -1712,7 +1722,10 @@ begin
end.
{
$Log$
Revision 1.53 2002-04-23 19:16:34 peter
Revision 1.54 2002-04-25 20:16:38 peter
* moved more routines from cga/n386util
Revision 1.53 2002/04/23 19:16:34 peter
* add pinline unit that inserts compiler supported functions using
one or more statements
* moved finalize and setlength from ninl to pinline

135
compiler/nld.pas
View File

@ -124,7 +124,7 @@ implementation
cutils,verbose,globtype,globals,systems,
symtable,types,
htypechk,pass_1,
ncnv,nmem,ncal,cpubase,rgobj,cginfo,cgbase
ncon,ninl,ncnv,nmem,ncal,cpubase,rgobj,cginfo,cgbase
;
@ -422,6 +422,7 @@ implementation
function tassignmentnode.det_resulttype:tnode;
var
hp : tnode;
useshelper : boolean;
begin
result:=nil;
resulttype:=voidtype;
@ -446,6 +447,9 @@ implementation
if is_open_array(left.resulttype.def) then
CGMessage(type_e_mismatch);
{ test if node can be assigned, properties are allowed }
valid_for_assignment(left);
{ assigning nil to a dynamic array clears the array }
if is_dynamic_array(left.resulttype.def) and
(right.nodetype=niln) then
@ -458,19 +462,84 @@ implementation
exit;
end;
{ some string functions don't need conversion, so treat them separatly }
if not (
is_shortstring(left.resulttype.def) and
(
is_shortstring(right.resulttype.def) or
is_ansistring(right.resulttype.def) or
is_char(right.resulttype.def)
)
) then
{ shortstring helpers can do the conversion directly,
so treat them separatly }
if (is_shortstring(left.resulttype.def)) then
begin
{ test for s:=s+anything ... }
{ the problem is for
s:=s+s+s;
this is broken here !! }
{$ifdef newoptimizations2}
{ the above is fixed now, but still problem with s := s + f(); if }
{ f modifies s (bad programming, so only enable if uncertain }
{ optimizations are on) (JM) }
if (cs_UncertainOpts in aktglobalswitches) then
begin
hp := right;
while hp.treetype=addn do
hp:=hp.left;
if equal_trees(left,hp) and
not multiple_uses(left,right) then
begin
concat_string:=true;
hp:=right;
while hp.treetype=addn do
begin
hp.use_strconcat:=true;
hp:=hp.left;
end;
end;
end;
{$endif newoptimizations2}
{ insert typeconv, except for chars that are handled in
secondpass and except for ansi/wide string that can
be converted immediatly }
if not(is_char(right.resulttype.def) or
(right.resulttype.def.deftype=stringdef)) then
inserttypeconv(right,left.resulttype);
if right.resulttype.def.deftype=stringdef then
begin
useshelper:=true;
{ convert constant strings to shortstrings. But
skip empty constant strings, that will be handled
in secondpass }
if (right.nodetype=stringconstn) then
begin
inserttypeconv(right,left.resulttype);
if (tstringconstnode(right).len=0) then
useshelper:=false;
end;
if useshelper then
begin
hp:=ccallparanode.create
(right,
ccallparanode.create(cinlinenode.create
(in_high_x,false,left.getcopy),nil));
result:=ccallnode.createinternreturn('fpc_'+tstringdef(right.resulttype.def).stringtypname+'_to_shortstr',hp,left);
left:=nil;
right:=nil;
exit;
end;
end;
end
else
inserttypeconv(right,left.resulttype);
{ test if node can be assigned, properties are allowed }
valid_for_assignment(left);
{ call helpers for interface }
if is_interfacecom(left.resulttype.def) then
begin
hp:=ccallparanode.create
(right,
ccallparanode.create(caddrnode.create
(left),nil));
hp:=ccallparanode.create(right,nil);
result:=ccallnode.createintern('fpc_intf_assign',hp);
left:=nil;
right:=nil;
exit;
end;
{ check if local proc/func is assigned to procvar }
if right.resulttype.def.deftype=procvardef then
@ -487,43 +556,6 @@ implementation
if codegenerror then
exit;
{ some string functions don't need conversion, so treat them separatly }
if is_shortstring(left.resulttype.def) and
(
is_shortstring(right.resulttype.def) or
is_ansistring(right.resulttype.def) or
is_char(right.resulttype.def)
) then
begin
{ we call STRCOPY }
procinfo^.flags:=procinfo^.flags or pi_do_call;
{ test for s:=s+anything ... }
{ the problem is for
s:=s+s+s;
this is broken here !! }
{$ifdef newoptimizations2}
{ the above is fixed now, but still problem with s := s + f(); if }
{ f modifies s (bad programming, so only enable if uncertain }
{ optimizations are on) (JM) }
if (cs_UncertainOpts in aktglobalswitches) then
begin
hp := right;
while hp.treetype=addn do hp:=hp.left;
if equal_trees(left,hp) and
not multiple_uses(left,right) then
begin
concat_string:=true;
hp:=right;
while hp.treetype=addn do
begin
hp.use_strconcat:=true;
hp:=hp.left;
end;
end;
end;
{$endif newoptimizations2}
end;
registers32:=left.registers32+right.registers32;
registersfpu:=max(left.registersfpu,right.registersfpu);
{$ifdef SUPPORT_MMX}
@ -924,7 +956,10 @@ begin
end.
{
$Log$
Revision 1.37 2002-04-23 19:16:34 peter
Revision 1.38 2002-04-25 20:16:39 peter
* moved more routines from cga/n386util
Revision 1.37 2002/04/23 19:16:34 peter
* add pinline unit that inserts compiler supported functions using
one or more statements
* moved finalize and setlength from ninl to pinline

16
compiler/symdef.pas
View File

@ -2686,6 +2686,7 @@ implementation
function tarraydef.size : longint;
var
newsize,
cachedsize: TConstExprInt;
begin
if IsDynamicArray then
@ -2708,7 +2709,15 @@ implementation
Message(sym_e_segment_too_large);
size := 4
End
Else size:=longint((highrange-lowrange+1)*cachedsize);
Else
begin
newsize:=(int64(highrange)-int64(lowrange)+1)*cachedsize;
{ prevent an overflow }
if newsize>high(longint) then
size:=high(longint)
else
size:=newsize;
end
end;
@ -5470,7 +5479,10 @@ implementation
end.
{
$Log$
Revision 1.74 2002-04-23 19:16:35 peter
Revision 1.75 2002-04-25 20:16:39 peter
* moved more routines from cga/n386util
Revision 1.74 2002/04/23 19:16:35 peter
* add pinline unit that inserts compiler supported functions using
one or more statements
* moved finalize and setlength from ninl to pinline

15
compiler/tainst.pas
View File

@ -59,6 +59,10 @@ Type
implementation
uses
verbose;
{*****************************************************************************
TaiRegAlloc
*****************************************************************************}
@ -140,6 +144,8 @@ implementation
procedure tainstruction.loadsymbol(opidx:longint;s:tasmsymbol;sofs:longint);
begin
if not assigned(s) then
internalerror(200204251);
if opidx>=ops then
ops:=opidx+1;
with oper[opidx] do
@ -150,9 +156,7 @@ implementation
symofs:=sofs;
typ:=top_symbol;
end;
{ Mark the symbol as used }
if assigned(s) then
inc(s.refs);
inc(s.refs);
end;
@ -242,7 +246,10 @@ end.
{
$Log$
Revision 1.4 2002-04-02 17:11:32 peter
Revision 1.5 2002-04-25 20:16:39 peter
* moved more routines from cga/n386util
Revision 1.4 2002/04/02 17:11:32 peter
* tlocation,treference update
* LOC_CONSTANT added for better constant handling
* secondadd splitted in multiple routines

37
compiler/types.pas
View File

@ -75,7 +75,7 @@ interface
{# Returns true, if def defines a signed data type (only for ordinal types) }
function is_signed(def : tdef) : boolean;
{# Returns true whether def_from's range is comprised in def_to's if both are
{# Returns true whether def_from's range is comprised in def_to's if both are
orddefs, false otherwise }
function is_in_limit(def_from,def_to : tdef) : boolean;
@ -85,9 +85,9 @@ interface
{# Returns true, if p points to a zero based (non special like open or
dynamic array def).
This is mainly used to see if the array
is convertable to a pointer
is convertable to a pointer
}
function is_zero_based_array(p : tdef) : boolean;
@ -106,10 +106,10 @@ interface
{# Returns true, if p points to an array of const }
function is_array_of_const(p : tdef) : boolean;
{# Returns true, if p points any kind of special array
{# Returns true, if p points any kind of special array
That is if the array is an open array, a variant
array, an array constants constructor, or an
array, an array constants constructor, or an
array of const.
}
function is_special_array(p : tdef) : boolean;
@ -162,16 +162,16 @@ interface
function push_high_param(def : tdef) : boolean;
{# Returns true if a parameter is too large to copy and only the address is pushed
{# Returns true if a parameter is too large to copy and only the address is pushed
}
function push_addr_param(def : tdef) : boolean;
{# Returns true, if def1 and def2 are semantically the same }
function is_equal(def1,def2 : tdef) : boolean;
{# Checks for type compatibility (subgroups of type)
used for case statements... probably missing stuff
to use on other types
{# Checks for type compatibility (subgroups of type)
used for case statements... probably missing stuff
to use on other types
}
function is_subequal(def1, def2: tdef): boolean;
@ -224,11 +224,11 @@ interface
function equal_constsym(sym1,sym2:tconstsym):boolean;
{# true, if two parameter lists are equal
if acp is cp_none, all have to match exactly
if acp is cp_value_equal_const call by value
and call by const parameter are assumed as
equal
{# true, if two parameter lists are equal
if acp is cp_none, all have to match exactly
if acp is cp_value_equal_const call by value
and call by const parameter are assumed as
equal
}
{ if acp is cp_all the var const or nothing are considered equal }
type
@ -249,7 +249,7 @@ interface
function get_proc_2_procvar_def(p:tprocsym;d:tprocvardef):tprocdef;
{# If @var(l) isn't in the range of def a range check error (if not explicit) is generated and
the value is placed within the range
the value is placed within the range
}
procedure testrange(def : tdef;var l : tconstexprint;explicit:boolean);
@ -1970,7 +1970,10 @@ implementation
end.
{
$Log$
Revision 1.68 2002-04-15 19:08:22 carl
Revision 1.69 2002-04-25 20:16:39 peter
* moved more routines from cga/n386util
Revision 1.68 2002/04/15 19:08:22 carl
+ target_info.size_of_pointer -> pointer_size
+ some cleanup of unused types/variables