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

* range checking is now processor independent (part in cgobj, part in

Browse Source
This commit is contained in:
Jonas Maebe 2001-12-30 17:24:45 +00:00
parent c536b532d0
commit f15dbd7bf0
17 changed files with 1090 additions and 614 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

254
compiler/cg64f32.pas
View File

@ -30,7 +30,7 @@ unit cg64f32;
interface
uses
aasm, cgobj, cpubase;
aasm, cgobj, cpubase,node,symtype;
type
tcg64f32 = class(tcg)
@ -38,12 +38,30 @@ unit cg64f32;
procedure a_load64_ref_reg(list : taasmoutput;const ref : treference;reglo,reghi : tregister);
procedure a_load64_reg_reg(list : taasmoutput;reglosrc,reghisrc,reglodst,reghidst : tregister);
procedure a_load64_loc_reg(list : taasmoutput;const l : tlocation;reglo,reghi : tregister);
procedure a_load64high_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);
procedure a_load64low_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);
procedure a_load64high_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);
procedure a_load64low_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);
{ override to catch 64bit rangechecks }
procedure g_rangecheck(list: taasmoutput; const p: tnode;
const todef: tdef); override;
private
{ produces range check code for 32bit processors when one of the }
{ operands is 64 bit }
procedure g_rangecheck64(list : taasmoutput; p : tnode;todef : tdef);
end;
implementation
uses
globals,systems,cgbase,verbose;
globtype,globals,systems,
cgbase,
verbose,
symbase,symconst,symdef,types,
cpuinfo;
procedure tcg64f32.a_load64_reg_ref(list : taasmoutput;reglo, reghi : tregister;const ref : treference);
var
@ -100,6 +118,233 @@ unit cg64f32;
end;
end;
procedure tcg64f32.a_load64high_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);
var
tmpref: treference;
begin
if target_info.endian = endian_big then
a_load_reg_ref(list,OS_32,reg,ref)
else
begin
tmpref := ref;
inc(tmpref.offset,4);
a_load_reg_ref(list,OS_32,reg,tmpref)
end;
end;
procedure tcg64f32.a_load64low_reg_ref(list : taasmoutput;reg : tregister;const ref : treference);
var
tmpref: treference;
begin
if target_info.endian = endian_little then
a_load_reg_ref(list,OS_32,reg,ref)
else
begin
tmpref := ref;
inc(tmpref.offset,4);
a_load_reg_ref(list,OS_32,reg,tmpref)
end;
end;
procedure tcg64f32.a_load64high_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);
var
tmpref: treference;
begin
if target_info.endian = endian_big then
a_load_ref_reg(list,OS_32,ref,reg)
else
begin
tmpref := ref;
inc(tmpref.offset,4);
a_load_ref_reg(list,OS_32,tmpref,reg)
end;
end;
procedure tcg64f32.a_load64low_ref_reg(list : taasmoutput;const ref : treference;reg : tregister);
var
tmpref: treference;
begin
if target_info.endian = endian_little then
a_load_ref_reg(list,OS_32,ref,reg)
else
begin
tmpref := ref;
inc(tmpref.offset,4);
a_load_ref_reg(list,OS_32,tmpref,reg)
end;
end;
procedure tcg64f32.g_rangecheck(list: taasmoutput; const p: tnode;
const todef: tdef);
begin
{ range checking on and range checkable value? }
if not(cs_check_range in aktlocalswitches) or
not(todef.deftype in [orddef,enumdef,arraydef]) then
exit;
{ special case for 64bit rangechecks }
if is_64bitint(p.resulttype.def) or is_64bitint(todef) then
g_rangecheck64(list,p,todef)
else
inherited g_rangecheck(list,p,todef);
end;
procedure tcg64f32.g_rangecheck64(list : taasmoutput; p : tnode;todef : tdef);
var
neglabel,
poslabel,
endlabel: tasmlabel;
hreg : tregister;
hdef : torddef;
fromdef : tdef;
opsize : tcgsize;
oldregisterdef: boolean;
from_signed,to_signed: boolean;
got_scratch: boolean;
begin
fromdef:=p.resulttype.def;
from_signed := is_signed(fromdef);
to_signed := is_signed(todef);
if not is_64bitint(todef) then
begin
oldregisterdef := registerdef;
registerdef := false;
{ get the high dword in a register }
if p.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
begin
hreg := p.location.registerhigh;
got_scratch := false
end
else
begin
hreg := get_scratch_reg(list);
got_scratch := true;
a_load64high_ref_reg(list,p.location.reference,hreg);
end;
getlabel(poslabel);
{ check high dword, must be 0 (for positive numbers) }
a_cmp_const_reg_label(list,OS_32,OC_EQ,0,hreg,poslabel);
{ It can also be $ffffffff, but only for negative numbers }
if from_signed and to_signed then
begin
getlabel(neglabel);
a_cmp_const_reg_label(list,OS_32,OC_EQ,aword(-1),hreg,neglabel);
end;
{ !!! freeing of register should happen directly after compare! (JM) }
if got_scratch then
free_scratch_reg(list,hreg);
{ For all other values we have a range check error }
a_call_name(list,'FPC_RANGEERROR',0);
{ if the high dword = 0, the low dword can be considered a }
{ simple cardinal }
a_label(list,poslabel);
hdef:=torddef.create(u32bit,0,longint($ffffffff));
{ the real p.resulttype.def is already saved in fromdef }
p.resulttype.def := hdef;
{ no use in calling just "g_rangecheck" since that one will }
{ simply call the inherited method too (JM) }
inherited g_rangecheck(list,p,todef);
hdef.free;
{ restore original resulttype.def }
p.resulttype.def := todef;
if from_signed and to_signed then
begin
getlabel(endlabel);
a_jmp_cond(list,OC_NONE,endlabel);
{ if the high dword = $ffffffff, then the low dword (when }
{ considered as a longint) must be < 0 }
a_label(list,neglabel);
if p.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
begin
hreg := p.location.registerlow;
got_scratch := false
end
else
begin
hreg := get_scratch_reg(list);
got_scratch := true;
a_load64low_ref_reg(list,p.location.reference,hreg);
end;
{ get a new neglabel (JM) }
getlabel(neglabel);
a_cmp_const_reg_label(list,OS_32,OC_LT,0,hreg,neglabel);
{ !!! freeing of register should happen directly after compare! (JM) }
if got_scratch then
free_scratch_reg(list,hreg);
a_call_name(list,'FPC_RANGEERROR',0);
{ if we get here, the 64bit value lies between }
{ longint($80000000) and -1 (JM) }
a_label(list,neglabel);
hdef:=torddef.create(s32bit,longint($80000000),-1);
p.resulttype.def := hdef;
inherited g_rangecheck(list,p,todef);
hdef.free;
a_label(list,endlabel);
end;
registerdef := oldregisterdef;
p.resulttype.def := fromdef;
{ restore p's resulttype.def }
end
else
{ todef = 64bit int }
{ no 64bit subranges supported, so only a small check is necessary }
{ if both are signed or both are unsigned, no problem! }
if (from_signed xor to_signed) and
{ also not if the fromdef is unsigned and < 64bit, since that will }
{ always fit in a 64bit int (todef is 64bit) }
(from_signed or
(torddef(fromdef).typ = u64bit)) then
begin
{ in all cases, there is only a problem if the higest bit is set }
if p.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
begin
if is_64bitint(fromdef) then
begin
hreg := p.location.registerhigh;
opsize := OS_32;
end
else
begin
hreg := p.location.register;
opsize := def_cgsize(p.resulttype.def);
end;
got_scratch := false;
end
else
begin
hreg := get_scratch_reg(list);
got_scratch := true;
opsize := def_cgsize(p.resulttype.def);
if opsize in [OS_64,OS_S64] then
a_load64high_ref_reg(list,p.location.reference,hreg)
else
a_load_ref_reg(list,opsize,p.location.reference,hreg);
end;
getlabel(poslabel);
a_cmp_const_reg_label(list,opsize,OC_GTE,0,hreg,poslabel);
{ !!! freeing of register should happen directly after compare! (JM) }
if got_scratch then
free_scratch_reg(list,hreg);
a_call_name(list,'FPC_RANGEERROR',0);
a_label(list,poslabel);
end;
end;
(*
procedure int64f32_assignment_int64_reg(p : passignmentnode);
@ -113,7 +358,10 @@ begin
end.
{
$Log$
Revision 1.1 2001-12-29 15:29:58 jonas
Revision 1.2 2001-12-30 17:24:48 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
Revision 1.1 2001/12/29 15:29:58 jonas
* powerpc/cgcpu.pas compiles :)
* several powerpc-related fixes
* cpuasm unit is now based on common tainst unit

19
compiler/cgbase.pas
View File

@ -34,7 +34,7 @@ unit cgbase;
{ symtable }
symconst,symtype,symdef,symsym,
{ aasm }
aasm,cpubase
aasm,cpubase, cpuinfo
;
type
@ -185,6 +185,7 @@ unit cgbase;
function def_cgsize(const p1: tdef): tcgsize;
function int_cgsize(const l: aword): tcgsize;
{ return the inverse condition of opcmp }
function inverse_opcmp(opcmp: topcmp): topcmp;
@ -445,7 +446,14 @@ implementation
function def_cgsize(const p1: tdef): tcgsize;
begin
case p1.size of
result := int_cgsize(p1.size);
if is_signed(p1) then
result := tcgsize(ord(result)+(ord(OS_S8)-ord(OS_8)));
end;
function int_cgsize(const l: aword): tcgsize;
begin
case l of
1: result := OS_8;
2: result := OS_16;
4: result := OS_32;
@ -453,8 +461,6 @@ implementation
else
internalerror(2001092311);
end;
if is_signed(p1) then
result := tcgsize(ord(result)+(ord(OS_S8)-ord(OS_8)));
end;
@ -501,7 +507,10 @@ begin
end.
{
$Log$
Revision 1.4 2001-11-06 14:53:48 jonas
Revision 1.5 2001-12-30 17:24:48 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
Revision 1.4 2001/11/06 14:53:48 jonas
* compiles again with -dmemdebug
Revision 1.3 2001/09/29 21:33:47 jonas

165
compiler/cgobj.pas
View File

@ -29,7 +29,7 @@ unit cgobj;
uses
cclasses,aasm,symtable,cpuasm,cpubase,cgbase,cpuinfo,
symconst,symbase,symtype;
symconst,symbase,symtype,node;
type
talignment = (AM_NATURAL,AM_NONE,AM_2BYTE,AM_4BYTE,AM_8BYTE);
@ -146,19 +146,28 @@ unit cgobj;
procedure a_op_reg_loc(list : taasmoutput; Op: TOpCG; size: TCGSize; reg: tregister; const loc: tlocation);
procedure a_op_ref_loc(list : taasmoutput; Op: TOpCG; size: TCGSize; const ref: TReference; const loc: tlocation);
{ trinary operations for processors that support them, 'emulated' }
{ on others. None with "ref" arguments since I don't think there }
{ are any processors that support it (JM) }
procedure a_op_const_reg_reg(list: taasmoutput; op: TOpCg;
size: tcgsize; a: aword; src, dst: tregister); virtual;
procedure a_op_reg_reg_reg(list: taasmoutput; op: TOpCg;
size: tcgsize; src1, src2, dst: tregister); virtual;
{ comparison operations }
procedure a_cmp_const_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;reg : tregister;
l : tasmlabel);virtual; abstract;
procedure a_cmp_const_ref_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;const ref : treference;
l : tasmlabel); virtual;
procedure a_cmp_const_loc_label(list: taasmoutput; size: tcgsize;cmp_op: topcmp; a: aword; const loc: tlocation;
l : tasmlabel); virtual;
l : tasmlabel);
procedure a_cmp_reg_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;reg1,reg2 : tregister;l : tasmlabel); virtual; abstract;
procedure a_cmp_ref_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp; const ref: treference; reg : tregister; l : tasmlabel); virtual;
procedure a_cmp_ref_loc_label(list: taasmoutput; size: tcgsize;cmp_op: topcmp; const ref: treference; const loc: tlocation;
l : tasmlabel);
procedure a_jmp_cond(list : taasmoutput;cond : TOpCmp;l: tasmlabel); virtual; abstract;
procedure a_jmp_flags(list : taasmoutput;const f : TResFlags;l: tasmlabel); virtual; abstract;
procedure g_flags2reg(list: taasmoutput; const f: tresflags; reg: TRegister); virtual; abstract;
@ -195,6 +204,13 @@ unit cgobj;
{ source points to }
procedure g_concatcopy(list : taasmoutput;const source,dest : treference;len : aword;delsource,loadref : boolean);virtual; abstract;
{ generates rangechecking code for a node }
procedure g_rangecheck(list: taasmoutput; const p: tnode;
const todef: tdef); virtual;
{ returns the tcgsize corresponding with the size of reg }
class function reg_cgsize(const reg: tregister) : tcgsize; virtual;
{$ifdef i386}
{ this one is only necessary due the the restrictions of the 80x86, }
{ so make it a special case (JM) }
@ -208,7 +224,7 @@ unit cgobj;
implementation
uses
strings,globals,globtype,options,{files,}gdb,systems,
strings,globals,globtype,options,gdb,systems,
ppu,verbose,types,{tgobj,}tgcpu,symdef,symsym,cga,tainst;
const
@ -1071,7 +1087,7 @@ unit cgobj;
{$ifdef i386}
case size of
OS_8,OS_S8:
tmpreg := reg32toreg8(getregister32);
tmpreg := reg32toreg8(getregisterint);
OS_16,OS_S16:
tmpreg := reg32toreg16(get_scratch_reg(list));
else
@ -1201,6 +1217,21 @@ unit cgobj;
end;
end;
procedure tcg.a_op_const_reg_reg(list: taasmoutput; op: TOpCg;
size: tcgsize; a: aword; src, dst: tregister);
begin
a_load_reg_reg(list,size,src,dst);
a_op_const_reg(list,op,a,dst);
end;
procedure tcg.a_op_reg_reg_reg(list: taasmoutput; op: TOpCg;
size: tcgsize; src1, src2, dst: tregister);
begin
a_load_reg_reg(list,size,src2,dst);
a_op_reg_reg(list,op,size,src1,dst);
end;
procedure tcg.a_cmp_const_ref_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;const ref : treference;
l : tasmlabel);
@ -1258,7 +1289,7 @@ unit cgobj;
{ 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 := getregister32
tmpreg := getregisterint
else
{$endif i386}
tmpreg := get_scratch_reg(list);
@ -1279,12 +1310,134 @@ unit cgobj;
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 }
{ the check is also insert (needed for succ,pref,inc,dec) }
var
neglabel : tasmlabel;
hreg : tregister;
fromdef : tdef;
lto,hto,
lfrom,hfrom : TConstExprInt;
from_signed: boolean;
begin
{ range checking on and range checkable value? }
if not(cs_check_range in aktlocalswitches) or
not(todef.deftype in [orddef,enumdef,arraydef]) then
exit;
{ only check when assigning to scalar, subranges are different, }
{ when todef=fromdef then the check is always generated }
fromdef:=p.resulttype.def;
getrange(p.resulttype.def,lfrom,hfrom);
getrange(todef,lto,hto);
{ no range check if from and to are equal and are both longint/dword }
{ (if we have a 32bit processor) or int64/qword, since such }
{ operations can at most cause overflows (JM) }
{ Note that these checks are mostly processor independent, they only }
{ have to be changed once we introduce 64bit subrange types }
if (fromdef = todef) and
{ then fromdef and todef can only be orddefs }
(((sizeof(aword) = 4) and
(((torddef(fromdef).typ = s32bit) and
(lfrom = low(longint)) and
(hfrom = high(longint))) or
((torddef(fromdef).typ = u32bit) and
(lfrom = low(cardinal)) and
(hfrom = high(cardinal))))) or
is_64bitint(fromdef)) then
exit;
if todef<>fromdef then
begin
{ if the from-range falls completely in the to-range, no check }
{ is necessary }
if (lto<=lfrom) and (hto>=hfrom) then
exit;
end;
{ generate the rangecheck code for the def where we are going to }
{ store the result }
{ use the trick that }
{ a <= x <= b <=> 0 <= x-a <= b-a <=> cardinal(x-a) <= cardinal(b-a) }
{ To be able to do that, we have to make sure however that either }
{ fromdef and todef are both signed or unsigned, or that we leave }
{ the parts < 0 and > maxlongint out }
{ is_signed now also works for arrays (it checks the rangetype) (JM) }
from_signed := is_signed(fromdef);
if from_signed xor is_signed(todef) then
if from_signed then
{ from is signed, to is unsigned }
begin
{ if high(from) < 0 -> always range error }
if (hfrom < 0) or
{ if low(to) > maxlongint also range error }
(lto > (high(aword) div 2)) then
begin
a_call_name(list,'FPC_RANGEERROR',0);
exit
end;
{ from is signed and to is unsigned -> when looking at from }
{ as an unsigned value, it must be < maxlongint (otherwise }
{ it's negative, which is invalid since "to" is unsigned) }
if hto > (high(aword) div 2) then
hto := (high(aword) div 2);
end
else
{ from is unsigned, to is signed }
begin
if (lfrom > (high(aword) div 2)) or
(hto < 0) then
begin
a_call_name(list,'FPC_RANGEERROR',0);
exit
end;
{ from is unsigned and to is signed -> when looking at to }
{ as an unsigned value, it must be >= 0 (since negative }
{ values are the same as values > maxlongint) }
if lto < 0 then
lto := 0;
end;
hreg := get_scratch_reg(list);
if (p.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
a_op_const_reg_reg(list,OP_SUB,def_cgsize(p.resulttype.def),
aword(lto),p.location.register,hreg)
else
begin
a_load_ref_reg(list,def_cgsize(p.resulttype.def),
p.location.reference,hreg);
a_op_const_reg(list,OP_SUB,aword(lto),hreg);
end;
getlabel(neglabel);
a_cmp_const_reg_label(list,OS_INT,OC_BE,aword(hto-lto),hreg,neglabel);
{ !!! should happen right after the compare (JM) }
free_scratch_reg(list,hreg);
a_call_name(list,'FPC_RANGEERROR',0);
a_label(list,neglabel);
end;
function tcg.reg_cgsize(const reg: tregister) : tcgsize;
begin
reg_cgsize := OS_INT;
end;
finalization
cg.free;
end.
{
$Log$
Revision 1.5 2001-12-29 15:28:58 jonas
Revision 1.6 2001-12-30 17:24:48 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
Revision 1.5 2001/12/29 15:28:58 jonas
* powerpc/cgcpu.pas compiles :)
* several powerpc-related fixes
* cpuasm unit is now based on common tainst unit

19
compiler/i386/cga.pas
View File

@ -230,9 +230,9 @@ implementation
function def_getreg(p1:tdef):tregister;
begin
case p1.size of
1 : def_getreg:=reg32toreg8(getregister32);
2 : def_getreg:=reg32toreg16(getregister32);
4 : def_getreg:=getregister32;
1 : def_getreg:=reg32toreg8(getregisterint);
2 : def_getreg:=reg32toreg16(getregisterint);
4 : def_getreg:=getregisterint;
else
internalerror(130820003);
end;
@ -284,7 +284,7 @@ implementation
begin
if (l.loc=LOC_FLAGS) then
begin
hregister:=getregister32;
hregister:=getregisterint;
case opsize of
S_W : hregister:=reg32toreg16(hregister);
S_B : hregister:=reg32toreg8(hregister);
@ -304,7 +304,7 @@ implementation
begin
if l.loc = LOC_JUMP then
begin
hregister:=getregister32;
hregister:=getregisterint;
case opsize of
S_W : hregister:=reg32toreg16(hregister);
S_B : hregister:=reg32toreg8(hregister);
@ -361,7 +361,7 @@ implementation
begin
hreg:=makereg8(hregister);
ai:=Taicpu.Op_reg(A_Setcc,S_B,hreg);
ai.SetCondition(flag_2_cond[flag]);
ai.SetCondition(flags_to_cond(flag));
exprasmList.concat(ai);
if hreg<>hregister then
begin
@ -487,7 +487,7 @@ implementation
{ we can't do a getregister in the code generator }
{ without problems!!! }
if usablereg32>0 then
hreg:=reg32toreg8(getregister32)
hreg:=reg32toreg8(getregisterint)
else
begin
emit_reg(A_PUSH,S_L,R_EAX);
@ -2976,7 +2976,10 @@ implementation
end.
{
$Log$
Revision 1.12 2001-12-29 15:28:58 jonas
Revision 1.13 2001-12-30 17:24:45 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
Revision 1.12 2001/12/29 15:28:58 jonas
* powerpc/cgcpu.pas compiles :)
* several powerpc-related fixes
* cpuasm unit is now based on common tainst unit

129
compiler/i386/cgcpu.pas
View File

@ -27,10 +27,10 @@ unit cgcpu;
interface
uses
cgbase,cgobj,aasm,cpuasm,cpubase,cpuinfo;
cgbase,cgobj,cg64f32,aasm,cpuasm,cpubase,cpuinfo;
type
tcg386 = class(tcg)
tcg386 = class(tcg64f32)
{ passing parameters, per default the parameter is pushed }
{ nr gives the number of the parameter (enumerated from }
@ -53,6 +53,11 @@ unit cgcpu;
procedure a_op_ref_reg(list : taasmoutput; Op: TOpCG; size: TCGSize; const ref: TReference; reg: TRegister); override;
procedure a_op_reg_ref(list : taasmoutput; Op: TOpCG; size: TCGSize;reg: TRegister; const ref: TReference); override;
procedure a_op_const_reg_reg(list: taasmoutput; op: TOpCg;
size: tcgsize; a: aword; src, dst: tregister); override;
procedure a_op_reg_reg_reg(list: taasmoutput; op: TOpCg;
size: tcgsize; src1, src2, dst: tregister); override;
{ move instructions }
procedure a_load_const_reg(list : taasmoutput; size: tcgsize; a : aword;reg : tregister);override;
procedure a_load_const_ref(list : taasmoutput; size: tcgsize; a : aword;const ref : treference);override;
@ -70,6 +75,8 @@ unit cgcpu;
procedure a_cmp_ref_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;const ref: treference; reg : tregister; l : tasmlabel); override;
procedure a_jmp_cond(list : taasmoutput;cond : TOpCmp;l: tasmlabel); override;
procedure a_jmp_flags(list : taasmoutput;const f : TResFlags;l: tasmlabel); override;
procedure g_flags2reg(list: taasmoutput; const f: tresflags; reg: TRegister); override;
@ -86,6 +93,8 @@ unit cgcpu;
function makeregsize(var reg: tregister; size: tcgsize): topsize; override;
class function reg_cgsize(const reg: tregister): tcgsize; override;
private
procedure sizes2load(s1: tcgsize; s2: topsize; var op: tasmop; var s3: topsize);
@ -307,6 +316,11 @@ unit cgcpu;
list.concat(taicpu.op_reg(A_INC,regsize(reg),reg))
else
list.concat(taicpu.op_reg(A_DEC,regsize(reg),reg))
else if (a = 0) then
if (op <> OP_AND) then
exit
else
list.concat(taicpu.op_const_reg(A_MOV,regsize(reg),0,reg))
else
list.concat(taicpu.op_const_reg(TOpCG2AsmOp[op],regsize(reg),
longint(a),reg));
@ -376,6 +390,11 @@ unit cgcpu;
else
list.concat(taicpu.op_ref(A_DEC,TCgSize2OpSize[size],
newreference(ref)))
else if (a = 0) then
if (op <> OP_AND) then
exit
else
a_load_const_ref(list,size,0,ref)
else
list.concat(taicpu.op_const_ref(TOpCG2AsmOp[op],
TCgSize2OpSize[size],longint(a),newreference(ref)));
@ -535,6 +554,88 @@ unit cgcpu;
end;
end;
procedure tcg386.a_op_const_reg_reg(list: taasmoutput; op: TOpCg;
size: tcgsize; a: aword; src, dst: tregister);
var
tmpref: treference;
power: longint;
opsize: topsize;
begin
opsize := regsize(src);
if (opsize <> S_L) or
not (size in [OS_32,OS_S32]) then
begin
inherited a_op_const_reg_reg(list,op,size,a,src,dst);
exit;
end;
{ if we get here, we have to do a 32 bit calculation, guaranteed }
Case Op of
OP_DIV, OP_IDIV, OP_MUL, OP_AND, OP_OR, OP_XOR, OP_SHL, OP_SHR,
OP_SAR:
{ can't do anything special for these }
inherited a_op_const_reg_reg(list,op,size,a,src,dst);
OP_IMUL:
begin
if not(cs_check_overflow in aktlocalswitches) and
ispowerof2(longint(a),power) then
{ can be done with a shift }
inherited a_op_const_reg_reg(list,op,size,a,src,dst);
list.concat(taicpu.op_const_reg_reg(A_IMUL,S_L,longint(a),src,dst));
end;
OP_ADD, OP_SUB:
if (a = 0) then
a_load_reg_reg(list,size,src,dst)
else
begin
reset_reference(tmpref);
tmpref.base := src;
tmpref.offset := longint(a);
if op = OP_SUB then
tmpref.offset := -tmpref.offset;
list.concat(taicpu.op_ref_reg(A_LEA,S_L,newreference(tmpref),
dst));
end
else internalerror(200112302);
end;
end;
procedure tcg386.a_op_reg_reg_reg(list: taasmoutput; op: TOpCg;
size: tcgsize; src1, src2, dst: tregister);
var
tmpref: treference;
power: longint;
opsize: topsize;
begin
opsize := regsize(src1);
if (opsize <> S_L) or
(regsize(src2) <> S_L) or
not (size in [OS_32,OS_S32]) then
begin
inherited a_op_reg_reg_reg(list,op,size,src1,src2,dst);
exit;
end;
{ if we get here, we have to do a 32 bit calculation, guaranteed }
Case Op of
OP_DIV, OP_IDIV, OP_MUL, OP_AND, OP_OR, OP_XOR, OP_SHL, OP_SHR,
OP_SAR,OP_SUB,OP_NOT,OP_NEG:
{ can't do anything special for these }
inherited a_op_reg_reg_reg(list,op,size,src1,src2,dst);
OP_IMUL:
list.concat(taicpu.op_reg_reg_reg(A_IMUL,S_L,src1,src2,dst));
OP_ADD:
begin
reset_reference(tmpref);
tmpref.base := src1;
tmpref.index := src2;
tmpref.scalefactor := 1;
list.concat(taicpu.op_ref_reg(A_LEA,S_L,newreference(tmpref),
dst));
end
else internalerror(200112303);
end;
end;
{*************** compare instructructions ****************}
procedure tcg386.a_cmp_const_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;reg : tregister;
@ -596,6 +697,15 @@ unit cgcpu;
list.concat(ai);
end;
procedure tcg386.a_jmp_flags(list : taasmoutput;const f : TResFlags;l: tasmlabel);
var
ai : taicpu;
begin
ai := Taicpu.op_sym(A_Jcc,S_NO,l);
ai.SetCondition(flags_to_cond(f));
ai.is_jmp := true;
list.concat(ai);
end;
procedure tcg386.g_flags2reg(list: taasmoutput; const f: tresflags; reg: TRegister);
@ -605,7 +715,7 @@ unit cgcpu;
begin
hreg := makereg8(reg);
ai:=Taicpu.Op_reg(A_Setcc,S_B,hreg);
ai.SetCondition(flag_2_cond[f]);
ai.SetCondition(flags_to_cond(f));
list.concat(ai);
if hreg<>reg then
begin
@ -718,6 +828,14 @@ unit cgcpu;
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);
begin
result := regsize_2_cgsize[regsize(reg)];
end;
{***************** This is private property, keep out! :) *****************}
procedure tcg386.sizes2load(s1: tcgsize; s2: topsize; var op: tasmop; var s3: topsize);
@ -762,7 +880,10 @@ begin
end.
{
$Log$
Revision 1.5 2001-12-29 15:29:59 jonas
Revision 1.6 2001-12-30 17:24:46 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
Revision 1.5 2001/12/29 15:29:59 jonas
* powerpc/cgcpu.pas compiles :)
* several powerpc-related fixes
* cpuasm unit is now based on common tainst unit

19
compiler/i386/cpubase.pas
View File

@ -421,12 +421,6 @@ const
type
TResFlags = (F_E,F_NE,F_G,F_L,F_GE,F_LE,F_C,F_NC,F_A,F_AE,F_B,F_BE);
const
{ arrays for boolean location conversions }
flag_2_cond : array[TResFlags] of TAsmCond =
(C_E,C_NE,C_G,C_L,C_GE,C_LE,C_C,C_NC,C_A,C_AE,C_B,C_BE);
{*****************************************************************************
Reference
*****************************************************************************}
@ -707,6 +701,7 @@ const
procedure swap_location(var destloc,sourceloc : tlocation);
procedure inverse_flags(var f: TResFlags);
function flags_to_cond(const f: TResFlags) : TAsmCond;
implementation
@ -943,6 +938,13 @@ end;
f := flagsinvers[f];
end;
function flags_to_cond(const f: TResFlags) : TAsmCond;
const
flags_2_cond : array[TResFlags] of TAsmCond =
(C_E,C_NE,C_G,C_L,C_GE,C_LE,C_C,C_NC,C_A,C_AE,C_B,C_BE);
begin
result := flags_2_cond[f];
end;
procedure InitCpu;
begin
@ -955,7 +957,10 @@ end;
end.
{
$Log$
Revision 1.8 2001-12-29 15:29:59 jonas
Revision 1.9 2001-12-30 17:24:46 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
Revision 1.8 2001/12/29 15:29:59 jonas
* powerpc/cgcpu.pas compiles :)
* several powerpc-related fixes
* cpuasm unit is now based on common tainst unit

55
compiler/i386/n386add.pas
View File

@ -49,7 +49,7 @@ interface
cgbase,temp_gen,pass_2,regvars,
cpuasm,
ncon,nset,
tainst,cga,n386util,tgcpu;
tainst,cga,ncgutil,n386util,tgcpu;
function ti386addnode.getresflags(unsigned : boolean) : tresflags;
@ -305,10 +305,10 @@ interface
case nodetype of
ltn,gtn:
begin
emitjmp(flag_2_cond[getresflags(unsigned)],truelabel);
emitjmp(flags_to_cond(getresflags(unsigned)),truelabel);
{ cheat a little bit for the negative test }
toggleflag(nf_swaped);
emitjmp(flag_2_cond[getresflags(unsigned)],falselabel);
emitjmp(flags_to_cond(getresflags(unsigned)),falselabel);
toggleflag(nf_swaped);
end;
lten,gten:
@ -318,13 +318,13 @@ interface
nodetype:=ltn
else
nodetype:=gtn;
emitjmp(flag_2_cond[getresflags(unsigned)],truelabel);
emitjmp(flags_to_cond(getresflags(unsigned)),truelabel);
{ cheat for the negative test }
if nodetype=ltn then
nodetype:=gtn
else
nodetype:=ltn;
emitjmp(flag_2_cond[getresflags(unsigned)],falselabel);
emitjmp(flags_to_cond(getresflags(unsigned)),falselabel);
nodetype:=oldnodetype;
end;
equaln:
@ -343,7 +343,7 @@ interface
begin
{ the comparisaion of the low dword have to be }
{ always unsigned! }
emitjmp(flag_2_cond[getresflags(true)],truelabel);
emitjmp(flags_to_cond(getresflags(true)),truelabel);
emitjmp(C_None,falselabel);
end;
equaln:
@ -573,7 +573,7 @@ interface
ungetiftemp(left.location.reference);
del_location(left.location);
{!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!}
hregister:=getregister32;
hregister:=getregisterint;
emit_ref_reg(A_MOV,opsize,
newreference(left.location.reference),hregister);
clear_location(left.location);
@ -585,7 +585,7 @@ interface
begin
ungetiftemp(right.location.reference);
del_location(right.location);
hregister:=getregister32;
hregister:=getregisterint;
emit_ref_reg(A_MOV,opsize,
newreference(right.location.reference),hregister);
clear_location(right.location);
@ -667,7 +667,7 @@ interface
begin
ungetiftemp(left.location.reference);
del_reference(left.location.reference);
hregister:=getregister32;
hregister:=getregisterint;
emit_ref_reg(A_MOV,opsize,
newreference(left.location.reference),hregister);
clear_location(left.location);
@ -680,7 +680,7 @@ interface
{save the register var in a temp register, because
its value is going to be modified}
begin
hregister := getregister32;
hregister := getregisterint;
emit_reg_reg(A_MOV,opsize,
left.location.register,hregister);
clear_location(left.location);
@ -738,7 +738,7 @@ interface
{ release left.location, since it's a }
{ constant (JM) }
release_loc(right.location);
location.register := getregister32;
location.register := getregisterint;
emitloadord2reg(right.location,torddef(u32bittype.def),location.register,false);
emit_const_reg(A_SHL,S_L,power,location.register)
End
@ -786,7 +786,7 @@ interface
exprasmList.concat(Tairegalloc.DeAlloc(R_EDX));
if R_EAX in unused then
exprasmList.concat(Tairegalloc.DeAlloc(R_EAX));
location.register := getregister32;
location.register := getregisterint;
emit_reg_reg(A_MOV,S_L,R_EAX,location.register);
if popedx then
emit_reg(A_POP,S_L,R_EDX);
@ -829,8 +829,8 @@ interface
else
begin
case opsize of
S_L : hregister:=getregister32;
S_B : hregister:=reg32toreg8(getregister32);
S_L : hregister:=getregisterint;
S_B : hregister:=reg32toreg8(getregisterint);
end;
emit_reg_reg(A_MOV,opsize,left.location.register,
hregister);
@ -850,9 +850,9 @@ interface
begin
{ first give free, then demand new register }
case opsize of
S_L : hregister:=getregister32;
S_W : hregister:=reg32toreg16(getregister32);
S_B : hregister:=reg32toreg8(getregister32);
S_L : hregister:=getregisterint;
S_W : hregister:=reg32toreg16(getregisterint);
S_B : hregister:=reg32toreg8(getregisterint);
end;
emit_ref_reg(A_MOV,opsize,
newreference(left.location.reference),hregister);
@ -1059,7 +1059,7 @@ interface
hregister:=location.register
else
begin
hregister:=reg32toreg8(getregister32);
hregister:=reg32toreg8(getregisterint);
emit_reg_reg(A_MOV,S_B,location.register,
hregister);
end;
@ -1069,7 +1069,7 @@ interface
del_reference(location.reference);
{ first give free then demand new register }
hregister:=reg32toreg8(getregister32);
hregister:=reg32toreg8(getregisterint);
emit_ref_reg(A_MOV,S_B,newreference(location.reference),
hregister);
end;
@ -1134,7 +1134,7 @@ interface
hregister:=location.register
else
begin
hregister:=reg32toreg16(getregister32);
hregister:=reg32toreg16(getregisterint);
emit_reg_reg(A_MOV,S_W,location.register,
hregister);
end;
@ -1144,7 +1144,7 @@ interface
del_reference(location.reference);
{ first give free then demand new register }
hregister:=reg32toreg16(getregister32);
hregister:=reg32toreg16(getregisterint);
emit_ref_reg(A_MOV,S_W,newreference(location.reference),
hregister);
end;
@ -1274,8 +1274,8 @@ interface
end
else
begin
hregister:=getregister32;
hregister2:=getregister32;
hregister:=getregisterint;
hregister2:=getregisterint;
emit_reg_reg(A_MOV,S_L,left.location.registerlow,
hregister);
emit_reg_reg(A_MOV,S_L,left.location.registerhigh,
@ -1294,8 +1294,8 @@ interface
end
else
begin
hregister:=getregister32;
hregister2:=getregister32;
hregister:=getregisterint;
hregister2:=getregisterint;
emit_mov_ref_reg64(left.location.reference,hregister,hregister2);
end;
end;
@ -1863,7 +1863,10 @@ begin
end.
{
$Log$
Revision 1.27 2001-12-29 15:29:58 jonas
Revision 1.28 2001-12-30 17:24:46 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
Revision 1.27 2001/12/29 15:29:58 jonas
* powerpc/cgcpu.pas compiles :)
* several powerpc-related fixes
* cpuasm unit is now based on common tainst unit

17
compiler/i386/n386cnv.pas
View File

@ -63,7 +63,7 @@ implementation
cgbase,temp_gen,pass_2,
ncon,ncal,
cpubase,
cga,tgcpu,n386util;
cgobj,cga,tgcpu,n386util;
{*****************************************************************************
@ -80,7 +80,7 @@ implementation
begin
{ insert range check if not explicit conversion }
if not(nf_explizit in flags) then
emitrangecheck(left,resulttype.def);
cg.g_rangecheck(exprasmlist,left,resulttype.def);
{ is the result size smaller ? }
if resulttype.def.size<left.resulttype.def.size then
@ -133,7 +133,7 @@ implementation
end;
{ load the register we need }
if left.location.loc<>LOC_REGISTER then
hregister:=getregister32
hregister:=getregisterint
else
hregister:=left.location.register;
@ -144,7 +144,7 @@ implementation
{ do we need a second register for a 64 bit type ? }
if is_64bitint(resulttype.def) then
begin
hregister2:=getregister32;
hregister2:=getregisterint;
location.registerhigh:=hregister2;
end;
case resulttype.def.size of
@ -331,7 +331,7 @@ implementation
begin
if is_64bitint(left.resulttype.def) then
begin
hregister:=getregister32;
hregister:=getregisterint;
emit_ref_reg(A_MOV,opsize,
newreference(left.location.reference),hregister);
pref:=newreference(left.location.reference);
@ -350,7 +350,7 @@ implementation
end;
LOC_FLAGS :
begin
hregister:=getregister32;
hregister:=getregisterint;
resflags:=left.location.resflags;
end;
LOC_REGISTER,LOC_CREGISTER :
@ -492,7 +492,10 @@ begin
end.
{
$Log$
Revision 1.28 2001-12-11 08:14:17 jonas
Revision 1.29 2001-12-30 17:24:46 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
Revision 1.28 2001/12/11 08:14:17 jonas
* part of my fix for dynarray -> open array conversion, forgot to
commit yesterday :(

31
compiler/i386/n386inl.pas
View File

@ -43,7 +43,7 @@ implementation
cgbase,temp_gen,pass_1,pass_2,
cpubase,
nbas,ncon,ncal,ncnv,nld,
cga,tgcpu,n386util;
cgobj,cga,tgcpu,n386util,ncgutil;
{*****************************************************************************
@ -126,7 +126,7 @@ implementation
{ for both cases load vmt }
if left.nodetype=typen then
begin
location.register:=getregister32;
location.register:=getregisterint;
emit_sym_ofs_reg(A_MOV,
S_L,newasmsymbol(tobjectdef(left.resulttype.def).vmt_mangledname),0,
location.register);
@ -136,7 +136,7 @@ implementation
secondpass(left);
del_reference(left.location.reference);
location.loc:=LOC_REGISTER;
location.register:=getregister32;
location.register:=getregisterint;
{ load VMT pointer }
inc(left.location.reference.offset,
tobjectdef(left.resulttype.def).vmt_offset);
@ -165,7 +165,7 @@ implementation
if left.location.loc<>LOC_REGISTER then
begin
del_location(left.location);
hregister:=getregister32;
hregister:=getregisterint;
emit_mov_loc_reg(left.location,hregister);
end
else
@ -211,8 +211,8 @@ implementation
begin
if left.location.loc=LOC_CREGISTER then
begin
location.registerlow:=getregister32;
location.registerhigh:=getregister32;
location.registerlow:=getregisterint;
location.registerhigh:=getregisterint;
emit_reg_reg(A_MOV,opsize,left.location.registerlow,
location.registerlow);
emit_reg_reg(A_MOV,opsize,left.location.registerhigh,
@ -221,8 +221,8 @@ implementation
else
begin
del_reference(left.location.reference);
location.registerlow:=getregister32;
location.registerhigh:=getregister32;
location.registerlow:=getregisterint;
location.registerhigh:=getregisterint;
emit_ref_reg(A_MOV,opsize,newreference(left.location.reference),
location.registerlow);
r:=newreference(left.location.reference);
@ -259,7 +259,7 @@ implementation
if left.location.loc in [LOC_MEM,LOC_REFERENCE] then
del_reference(left.location.reference);
location.register:=getregister32;
location.register:=getregisterint;
if (resulttype.def.size=2) then
location.register:=reg32toreg16(location.register);
if (resulttype.def.size=1) then
@ -283,7 +283,7 @@ implementation
location.register);
end;
emitoverflowcheck(self);
emitrangecheck(self,resulttype.def);
cg.g_rangecheck(exprasmlist,self,resulttype.def);
end;
in_dec_x,
in_inc_x :
@ -332,7 +332,7 @@ implementation
LOC_MEM,
LOC_REFERENCE : begin
del_reference(tcallparanode(tcallparanode(left).right).left.location.reference);
hregister:=getregister32;
hregister:=getregisterint;
emit_ref_reg(A_MOV,S_L,
newreference(tcallparanode(tcallparanode(left).right).left.location.reference),hregister);
end;
@ -393,12 +393,12 @@ implementation
ungetregister32(hregister);
end;
emitoverflowcheck(tcallparanode(left).left);
emitrangecheck(tcallparanode(left).left,tcallparanode(left).left.resulttype.def);
cg.g_rangecheck(exprasmlist,tcallparanode(left).left,tcallparanode(left).left.resulttype.def);
end;
in_typeinfo_x:
begin
location.register:=getregister32;
location.register:=getregisterint;
new(r);
reset_reference(r^);
r^.symbol:=tstoreddef(ttypenode(tcallparanode(left).left).resulttype.def).get_rtti_label(fullrtti);
@ -729,7 +729,10 @@ begin
end.
{
$Log$
Revision 1.30 2001-12-10 14:34:04 jonas
Revision 1.31 2001-12-30 17:24:46 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
Revision 1.30 2001/12/10 14:34:04 jonas
* fixed type conversions from dynamic arrays to open arrays
Revision 1.29 2001/12/04 15:59:03 jonas

21
compiler/i386/n386ld.pas
View File

@ -111,7 +111,7 @@ implementation
{ DLL variable }
else if (vo_is_dll_var in tvarsym(symtableentry).varoptions) then
begin
hregister:=getregister32;
hregister:=getregisterint;
location.reference.symbol:=newasmsymbol(tvarsym(symtableentry).mangledname);
emit_ref_reg(A_MOV,S_L,newreference(location.reference),hregister);
location.reference.symbol:=nil;
@ -135,7 +135,7 @@ implementation
emitcall('FPC_RELOCATE_THREADVAR');
reset_reference(location.reference);
location.reference.base:=getregister32;
location.reference.base:=getregisterint;
emit_reg_reg(A_MOV,S_L,R_EAX,location.reference.base);
if popeax then
emit_reg(A_POP,S_L,R_EAX);
@ -194,7 +194,7 @@ implementation
end;
if (lexlevel>(symtable.symtablelevel)) then
begin
hregister:=getregister32;
hregister:=getregisterint;
{ make a reference }
hp:=new_reference(procinfo^.framepointer,
@ -256,7 +256,7 @@ implementation
end
else
begin
hregister:=getregister32;
hregister:=getregisterint;
location.reference.base:=hregister;
emit_ref_reg(A_MOV,S_L,
newreference(twithnode(twithsymtable(symtable).withnode).withreference^),
@ -276,7 +276,7 @@ implementation
begin
simple_loadn:=false;
if hregister=R_NO then
hregister:=getregister32;
hregister:=getregisterint;
if location.loc=LOC_CREGISTER then
begin
emit_reg_reg(A_MOV,S_L,
@ -812,7 +812,7 @@ implementation
else
begin
ai:=Taicpu.Op_ref(A_Setcc,S_B,newreference(left.location.reference));
ai.SetCondition(flag_2_cond[right.location.resflags]);
ai.SetCondition(flags_to_cond(right.location.resflags));
exprasmList.concat(ai);
end;
{$IfDef regallocfix}
@ -842,7 +842,7 @@ implementation
if (not inlining_procedure) and
(lexlevel<>funcretsym.owner.symtablelevel) then
begin
hr:=getregister32;
hr:=getregisterint;
hr_valid:=true;
hp:=new_reference(procinfo^.framepointer,procinfo^.framepointer_offset);
emit_ref_reg(A_MOV,S_L,hp,hr);
@ -868,7 +868,7 @@ implementation
if ret_in_param(resulttype.def) then
begin
if not hr_valid then
hr:=getregister32;
hr:=getregisterint;
emit_ref_reg(A_MOV,S_L,newreference(location.reference),hr);
location.reference.base:=hr;
location.reference.offset:=0;
@ -1091,7 +1091,10 @@ begin
end.
{
$Log$
Revision 1.27 2001-12-17 23:16:05 florian
Revision 1.28 2001-12-30 17:24:46 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
Revision 1.27 2001/12/17 23:16:05 florian
* array of const can now take widestring parameters as well
Revision 1.26 2001/11/02 22:58:11 peter

43
compiler/i386/n386mat.pas
View File

@ -56,7 +56,7 @@ implementation
cgbase,temp_gen,pass_1,pass_2,
ncon,
cpubase,
cga,tgcpu,n386util;
cga,tgcpu,n386util,ncgutil;
{*****************************************************************************
TI386MODDIVNODE
@ -97,13 +97,13 @@ implementation
begin
if left.location.loc=LOC_CREGISTER then
begin
hreg1:=getregister32;
hreg1:=getregisterint;
emit_reg_reg(A_MOV,S_L,left.location.register,hreg1);
end
else
begin
del_reference(left.location.reference);
hreg1:=getregister32;
hreg1:=getregisterint;
emit_ref_reg(A_MOV,S_L,newreference(left.location.reference),
hreg1);
end;
@ -329,8 +329,8 @@ implementation
begin
if left.location.loc=LOC_CREGISTER then
begin
hregisterlow:=getregister32;
hregisterhigh:=getregister32;
hregisterlow:=getregisterint;
hregisterhigh:=getregisterint;
emit_reg_reg(A_MOV,S_L,left.location.registerlow,
hregisterlow);
emit_reg_reg(A_MOV,S_L,left.location.registerhigh,
@ -339,8 +339,8 @@ implementation
else
begin
del_reference(left.location.reference);
hregisterlow:=getregister32;
hregisterhigh:=getregister32;
hregisterlow:=getregisterint;
hregisterhigh:=getregisterint;
emit_mov_ref_reg64(left.location.reference,
hregisterlow,
hregisterhigh);
@ -529,14 +529,14 @@ implementation
begin
if left.location.loc=LOC_CREGISTER then
begin
hregister1:=getregister32;
hregister1:=getregisterint;
emit_reg_reg(A_MOV,S_L,left.location.register,
hregister1);
end
else
begin
del_reference(left.location.reference);
hregister1:=getregister32;
hregister1:=getregisterint;
emit_ref_reg(A_MOV,S_L,newreference(left.location.reference),
hregister1);
end;
@ -715,16 +715,16 @@ implementation
end;
LOC_CREGISTER :
begin
location.registerlow:=getregister32;
location.registerhigh:=getregister32;
location.registerlow:=getregisterint;
location.registerhigh:=getregisterint;
emit_reg_reg(A_MOV,S_L,left.location.registerlow,location.registerlow);
emit_reg_reg(A_MOV,S_L,left.location.registerhigh,location.registerhigh);
end;
LOC_REFERENCE,LOC_MEM :
begin
del_reference(left.location.reference);
location.registerlow:=getregister32;
location.registerhigh:=getregister32;
location.registerlow:=getregisterint;
location.registerhigh:=getregisterint;
emit_mov_ref_reg64(left.location.reference,
location.registerlow,
location.registerhigh);
@ -751,7 +751,7 @@ implementation
end;
LOC_CREGISTER:
begin
location.register:=getregister32;
location.register:=getregisterint;
emit_reg_reg(A_MOV,S_L,location.register,
location.register);
emit_reg(A_NEG,S_L,location.register);
@ -795,7 +795,7 @@ implementation
{$endif SUPPORT_MMX}
else
begin
location.register:=getregister32;
location.register:=getregisterint;
emit_ref_reg(A_MOV,S_L,
newreference(left.location.reference),
location.register);
@ -940,8 +940,8 @@ implementation
end;
LOC_CREGISTER :
begin
location.registerlow:=getregister32;
location.registerhigh:=getregister32;
location.registerlow:=getregisterint;
location.registerhigh:=getregisterint;
emit_reg_reg(A_MOV,S_L,left.location.registerlow,location.registerlow);
emit_reg_reg(A_MOV,S_L,left.location.registerhigh,location.registerhigh);
emit_reg(A_NOT,S_L,location.registerlow);
@ -950,8 +950,8 @@ implementation
LOC_REFERENCE,LOC_MEM :
begin
del_reference(left.location.reference);
location.registerlow:=getregister32;
location.registerhigh:=getregister32;
location.registerlow:=getregisterint;
location.registerhigh:=getregisterint;
emit_mov_ref_reg64(left.location.reference,
location.registerlow,
location.registerhigh);
@ -999,7 +999,10 @@ begin
end.
{
$Log$
Revision 1.21 2001-12-29 15:27:24 jonas
Revision 1.22 2001-12-30 17:24:47 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
Revision 1.21 2001/12/29 15:27:24 jonas
* made 'mod powerof2' -> 'and' optimization processor independent
Revision 1.20 2001/12/27 15:33:58 jonas

21
compiler/i386/n386mem.pas
View File

@ -62,7 +62,7 @@ implementation
cgbase,temp_gen,pass_2,
pass_1,nld,ncon,nadd,
cpubase,cpuasm,
cga,tgcpu,n386util;
cgobj,cga,tgcpu,n386util;
{*****************************************************************************
TI386NEWNODE
@ -293,7 +293,7 @@ implementation
else
begin
del_reference(left.location.reference);
location.reference.base:=getregister32;
location.reference.base:=getregisterint;
emit_ref_reg(A_MOV,S_L,
newreference(left.location.reference),
location.reference.base);
@ -338,7 +338,7 @@ implementation
else
begin
del_reference(left.location.reference);
location.reference.base:=getregister32;
location.reference.base:=getregisterint;
emit_ref_reg(A_MOV,S_L,
newreference(left.location.reference),
location.reference.base);
@ -544,7 +544,7 @@ implementation
hightree.free;
hightree:=nil;
end;
emitrangecheck(right,left.resulttype.def);
cg.g_rangecheck(exprasmlist,right,left.resulttype.def);
end;
end;
@ -569,7 +569,7 @@ implementation
end;
LOC_CREGISTER:
begin
ind:=getregister32;
ind:=getregisterint;
case right.resulttype.def.size of
1:
emit_reg_reg(A_MOVZX,S_BL,right.location.register,ind);
@ -581,13 +581,13 @@ implementation
end;
LOC_FLAGS:
begin
ind:=getregister32;
ind:=getregisterint;
emit_flag2reg(right.location.resflags,reg32toreg8(ind));
emit_reg_reg(A_MOVZX,S_BL,reg32toreg8(ind),ind);
end;
LOC_JUMP :
begin
ind:=getregister32;
ind:=getregisterint;
emitlab(truelabel);
truelabel:=otl;
emit_const_reg(A_MOV,S_L,1,ind);
@ -601,7 +601,7 @@ implementation
LOC_REFERENCE,LOC_MEM :
begin
del_reference(right.location.reference);
ind:=getregister32;
ind:=getregisterint;
{ Booleans are stored in an 8 bit memory location, so
the use of MOVL is not correct }
case right.resulttype.def.size of
@ -701,7 +701,10 @@ begin
end.
{
$Log$
Revision 1.18 2001-12-03 21:48:43 peter
Revision 1.19 2001-12-30 17:24:47 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
Revision 1.18 2001/12/03 21:48:43 peter
* freemem change to value parameter
* torddef low/high range changed to int64

358
compiler/i386/n386util.pas
View File

@ -29,9 +29,6 @@ interface
uses
symtype,node;
type
tloadregvars = (lr_dont_load_regvars, lr_load_regvars);
function maybe_push(needed : byte;p : tnode;isint64 : boolean) : boolean;
function maybe_pushfpu(needed : byte;p : tnode) : boolean;
{$ifdef TEMPS_NOT_PUSH}
@ -50,9 +47,7 @@ interface
procedure loadwide2short(source,dest : tnode);
procedure loadinterfacecom(p: tbinarynode);
procedure maketojumpbool(p : tnode; loadregvars: tloadregvars);
procedure emitoverflowcheck(p:tnode);
procedure emitrangecheck(p:tnode;todef:tdef);
procedure firstcomplex(p : tbinarynode);
implementation
@ -229,7 +224,7 @@ implementation
load_regvar_reg(exprasmlist,p.location.register);
exit;
end;
hregister:=getregister32;
hregister:=getregisterint;
{$ifdef TEMPS_NOT_PUSH}
reset_reference(href);
href.base:=procinfo^.frame_pointer;
@ -243,7 +238,7 @@ implementation
p.location.register:=hregister;
if isint64 then
begin
p.location.registerhigh:=getregister32;
p.location.registerhigh:=getregisterint;
{$ifdef TEMPS_NOT_PUSH}
href.offset:=p.temp_offset+4;
emit_ref_reg(A_MOV,S_L,p.location.registerhigh);
@ -277,7 +272,7 @@ implementation
href : treference;
begin
hregister:=getregister32;
hregister:=getregisterint;
reset_reference(href);
href.base:=procinfo^.frame_pointer;
href.offset:=p.temp_offset;
@ -287,7 +282,7 @@ implementation
p.location.register:=hregister;
if isint64 then
begin
p.location.registerhigh:=getregister32;
p.location.registerhigh:=getregisterint;
href.offset:=p.temp_offset+4;
emit_ref_reg(A_MOV,S_L,p.location.registerhigh);
{ set correctly for release ! }
@ -872,67 +867,6 @@ implementation
Emit Functions
*****************************************************************************}
procedure maketojumpbool(p : tnode; loadregvars: tloadregvars);
{
produces jumps to true respectively false labels using boolean expressions
depending on whether the loading of regvars is currently being
synchronized manually (such as in an if-node) or automatically (most of
the other cases where this procedure is called), loadregvars can be
"lr_load_regvars" or "lr_dont_load_regvars"
}
var
opsize : topsize;
storepos : tfileposinfo;
begin
if nf_error in p.flags then
exit;
storepos:=aktfilepos;
aktfilepos:=p.fileinfo;
if is_boolean(p.resulttype.def) then
begin
if loadregvars = lr_load_regvars then
load_all_regvars(exprasmlist);
if is_constboolnode(p) then
begin
if tordconstnode(p).value<>0 then
emitjmp(C_None,truelabel)
else
emitjmp(C_None,falselabel);
end
else
begin
opsize:=def_opsize(p.resulttype.def);
case p.location.loc of
LOC_CREGISTER,LOC_REGISTER : begin
if (p.location.loc = LOC_CREGISTER) then
load_regvar_reg(exprasmlist,p.location.register);
emit_reg_reg(A_OR,opsize,p.location.register,
p.location.register);
ungetregister(p.location.register);
emitjmp(C_NZ,truelabel);
emitjmp(C_None,falselabel);
end;
LOC_MEM,LOC_REFERENCE : begin
emit_const_ref(
A_CMP,opsize,0,newreference(p.location.reference));
del_reference(p.location.reference);
emitjmp(C_NZ,truelabel);
emitjmp(C_None,falselabel);
end;
LOC_FLAGS : begin
emitjmp(flag_2_cond[p.location.resflags],truelabel);
emitjmp(C_None,falselabel);
end;
end;
end;
end
else
CGMessage(type_e_mismatch);
aktfilepos:=storepos;
end;
{ produces if necessary overflowcode }
procedure emitoverflowcheck(p:tnode);
var
@ -952,285 +886,6 @@ implementation
emitlab(hl);
end;
{ produces range check code, while one of the operands is a 64 bit
integer }
procedure emitrangecheck64(p : tnode;todef : tdef);
var
neglabel,
poslabel,
endlabel: tasmlabel;
href : preference;
hreg : tregister;
hdef : torddef;
fromdef : tdef;
opcode : tasmop;
opsize : topsize;
oldregisterdef: boolean;
from_signed,to_signed: boolean;
begin
fromdef:=p.resulttype.def;
from_signed := is_signed(fromdef);
to_signed := is_signed(todef);
if not is_64bitint(todef) then
begin
oldregisterdef := registerdef;
registerdef := false;
{ get the high dword in a register }
if p.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
hreg := p.location.registerhigh
else
begin
hreg := getexplicitregister32(R_EDI);
href := newreference(p.location.reference);
inc(href^.offset,4);
emit_ref_reg(A_MOV,S_L,href,hreg);
end;
getlabel(poslabel);
{ check high dword, must be 0 (for positive numbers) }
emit_reg_reg(A_TEST,S_L,hreg,hreg);
emitjmp(C_E,poslabel);
{ It can also be $ffffffff, but only for negative numbers }
if from_signed and to_signed then
begin
getlabel(neglabel);
emit_const_reg(A_CMP,S_L,longint($ffffffff),hreg);
emitjmp(C_E,neglabel);
end;
if hreg = R_EDI then
ungetregister32(hreg);
{ For all other values we have a range check error }
emitcall('FPC_RANGEERROR');
{ if the high dword = 0, the low dword can be considered a }
{ simple cardinal }
emitlab(poslabel);
hdef:=torddef.create(u32bit,0,longint($ffffffff));
{ the real p.resulttype.def is already saved in fromdef }
p.resulttype.def := hdef;
emitrangecheck(p,todef);
hdef.free;
{ restore original resulttype.def }
p.resulttype.def := todef;
if from_signed and to_signed then
begin
getlabel(endlabel);
emitjmp(C_None,endlabel);
{ if the high dword = $ffffffff, then the low dword (when }
{ considered as a longint) must be < 0 }
emitlab(neglabel);
if p.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
hreg := p.location.registerlow
else
begin
hreg := getexplicitregister32(R_EDI);
emit_ref_reg(A_MOV,S_L,
newreference(p.location.reference),hreg);
end;
{ get a new neglabel (JM) }
getlabel(neglabel);
emit_reg_reg(A_TEST,S_L,hreg,hreg);
if hreg = R_EDI then
ungetregister32(hreg);
emitjmp(C_L,neglabel);
emitcall('FPC_RANGEERROR');
{ if we get here, the 64bit value lies between }
{ longint($80000000) and -1 (JM) }
emitlab(neglabel);
hdef:=torddef.create(s32bit,longint($80000000),-1);
p.resulttype.def := hdef;
emitrangecheck(p,todef);
hdef.free;
emitlab(endlabel);
end;
registerdef := oldregisterdef;
p.resulttype.def := fromdef;
{ restore p's resulttype.def }
end
else
{ todef = 64bit int }
{ no 64bit subranges supported, so only a small check is necessary }
{ if both are signed or both are unsigned, no problem! }
if (from_signed xor to_signed) and
{ also not if the fromdef is unsigned and < 64bit, since that will }
{ always fit in a 64bit int (todef is 64bit) }
(from_signed or
(torddef(fromdef).typ = u64bit)) then
begin
{ in all cases, there is only a problem if the higest bit is set }
if p.location.loc in [LOC_REGISTER,LOC_CREGISTER] then
if is_64bitint(fromdef) then
hreg := p.location.registerhigh
else
hreg := p.location.register
else
begin
hreg := getexplicitregister32(R_EDI);
case p.resulttype.def.size of
1: opsize := S_BL;
2: opsize := S_WL;
4,8: opsize := S_L;
end;
if opsize in [S_BL,S_WL] then
if from_signed then
opcode := A_MOVSX
else opcode := A_MOVZX
else
opcode := A_MOV;
href := newreference(p.location.reference);
if p.resulttype.def.size = 8 then
inc(href^.offset,4);
emit_ref_reg(opcode,opsize,href,hreg);
end;
getlabel(poslabel);
emit_reg_reg(A_TEST,regsize(hreg),hreg,hreg);
if hreg = R_EDI then
ungetregister32(hreg);
emitjmp(C_GE,poslabel);
emitcall('FPC_RANGEERROR');
emitlab(poslabel);
end;
end;
{ produces if necessary rangecheckcode }
procedure emitrangecheck(p:tnode;todef:tdef);
{
generate range checking code for the value at location t. The
type used is the checked against todefs ranges. fromdef (p.resulttype.def)
is the original type used at that location, when both defs are
equal the check is also insert (needed for succ,pref,inc,dec)
}
var
neglabel : tasmlabel;
opsize : topsize;
op : tasmop;
fromdef : tdef;
lto,hto,
lfrom,hfrom : TConstExprInt;
is_reg : boolean;
begin
{ range checking on and range checkable value? }
if not(cs_check_range in aktlocalswitches) or
not(todef.deftype in [orddef,enumdef,arraydef]) then
exit;
{ only check when assigning to scalar, subranges are different,
when todef=fromdef then the check is always generated }
fromdef:=p.resulttype.def;
{ no range check if from and to are equal and are both longint/dword or }
{ int64/qword, since such operations can at most cause overflows (JM) }
if (fromdef = todef) and
{ then fromdef and todef can only be orddefs }
(((torddef(fromdef).typ = s32bit) and
(torddef(fromdef).low = longint($80000000)) and
(torddef(fromdef).high = $7fffffff)) or
((torddef(fromdef).typ = u32bit) and
(torddef(fromdef).low = 0) and
(torddef(fromdef).high = longint($ffffffff))) or
is_64bitint(fromdef)) then
exit;
if is_64bitint(fromdef) or is_64bitint(todef) then
begin
emitrangecheck64(p,todef);
exit;
end;
{we also need lto and hto when checking if we need to use doublebound!
(JM)}
getrange(todef,lto,hto);
if todef<>fromdef then
begin
getrange(p.resulttype.def,lfrom,hfrom);
{ first check for not being u32bit, then if the to is bigger than
from }
if (lto<hto) and (lfrom<hfrom) and
(lto<=lfrom) and (hto>=hfrom) then
exit;
end;
{ generate the rangecheck code for the def where we are going to
store the result }
{ get op and opsize }
opsize:=def2def_opsize(fromdef,u32bittype.def);
if opsize in [S_B,S_W,S_L] then
op:=A_MOV
else
if is_signed(fromdef) then
op:=A_MOVSX
else
op:=A_MOVZX;
is_reg:=(p.location.loc in [LOC_REGISTER,LOC_CREGISTER]);
{ use the trick that }
{ a <= x <= b <=> 0 <= x-a <= b-a <=> cardinal(x-a) <= cardinal(b-a) }
{ To be able to do that, we have to make sure however that either }
{ fromdef and todef are both signed or unsigned, or that we leave }
{ the parts < 0 and > maxlongint out }
{ is_signed now also works for arrays (it checks the rangetype) (JM) }
if is_signed(fromdef) xor is_signed(todef) then
if is_signed(fromdef) then
{ from is signed, to is unsigned }
begin
{ if high(from) < 0 -> always range error }
if (hfrom < 0) or
{ if low(to) > maxlongint (== < 0, since we only have }
{ longints here), also range error }
(lto < 0) then
begin
emitcall('FPC_RANGEERROR');
exit
end;
{ to is unsigned -> hto < 0 == hto > maxlongint }
{ since from is signed, values > maxlongint are < 0 and must }
{ be rejected }
if hto < 0 then
hto := maxlongint;
end
else
{ from is unsigned, to is signed }
begin
if (lfrom < 0) or
(hto < 0) then
begin
emitcall('FPC_RANGEERROR');
exit
end;
{ since from is unsigned, values > maxlongint are < 0 and must }
{ be rejected }
if lto < 0 then
lto := 0;
end;
getexplicitregister32(R_EDI);
if is_reg and
(opsize = S_L) then
emit_ref_reg(A_LEA,opsize,new_reference(p.location.register,-lto),
R_EDI)
else
begin
if is_reg then
emit_reg_reg(op,opsize,p.location.register,R_EDI)
else
emit_ref_reg(op,opsize,newreference(p.location.reference),R_EDI);
if lto <> 0 then
emit_const_reg(A_SUB,S_L,lto,R_EDI);
end;
emit_const_reg(A_CMP,S_L,hto-lto,R_EDI);
ungetregister32(R_EDI);
getlabel(neglabel);
emitjmp(C_BE,neglabel);
emitcall('FPC_RANGEERROR');
emitlab(neglabel);
end;
{ DO NOT RELY on the fact that the tnode is not yet swaped
because of inlining code PM }
procedure firstcomplex(p : tbinarynode);
@ -1544,7 +1199,10 @@ implementation
end.
{
$Log$
Revision 1.24 2001-12-03 21:48:43 peter
Revision 1.25 2001-12-30 17:24:47 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
Revision 1.24 2001/12/03 21:48:43 peter
* freemem change to value parameter
* torddef low/high range changed to int64

9
compiler/ncgflw.pas
View File

@ -72,9 +72,7 @@ implementation
cpubase,cpuasm,cpuinfo,
nld,ncon,
cga,tgcpu,
{$ifdef i386}
n386util,
{$endif}
ncgutil,
tainst,regvars,cgobj,cgcpu;
{*****************************************************************************
@ -651,7 +649,10 @@ begin
end.
{
$Log$
Revision 1.6 2001-12-29 15:28:57 jonas
Revision 1.7 2001-12-30 17:24:48 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
Revision 1.6 2001/12/29 15:28:57 jonas
* powerpc/cgcpu.pas compiles :)
* several powerpc-related fixes
* cpuasm unit is now based on common tainst unit

220
compiler/ncgutil.pas Normal file
View File

@ -0,0 +1,220 @@
{
$Id$
Copyright (c) 1998-2000 by Florian Klaempfl
Helper routines for all code generators
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit ncgutil;
{$i defines.inc}
interface
uses
node;
type
tloadregvars = (lr_dont_load_regvars, lr_load_regvars);
{$ifdef TEMPS_NOT_PUSH}
function maybe_savetotemp(needed : byte;p : tnode;isint64 : boolean) : boolean;
procedure restorefromtemp(p : tnode;isint64 : boolean);
{$endif TEMPS_NOT_PUSH}
procedure maketojumpbool(p : tnode; loadregvars: tloadregvars);
implementation
uses
globals,globtype,systems,verbose,
types,
aasm,cgbase,regvars,
temp_gen,ncon,
cpubase,cpuinfo,tgcpu,cgobj,cgcpu,cg64f32;
{$ifdef TEMPS_NOT_PUSH}
function maybe_savetotemp(needed : byte;p : tnode;isint64 : boolean) : boolean;
var
href : treference;
scratchreg : tregister;
saved : boolean;
begin
if needed>usablereg32 then
begin
if (p.location.loc=LOC_REGISTER) then
begin
if isint64 then
begin
gettempofsizereference(8,href);
p.temp_offset:=href.offset;
{ do we have a 64bit processor? }
if sizeof(aword) < 8 then
begin
tcg64f32(cg).a_load64_reg_ref(exprasmlist,
p.location.registerlow,p.location.registerhigh,
href);
ungetregister(p.location.registerhigh);
ungetregister(p.location.registerlow);
end
else
begin
cg.a_load_reg_ref(exprasmlist,OS_64,
p.location.register,href);
ungetregister(p.location.register);
end;
end
else
begin
gettempofsizereference(4,href);
p.temp_offset:=href.offset;
cg.a_load_reg_ref(exprasmlist,OS_32,
p.location.register,href);
ungetregister(p.location.register);
end;
saved:=true;
end
else if (p.location.loc in [LOC_MEM,LOC_REFERENCE]) and
((p.location.reference.base<>R_NO) or
(p.location.reference.index<>R_NO)
) then
begin
scratchreg := cg.get_scratch_reg(exprasmlist);
cg.a_loadaddress_ref_reg(exprasmlist,
p.location.reference,scratchreg);
del_reference(p.location.reference);
gettempofsizereference(target_info.size_of_pointer,href);
cg.a_load_reg_ref(exprasmlist,OS_ADDR,scratchreg,href);
cg.free_scratch_reg(exprasmlist,scratchreg);
p.temp_offset:=href.offset;
saved:=true;
end
else saved:=false;
end
else saved:=false;
maybe_savetotemp:=saved;
end;
procedure restorefromtemp(p : tnode;isint64 : boolean);
var
hregister : tregister;
href : treference;
begin
hregister:=getregisterint;
reset_reference(href);
href.base:=procinfo^.framepointer;
href.offset:=p.temp_offset;
if (p.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
begin
p.location.registerlow:=hregister;
if isint64 then
begin
if sizeof(aword) < 8 then
begin
p.location.registerhigh:=getregisterint;
tcg64f32(cg).a_load64_ref_reg(exprasmlist,
href,p.location.registerlow,p.location.registerhigh);
end
else
cg.a_load_ref_reg(exprasmlist,OS_64,href,
p.location.register);
end
else
cg.a_load_ref_reg(exprasmlist,OS_32,href,p.location.register);
end
else
begin
reset_reference(p.location.reference);
p.location.reference.base:=hregister;
{ Why is this done? We can never be sure about p^.left
because otherwise secondload fails PM
set_location(p^.left^.location,p^.location);}
end;
ungetiftemp(href);
end;
{$endif TEMPS_NOT_PUSH}
procedure maketojumpbool(p : tnode; loadregvars: tloadregvars);
{
produces jumps to true respectively false labels using boolean expressions
depending on whether the loading of regvars is currently being
synchronized manually (such as in an if-node) or automatically (most of
the other cases where this procedure is called), loadregvars can be
"lr_load_regvars" or "lr_dont_load_regvars"
}
var
opsize : tcgsize;
storepos : tfileposinfo;
begin
if nf_error in p.flags then
exit;
storepos:=aktfilepos;
aktfilepos:=p.fileinfo;
if is_boolean(p.resulttype.def) then
begin
if loadregvars = lr_load_regvars then
load_all_regvars(exprasmlist);
if is_constboolnode(p) then
begin
if tordconstnode(p).value<>0 then
cg.a_jmp_cond(exprasmlist,OC_NONE,truelabel)
else
cg.a_jmp_cond(exprasmlist,OC_NONE,falselabel)
end
else
begin
opsize:=def_cgsize(p.resulttype.def);
case p.location.loc of
LOC_CREGISTER,LOC_REGISTER,LOC_MEM,LOC_REFERENCE :
begin
if (p.location.loc = LOC_CREGISTER) then
load_regvar_reg(exprasmlist,p.location.register);
cg.a_cmp_const_loc_label(exprasmlist,opsize,OC_NE,
0,p.location,truelabel);
{ !!! should happen right after cmp (JM) }
del_location(p.location);
cg.a_jmp_cond(exprasmlist,OC_NONE,falselabel);
end;
LOC_FLAGS :
begin
cg.a_jmp_flags(exprasmlist,p.location.resflags,
truelabel);
cg.a_jmp_cond(exprasmlist,OC_None,falselabel);
end;
end;
end;
end
else
internalerror(200112305);
aktfilepos:=storepos;
end;
end.
{
$Log$
Revision 1.1 2001-12-30 17:24:48 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
}

292
compiler/powerpc/cgcpu.pas
View File

@ -48,6 +48,11 @@ unit cgcpu;
procedure a_op_const_reg(list : taasmoutput; Op: TOpCG; a: AWord; reg: TRegister); override;
procedure a_op_reg_reg(list : taasmoutput; Op: TOpCG; size: TCGSize; src, dst: TRegister); override;
procedure a_op_const_reg_reg(list: taasmoutput; op: TOpCg;
size: tcgsize; a: aword; src, dst: tregister); override;
procedure a_op_reg_reg_reg(list: taasmoutput; op: TOpCg;
size: tcgsize; src1, src2, dst: tregister); override;
{ move instructions }
procedure a_load_const_reg(list : taasmoutput; size: tcgsize; a : aword;reg : tregister);override;
procedure a_load_reg_ref(list : taasmoutput; size: tcgsize; reg : tregister;const ref : treference);override;
@ -61,6 +66,8 @@ unit cgcpu;
procedure a_cmp_reg_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;reg1,reg2 : tregister;l : tasmlabel); override;
procedure a_jmp_cond(list : taasmoutput;cond : TOpCmp;l: tasmlabel); override;
procedure a_jmp_flags(list : taasmoutput;const f : TResFlags;l: tasmlabel); override;
procedure g_flags2reg(list: taasmoutput; const f: TResFlags; reg: TRegister); override;
@ -78,12 +85,6 @@ unit cgcpu;
{ that's the case, we can use rlwinm to do an AND operation }
function get_rlwi_const(a: longint; var l1, l2: longint): boolean;
procedure a_op_const_reg_reg(list: taasmoutput; op: TOpCg;
a: aword; src, dst: tregister);
procedure a_op_reg_reg_reg(list: taasmoutput; op: TOpCg; src1, src2,
dst: tregister);
private
procedure g_return_from_proc_sysv(list : taasmoutput;parasize : aword);
@ -101,7 +102,7 @@ unit cgcpu;
{ creates the correct branch instruction for a given combination }
{ of asmcondflags and destination addressing mode }
procedure a_jmp(list: taasmoutput; op: tasmop;
c: tasmcondflag; l: tasmlabel);
c: tasmcondflag; crval: longint; l: tasmlabel);
end;
@ -332,30 +333,19 @@ const
scratch_register: TRegister;
begin
Case Op of
OP_DIV, OP_IDIV, OP_IMUL, OP_MUL:
If (Op = OP_IMUL) And (longint(a) >= -32768) And
(longint(a) <= 32767) Then
list.concat(taicpu.op_reg_reg_const(A_MULLI,reg,reg,a))
Else
Begin
scratch_register := get_scratch_reg(list);
a_load_const_reg(list,OS_32,a,scratch_register);
list.concat(taicpu.op_reg_reg_reg(TOpCG2AsmOpConstLo[Op],
reg,scratch_register,reg));
free_scratch_reg(list,scratch_register);
End;
OP_ADD, OP_AND, OP_OR, OP_SUB,OP_XOR:
a_op_const_reg_reg(list,op,a,reg,reg);
case op of
OP_DIV, OP_IDIV, OP_IMUL, OP_MUL, OP_ADD, OP_AND, OP_OR, OP_SUB,
OP_XOR:
a_op_const_reg_reg(list,op,OS_32,a,reg,reg);
OP_SHL,OP_SHR,OP_SAR:
Begin
if (a and 31) <> 0 Then
begin
if (a and 31) <> 0 then
list.concat(taicpu.op_reg_reg_const(
TOpCG2AsmOpConstLo[Op],reg,reg,a and 31));
If (a shr 5) <> 0 Then
InternalError(68991);
End
Else InternalError(68992);
TOpCG2AsmOpConstLo[op],reg,reg,a and 31));
if (a shr 5) <> 0 then
internalError(68991);
end
else internalError(68992);
end;
end;
@ -363,9 +353,123 @@ const
procedure tcgppc.a_op_reg_reg(list : taasmoutput; Op: TOpCG; size: TCGSize; src, dst: TRegister);
begin
a_op_reg_reg_reg(list,op,src,dst,dst);
a_op_reg_reg_reg(list,op,OS_32,src,dst,dst);
end;
procedure tcgppc.a_op_const_reg_reg(list: taasmoutput; op: TOpCg;
size: tcgsize; a: aword; src, dst: tregister);
var
l1,l2: longint;
var
oplo, ophi: tasmop;
scratchreg: tregister;
useReg: boolean;
begin
ophi := TOpCG2AsmOpConstHi[op];
oplo := TOpCG2AsmOpConstLo[op];
{ constants in a PPC instruction are always interpreted as signed }
{ 16bit values, so if the value is between low(smallint) and }
{ high(smallint), it's easy }
if (op in [OP_ADD,OP_SUB,OP_AND,OP_OR,OP_XOR]) then
begin
if (longint(a) >= low(smallint)) and
(longint(a) <= high(smallint)) then
begin
list.concat(taicpu.op_reg_reg_const(oplo,dst,src,a));
exit;
end;
{ all basic constant instructions also have a shifted form that }
{ works only on the highest 16bits, so if low(a) is 0, we can }
{ use that one }
if (lo(a) = 0) then
begin
list.concat(taicpu.op_reg_reg_const(ophi,dst,src,hi(a)));
exit;
end;
end;
{ otherwise, the instructions we can generate depend on the }
{ operation }
useReg := false;
case op of
OP_DIV, OP_IDIV, OP_IMUL, OP_MUL:
if (Op = OP_IMUL) and (longint(a) >= -32768) and
(longint(a) <= 32767) then
list.concat(taicpu.op_reg_reg_const(A_MULLI,dst,src,a))
else
usereg := true;
OP_ADD,OP_SUB:
begin
list.concat(taicpu.op_reg_reg_const(oplo,dst,src,low(a)));
list.concat(taicpu.op_reg_reg_const(ophi,dst,dst,
high(a) + ord(smallint(a) < 0)));
end;
OP_OR:
{ try to use rlwimi }
if get_rlwi_const(a,l1,l2) then
begin
if src <> dst then
list.concat(taicpu.op_reg_reg(A_MR,dst,src));
scratchreg := get_scratch_reg(list);
list.concat(taicpu.op_reg_const(A_LI,scratchreg,-1));
list.concat(taicpu.op_reg_reg_const_const_const(A_RLWIMI,dst,
scratchreg,0,l1,l2));
free_scratch_reg(list,scratchreg);
end
else
useReg := true;
OP_AND:
{ try to use rlwinm }
if get_rlwi_const(a,l1,l2) then
list.concat(taicpu.op_reg_reg_const_const_const(A_RLWINM,dst,
src,0,l1,l2))
else
useReg := true;
OP_XOR:
useReg := true;
OP_SHL,OP_SHR,OP_SAR:
begin
if (a and 31) <> 0 Then
list.concat(taicpu.op_reg_reg_const(
TOpCG2AsmOpConstLo[Op],dst,src,a and 31));
if (a shr 5) <> 0 then
internalError(68991);
end
else
internalerror(200109091);
end;
{ if all else failed, load the constant in a register and then }
{ perform the operation }
if useReg then
begin
scratchreg := get_scratch_reg(list);
a_load_const_reg(list,OS_32,a,scratchreg);
a_op_reg_reg_reg(list,op,OS_32,scratchreg,src,dst);
free_scratch_reg(list,scratchreg);
end;
end;
procedure tcgppc.a_op_reg_reg_reg(list: taasmoutput; op: TOpCg;
size: tcgsize; src1, src2, dst: tregister);
const
op_reg_reg_opcg2asmop: array[TOpCG] of tasmop =
(A_ADD,A_AND,A_DIVWU,A_DIVW,A_MULLW,A_MULLW,A_NEG,A_NOT,A_OR,
A_SRAW,A_SLW,A_SRW,A_SUB,A_XOR);
begin
case op of
OP_NEG,OP_NOT:
list.concat(taicpu.op_reg_reg(op_reg_reg_opcg2asmop[op],dst,dst));
else
list.concat(taicpu.op_reg_reg_reg(op_reg_reg_opcg2asmop[op],dst,src2,src1));
end;
end;
{*************** compare instructructions ****************}
procedure tcgppc.a_cmp_const_reg_label(list : taasmoutput;size : tcgsize;cmp_op : topcmp;a : aword;reg : tregister;
@ -398,7 +502,7 @@ const
list.concat(taicpu.op_reg_reg_reg(A_CMPL,R_CR0,reg,scratch_register));
free_scratch_reg(list,scratch_register);
end;
a_jmp(list,A_BC,TOpCmp2AsmCond[cmp_op],l);
a_jmp(list,A_BC,TOpCmp2AsmCond[cmp_op],0,l);
end;
@ -414,16 +518,24 @@ const
op := A_CMP
else op := A_CMPL;
list.concat(taicpu.op_reg_reg_reg(op,R_CR0,reg1,reg2));
a_jmp(list,A_BC,TOpCmp2AsmCond[cmp_op],l);
a_jmp(list,A_BC,TOpCmp2AsmCond[cmp_op],0,l);
end;
procedure tcgppc.a_jmp_cond(list : taasmoutput;cond : TOpCmp;l: tasmlabel);
begin
a_jmp(list,A_BC,TOpCmp2AsmCond[cond],l);
a_jmp(list,A_BC,TOpCmp2AsmCond[cond],0,l);
end;
procedure tcgppc.a_jmp_flags(list : taasmoutput;const f : TResFlags;l: tasmlabel);
var
c: tasmcond;
begin
c := flags_to_cond(f);
a_jmp(list,A_BC,c.cond,longint(c.cr),l);
end;
procedure tcgppc.g_flags2reg(list: taasmoutput; const f: TResFlags; reg: TRegister);
@ -434,7 +546,7 @@ const
begin
{ get the bit to extract from the conditional register + its }
{ requested value (0 or 1) }
testbit := (f.cr * 4);
testbit := (longint(f.cr) * 4);
case f.flag of
F_EQ,F_NE:
bitvalue := f.flag = F_EQ;
@ -465,7 +577,7 @@ const
end;
(*
procedure tcgppc.g_flags2reg(list: taasmoutput; const f: TAsmCond; reg: TRegister);
procedure tcgppc.g_cond2reg(list: taasmoutput; const f: TAsmCond; reg: TRegister);
var
testbit: byte;
@ -696,7 +808,7 @@ const
end;
if ref.offset <> 0 Then
if ref.base <> R_NO then
a_op_const_reg_reg(list,OP_ADD,ref.offset,ref.base,r)
a_op_const_reg_reg(list,OP_ADD,OS_32,ref.offset,ref.base,r)
{ FixRef makes sure that "(ref.index <> R_NO) and (ref.offset <> 0)" never}
{ occurs, so now only ref.offset has to be loaded }
else a_load_const_reg(list, OS_32, ref.offset, r)
@ -764,7 +876,7 @@ const
list.concat(taicpu.op_reg_reg_const(A_CMPI,R_CR0,countreg,0));
list.concat(taicpu.op_reg_ref(A_STWU,tempreg,newreference(dst)));
list.concat(taicpu.op_reg_reg_const(A_SUBI,countreg,countreg,1));
a_jmp(list,A_BC,C_NE,lab);
a_jmp(list,A_BC,C_NE,0,lab);
free_scratch_reg(list,countreg);
end
else
@ -939,102 +1051,6 @@ const
get_rlwi_const := true;
end;
procedure tcgppc.a_op_const_reg_reg(list: taasmoutput; op: TOpCg;
a: aword; src, dst: tregister);
var
l1,l2: longint;
var
oplo, ophi: tasmop;
scratchreg: tregister;
useReg: boolean;
begin
ophi := TOpCG2AsmOpConstHi[op];
oplo := TOpCG2AsmOpConstLo[op];
{ constants in a PPC instruction are always interpreted as signed }
{ 16bit values, so if the value is between low(smallint) and }
{ high(smallint), it's easy }
if (longint(a) >= low(smallint)) and
(longint(a) <= high(smallint)) then
begin
list.concat(taicpu.op_reg_reg_const(oplo,dst,src,a));
exit;
end;
{ all basic constant instructions also have a shifted form that }
{ works only on the highest 16bits, so if low(a) is 0, we can }
{ use that one }
if (lo(a) = 0) then
begin
list.concat(taicpu.op_reg_reg_const(ophi,dst,src,hi(a)));
exit;
end;
{ otherwise, the instructions we can generate depend on the }
{ operation }
useReg := false;
case op of
OP_ADD,OP_SUB:
begin
list.concat(taicpu.op_reg_reg_const(oplo,dst,src,low(a)));
list.concat(taicpu.op_reg_reg_const(ophi,dst,dst,
high(a) + ord(smallint(a) < 0)));
end;
OP_OR:
{ try to use rlwimi }
if get_rlwi_const(a,l1,l2) then
begin
if src <> dst then
list.concat(taicpu.op_reg_reg(A_MR,dst,src));
scratchreg := get_scratch_reg(list);
list.concat(taicpu.op_reg_const(A_LI,scratchreg,-1));
list.concat(taicpu.op_reg_reg_const_const_const(A_RLWIMI,dst,
scratchreg,0,l1,l2));
free_scratch_reg(list,scratchreg);
end
else
useReg := true;
OP_AND:
{ try to use rlwinm }
if get_rlwi_const(a,l1,l2) then
list.concat(taicpu.op_reg_reg_const_const_const(A_RLWINM,dst,
src,0,l1,l2))
else
useReg := true;
OP_XOR:
useReg := true;
else
internalerror(200109091);
end;
{ if all else failed, load the constant in a register and then }
{ perform the operation }
if useReg then
begin
scratchreg := get_scratch_reg(list);
a_load_const_reg(list,OS_32,a,scratchreg);
a_op_reg_reg_reg(list,op,scratchreg,src,dst);
free_scratch_reg(list,scratchreg);
end;
end;
procedure tcgppc.a_op_reg_reg_reg(list: taasmoutput; op: TOpCg;
src1, src2, dst: tregister);
const
op_reg_reg_opcg2asmop: array[TOpCG] of tasmop =
(A_ADD,A_AND,A_DIVWU,A_DIVW,A_MULLW,A_MULLW,A_NEG,A_NOT,A_OR,
A_SRAW,A_SLW,A_SRW,A_SUB,A_XOR);
begin
case op of
OP_NEG,OP_NOT:
list.concat(taicpu.op_reg_reg(op_reg_reg_opcg2asmop[op],dst,dst));
else
list.concat(taicpu.op_reg_reg_reg(op_reg_reg_opcg2asmop[op],dst,src2,src1));
end;
end;
procedure tcgppc.a_load_store(list:taasmoutput;op: tasmop;reg:tregister;
ref: treference);
@ -1066,13 +1082,14 @@ const
procedure tcgppc.a_jmp(list: taasmoutput; op: tasmop; c: tasmcondflag;
l: tasmlabel);
crval: longint; l: tasmlabel);
var
p: taicpu;
begin
p := taicpu.op_sym(op,newasmsymbol(l.name));
create_cond_norm(c,0,p.condition);
create_cond_norm(c,crval,p.condition);
p.is_jmp := true;
list.concat(p)
end;
@ -1081,7 +1098,10 @@ begin
end.
{
$Log$
Revision 1.9 2001-12-29 15:28:58 jonas
Revision 1.10 2001-12-30 17:24:48 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
Revision 1.9 2001/12/29 15:28:58 jonas
* powerpc/cgcpu.pas compiles :)
* several powerpc-related fixes
* cpuasm unit is now based on common tainst unit

32
compiler/powerpc/cpubase.pas
View File

@ -209,8 +209,10 @@ type
{$ifndef tp}
{$minenumsize 1}
{$endif tp}
TAsmCondFlag = (C_None { unconditional junps },
TAsmCondFlag = (C_None { unconditional jumps },
{ conditions when not using ctr decrement etc }
{ TO DO: OV and CA. They're somewhere in bits 0:3 of XER, but can be }
{ brought to CRx with the mcrxr instruction }
C_LT,C_LE,C_EQ,C_GE,C_GT,C_NL,C_NE,C_NG,C_SO,C_NS,C_UN,C_NU,
{ conditions when using ctr decrement etc }
C_T,C_F,C_DNZ,C_DNZT,C_DNZF,C_DZ,C_DZT,C_DZF);
@ -262,7 +264,7 @@ const
type
TResFlagsEnum = (F_EQ,F_NE,F_LT,F_LE,F_GT,F_GE,F_SO,F_FX,F_FEX,F_VX,F_OX);
TResFlags = record
cr: byte;
cr: R_CR0..R_CR7;
flag: TResFlagsEnum;
end;
@ -462,6 +464,7 @@ const
procedure inverse_flags(var f: TResFlags);
procedure inverse_cond(c: TAsmCond;var r : TAsmCond);
function flags_to_cond(const f: TResFlags) : TAsmCond;
procedure create_cond_imm(BO,BI:byte;var r : TAsmCond);
procedure create_cond_norm(cond: TAsmCondFlag; cr: byte;var r : TasmCond);
@ -479,11 +482,12 @@ const
implementation
{$ifdef heaptrc}
uses
ppheap;
verbose
{$ifdef heaptrc}
,ppheap
{$endif heaptrc}
;
{*****************************************************************************
Helpers
*****************************************************************************}
@ -543,6 +547,7 @@ implementation
f.flag := flagsinvers[f.flag];
end;
procedure inverse_cond(c: TAsmCond;var r : TAsmCond);
const
inv_condflags:array[TAsmCondFlag] of TAsmCondFlag=(C_None,
@ -553,6 +558,18 @@ implementation
r := c;
end;
function flags_to_cond(const f: TResFlags) : TAsmCond;
const
flag_2_cond: array[F_EQ..F_SO] of TAsmCondFlag =
(C_EQ,C_NE,C_LT,C_LE,C_GT,C_GE,C_SO);
begin
if f.flag > high(flag_2_cond) then
internalerror(200112301);
result.simple := true;
result.cr := f.cr;
result.cond := flag_2_cond[f.flag];
end;
procedure create_cond_imm(BO,BI:byte;var r : TAsmCond);
begin
r.simple := false;
@ -612,7 +629,10 @@ implementation
end.
{
$Log$
Revision 1.5 2001-12-29 15:28:58 jonas
Revision 1.6 2001-12-30 17:24:48 jonas
* range checking is now processor independent (part in cgobj, part in cg64f32) and should work correctly again (it needed some changes after the changes of the low and high of tordef's to int64) * maketojumpbool() is now processor independent (in ncgutil) * getregister32 is now called getregisterint
Revision 1.5 2001/12/29 15:28:58 jonas
* powerpc/cgcpu.pas compiles :)
* several powerpc-related fixes
* cpuasm unit is now based on common tainst unit