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

+ more fixes

Browse Source
This commit is contained in:
carl 2002-12-08 15:02:17 +00:00
parent e64d5033b0
commit b6d87094de
1 changed files with 315 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

350
compiler/ncgadd.pas
View File

@ -20,7 +20,7 @@
**************************************************************************** ****************************************************************************
} }
unit ncgcadd; unit ncgadd;
{$i fpcdefs.inc} {$i fpcdefs.inc}
@ -30,19 +30,33 @@ interface
node,nadd,cpubase,cginfo; node,nadd,cpubase,cginfo;
type type
tppcaddnode = class(taddnode) tcgaddnode = class(taddnode)
function pass_1: tnode; override; { function pass_1: tnode; override;}
procedure pass_2;override; procedure pass_2;override;
private private
procedure pass_left_and_right; procedure pass_left_and_right;
{ load left and right nodes into registers }
procedure load_left_right(cmpop, load_constants: boolean); procedure load_left_right(cmpop, load_constants: boolean);
{ free used registers, except result location }
procedure clear_left_right(cmpop: boolean); procedure clear_left_right(cmpop: boolean);
function getresflags : tresflags;
procedure emit_compare(unsigned : boolean); procedure second_opfloat;
procedure second_addfloat; procedure second_opboolean;
procedure second_addboolean; procedure second_opsmallset;
procedure second_addsmallset; procedure second_op64bit;
procedure second_add64bit; { done }
{ procedure second_addfloat;virtual;}
procedure second_addboolean;virtual;
procedure second_addsmallset;virtual;
procedure second_add64bit;virtual;
procedure second_addordinal;virtual;
{ procedure second_cmpfloat;virtual;}
procedure second_cmpboolean;virtual;
procedure second_cmpsmallset;virtual;
procedure second_cmp64bit;virtual;
procedure second_cmpordinal;virtual;
end; end;
implementation implementation
@ -62,7 +76,7 @@ interface
{***************************************************************************** {*****************************************************************************
Helpers Helpers
*****************************************************************************} *****************************************************************************}
(*
function tcgaddnode.getresflags(unsigned : boolean) : tresflags; function tcgaddnode.getresflags(unsigned : boolean) : tresflags;
begin begin
case nodetype of case nodetype of
@ -105,7 +119,7 @@ interface
end; end;
end; end;
end; end;
*)
procedure tcgaddnode.pass_left_and_right; procedure tcgaddnode.pass_left_and_right;
var var
@ -182,10 +196,32 @@ interface
end; end;
procedure tcgaddnode.clear_left_right(cmpop: boolean);
begin
if (right.location.loc in [LOC_REGISTER,LOC_FPUREGISTER]) and
(cmpop or
(location.register <> right.location.register)) then
begin
rg.ungetregister(exprasmlist,right.location.register);
if is_64bitint(right.resulttype.def) then
rg.ungetregister(exprasmlist,right.location.registerhigh);
end;
if (left.location.loc in [LOC_REGISTER,LOC_FPUREGISTER]) and
(cmpop or
(location.register <> left.location.register)) then
begin
rg.ungetregister(exprasmlist,left.location.register);
if is_64bitint(left.resulttype.def) then
rg.ungetregister(exprasmlist,left.location.registerhigh);
end;
end;
{***************************************************************************** {*****************************************************************************
AddSmallSet Smallsets
*****************************************************************************} *****************************************************************************}
procedure tppcaddnode.second_opsmallset; procedure tcgaddnode.second_opsmallset;
var var
cmpop : boolean; cmpop : boolean;
begin begin
@ -199,9 +235,10 @@ interface
(tsetdef(right.resulttype.def).settype<>smallset)) then (tsetdef(right.resulttype.def).settype<>smallset)) then
internalerror(200203301); internalerror(200203301);
if nodetype in [equaln,unequaln,gtn,gten,lte,lten] then if nodetype in [equaln,unequaln,gtn,gten,lten,ltn] then
cmpop := true; cmpop := true;
{ load non-constant values (left and right) into registers }
load_left_right(cmpop,false); load_left_right(cmpop,false);
if cmpop then if cmpop then
@ -267,7 +304,7 @@ interface
end; end;
procedure tppcaddnode.second_addsmallset; procedure tcgaddnode.second_addsmallset;
var var
cgop : TOpCg; cgop : TOpCg;
tmpreg : tregister; tmpreg : tregister;
@ -278,7 +315,7 @@ interface
opdone := false; opdone := false;
location_reset(location,LOC_REGISTER,def_cgsize(resulttype.def)) location_reset(location,LOC_REGISTER,def_cgsize(resulttype.def));
if (location.register = R_NO) then if (location.register = R_NO) then
location.register := rg.getregisterint(exprasmlist); location.register := rg.getregisterint(exprasmlist);
@ -343,16 +380,16 @@ interface
tmpreg := cg.get_scratch_reg_int(exprasmlist); tmpreg := cg.get_scratch_reg_int(exprasmlist);
cg.a_load_const_reg(exprasmlist,OS_INT, cg.a_load_const_reg(exprasmlist,OS_INT,
aword(left.location.value),tmpreg); aword(left.location.value),tmpreg);
cg.a_op_reg(OP_NOT,OS_INT,right.location.register); cg.a_op_reg_reg(exprasmlist,OP_NOT,OS_INT,right.location.register,right.location.register);
cg.a_op_reg_reg(OP_AND,OS_INT,right.location.register,tmpreg); cg.a_op_reg_reg(exprasmlist,OP_AND,OS_INT,right.location.register,tmpreg);
cg.a_load_reg_reg(OS_INT,tmpreg,location.register); cg.a_load_reg_reg(exprasmlist,OS_INT,OS_INT,tmpreg,location.register);
cg.free_scratch_reg(exprasmlist,tmpreg); cg.free_scratch_reg(exprasmlist,tmpreg);
end end
else else
begin begin
cg.a_op_reg(OP_NOT,OS_INT,right.location.register); cg.a_op_reg_reg(exprasmlist,OP_NOT,OS_INT,right.location.register,right.location.register);
cg.a_op_reg_reg(OP_AND,OS_INT,right.location.register,left.location.register); cg.a_op_reg_reg(exprasmlist,OP_AND,OS_INT,right.location.register,left.location.register);
cg.a_load_reg_reg(OS_INT,left.location.register,location.register); cg.a_load_reg_reg(exprasmlist,OS_INT,OS_INT,left.location.register,location.register);
end; end;
end; end;
end; end;
@ -378,21 +415,30 @@ interface
end; end;
{***************************************************************************** {*****************************************************************************
AddBoolean Boolean
*****************************************************************************} *****************************************************************************}
procedure tppcaddnode.second_opboolean procedure tcgaddnode.second_opboolean;
var
cmpop : boolean;
begin begin
cmpop := false;
{ calculate the operator which is more difficult } { calculate the operator which is more difficult }
firstcomplex(self); firstcomplex(self);
if cmpop then
second_cmpboolean
else
second_addboolean;
end; end;
procedure tppcaddnode.second_cmpboolean; procedure tcgaddnode.second_cmpboolean;
begin begin
end; end;
procedure tppcaddnode.second_addboolean; procedure tcgaddnode.second_addboolean;
var var
cgop : TOpCg; cgop : TOpCg;
cgsize : TCgSize; cgsize : TCgSize;
@ -541,12 +587,13 @@ interface
end; end;
end; end;
end;*) end;*)
{ free used register (except the result register) }
clear_left_right(cmpop); clear_left_right(cmpop);
end; end;
{***************************************************************************** {*****************************************************************************
Add64bit 64-bit
*****************************************************************************} *****************************************************************************}
procedure tcgaddnode.second_op64bit; procedure tcgaddnode.second_op64bit;
@ -558,7 +605,7 @@ interface
pass_left_and_right; pass_left_and_right;
if nodetype in [equaln,unequaln,gtn,gten,lte,lten] then if nodetype in [equaln,unequaln,gtn,gten,ltn,lten] then
cmpop := true; cmpop := true;
if cmpop then if cmpop then
@ -566,6 +613,7 @@ interface
else else
second_add64bit; second_add64bit;
{ free used register (except the result register) }
clear_left_right(cmpop); clear_left_right(cmpop);
end; end;
@ -669,10 +717,11 @@ interface
end; end;
procedure tppcaddnode.second_add64bit; procedure tcgaddnode.second_add64bit;
var var
op : TOpCG; op : TOpCG;
unsigned : boolean; unsigned : boolean;
checkoverflow : boolean;
begin begin
@ -680,11 +729,20 @@ interface
(torddef(left.resulttype.def).typ=u64bit)) or (torddef(left.resulttype.def).typ=u64bit)) or
((right.resulttype.def.deftype=orddef) and ((right.resulttype.def.deftype=orddef) and
(torddef(right.resulttype.def).typ=u64bit)); (torddef(right.resulttype.def).typ=u64bit));
{ assume no overflow checking is required }
checkoverflow := false;
case nodetype of case nodetype of
addn : addn :
op:=OP_ADD; begin
op:=OP_ADD;
checkoverflow := true;
end;
subn : subn :
op:=OP_SUB; begin
op:=OP_SUB;
checkoverflow := true;
end;
xorn: xorn:
op:=OP_XOR; op:=OP_XOR;
orn: orn:
@ -706,7 +764,6 @@ interface
(nodetype in [addn,subn])); (nodetype in [addn,subn]));
case nodetype of case nodetype of
begin
xorn,orn,andn,addn: xorn,orn,andn,addn:
begin begin
if (location.registerlow = R_NO) then if (location.registerlow = R_NO) then
@ -767,16 +824,239 @@ interface
else else
internalerror(2002072803); internalerror(2002072803);
end; end;
end
{ emit overflow check if enabled } { emit overflow check if enabled }
cg.g_overflowcheck(exprasmlist,self); if checkoverflow then
cg.g_overflowcheck(exprasmlist,self);
end; end;
{*****************************************************************************
Floats
*****************************************************************************}
procedure tcgaddnode.second_opfloat;
begin
end;
{*****************************************************************************
Ordinals
*****************************************************************************}
procedure tcgaddnode.second_cmpordinal;
var
unsigned : boolean;
begin
{ set result location }
location_reset(location,LOC_FLAGS,OS_NO);
{ load values into registers (except constants) }
load_left_right(true, false);
{ determine if the comparison will be unsigned }
unsigned:=not(is_signed(left.resulttype.def)) or
not(is_signed(right.resulttype.def));
end;
procedure tcgaddnode.second_addordinal;
var
unsigned : boolean;
checkoverflow : boolean;
cgop : topcg;
tmpreg : tregister;
begin
{ set result location }
location_reset(location,LOC_REGISTER,def_cgsize(resulttype.def));
{ determine if the comparison will be unsigned }
unsigned:=not(is_signed(left.resulttype.def)) or
not(is_signed(right.resulttype.def));
{ load values into registers }
load_left_right(false, (cs_check_overflow in aktlocalswitches) and
(nodetype in [addn,subn,muln]));
if (location.register = R_NO) then
location.register := rg.getregisterint(exprasmlist);
{ assume no overflow checking is require }
checkoverflow := false;
case nodetype of
addn:
begin
cgop := OP_ADD;
checkoverflow := true;
end;
xorn :
begin
cgop := OP_XOR;
end;
orn :
begin
cgop := OP_OR;
end;
andn:
begin
cgop := OP_AND;
end;
muln:
begin
checkoverflow := true;
if unsigned then
cgop := OP_MUL
else
cgop := OP_IMUL;
end;
subn :
begin
checkoverflow := true;
cgop := OP_SUB;
end;
end;
if nodetype <> subn then
begin
if (left.location.loc = LOC_CONSTANT) then
swapleftright;
if (right.location.loc <> LOC_CONSTANT) then
cg.a_op_reg_reg_reg(exprasmlist,cgop,OS_INT,
left.location.register,right.location.register,
location.register)
else
cg.a_op_const_reg_reg(exprasmlist,cgop,OS_INT,
aword(right.location.value),left.location.register,
location.register);
end
else { subtract is a special case since its not commutative }
begin
if (nf_swaped in flags) then
swapleftright;
if left.location.loc <> LOC_CONSTANT then
begin
if right.location.loc <> LOC_CONSTANT then
cg.a_op_reg_reg_reg(exprasmlist,OP_SUB,OS_INT,
right.location.register,left.location.register,
location.register)
else
cg.a_op_const_reg_reg(exprasmlist,OP_SUB,OS_INT,
aword(right.location.value),left.location.register,
location.register);
end
else
begin
tmpreg := cg.get_scratch_reg_int(exprasmlist);
cg.a_load_const_reg(exprasmlist,OS_INT,
aword(left.location.value),tmpreg);
cg.a_op_reg_reg_reg(exprasmlist,OP_SUB,OS_INT,
right.location.register,tmpreg,location.register);
cg.free_scratch_reg(exprasmlist,tmpreg);
end;
end;
{ emit overflow check if required }
if checkoverflow then
cg.g_overflowcheck(exprasmlist,self);
end;
{*****************************************************************************
pass_2
*****************************************************************************}
procedure tcgaddnode.pass_2;
{ is also being used for xor, and "mul", "sub, or and comparative }
{ operators }
var
cmpop : boolean;
cgop : topcg;
op : tasmop;
tmpreg : tregister;
{ true, if unsigned types are compared }
unsigned : boolean;
regstopush: tregisterset;
begin
{ to make it more readable, string and set (not smallset!) have their
own procedures }
case left.resulttype.def.deftype of
orddef :
begin
{ handling boolean expressions }
if is_boolean(left.resulttype.def) and
is_boolean(right.resulttype.def) then
begin
second_opboolean;
exit;
end
{ 64bit operations }
else if is_64bitint(left.resulttype.def) then
begin
second_op64bit;
exit;
end;
end;
stringdef :
begin
{ this should already be handled in pass1 }
internalerror(2002072402);
exit;
end;
setdef :
begin
{ normalsets are already handled in pass1 }
if (tsetdef(left.resulttype.def).settype<>smallset) then
internalerror(200109041);
second_opsmallset;
exit;
end;
arraydef :
begin
{$ifdef SUPPORT_MMX}
if is_mmx_able_array(left.resulttype.def) then
begin
second_opmmx;
exit;
end;
{$endif SUPPORT_MMX}
end;
floatdef :
begin
second_opfloat;
exit;
end;
end;
{*********************** ordinals / integrals *******************}
cmpop:=nodetype in [ltn,lten,gtn,gten,equaln,unequaln];
{ normally nothing should be in flags }
if (left.location.loc = LOC_FLAGS) or
(right.location.loc = LOC_FLAGS) then
internalerror(2002072602);
pass_left_and_right;
if cmpop then
second_cmpordinal
else
second_addordinal;
{ free used register (except the result register) }
clear_left_right(cmpop);
end;
end.
{ {
$Log$ $Log$
Revision 1.1 2002-12-07 19:51:35 carl Revision 1.2 2002-12-08 15:02:17 carl
+ more fixes
Revision 1.1 2002/12/07 19:51:35 carl
+ first version (uncompilable!) + first version (uncompilable!)
} }