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

* new internal set format for big endian systems. Advantages:

Browse Source 
* varsets ({$packset x}) are now supported on big endian targets
    * gdb now displays sets properly on big endian systems
    * cleanup of generic set code (in, include/exclude, helpers), all
      based on "bitpacked array[] of 0..1" now
  * there are no helpers available yet to convert sets from the old to
    the new format, because the set format will change again slightly
    in the near future (so that e.g. a set of 24..31 will be stored in
    1 byte), and creating two classes of set conversion helpers would
    confuse things (i.e., it's not recommended to use trunk currently for
    programs  which load sets stored to disk by big endian programs compiled
    by previous FPC versions)
  * cross-endian compiling has been tested and still works, but one case
    is not supported: compiling a compiler for a different endianess
    using a starting compiler from before the current revision (so first
    cycle natively, and then use the newly created compiler to create a
    cross-compiler)

git-svn-id: trunk@7395 -
This commit is contained in:
Jonas Maebe 2007-05-19 17:15:15 +00:00
parent abd6b9c3f1
commit a0b57eddb5
20 changed files with 703 additions and 577 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -6933,6 +6933,7 @@ tests/test/tset4.pp svneol=native#text/plain
tests/test/tset5.pp svneol=native#text/plain
tests/test/tset5a.pp svneol=native#text/plain
tests/test/tset6.pp svneol=native#text/plain
tests/test/tset7.pp svneol=native#text/plain
tests/test/tstack.pp svneol=native#text/plain
tests/test/tstprocv.pp svneol=native#text/plain
tests/test/tstring1.pp svneol=native#text/plain

359
compiler/cgobj.pas
View File

@ -237,6 +237,24 @@ unit cgobj;
procedure a_load_subsetref_subsetreg(list: TAsmlist; fromsubsetsize, tosubsetsize : tcgsize; const fromsref: tsubsetreference; const tosreg: tsubsetregister); virtual;
procedure a_load_subsetreg_subsetref(list: TAsmlist; fromsubsetsize, tosubsetsize : tcgsize; const fromsreg: tsubsetregister; const tosref: tsubsetreference); virtual;
{ bit test instructions }
procedure a_bit_test_reg_reg_reg(list : TAsmList; bitnumbersize,valuesize,destsize: tcgsize;bitnumber,value,destreg: tregister); virtual;
procedure a_bit_test_const_ref_reg(list: TAsmList; destsize: tcgsize; bitnumber: aint; const ref: treference; destreg: tregister); virtual;
procedure a_bit_test_const_reg_reg(list: TAsmList; setregsize, destsize: tcgsize; bitnumber: aint; setreg, destreg: tregister); virtual;
procedure a_bit_test_const_subsetreg_reg(list: TAsmList; setregsize, destsize: tcgsize; bitnumber: aint; const setreg: tsubsetregister; destreg: tregister); virtual;
procedure a_bit_test_reg_ref_reg(list: TAsmList; bitnumbersize, destsize: tcgsize; bitnumber: tregister; const ref: treference; destreg: tregister); virtual;
procedure a_bit_test_reg_loc_reg(list: TAsmList; bitnumbersize, destsize: tcgsize; bitnumber: tregister; const loc: tlocation; destreg: tregister);
procedure a_bit_test_const_loc_reg(list: TAsmList; destsize: tcgsize; bitnumber: aint; const loc: tlocation; destreg: tregister);
{ bit set/clear instructions }
procedure a_bit_set_reg_reg(list : TAsmList; doset: boolean; bitnumbersize, destsize: tcgsize; bitnumber,dest: tregister); virtual;
procedure a_bit_set_const_ref(list: TAsmList; doset: boolean;destsize: tcgsize; bitnumber: aint; const ref: treference); virtual;
procedure a_bit_set_const_reg(list: TAsmList; doset: boolean; destsize: tcgsize; bitnumber: aint; destreg: tregister); virtual;
procedure a_bit_set_const_subsetreg(list: TAsmList; doset: boolean; destsize: tcgsize; bitnumber: aint; const destreg: tsubsetregister); virtual;
procedure a_bit_set_reg_ref(list: TAsmList; doset: boolean; bitnumbersize: tcgsize; bitnumber: tregister; const ref: treference); virtual;
procedure a_bit_set_reg_loc(list: TAsmList; doset: boolean; bitnumbersize: tcgsize; bitnumber: tregister; const loc: tlocation);
procedure a_bit_set_const_loc(list: TAsmList; doset: boolean; bitnumber: aint; const loc: tlocation);
{ fpu move instructions }
procedure a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize:tcgsize; reg1, reg2: tregister); virtual; abstract;
procedure a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tcgsize; const ref: treference; reg: tregister); virtual; abstract;
@ -463,6 +481,10 @@ unit cgobj;
procedure a_load_regconst_subsetref_intern(list : TAsmList; fromsize, subsetsize: tcgsize; fromreg: tregister; const sref: tsubsetreference; slopt: tsubsetloadopt); virtual;
procedure a_load_regconst_subsetreg_intern(list : TAsmList; fromsize, subsetsize: tcgsize; fromreg: tregister; const sreg: tsubsetregister; slopt: tsubsetloadopt); virtual;
function get_bit_const_ref_sref(bitnumber: aint; const ref: treference): tsubsetreference;
function get_bit_const_reg_sreg(setregsize: tcgsize; bitnumber: aint; setreg: tregister): tsubsetregister;
function get_bit_reg_ref_sref(list: TAsmList; bitnumbersize: tcgsize; bitnumber: tregister; const ref: treference): tsubsetreference;
end;
{$ifndef cpu64bit}
@ -1312,7 +1334,7 @@ implementation
loadbitsize := tcgsize2size[loadsize]*8;
{ load the (first part) of the bit sequence }
valuereg := cg.getintregister(list,OS_INT);
valuereg := getintregister(list,OS_INT);
a_load_ref_reg(list,loadsize,OS_INT,sref.ref,valuereg);
if not extra_load then
@ -1401,6 +1423,7 @@ implementation
tmpreg, tmpindexreg, valuereg, extra_value_reg, maskreg: tregister;
tosreg, fromsreg: tsubsetregister;
tmpref: treference;
bitmask: aword;
loadsize: tcgsize;
loadbitsize: byte;
extra_load: boolean;
@ -1413,7 +1436,7 @@ implementation
loadbitsize := tcgsize2size[loadsize]*8;
{ load the (first part) of the bit sequence }
valuereg := cg.getintregister(list,OS_INT);
valuereg := getintregister(list,OS_INT);
a_load_ref_reg(list,loadsize,OS_INT,sref.ref,valuereg);
{ constant offset of bit sequence? }
@ -1441,21 +1464,20 @@ implementation
if (sref.bitlen = AIntBits) then
internalerror(2006081711);
{ calculated correct shiftcount for big endian }
tmpindexreg := getintregister(list,OS_INT);
a_load_reg_reg(list,OS_INT,OS_INT,sref.bitindexreg,tmpindexreg);
if (target_info.endian = endian_big) then
begin
a_op_const_reg(list,OP_SUB,OS_INT,loadbitsize-sref.bitlen,tmpindexreg);
a_op_reg_reg(list,OP_NEG,OS_INT,tmpindexreg,tmpindexreg);
end;
{ zero the bits we have to insert }
if (slopt <> SL_SETMAX) then
begin
maskreg := getintregister(list,OS_INT);
a_load_const_reg(list,OS_INT,aint((aword(1) shl sref.bitlen)-1),maskreg);
a_op_reg_reg(list,OP_SHL,OS_INT,tmpindexreg,maskreg);
if (target_info.endian = endian_big) then
begin
a_load_const_reg(list,OS_INT,aint((aword(1) shl sref.bitlen)-1) shl (loadbitsize-sref.bitlen),maskreg);
a_op_reg_reg(list,OP_SHR,OS_INT,sref.bitindexreg,maskreg);
end
else
begin
a_load_const_reg(list,OS_INT,aint((aword(1) shl sref.bitlen)-1),maskreg);
a_op_reg_reg(list,OP_SHL,OS_INT,sref.bitindexreg,maskreg);
end;
a_op_reg_reg(list,OP_NOT,OS_INT,maskreg,maskreg);
a_op_reg_reg(list,OP_AND,OS_INT,maskreg,valuereg);
end;
@ -1470,9 +1492,25 @@ implementation
a_load_const_reg(list,OS_INT,aint((aword(1) shl sref.bitlen) - 1), tmpreg)
else
a_load_const_reg(list,OS_INT,-1,tmpreg);
if (slopt <> SL_REGNOSRCMASK) then
a_op_const_reg(list,OP_AND,OS_INT,aint((aword(1) shl sref.bitlen)-1),tmpreg);
a_op_reg_reg(list,OP_SHL,OS_INT,tmpindexreg,tmpreg);
if (target_info.endian = endian_big) then
begin
a_op_const_reg(list,OP_SHL,OS_INT,loadbitsize-sref.bitlen,tmpreg);
if not(slopt in [SL_REGNOSRCMASK,SL_SETMAX]) then
begin
if (loadbitsize <> AIntBits) then
bitmask := (((aword(1) shl loadbitsize)-1) xor ((aword(1) shl (loadbitsize-sref.bitlen))-1))
else
bitmask := (high(aword) xor ((aword(1) shl (loadbitsize-sref.bitlen))-1));
a_op_const_reg(list,OP_AND,OS_INT,bitmask,tmpreg);
end;
a_op_reg_reg(list,OP_SHR,OS_INT,sref.bitindexreg,tmpreg);
end
else
begin
if not(slopt in [SL_REGNOSRCMASK,SL_SETMAX]) then
a_op_const_reg(list,OP_AND,OS_INT,aint((aword(1) shl sref.bitlen)-1),tmpreg);
a_op_reg_reg(list,OP_SHL,OS_INT,sref.bitindexreg,tmpreg);
end;
a_op_reg_reg(list,OP_OR,OS_INT,tmpreg,valuereg);
end;
end;
@ -1786,6 +1824,279 @@ implementation
{$undef overflowon}
{$endif}
{ generic bit address calculation routines }
function tcg.get_bit_const_ref_sref(bitnumber: aint; const ref: treference): tsubsetreference;
begin
result.ref:=ref;
inc(result.ref.offset,bitnumber div 8);
result.bitindexreg:=NR_NO;
result.startbit:=bitnumber mod 8;
result.bitlen:=1;
end;
function tcg.get_bit_const_reg_sreg(setregsize: tcgsize; bitnumber: aint; setreg: tregister): tsubsetregister;
begin
result.subsetreg:=setreg;
result.subsetregsize:=setregsize;
{ subsetregs always count from the least significant to the most significant bit }
if (target_info.endian=endian_big) then
result.startbit:=(tcgsize2size[setregsize]*8)-bitnumber-1
else
result.startbit:=bitnumber;
result.bitlen:=1;
end;
function tcg.get_bit_reg_ref_sref(list: TAsmList; bitnumbersize: tcgsize; bitnumber: tregister; const ref: treference): tsubsetreference;
var
tmpreg,
tmpaddrreg: tregister;
begin
result.ref:=ref;
result.startbit:=0;
result.bitlen:=1;
tmpreg:=getintregister(list,bitnumbersize);
a_op_const_reg_reg(list,OP_SHR,bitnumbersize,3,bitnumber,tmpreg);
tmpaddrreg:=cg.getaddressregister(list);
a_load_reg_reg(list,bitnumbersize,OS_ADDR,tmpreg,tmpaddrreg);
if (result.ref.base=NR_NO) then
result.ref.base:=tmpaddrreg
else if (result.ref.index=NR_NO) then
result.ref.index:=tmpaddrreg
else
begin
a_op_reg_reg(list,OP_ADD,OS_ADDR,result.ref.index,tmpaddrreg);
result.ref.index:=tmpaddrreg;
end;
tmpreg:=getintregister(list,OS_INT);
a_op_const_reg_reg(list,OP_AND,OS_INT,7,bitnumber,tmpreg);
result.bitindexreg:=tmpreg;
end;
{ bit testing routines }
procedure tcg.a_bit_test_reg_reg_reg(list : TAsmList; bitnumbersize,valuesize,destsize: tcgsize;bitnumber,value,destreg: tregister);
var
tmpvalue: tregister;
begin
tmpvalue:=cg.getintregister(list,valuesize);
if (target_info.endian=endian_little) then
begin
{ rotate value register "bitnumber" bits to the right }
a_op_reg_reg_reg(list,OP_SHR,valuesize,bitnumber,value,tmpvalue);
{ extract the bit we want }
a_op_const_reg(list,OP_AND,valuesize,1,tmpvalue);
end
else
begin
{ highest (leftmost) bit = bit 0 -> shl bitnumber results in wanted }
{ bit in uppermost position, then move it to the lowest position }
{ "and" is not necessary since combination of shl/shr will clear }
{ all other bits }
a_op_reg_reg_reg(list,OP_SHL,valuesize,bitnumber,value,tmpvalue);
a_op_const_reg(list,OP_SHR,valuesize,tcgsize2size[valuesize]*8-1,tmpvalue);
end;
a_load_reg_reg(list,valuesize,destsize,tmpvalue,destreg);
end;
procedure tcg.a_bit_test_const_ref_reg(list: TAsmList; destsize: tcgsize; bitnumber: aint; const ref: treference; destreg: tregister);
begin
a_load_subsetref_reg(list,OS_8,destsize,get_bit_const_ref_sref(bitnumber,ref),destreg);
end;
procedure tcg.a_bit_test_const_reg_reg(list: TAsmList; setregsize, destsize: tcgsize; bitnumber: aint; setreg, destreg: tregister);
begin
a_load_subsetreg_reg(list,setregsize,destsize,get_bit_const_reg_sreg(setregsize,bitnumber,setreg),destreg);
end;
procedure tcg.a_bit_test_const_subsetreg_reg(list: TAsmList; setregsize, destsize: tcgsize; bitnumber: aint; const setreg: tsubsetregister; destreg: tregister);
var
tmpsreg: tsubsetregister;
begin
{ the first parameter is used to calculate the bit offset in }
{ case of big endian, and therefore must be the size of the }
{ set and not of the whole subsetreg }
tmpsreg:=get_bit_const_reg_sreg(setregsize,bitnumber,setreg.subsetreg);
{ now fix the size of the subsetreg }
tmpsreg.subsetregsize:=setreg.subsetregsize;
{ correct offset of the set in the subsetreg }
inc(tmpsreg.startbit,setreg.startbit);
a_load_subsetreg_reg(list,setregsize,destsize,tmpsreg,destreg);
end;
procedure tcg.a_bit_test_reg_ref_reg(list: TAsmList; bitnumbersize, destsize: tcgsize; bitnumber: tregister; const ref: treference; destreg: tregister);
begin
a_load_subsetref_reg(list,OS_8,destsize,get_bit_reg_ref_sref(list,bitnumbersize,bitnumber,ref),destreg);
end;
procedure tcg.a_bit_test_reg_loc_reg(list: TAsmList; bitnumbersize, destsize: tcgsize; bitnumber: tregister; const loc: tlocation; destreg: tregister);
var
tmpreg: tregister;
begin
case loc.loc of
LOC_REFERENCE,LOC_CREFERENCE:
a_bit_test_reg_ref_reg(list,bitnumbersize,destsize,bitnumber,loc.reference,destreg);
LOC_REGISTER,LOC_CREGISTER,
LOC_SUBSETREG,LOC_CSUBSETREG,
LOC_CONSTANT:
begin
case loc.loc of
LOC_REGISTER,LOC_CREGISTER:
tmpreg:=loc.register;
LOC_SUBSETREG,LOC_CSUBSETREG:
begin
tmpreg:=getintregister(list,loc.size);
a_load_subsetreg_reg(list,loc.size,loc.size,loc.sreg,tmpreg);
end;
LOC_CONSTANT:
begin
tmpreg:=getintregister(list,loc.size);
a_load_const_reg(list,loc.size,loc.value,tmpreg);
end;
end;
a_bit_test_reg_reg_reg(list,bitnumbersize,loc.size,destsize,bitnumber,tmpreg,destreg);
end;
{ LOC_SUBSETREF is not possible, because sets are not (yet) bitpacked }
else
internalerror(2007051701);
end;
end;
procedure tcg.a_bit_test_const_loc_reg(list: TAsmList; destsize: tcgsize; bitnumber: aint; const loc: tlocation; destreg: tregister);
begin
case loc.loc of
LOC_REFERENCE,LOC_CREFERENCE:
a_bit_test_const_ref_reg(list,destsize,bitnumber,loc.reference,destreg);
LOC_REGISTER,LOC_CREGISTER:
a_bit_test_const_reg_reg(list,loc.size,destsize,bitnumber,loc.register,destreg);
LOC_SUBSETREG,LOC_CSUBSETREG:
a_bit_test_const_subsetreg_reg(list,loc.size,destsize,bitnumber,loc.sreg,destreg);
{ LOC_SUBSETREF is not possible, because sets are not (yet) bitpacked }
else
internalerror(2007051702);
end;
end;
{ bit setting/clearing routines }
procedure tcg.a_bit_set_reg_reg(list : TAsmList; doset: boolean; bitnumbersize, destsize: tcgsize; bitnumber,dest: tregister);
var
tmpvalue: tregister;
begin
tmpvalue:=cg.getintregister(list,destsize);
if (target_info.endian=endian_little) then
begin
a_load_const_reg(list,destsize,1,tmpvalue);
{ rotate bit "bitnumber" bits to the left }
a_op_reg_reg(list,OP_SHL,destsize,bitnumber,tmpvalue);
end
else
begin
{ highest (leftmost) bit = bit 0 -> "$80/$8000/$80000000/ ... }
{ shr bitnumber" results in correct mask }
a_load_const_reg(list,destsize,1 shl (tcgsize2size[destsize]*8-1),tmpvalue);
a_op_reg_reg(list,OP_SHR,destsize,bitnumber,tmpvalue);
end;
{ set/clear the bit we want }
if (doset) then
a_op_reg_reg(list,OP_OR,destsize,tmpvalue,dest)
else
begin
a_op_reg_reg(list,OP_NOT,destsize,tmpvalue,tmpvalue);
a_op_reg_reg(list,OP_AND,destsize,tmpvalue,dest)
end;
end;
procedure tcg.a_bit_set_const_ref(list: TAsmList; doset: boolean;destsize: tcgsize; bitnumber: aint; const ref: treference);
begin
a_load_const_subsetref(list,OS_8,ord(doset),get_bit_const_ref_sref(bitnumber,ref));
end;
procedure tcg.a_bit_set_const_reg(list: TAsmList; doset: boolean; destsize: tcgsize; bitnumber: aint; destreg: tregister);
begin
a_load_const_subsetreg(list,OS_8,ord(doset),get_bit_const_reg_sreg(destsize,bitnumber,destreg));
end;
procedure tcg.a_bit_set_const_subsetreg(list: TAsmList; doset: boolean; destsize: tcgsize; bitnumber: aint; const destreg: tsubsetregister);
var
tmpsreg: tsubsetregister;
begin
{ the first parameter is used to calculate the bit offset in }
{ case of big endian, and therefore must be the size of the }
{ set and not of the whole subsetreg }
tmpsreg:=get_bit_const_reg_sreg(destsize,bitnumber,destreg.subsetreg);
{ now fix the size of the subsetreg }
tmpsreg.subsetregsize:=destreg.subsetregsize;
{ correct offset of the set in the subsetreg }
inc(tmpsreg.startbit,destreg.startbit);
a_load_const_subsetreg(list,OS_8,ord(doset),tmpsreg);
end;
procedure tcg.a_bit_set_reg_ref(list: TAsmList; doset: boolean; bitnumbersize: tcgsize; bitnumber: tregister; const ref: treference);
begin
a_load_const_subsetref(list,OS_8,ord(doset),get_bit_reg_ref_sref(list,bitnumbersize,bitnumber,ref));
end;
procedure tcg.a_bit_set_reg_loc(list: TAsmList; doset: boolean; bitnumbersize: tcgsize; bitnumber: tregister; const loc: tlocation);
var
tmpreg: tregister;
begin
case loc.loc of
LOC_REFERENCE:
a_bit_set_reg_ref(list,doset,bitnumbersize,bitnumber,loc.reference);
LOC_CREGISTER:
a_bit_set_reg_reg(list,doset,bitnumbersize,loc.size,bitnumber,loc.register);
{ e.g. a 2-byte set in a record regvar }
LOC_CSUBSETREG:
begin
{ hard to do in-place in a generic way, so operate on a copy }
tmpreg:=cg.getintregister(list,loc.size);
a_load_subsetreg_reg(list,loc.size,loc.size,loc.sreg,tmpreg);
a_bit_set_reg_reg(list,doset,bitnumbersize,loc.size,bitnumber,tmpreg);
a_load_reg_subsetreg(list,loc.size,loc.size,tmpreg,loc.sreg);
end;
{ LOC_SUBSETREF is not possible, because sets are not (yet) bitpacked }
else
internalerror(2007051703)
end;
end;
procedure tcg.a_bit_set_const_loc(list: TAsmList; doset: boolean; bitnumber: aint; const loc: tlocation);
begin
case loc.loc of
LOC_REFERENCE:
a_bit_set_const_ref(list,doset,loc.size,bitnumber,loc.reference);
LOC_CREGISTER:
a_bit_set_const_reg(list,doset,loc.size,bitnumber,loc.register);
LOC_CSUBSETREG:
a_bit_set_const_subsetreg(list,doset,loc.size,bitnumber,loc.sreg);
{ LOC_SUBSETREF is not possible, because sets are not (yet) bitpacked }
else
internalerror(2007051704)
end;
end;
{ memory/register loading }
procedure tcg.a_load_reg_ref_unaligned(list : TAsmList;fromsize,tosize : tcgsize;register : tregister;const ref : treference);
var
tmpref : treference;
@ -2188,7 +2499,7 @@ implementation
var
tmpreg: tregister;
begin
tmpreg := cg.getintregister(list, size);
tmpreg := getintregister(list, size);
a_load_subsetreg_reg(list,subsetsize,size,sreg,tmpreg);
a_op_const_reg(list,op,size,a,tmpreg);
a_load_reg_subsetreg(list,size,subsetsize,tmpreg,sreg);
@ -2199,7 +2510,7 @@ implementation
var
tmpreg: tregister;
begin
tmpreg := cg.getintregister(list, size);
tmpreg := getintregister(list, size);
a_load_subsetref_reg(list,subsetsize,size,sref,tmpreg);
a_op_const_reg(list,op,size,a,tmpreg);
a_load_reg_subsetref(list,size,subsetsize,tmpreg,sref);
@ -2261,7 +2572,7 @@ implementation
var
tmpreg: tregister;
begin
tmpreg := cg.getintregister(list, opsize);
tmpreg := getintregister(list, opsize);
a_load_subsetreg_reg(list,subsetsize,opsize,sreg,tmpreg);
a_op_reg_reg(list,op,opsize,reg,tmpreg);
a_load_reg_subsetreg(list,opsize,subsetsize,tmpreg,sreg);
@ -2272,7 +2583,7 @@ implementation
var
tmpreg: tregister;
begin
tmpreg := cg.getintregister(list, opsize);
tmpreg := getintregister(list, opsize);
a_load_subsetref_reg(list,subsetsize,opsize,sref,tmpreg);
a_op_reg_reg(list,op,opsize,reg,tmpreg);
a_load_reg_subsetref(list,opsize,subsetsize,tmpreg,sref);
@ -3330,13 +3641,13 @@ implementation
paraloc:=tparavarsym(hsym).paraloc[callerside].location^;
case paraloc.loc of
LOC_REGISTER:
cg.a_op_const_reg(list,OP_SUB,paraloc.size,ioffset,paraloc.register);
a_op_const_reg(list,OP_SUB,paraloc.size,ioffset,paraloc.register);
LOC_REFERENCE:
begin
{ offset in the wrapper needs to be adjusted for the stored
return address }
reference_reset_base(href,paraloc.reference.index,paraloc.reference.offset+sizeof(aint));
cg.a_op_const_ref(list,OP_SUB,paraloc.size,ioffset,href);
a_op_const_ref(list,OP_SUB,paraloc.size,ioffset,href);
end
else
internalerror(200309189);
@ -3374,11 +3685,11 @@ implementation
current_asmdata.asmlists[al_picdata].concat(tai_const.create_32bit(0));
{$endif cpu64bit}
end;
result := cg.getaddressregister(list);
result := getaddressregister(list);
reference_reset_symbol(ref,l,0);
{ ref.base:=current_procinfo.got;
ref.relsymbol:=current_procinfo.CurrGOTLabel;}
cg.a_load_ref_reg(list,OS_ADDR,OS_ADDR,ref,result);
a_load_ref_reg(list,OS_ADDR,OS_ADDR,ref,result);
end;
end;
end;

11
compiler/cutils.pas
View File

@ -54,6 +54,8 @@ interface
Function SwapQWord(x : qword) : qword;{$ifdef USEINLINE}inline;{$endif}
{# Return value @var(i) aligned on @var(a) boundary }
function align(i,a:longint):longint;{$ifdef USEINLINE}inline;{$endif}
{# Return @var(b) with the bit order reversed }
function reverse_byte(b: byte): byte;
function used_align(varalign,minalign,maxalign:shortint):shortint;
function isbetteralignedthan(new, org, limit: cardinal): boolean;
@ -235,6 +237,15 @@ implementation
End;
function reverse_byte(b: byte): byte;
const
reverse_nible:array[0..15] of 0..15 =
(%0000,%1000,%0100,%1100,%0010,%1010,%0110,%1110,
%0001,%1001,%0101,%1101,%0011,%1011,%0111,%1111);
begin
reverse_byte:=(reverse_nible[b and $f] shl 4) or reverse_nible[b shr 4];
end;
function align(i,a:longint):longint;{$ifdef USEINLINE}inline;{$endif}
{
return value <i> aligned <a> boundary

10
compiler/defutil.pas
View File

@ -1024,19 +1024,13 @@ implementation
{# returns true, if the type passed is a varset }
function is_varset(p : tdef) : boolean;
begin
if target_info.endian=endian_little then
result:=(p.typ=setdef) and not(p.size in [1,2,4])
else
result:=false;
result:=(p.typ=setdef) and not(p.size in [1,2,4])
end;
function is_normalset(p : tdef) : boolean;
begin
if target_info.endian=endian_big then
result:=(p.typ=setdef) and (tsetdef(p).size=32)
else
result:=false;
result:=false;
end;

27
compiler/ncgadd.pas
View File

@ -249,6 +249,7 @@ interface
var
cgop : TOpCg;
tmpreg : tregister;
mask : aint;
opdone : boolean;
begin
opdone := false;
@ -279,14 +280,30 @@ interface
if assigned(tsetelementnode(right).right) then
internalerror(43244);
if (right.location.loc = LOC_CONSTANT) then
cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_OR,location.size,
aint(1 shl right.location.value),
left.location.register,location.register)
begin
if (target_info.endian=endian_big) then
mask:=aint((aword(1) shl (resultdef.size*8-1)) shr aword(right.location.value))
else
mask:=aint(1 shl right.location.value);
cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_OR,location.size,
mask,left.location.register,location.register);
end
else
begin
if (target_info.endian=endian_big) then
begin
mask:=aint((aword(1) shl (resultdef.size*8-1)));
cgop:=OP_SHR
end
else
begin
mask:=1;
cgop:=OP_SHL
end;
tmpreg := cg.getintregister(current_asmdata.CurrAsmList,location.size);
cg.a_load_const_reg(current_asmdata.CurrAsmList,location.size,1,tmpreg);
cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_SHL,location.size,
cg.a_load_const_reg(current_asmdata.CurrAsmList,location.size,mask,tmpreg);
location_force_reg(current_asmdata.CurrAsmList,right.location,location.size,true);
cg.a_op_reg_reg(current_asmdata.CurrAsmList,cgop,location.size,
right.location.register,tmpreg);
if left.location.loc <> LOC_CONSTANT then
cg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,OP_OR,location.size,tmpreg,

59
compiler/ncgcon.pas
View File

@ -67,7 +67,7 @@ implementation
uses
globtype,widestr,systems,
verbose,globals,
verbose,globals,cutils,
symconst,symdef,aasmbase,aasmtai,aasmdata,aasmcpu,defutil,
cpuinfo,cpubase,
cgbase,cgobj,cgutils,
@ -511,23 +511,38 @@ implementation
lastlabel : tasmlabel;
i : longint;
neededtyp : taiconst_type;
indexadjust : longint;
type
setbytes=array[0..31] of byte;
Psetbytes=^setbytes;
begin
{ xor indexadjust with indexes in a set typecasted to an array of }
{ bytes to get the correct locations, also when endianess of source }
{ and destiantion differs (JM) }
if (source_info.endian = target_info.endian) then
indexadjust := 0
else
indexadjust := 3;
{ small sets are loaded as constants }
if not(is_varset(resultdef)) and not(is_normalset(resultdef)) then
begin
location_reset(location,LOC_CONSTANT,int_cgsize(resultdef.size));
location.value:=pLongint(value_set)^;
if (source_info.endian=target_info.endian) then
begin
{$if defined(FPC_NEW_BIGENDIAN_SETS) or defined(FPC_LITTLE_ENDIAN)}
{ not plongint, because that will "sign extend" the set on 64 bit platforms }
{ if changed to "paword", please also modify "32-resultdef.size*8" and }
{ cross-endian code below }
location.value:=pCardinal(value_set)^
{$else}
location.value:=reverse_byte(Psetbytes(value_set)^[0]);
location.value:=location.value or (reverse_byte(Psetbytes(value_set)^[1]) shl 8);
location.value:=location.value or (reverse_byte(Psetbytes(value_set)^[2]) shl 16);
location.value:=location.value or (reverse_byte(Psetbytes(value_set)^[3]) shl 24);
{$endif}
end
else
begin
location.value:=cardinal(SwapLong(pLongint(value_set)^));
location.value:= reverse_byte (location.value and $ff) or
(reverse_byte((location.value shr 8) and $ff) shl 8) or
(reverse_byte((location.value shr 16) and $ff) shl 16) or
(reverse_byte((location.value shr 24) and $ff) shl 24);
end;
if (target_info.endian=endian_big) then
location.value:=location.value shr (32-resultdef.size*8);
exit;
end;
location_reset(location,LOC_CREFERENCE,OS_NO);
@ -554,7 +569,16 @@ implementation
i:=0;
while assigned(hp1) and (i<32) do
begin
if tai_const(hp1).value<>Psetbytes(value_set)^[i xor indexadjust] then
if (source_info.endian=target_info.endian) then
begin
{$if defined(FPC_NEW_BIGENDIAN_SETS) or defined(FPC_LITTLE_ENDIAN)}
if tai_const(hp1).value<>Psetbytes(value_set)^[i ] then
{$else}
if tai_const(hp1).value<>reverse_byte(Psetbytes(value_set)^[i xor 3]) then
{$endif}
break
end
else if tai_const(hp1).value<>reverse_byte(Psetbytes(value_set)^[i]) then
break;
inc(i);
hp1:=tai(hp1.next);
@ -602,8 +626,17 @@ implementation
else
}
begin
for i:=0 to 31 do
current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(Psetbytes(value_set)^[i xor indexadjust]));
if (source_info.endian=target_info.endian) then
{$if defined(FPC_NEW_BIGENDIAN_SETS) or defined(FPC_LITTLE_ENDIAN)}
for i:=0 to 31 do
current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(Psetbytes(value_set)^[i]))
{$else}
for i:=0 to 31 do
current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(reverse_byte(Psetbytes(value_set)^[i xor 3])))
{$endif}
else
for i:=0 to 31 do
current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(reverse_byte(Psetbytes(value_set)^[i])));
end;
end;
end;

128
compiler/ncginl.pas
View File

@ -508,126 +508,26 @@ implementation
procedure tcginlinenode.second_IncludeExclude;
var
bitsperop,l : longint;
opsize : tcgsize;
cgop : topcg;
addrreg2,addrreg,
hregister,hregister2: tregister;
use_small : boolean;
href : treference;
setpara, elepara: tnode;
begin
if not(is_varset(tcallparanode(left).resultdef)) and
not(is_normalset(tcallparanode(left).resultdef)) then
opsize:=int_cgsize(tcallparanode(left).resultdef.size)
else
opsize:=OS_32;
bitsperop:=(8*tcgsize2size[opsize]);
{ the set }
secondpass(tcallparanode(left).left);
if tcallparanode(tcallparanode(left).right).left.nodetype=ordconstn then
begin
{ calculate bit position }
l:=1 shl (tordconstnode(tcallparanode(tcallparanode(left).right).left).value mod bitsperop);
{ the element to set }
secondpass(tcallparanode(tcallparanode(left).right).left);
{ determine operator }
if inlinenumber=in_include_x_y then
cgop:=OP_OR
else
begin
cgop:=OP_AND;
l:=not(l);
end;
case tcallparanode(left).left.location.loc of
LOC_REFERENCE :
begin
inc(tcallparanode(left).left.location.reference.offset,
(tordconstnode(tcallparanode(tcallparanode(left).right).left).value div bitsperop)*tcgsize2size[opsize]);
cg.a_op_const_ref(current_asmdata.CurrAsmList,cgop,opsize,l,tcallparanode(left).left.location.reference);
end;
LOC_CREGISTER :
cg.a_op_const_reg(current_asmdata.CurrAsmList,cgop,tcallparanode(left).left.location.size,l,tcallparanode(left).left.location.register);
else
internalerror(200405021);
end;
setpara:=tcallparanode(left).left;
elepara:=tcallparanode(tcallparanode(left).right).left;
if elepara.location.loc=LOC_CONSTANT then
begin
cg.a_bit_set_const_loc(current_asmdata.CurrAsmList,(inlinenumber=in_include_x_y),
elepara.location.value,setpara.location);
end
else
begin
use_small:=
{ set type }
(tsetdef(tcallparanode(left).left.resultdef).settype=smallset)
and
{ elemenut number between 1 and 32 }
((tcallparanode(tcallparanode(left).right).left.resultdef.typ=orddef) and
(torddef(tcallparanode(tcallparanode(left).right).left.resultdef).high<=32) or
(tcallparanode(tcallparanode(left).right).left.resultdef.typ=enumdef) and
(tenumdef(tcallparanode(tcallparanode(left).right).left.resultdef).max<=32));
{ generate code for the element to set }
secondpass(tcallparanode(tcallparanode(left).right).left);
{ bitnumber - which must be loaded into register }
hregister:=cg.getintregister(current_asmdata.CurrAsmList,opsize);
hregister2:=cg.getintregister(current_asmdata.CurrAsmList,opsize);
cg.a_load_loc_reg(current_asmdata.CurrAsmList,opsize,
tcallparanode(tcallparanode(left).right).left.location,hregister);
if use_small then
begin
{ hregister contains the bitnumber to add }
cg.a_load_const_reg(current_asmdata.CurrAsmList, opsize, 1, hregister2);
cg.a_op_reg_reg(current_asmdata.CurrAsmList, OP_SHL, opsize, hregister, hregister2);
{ possiblities :
bitnumber : LOC_REFERENCE, LOC_REGISTER, LOC_CREGISTER
set value : LOC_REFERENCE, LOC_REGISTER
}
{ location of set }
if inlinenumber=in_include_x_y then
begin
cg.a_op_reg_loc(current_asmdata.CurrAsmList, OP_OR, hregister2,
tcallparanode(left).left.location);
end
else
begin
cg.a_op_reg_reg(current_asmdata.CurrAsmList, OP_NOT, opsize, hregister2,hregister2);
cg.a_op_reg_loc(current_asmdata.CurrAsmList, OP_AND, hregister2,
tcallparanode(left).left.location);
end;
end
else
begin
{ possiblities :
bitnumber : LOC_REFERENCE, LOC_REGISTER, LOC_CREGISTER
set value : LOC_REFERENCE
}
{ hregister contains the bitnumber (div 32 to get the correct offset) }
{ hregister contains the bitnumber to add }
cg.a_op_const_reg_reg(current_asmdata.CurrAsmList, OP_SHR, opsize, 5, hregister,hregister2);
cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SHL, opsize, 2, hregister2);
addrreg:=cg.getaddressregister(current_asmdata.CurrAsmList);
{ we need an extra address register to be able to do an ADD operation }
addrreg2:=cg.getaddressregister(current_asmdata.CurrAsmList);
cg.a_load_reg_reg(current_asmdata.CurrAsmList,opsize,OS_ADDR,hregister2,addrreg2);
{ calculate the correct address of the operand }
cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList, tcallparanode(left).left.location.reference,addrreg);
cg.a_op_reg_reg(current_asmdata.CurrAsmList, OP_ADD, OS_ADDR, addrreg2, addrreg);
{ hregister contains the bitnumber to add }
cg.a_load_const_reg(current_asmdata.CurrAsmList, opsize, 1, hregister2);
cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_AND, opsize, 31, hregister);
cg.a_op_reg_reg(current_asmdata.CurrAsmList, OP_SHL, opsize, hregister, hregister2);
reference_reset_base(href,addrreg,0);
if inlinenumber=in_include_x_y then
cg.a_op_reg_ref(current_asmdata.CurrAsmList, OP_OR, opsize, hregister2, href)
else
begin
cg.a_op_reg_reg(current_asmdata.CurrAsmList, OP_NOT, opsize, hregister2, hregister2);
cg.a_op_reg_ref(current_asmdata.CurrAsmList, OP_AND, opsize, hregister2, href);
end;
end;
location_force_reg(current_asmdata.CurrAsmList,elepara.location,OS_INT,true);
cg.a_bit_set_reg_loc(current_asmdata.CurrAsmList,(inlinenumber=in_include_x_y),
elepara.location.size,elepara.location.register,setpara.location);
end;
end;

178
compiler/ncgset.pas
View File

@ -27,7 +27,7 @@ interface
uses
globtype,globals,
node,nset,cpubase,cgbase,cgobj,aasmbase,aasmtai,aasmdata;
node,nset,cpubase,cgbase,cgutils,cgobj,aasmbase,aasmtai,aasmdata;
type
tcgsetelementnode = class(tsetelementnode)
@ -45,18 +45,6 @@ interface
function pass_1: tnode;override;
procedure pass_generate_code;override;
protected
{# Routine to test bitnumber in bitnumber register on value
in value register. The __result register should be set
to one if the bit is set, otherwise __result register
should be set to zero.
Should be overriden on processors which have specific
instructions to do bit tests.
}
procedure emit_bit_test_reg_reg(list : TAsmList;
bitsize: tcgsize; bitnumber,value : tregister;
ressize: tcgsize; res :tregister);virtual;
function checkgenjumps(out setparts: Tsetparts; out numparts: byte; out use_small: boolean): boolean; virtual;
function analizeset(const Aset:Tconstset;out setparts: Tsetparts; out numparts: byte;is_small:boolean):boolean;virtual;
end;
@ -100,8 +88,7 @@ implementation
paramgr,
procinfo,pass_2,tgobj,
nbas,ncon,nflw,
ncgutil,regvars,
cgutils;
ncgutil;
{*****************************************************************************
@ -133,45 +120,6 @@ implementation
{*****************************************************************************
*****************************************************************************}
{**********************************************************************}
{ Description: Emit operation to do a bit test, where the bitnumber }
{ to test is in the bitnumber register. The value to test against is }
{ located in the value register. }
{ WARNING: Bitnumber register value is DESTROYED! }
{ __Result register is set to 1, if the bit is set otherwise, __Result}
{ is set to zero. __RESULT register is also used as scratch. }
{**********************************************************************}
procedure tcginnode.emit_bit_test_reg_reg(list : TAsmList;
bitsize: tcgsize; bitnumber,value : tregister;
ressize: tcgsize; res :tregister);
begin
{ first make sure that the bit number is modulo 32 }
{ not necessary, since if it's > 31, we have a range error -> will }
{ be caught when range checking is on! (JM) }
{ cg.a_op_const_reg(list,OP_AND,31,bitnumber); }
if tcgsize2unsigned[bitsize]<>tcgsize2unsigned[ressize] then
begin
internalerror(2007020401);
{ FIX ME! We're not allowed to modify the value register here! }
{ shift value register "bitnumber" bits to the right }
cg.a_op_reg_reg(list,OP_SHR,bitsize,bitnumber,value);
{ extract the bit we want }
cg.a_op_const_reg(list,OP_AND,bitsize,1,value);
cg.a_load_reg_reg(list,bitsize,ressize,value,res);
end
else
begin
{ rotate value register "bitnumber" bits to the right }
cg.a_op_reg_reg_reg(list,OP_SHR,bitsize,bitnumber,value,res);
{ extract the bit we want }
cg.a_op_const_reg(list,OP_AND,bitsize,1,res);
end;
end;
function tcginnode.analizeset(const Aset:Tconstset; out setparts:tsetparts; out numparts: byte; is_small:boolean):boolean;
var
compares,maxcompares:word;
@ -234,8 +182,8 @@ implementation
{ check if we can use smallset operation using btl which is limited
to 32 bits, the left side may also not contain higher values !! }
use_small:=(tsetdef(right.resultdef).settype=smallset) and not is_signed(left.resultdef) and
((left.resultdef.typ=orddef) and (torddef(left.resultdef).high<=32) or
(left.resultdef.typ=enumdef) and (tenumdef(left.resultdef).max<=32));
((left.resultdef.typ=orddef) and (torddef(left.resultdef).high<32) or
(left.resultdef.typ=enumdef) and (tenumdef(left.resultdef).max<32));
{ Can we generate jumps? Possible for all types of sets }
checkgenjumps:=(right.nodetype=setconstn) and
@ -258,6 +206,7 @@ implementation
procedure tcginnode.pass_generate_code;
var
adjustment : aint;
l, l2 : tasmlabel;
href : treference;
hr,hr2,
pleftreg : tregister;
@ -268,7 +217,6 @@ implementation
genjumps,
use_small : boolean;
i,numparts : byte;
l, l2 : tasmlabel;
needslabel : Boolean;
begin
{ We check first if we can generate jumps, this can be done
@ -375,30 +323,25 @@ implementation
begin
{ location is always LOC_REGISTER }
location_reset(location, LOC_REGISTER, uopsize{def_cgsize(resultdef)});
{ allocate a register for the result }
location.register := cg.getintregister(current_asmdata.CurrAsmList, uopsize);
{ We will now generated code to check the set itself, no jmps,
handle smallsets separate, because it allows faster checks }
if use_small then
begin
{**************************** SMALL SET **********************}
if left.nodetype=ordconstn then
if left.location.loc=LOC_CONSTANT then
begin
location_force_reg(current_asmdata.CurrAsmList, right.location, uopsize, true);
location.register:=cg.getintregister(current_asmdata.CurrAsmList,location.size);
{ first SHR the register }
cg.a_op_const_reg_reg(current_asmdata.CurrAsmList, OP_SHR, uopsize, tordconstnode(left).value and 31, right.location.register, location.register);
{ then extract the lowest bit }
cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_AND, uopsize, 1, location.register);
cg.a_bit_test_const_loc_reg(current_asmdata.CurrAsmList,location.size,
left.location.value,right.location,
location.register);
end
else
begin
location_force_reg(current_asmdata.CurrAsmList,left.location,opsize,false);
location_force_reg(current_asmdata.CurrAsmList, right.location, uopsize, false);
{ allocate a register for the result }
location.register:=cg.getintregister(current_asmdata.CurrAsmList,location.size);
{ emit bit test operation }
emit_bit_test_reg_reg(current_asmdata.CurrAsmList,left.location.size,left.location.register,
right.location.register,location.size,location.register);
location_force_reg(current_asmdata.CurrAsmList,left.location,opsize,true);
cg.a_bit_test_reg_loc_reg(current_asmdata.CurrAsmList,left.location.size,
location.size,left.location.register,right.location,location.register);
end;
end
else
@ -413,59 +356,39 @@ implementation
{ assumption (other cases will be caught by range checking) (JM) }
{ load left in register }
location_force_reg(current_asmdata.CurrAsmList,left.location,opsize,true);
if left.location.loc = LOC_CREGISTER then
hr := cg.getintregister(current_asmdata.CurrAsmList,opsize)
else
hr := left.location.register;
{ load right in register }
hr2:=cg.getintregister(current_asmdata.CurrAsmList, uopsize);
cg.a_load_const_reg(current_asmdata.CurrAsmList, uopsize, right.location.value, hr2);
location_force_reg(current_asmdata.CurrAsmList,left.location,location.size,true);
location_force_reg(current_asmdata.CurrAsmList,right.location,opsize,true);
{ emit bit test operation }
emit_bit_test_reg_reg(current_asmdata.CurrAsmList, left.location.size, left.location.register, hr2, uopsize, hr2);
cg.a_bit_test_reg_reg_reg(current_asmdata.CurrAsmList,
left.location.size,right.location.size,location.size,
left.location.register, right.location.register,location.register);
{ if left > 31 then hr := 0 else hr := $ffffffff }
cg.a_op_const_reg_reg(current_asmdata.CurrAsmList, OP_SUB, uopsize, 32, left.location.register, hr);
cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SAR, uopsize, 31, hr);
{ now zero the result if left > nr_of_bits_in_right_register }
hr := cg.getintregister(current_asmdata.CurrAsmList,location.size);
{ if left > tcgsize2size[opsize]*8 then hr := 0 else hr := $ffffffff }
{ (left.location.size = location.size at this point) }
cg.a_op_const_reg_reg(current_asmdata.CurrAsmList, OP_SUB, location.size, tcgsize2size[opsize]*8, left.location.register, hr);
cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SAR, location.size, (tcgsize2size[opsize]*8)-1, hr);
{ if left > 31, then result := 0 else result := result of bit test }
cg.a_op_reg_reg(current_asmdata.CurrAsmList, OP_AND, uopsize, hr, hr2);
{ allocate a register for the result }
location.register := cg.getintregister(current_asmdata.CurrAsmList,location.size);
cg.a_load_reg_reg(current_asmdata.CurrAsmList, uopsize, location.size, hr2, location.register);
{ if left > tcgsize2size[opsize]*8-1, then result := 0 else result := result of bit test }
cg.a_op_reg_reg(current_asmdata.CurrAsmList, OP_AND, location.size, hr, location.register);
end { of right.location.loc=LOC_CONSTANT }
{ do search in a normal set which could have >32 elementsm
but also used if the left side contains higher values > 32 }
else if left.nodetype=ordconstn then
else if (left.location.loc=LOC_CONSTANT) then
begin
if (tordconstnode(left).value < 0) or ((tordconstnode(left).value shr 3) >= right.resultdef.size) then
if (left.location.value < 0) or ((left.location.value shr 3) >= right.resultdef.size) then
{should be caught earlier }
internalerror(2007020402);
{ use location.register as scratch register here }
if (target_info.endian = endian_little) then
inc(right.location.reference.offset,tordconstnode(left).value shr 3)
else
{ adjust for endianess differences }
inc(right.location.reference.offset,(tordconstnode(left).value shr 3) xor 3);
{ allocate a register for the result }
location.register := cg.getintregister(current_asmdata.CurrAsmList,location.size);
cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_8,location.size,right.location.reference, location.register);
cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SHR,location.size,tordconstnode(left).value and 7,
location.register);
cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_AND,location.size,1,location.register);
cg.a_bit_test_const_loc_reg(current_asmdata.CurrAsmList,location.size,left.location.value,
right.location,location.register);
end
else
begin
location_force_reg(current_asmdata.CurrAsmList, left.location, opsize, true);
pleftreg := left.location.register;
location_freetemp(current_asmdata.CurrAsmList,left.location);
{ allocate a register for the result }
location.register := cg.getintregister(current_asmdata.CurrAsmList, uopsize);
if (opsize >= OS_S8) or { = if signed }
((left.resultdef.typ=orddef) and (torddef(left.resultdef).high > tsetdef(right.resultdef).setmax)) or
((left.resultdef.typ=enumdef) and (tenumdef(left.resultdef).max > tsetdef(right.resultdef).setmax)) then
@ -474,47 +397,16 @@ implementation
current_asmdata.getjumplabel(l2);
needslabel := True;
cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, OC_BE, tsetdef(right.resultdef).setmax, pleftreg, l);
cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, left.location.size, OC_BE, tsetdef(right.resultdef).setmax, pleftreg, l);
cg.a_load_const_reg(current_asmdata.CurrAsmList, opsize, 0, location.register);
cg.a_load_const_reg(current_asmdata.CurrAsmList, location.size, 0, location.register);
cg.a_jmp_always(current_asmdata.CurrAsmList, l2);
cg.a_label(current_asmdata.CurrAsmList, l);
end;
case right.location.loc of
LOC_REGISTER, LOC_CREGISTER :
begin
cg.a_load_reg_reg(current_asmdata.CurrAsmList, uopsize, uopsize, right.location.register, location.register);
end;
LOC_CREFERENCE, LOC_REFERENCE :
begin
hr := cg.getaddressregister(current_asmdata.CurrAsmList);
cg.a_op_const_reg_reg(current_asmdata.CurrAsmList, OP_SHR, uopsize, 5, pleftreg, hr);
cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_SHL, uopsize, 2, hr);
href := right.location.reference;
if (href.base = NR_NO) then
href.base := hr
else if (right.location.reference.index = NR_NO) then
href.index := hr
else
begin
hr2 := cg.getaddressregister(current_asmdata.CurrAsmList);
cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList, href, hr2);
reference_reset_base(href, hr2, 0);
href.index := hr;
end;
cg.a_load_ref_reg(current_asmdata.CurrAsmList, uopsize, uopsize, href, location.register);
end
else
internalerror(2007020403);
end;
hr := cg.getintregister(current_asmdata.CurrAsmList, uopsize);
cg.a_op_const_reg_reg(current_asmdata.CurrAsmList, OP_AND, uopsize, 31, pleftreg, hr);
cg.a_op_reg_reg(current_asmdata.CurrAsmList, OP_SHR, uopsize, hr, location.register);
cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_AND, uopsize, 1, location.register);
cg.a_bit_test_reg_loc_reg(current_asmdata.CurrAsmList,left.location.size,location.size,
left.location.register,right.location,location.register);
if needslabel then
cg.a_label(current_asmdata.CurrAsmList, l2);

1
compiler/options.pas
View File

@ -1990,6 +1990,7 @@ begin
def_system_macro('FPC_HAS_STR_CURRENCY');
def_system_macro('FPC_REAL2REAL_FIXED');
def_system_macro('FPC_STRTOCHARARRAYPROC');
def_system_macro('FPC_NEW_BIGENDIAN_SETS');
{$if defined(x86) or defined(arm)}
def_system_macro('INTERNAL_BACKTRACE');

6
compiler/ppcgen/ngppcadd.pas
View File

@ -416,13 +416,13 @@ implementation
internalerror(43244);
if (right.location.loc = LOC_CONSTANT) then
cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_OR,OS_INT,
aint(aword(1) shl aword(right.location.value)),
aint((aword(1) shl (resultdef.size*8-1)) shr aword(right.location.value)),
left.location.register,location.register)
else
begin
tmpreg := cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,1,tmpreg);
cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_SHL,OS_INT,
cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,aint((aword(1) shl (resultdef.size*8-1))),tmpreg);
cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_SHR,OS_INT,
right.location.register,tmpreg);
if left.location.loc <> LOC_CONSTANT then
cg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,OP_OR,OS_INT,tmpreg,

2
compiler/ppu.pas
View File

@ -43,7 +43,7 @@ type
{$endif Test_Double_checksum}
const
CurrentPPUVersion=79;
CurrentPPUVersion=80;
{ buffer sizes }
maxentrysize = 1024;

19
compiler/ptconst.pas
View File

@ -546,7 +546,7 @@ implementation
Psetbytes = ^setbytes;
var
p : tnode;
i,j : longint;
i : longint;
begin
p:=comp_expr(true);
if p.nodetype=setconstn then
@ -564,21 +564,18 @@ implementation
{ arrays of 32-bit values CEC }
if source_info.endian = target_info.endian then
begin
{$if defined(FPC_NEW_BIGENDIAN_SETS) or defined(FPC_LITTLE_ENDIAN)}
for i:=0 to p.resultdef.size-1 do
list.concat(tai_const.create_8bit(Psetbytes(tsetconstnode(p).value_set)^[i]));
{$else}
for i:=0 to p.resultdef.size-1 do
list.concat(tai_const.create_8bit(reverse_byte(Psetbytes(tsetconstnode(p).value_set)^[i xor 3])));
{$endif}
end
else
begin
{ store as longint values in swaped format }
j:=0;
for i:=0 to ((p.resultdef.size-1) div 4) do
begin
list.concat(tai_const.create_8bit(Psetbytes(tsetconstnode(p).value_set)^[j+3]));
list.concat(tai_const.create_8bit(Psetbytes(tsetconstnode(p).value_set)^[j+2]));
list.concat(tai_const.create_8bit(Psetbytes(tsetconstnode(p).value_set)^[j+1]));
list.concat(tai_const.create_8bit(Psetbytes(tsetconstnode(p).value_set)^[j]));
Inc(j,4);
end;
for i:=0 to p.resultdef.size-1 do
list.concat(tai_const.create_8bit(reverse_byte(Psetbytes(tsetconstnode(p).value_set)^[i])));
end;
end;
end

21
compiler/x86/nx86set.pas
View File

@ -162,8 +162,8 @@ implementation
{ check if we can use smallset operation using btl which is limited
to 32 bits, the left side may also not contain higher values or be signed !! }
use_small:=(tsetdef(right.resultdef).settype=smallset) and not is_signed(left.resultdef) and
((left.resultdef.typ=orddef) and (torddef(left.resultdef).high<=32) or
(left.resultdef.typ=enumdef) and (tenumdef(left.resultdef).max<=32));
((left.resultdef.typ=orddef) and (torddef(left.resultdef).high<32) or
(left.resultdef.typ=enumdef) and (tenumdef(left.resultdef).max<32));
{ Can we generate jumps? Possible for all types of sets }
genjumps:=(right.nodetype=setconstn) and
@ -191,6 +191,8 @@ implementation
if not(left.location.loc in [LOC_REGISTER,LOC_CREGISTER,LOC_REFERENCE,LOC_CREFERENCE]) then
location_force_reg(current_asmdata.CurrAsmList,left.location,opsize,true);
if (right.location.loc in [LOC_SUBSETREG,LOC_CSUBSETREG]) then
location_force_reg(current_asmdata.CurrAsmList,right.location,opsize,true);
if genjumps then
begin
@ -388,8 +390,19 @@ implementation
internalerror(2007020201);
location.resflags:=F_NE;
inc(right.location.reference.offset,tordconstnode(left).value shr 3);
emit_const_ref(A_TEST,S_B,1 shl (tordconstnode(left).value and 7),right.location.reference);
case right.location.loc of
LOC_REFERENCE,LOC_CREFERENCE:
begin
inc(right.location.reference.offset,tordconstnode(left).value shr 3);
emit_const_ref(A_TEST,S_B,1 shl (tordconstnode(left).value and 7),right.location.reference);
end;
LOC_REGISTER,LOC_CREGISTER:
begin
emit_const_reg(A_TEST,TCGSize2OpSize[right.location.size],1 shl (tordconstnode(left).value),right.location.register);
end;
else
internalerror(2007051901);
end;
end
else
begin

9
rtl/inc/compproc.inc
View File

@ -32,8 +32,15 @@ type
fpc_big_chararray = array[0..0] of char;
fpc_big_widechararray = array[0..0] of widechar;
{$endif ndef FPC_STRTOCHARARRAYPROC}
{$ifdef FPC_NEW_BIGENDIAN_SETS}
fpc_small_set = bitpacked array[0..31] of 0..1;
fpc_normal_set = bitpacked array[0..255] of 0..1;
{$else}
fpc_small_set = longint;
fpc_normal_set = array[0..7] of longint;
{$endif}
fpc_normal_set_byte = array[0..31] of byte;
fpc_normal_set_long = array[0..7] of longint;
{$ifdef FPC_HAS_FEATURE_HEAP}
@ -410,7 +417,6 @@ function fpc_set_create_element(b : byte): fpc_normal_set; compilerproc;
function fpc_set_set_byte(const source: fpc_normal_set; b : byte): fpc_normal_set; compilerproc;
function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_set; compilerproc;
function fpc_set_set_range(const orgset: fpc_normal_set; l,h : byte): fpc_normal_set; compilerproc;
function fpc_set_in_byte(const p: fpc_normal_set; b: byte): boolean; compilerproc;
function fpc_set_add_sets(const set1,set2: fpc_normal_set): fpc_normal_set; compilerproc;
function fpc_set_mul_sets(const set1,set2: fpc_normal_set): fpc_normal_set; compilerproc;
function fpc_set_sub_sets(const set1,set2: fpc_normal_set): fpc_normal_set; compilerproc;
@ -423,7 +429,6 @@ procedure fpc_varset_create_element(b,size : ptrint; var data); compilerproc;
procedure fpc_varset_set(const source;var dest; b,size : ptrint); compilerproc;
procedure fpc_varset_unset(const source;var dest; b,size : ptrint); compilerproc;
procedure fpc_varset_set_range(const orgset; var dest;l,h,size : ptrint); compilerproc;
function fpc_varset_in(const p; b : ptrint): boolean; compilerproc;
procedure fpc_varset_add_sets(const set1,set2; var dest;size : ptrint); compilerproc;
procedure fpc_varset_mul_sets(const set1,set2; var dest;size : ptrint); compilerproc;
procedure fpc_varset_sub_sets(const set1,set2; var dest;size : ptrint); compilerproc;

103
rtl/inc/genset.inc
View File

@ -23,8 +23,8 @@ function fpc_set_load_small(l: fpc_small_set): fpc_normal_set; [public,alias:'FP
load a normal set p from a smallset l
}
begin
fpc_set_load_small[0] := l;
FillDWord(fpc_set_load_small[1],7,0);
FillDWord(fpc_set_load_small,sizeof(fpc_set_load_small) div 4,0);
move(l,fpc_set_load_small,sizeof(l));
end;
{$endif FPC_SYSTEM_HAS_FPC_SET_LOAD_SMALL}
@ -36,7 +36,11 @@ function fpc_set_create_element(b : byte): fpc_normal_set;[public,alias:'FPC_SET
}
begin
FillDWord(fpc_set_create_element,SizeOf(fpc_set_create_element) div 4,0);
{$ifndef FPC_NEW_BIGENDIAN_SETS}
fpc_set_create_element[b div 32] := 1 shl (b mod 32);
{$else}
fpc_set_create_element[b] := 1;
{$endif}
end;
{$endif FPC_SYSTEM_HAS_FPC_SET_CREATE_ELEMENT}
@ -50,9 +54,13 @@ function fpc_set_create_element(b : byte): fpc_normal_set;[public,alias:'FPC_SET
c: longint;
begin
move(source,fpc_set_set_byte,sizeof(source));
{$ifndef FPC_NEW_BIGENDIAN_SETS}
c := fpc_set_set_byte[b div 32];
c := (1 shl (b mod 32)) or c;
fpc_set_set_byte[b div 32] := c;
{$else}
fpc_set_set_byte[b] := 1;
{$endif}
end;
{$endif FPC_SYSTEM_HAS_FPC_SET_SET_BYTE}
@ -68,9 +76,13 @@ function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_
c: longint;
begin
move(source,fpc_set_unset_byte,sizeof(source));
{$ifndef FPC_NEW_BIGENDIAN_SETS}
c := fpc_set_unset_byte[b div 32];
c := c and not (1 shl (b mod 32));
fpc_set_unset_byte[b div 32] := c;
{$else}
fpc_set_unset_byte[b] := 0;
{$endif}
end;
{$endif FPC_SYSTEM_HAS_FPC_SET_UNSET_BYTE}
@ -87,30 +99,24 @@ function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_
move(orgset,fpc_set_set_range,sizeof(orgset));
for i:=l to h do
begin
{$ifndef FPC_NEW_BIGENDIAN_SETS}
c := fpc_set_set_range[i div 32];
c := (1 shl (i mod 32)) or c;
fpc_set_set_range[i div 32] := c;
{$else}
fpc_set_set_range[i] := 1;
{$endif}
end;
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_SET_SET_RANGE}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_IN_BYTE}
function fpc_set_in_byte(const p: fpc_normal_set; b: byte): boolean; [public,alias:'FPC_SET_IN_BYTE']; compilerproc;
{
tests if the element b is in the set p the carryflag is set if it present
}
begin
fpc_set_in_byte := (p[b div 32] and (1 shl (b mod 32))) <> 0;
end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_FPC_SET_ADD_SETS}
function fpc_set_add_sets(const set1,set2: fpc_normal_set): fpc_normal_set;[public,alias:'FPC_SET_ADD_SETS']; compilerproc;
var
dest: fpc_normal_set absolute fpc_set_add_sets;
src1: fpc_normal_set_long absolute set1;
src2: fpc_normal_set_long absolute set2;
dest: fpc_normal_set_long absolute fpc_set_add_sets;
{
adds set1 and set2 into set dest
}
@ -118,7 +124,7 @@ function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_
i: integer;
begin
for i:=0 to 7 do
dest[i] := set1[i] or set2[i];
dest[i] := src1[i] or src2[i];
end;
{$endif}
@ -126,6 +132,8 @@ function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_
{$ifndef FPC_SYSTEM_HAS_FPC_SET_MUL_SETS}
function fpc_set_mul_sets(const set1,set2: fpc_normal_set): fpc_normal_set;[public,alias:'FPC_SET_MUL_SETS']; compilerproc;
var
src1: fpc_normal_set_long absolute set1;
src2: fpc_normal_set_long absolute set2;
dest: fpc_normal_set absolute fpc_set_mul_sets;
{
multiplies (takes common elements of) set1 and set2 result put in dest
@ -134,7 +142,7 @@ function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_
i: integer;
begin
for i:=0 to 7 do
dest[i] := set1[i] and set2[i];
dest[i] := src1[i] and src2[i];
end;
{$endif}
@ -142,6 +150,8 @@ function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_
{$ifndef FPC_SYSTEM_HAS_FPC_SET_SUB_SETS}
function fpc_set_sub_sets(const set1,set2: fpc_normal_set): fpc_normal_set;[public,alias:'FPC_SET_SUB_SETS']; compilerproc;
var
src1: fpc_normal_set_long absolute set1;
src2: fpc_normal_set_long absolute set2;
dest: fpc_normal_set absolute fpc_set_sub_sets;
{
computes the diff from set1 to set2 result in dest
@ -150,7 +160,7 @@ function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_
i: integer;
begin
for i:=0 to 7 do
dest[i] := set1[i] and not set2[i];
dest[i] := src1[i] and not src2[i];
end;
{$endif}
@ -158,6 +168,8 @@ function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_
{$ifndef FPC_SYSTEM_HAS_FPC_SET_SYMDIF_SETS}
function fpc_set_symdif_sets(const set1,set2: fpc_normal_set): fpc_normal_set;[public,alias:'FPC_SET_SYMDIF_SETS']; compilerproc;
var
src1: fpc_normal_set_long absolute set1;
src2: fpc_normal_set_long absolute set2;
dest: fpc_normal_set absolute fpc_set_symdif_sets;
{
computes the symetric diff from set1 to set2 result in dest
@ -166,7 +178,7 @@ function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_
i: integer;
begin
for i:=0 to 7 do
dest[i] := set1[i] xor set2[i];
dest[i] := src1[i] xor src2[i];
end;
{$endif}
@ -177,10 +189,12 @@ function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_
}
var
i: integer;
src1: fpc_normal_set_long absolute set1;
src2: fpc_normal_set_long absolute set2;
begin
fpc_set_comp_sets:= false;
for i:=0 to 7 do
if set1[i] <> set2[i] then
if src1[i] <> src2[i] then
exit;
fpc_set_comp_sets:= true;
end;
@ -195,10 +209,12 @@ function fpc_set_unset_byte(const source: fpc_normal_set; b : byte): fpc_normal_
}
var
i : integer;
src1: fpc_normal_set_long absolute set1;
src2: fpc_normal_set_long absolute set2;
begin
fpc_set_contains_sets:= false;
for i:=0 to 7 do
if (set1[i] and not set2[i]) <> 0 then
if (src1[i] and not src2[i]) <> 0 then
exit;
fpc_set_contains_sets:= true;
end;
@ -229,10 +245,18 @@ procedure fpc_varset_load(const l;sourcesize : longint;var dest;size : ptrint);
}
procedure fpc_varset_create_element(b,size : ptrint; var data); compilerproc;
type
{$ifndef FPC_NEW_BIGENDIAN_SETS}
tbytearray = array[0..sizeof(sizeint)-1] of byte;
{$else}
tbsetarray = bitpacked array[0..sizeof(sizeint)-1] of 0..1;
{$endif}
begin
FillChar(data,size,0);
{$ifndef FPC_NEW_BIGENDIAN_SETS}
tbytearray(data)[b div 8]:=1 shl (b mod 8);
{$else}
tbsetarray(data)[b]:=1;
{$endif}
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_VARSET_CREATE_ELEMENT}
@ -243,10 +267,18 @@ procedure fpc_varset_create_element(b,size : ptrint; var data); compilerproc;
}
procedure fpc_varset_set(const source;var dest; b,size : ptrint); compilerproc;
type
{$ifndef FPC_NEW_BIGENDIAN_SETS}
tbytearray = array[0..sizeof(sizeint)-1] of byte;
{$else}
tbsetarray = bitpacked array[0..sizeof(sizeint)-1] of 0..1;
{$endif}
begin
move(source,dest,size);
{$ifndef FPC_NEW_BIGENDIAN_SETS}
tbytearray(dest)[b div 8]:=tbytearray(dest)[b div 8] or (1 shl (b mod 8));
{$else}
tbsetarray(dest)[b]:=1;
{$endif}
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_VARSET_SET_BYTE}
@ -258,10 +290,18 @@ procedure fpc_varset_set(const source;var dest; b,size : ptrint); compilerproc;
}
procedure fpc_varset_unset(const source;var dest; b,size : ptrint); compilerproc;
type
{$ifndef FPC_NEW_BIGENDIAN_SETS}
tbytearray = array[0..sizeof(sizeint)-1] of byte;
{$else}
tbsetarray = bitpacked array[0..sizeof(sizeint)-1] of 0..1;
{$endif}
begin
move(source,dest,size);
{$ifndef FPC_NEW_BIGENDIAN_SETS}
tbytearray(dest)[b div 8]:=tbytearray(dest)[b div 8] and not (1 shl (b mod 8));
{$else}
tbsetarray(dest)[b]:=0;
{$endif}
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_VARSET_UNSET_BYTE}
@ -272,30 +312,25 @@ procedure fpc_varset_unset(const source;var dest; b,size : ptrint); compilerproc
}
procedure fpc_varset_set_range(const orgset; var dest;l,h,size : ptrint); compilerproc;
type
{$ifndef FPC_NEW_BIGENDIAN_SETS}
tbytearray = array[0..sizeof(sizeint)-1] of byte;
{$else}
tbsetarray = bitpacked array[0..sizeof(sizeint)-1] of 0..1;
{$endif}
var
i : ptrint;
begin
move(orgset,dest,size);
for i:=l to h do
{$ifndef FPC_NEW_BIGENDIAN_SETS}
tbytearray(dest)[i div 8]:=(1 shl (i mod 8)) or tbytearray(dest)[i div 8];
{$else}
tbsetarray(dest)[i]:=1;
{$endif}
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_VARSET_SET_RANGE}
{$ifndef FPC_SYSTEM_HAS_FPC_VARSET_IN_BYTE}
{
tests if the element b is in the set p the carryflag is set if it present
}
function fpc_varset_in(const p; b : ptrint): boolean; compilerproc;
type
tbytearray = array[0..sizeof(sizeint)-1] of byte;
begin
fpc_varset_in:=(tbytearray(p)[b div 8] and (1 shl (b mod 8)))<>0;
end;
{$endif ndef FPC_SYSTEM_HAS_FPC_VARSET_IN_BYTE}
{$ifndef FPC_SYSTEM_HAS_FPC_VARSET_ADD_SETS}
{
adds set1 and set2 into set dest

17
rtl/objpas/typinfo.pp
View File

@ -392,23 +392,40 @@ end;
Function SetToString(TypeInfo: PTypeInfo; Value: Integer; Brackets: Boolean) : String;
{$ifdef FPC_NEW_BIGENDIAN_SETS}
type
tsetarr = bitpacked array[0..31] of 0..1;
{$endif}
Var
I : Integer;
PTI : PTypeInfo;
begin
{$if defined(FPC_NEW_BIGENDIAN_SETS) and defined(FPC_BIG_ENDIAN)}
case GetTypeData(TypeInfo)^.OrdType of
otSByte,otUByte: Value:=Value shl 24;
otSWord,otUWord: Value:=Value shl 16;
end;
{$endif}
PTI:=GetTypeData(TypeInfo)^.CompType;
Result:='';
For I:=0 to SizeOf(Integer)*8-1 do
begin
{$ifdef FPC_NEW_BIGENDIAN_SETS}
if (tsetarr(Value)[i]<>0) then
{$else}
if ((Value and 1)<>0) then
{$endif}
begin
If Result='' then
Result:=GetEnumName(PTI,i)
else
Result:=Result+','+GetEnumName(PTI,I);
end;
{$ifndef FPC_NEW_BIGENDIAN_SETS}
Value:=Value shr 1;
{$endif FPC_NEW_BIGENDIAN_SETS}
end;
if Brackets then
Result:='['+Result+']';

227
rtl/powerpc/set.inc
View File

@ -53,6 +53,7 @@ asm
stw r0,24(r3)
stw r0,28(r3)
{$ifndef FPC_NEW_BIGENDIAN_SETS}
// r0 := 1 shl r4[27-31] -> bit index in dword (rotate instructions
// with count in register only consider lower 5 bits of this register)
li r0,1
@ -62,9 +63,17 @@ asm
// (((b div 8) div 4)*4= (b div 8) and not(3))
// r5 := (r4 rotl(32-3)) and (0x01ffffff8)
rlwinm r4,r4,31-3+1,3,31-2
// store the result
stwx r0,r3,r4
{$else}
{ must be done byte- instead of dword-based }
rlwinm r5,r4,0,31-3+1,31
li r0,0x80
srw r0,r0,r5
srwi r4,r4,3
// store the result
stbx r0,r3,r4
{$endif}
end;
@ -86,6 +95,7 @@ asm
stfd f2,16(r3)
stfd f3,24(r3)
{$ifndef FPC_NEW_BIGENDIAN_SETS}
// get the index of the correct *dword* in the set
// r0 := (r5 rotl(32-3)) and (0x0fffffff8)
rlwinm r0,r5,31-3+1,3,31-2
@ -99,6 +109,17 @@ asm
or r5,r4,r5
// store result
stw r5,0(r3)
{$else}
{ must be done byte- instead of dword-based }
srwi r6,r5,3
lbzx r7,r6,r3
rlwinm r5,r5,0,31-3+1,31
li r0,0x80
srw r0,r0,r5
or r7,r7,r0
// store the result
stbx r7,r6,r3
{$endif}
end;
@ -120,6 +141,7 @@ asm
stfd f1,8(r3)
stfd f2,16(r3)
stfd f3,24(r3)
{$ifndef FPC_NEW_BIGENDIAN_SETS}
// get the index of the correct *dword* in the set
// r0 := (r4 rotl(32-3)) and (0x0fffffff8)
rlwinm r0,r5,31-3+1,3,31-2
@ -132,9 +154,22 @@ asm
andc r5,r4,r5
// store result
stw r4,0(r3)
{$else}
{ must be done byte- instead of dword-based }
srwi r6,r5,3
lbzx r7,r6,r3
rlwinm r5,r5,0,31-3+1,31
li r0,0x80
srw r0,r0,r5
andc r7,r7,r0
// store the result
stbx r7,r6,r3
{$endif}
end;
{$ifndef FPC_NEW_BIGENDIAN_SETS}
{$define FPC_SYSTEM_HAS_FPC_SET_SET_RANGE}
function fpc_set_set_range(const orgset: fpc_normal_set; l,h : byte): fpc_normal_set;assembler; compilerproc;
{
@ -196,29 +231,7 @@ asm
stw r5,0(r3) // store to set
.Lset_range_exit:
end;
{$define FPC_SYSTEM_HAS_FPC_SET_IN_BYTE}
function fpc_set_in_byte(const p: fpc_normal_set; b : byte): boolean;compilerproc;assembler;[public,alias:'FPC_SET_IN_BYTE'];
{
tests if the element b is in the set p, the **zero** flag is cleared if it's present
on entry: p in r3, b in r4
}
asm
// get the index of the correct *dword* in the set
// r0 := (r4 rotl(32-3)) and (0x0fffffff8)
rlwinm r0,r4,31-3+1,3,31-2
// load dword in which the bit has to be tested
lwzx r3,r3,r0
// r4 := 32 - r4 (no problem if r4 > 32, the rlwnm next does a mod 32)
subfic r4,r4,32
// r3 := (r3 shr (r4 mod 32)) and 1
rlwnm r3,r3,r4,31,31
end;
{$endif}
{$define FPC_SYSTEM_HAS_FPC_SET_ADD_SETS}
@ -354,169 +367,3 @@ asm
cntlzw r3,r0
srwi. r3,r3,5
end;
{$ifdef LARGESETS}
procedure do_set(p : pointer;b : word);assembler;[public,alias:'FPC_SET_SET_WORD'];
{
sets the element b in set p works for sets larger than 256 elements
not yet use by the compiler so
}
asm
pushl %eax
movl p,%edi
movw b,%ax
andl $0xfff8,%eax
shrl $3,%eax
addl %eax,%edi
movb 12(%ebp),%al
andl $7,%eax
btsl %eax,(%edi)
popl %eax
end;
procedure do_in(p : pointer;b : word);assembler;[public,alias:'FPC_SET_IN_WORD'];
{
tests if the element b is in the set p the carryflag is set if it present
works for sets larger than 256 elements
}
asm
pushl %eax
movl p,%edi
movw b,%ax
andl $0xfff8,%eax
shrl $3,%eax
addl %eax,%edi
movb 12(%ebp),%al
andl $7,%eax
btl %eax,(%edi)
popl %eax
end;
procedure add_sets(set1,set2,dest : pointer;size : longint);assembler;[public,alias:'FPC_SET_ADD_SETS_SIZE'];
{
adds set1 and set2 into set dest size is the number of bytes in the set
}
asm
movl set1,%esi
movl set2,%ebx
movl dest,%edi
movl size,%ecx
.LMADDSETSIZES1:
lodsl
orl (%ebx),%eax
stosl
addl $4,%ebx
decl %ecx
jnz .LMADDSETSIZES1
end;
procedure mul_sets(set1,set2,dest : pointer;size : longint);assembler;[public,alias:'FPC_SET_MUL_SETS_SIZE'];
{
multiplies (i.E. takes common elements of) set1 and set2 result put in
dest size is the number of bytes in the set
}
asm
movl set1,%esi
movl set2,%ebx
movl dest,%edi
movl size,%ecx
.LMMULSETSIZES1:
lodsl
andl (%ebx),%eax
stosl
addl $4,%ebx
decl %ecx
jnz .LMMULSETSIZES1
end;
procedure sub_sets(set1,set2,dest : pointer;size : longint);assembler;[public,alias:'FPC_SET_SUB_SETS_SIZE'];
asm
movl set1,%esi
movl set2,%ebx
movl dest,%edi
movl size,%ecx
.LMSUBSETSIZES1:
lodsl
movl (%ebx),%edx
notl %edx
andl %edx,%eax
stosl
addl $4,%ebx
decl %ecx
jnz .LMSUBSETSIZES1
end;
procedure sym_sub_sets(set1,set2,dest : pointer;size : longint);assembler;[public,alias:'FPC_SET_SYMDIF_SETS_SIZE'];
{
computes the symetric diff from set1 to set2 result in dest
}
asm
movl set1,%esi
movl set2,%ebx
movl dest,%edi
movl size,%ecx
.LMSYMDIFSETSIZE1:
lodsl
movl (%ebx),%edx
xorl %edx,%eax
stosl
addl $4,%ebx
decl %ecx
jnz LMSYMDIFSETSIZE1
end;
procedure comp_sets(set1,set2 : pointer;size : longint);assembler;[public,alias:'FPC_SET_COMP_SETS_SIZE'];
asm
movl set1,%esi
movl set2,%edi
movl size,%ecx
LMCOMPSETSIZES1:
lodsl
movl (%edi),%edx
cmpl %edx,%eax
jne LMCOMPSETSIZEEND
addl $4,%edi
decl %ecx
jnz LMCOMPSETSIZES1
{ we are here only if the two sets are equal
we have zero flag set, and that what is expected }
LMCOMPSETSIZEEND:
end;
{$IfNDef NoSetInclusion}
procedure contains_sets(set1,set2 : pointer; size: longint);assembler;[public,alias:'FPC_SET_CONTAINS_SETS'];
{
on exit, zero flag is set if set1 <= set2 (set2 contains set1)
}
asm
movl set1,%esi
movl set2,%edi
movl size,%ecx
LMCONTAINSSETS2:
movl (%esi),%eax
movl (%edi),%edx
andl %eax,%edx
cmpl %edx,%eax {set1 and set2 = set1?}
jne LMCONTAINSSETEND2
addl $4,%esi
addl $4,%edi
decl %ecx
jnz LMCONTAINSSETS2
{ we are here only if set2 contains set1
we have zero flag set, and that what is expected }
LMCONTAINSSETEND2:
end;
{$EndIf NoSetInclusion}
{$endif LARGESET}

60
rtl/powerpc64/set.inc
View File

@ -50,6 +50,7 @@ asm
stw r0,24(r3)
stw r0,28(r3)
{$ifndef FPC_NEW_BIGENDIAN_SETS}
// r0 := 1 shl r4[27-31] -> bit index in dword (rotate instructions
// with count in register only consider lower 5 bits of this register)
li r0,1
@ -59,9 +60,17 @@ asm
// (((b div 8) div 4)*4= (b div 8) and not(3))
// r5 := (r4 rotl(32-3)) and (0x01ffffff8)
rlwinm r4,r4,31-3+1,3,31-2
// store the result
stwx r0,r3,r4
{$else}
{ must be done byte- instead of dword-based }
rlwinm r5,r4,0,31-3+1,31
li r0,0x80
srw r0,r0,r5
srwi r4,r4,3
// store the result
stbx r0,r3,r4
{$endif}
end;
@ -83,6 +92,7 @@ asm
stfd f2,16(r3)
stfd f3,24(r3)
{$ifndef FPC_NEW_BIGENDIAN_SETS}
// get the index of the correct *dword* in the set
// r0 := (r5 rotl(32-3)) and (0x0fffffff8)
rlwinm r0,r5,31-3+1,3,31-2
@ -96,6 +106,17 @@ asm
or r5,r4,r5
// store result
stw r5,0(r3)
{$else}
{ must be done byte- instead of dword-based }
srwi r6,r5,3
lbzx r7,r6,r3
rlwinm r5,r5,0,31-3+1,31
li r0,0x80
srw r0,r0,r5
or r7,r7,r0
// store the result
stbx r7,r6,r3
{$endif}
end;
@ -117,6 +138,7 @@ asm
stfd f1,8(r3)
stfd f2,16(r3)
stfd f3,24(r3)
{$ifndef FPC_NEW_BIGENDIAN_SETS}
// get the index of the correct *dword* in the set
// r0 := (r4 rotl(32-3)) and (0x0fffffff8)
rlwinm r0,r5,31-3+1,3,31-2
@ -129,8 +151,20 @@ asm
andc r5,r4,r5
// store result
stw r4,0(r3)
{$else}
{ must be done byte- instead of dword-based }
srwi r6,r5,3
lbzx r7,r6,r3
rlwinm r5,r5,0,31-3+1,31
li r0,0x80
srw r0,r0,r5
andc r7,r7,r0
// store the result
stbx r7,r6,r3
{$endif}
end;
{$ifndef FPC_NEW_BIGENDIAN_SETS}
{$define FPC_SYSTEM_HAS_FPC_SET_SET_RANGE}
function fpc_set_set_range(const orgset: fpc_normal_set; l,h : byte): fpc_normal_set;assembler; compilerproc;
@ -193,29 +227,7 @@ asm
stw r5,0(r3) // store to set
.Lset_range_exit:
end;
{$define FPC_SYSTEM_HAS_FPC_SET_IN_BYTE}
function fpc_set_in_byte(const p: fpc_normal_set; b : byte): boolean;compilerproc;assembler;[public,alias:'FPC_SET_IN_BYTE'];
{
tests if the element b is in the set p, the **zero** flag is cleared if it's present
on entry: p in r3, b in r4
}
asm
// get the index of the correct *dword* in the set
// r0 := (r4 rotl(32-3)) and (0x0fffffff8)
rlwinm r0,r4,31-3+1,3,31-2
// load dword in which the bit has to be tested
lwzx r3,r3,r0
// r4 := 32 - r4 (no problem if r4 > 32, the rlwnm next does a mod 32)
subfic r4,r4,32
// r3 := (r3 shr (r4 mod 32)) and 1
rlwnm r3,r3,r4,31,31
end;
{$endif}
{$define FPC_SYSTEM_HAS_FPC_SET_ADD_SETS}

36
tests/test/tset7.pp Normal file
View File

@ -0,0 +1,36 @@
{ test for subsetreg sets }
{$packset 1}
type
ta = 0..7;
tr = record
b: byte;
a: set of ta;
w: word;
end;
procedure test(r: tr);
var
b: ta;
begin
b := 6;
if (r.b<>101) or
(r.w<>$abcd) or
(5 in r.a) or
(b in r.a) or
not(7 in r.a) or
([1..3] * r.a <> [2..3]) then
halt(1);
end;
var
r: tr;
begin
r.b:=101;
r.w:=$abcd;
r.a:=[2..3];
include(r.a,7);
test(r);
end.

6
tests/webtbs/tw8660.pp
View File

@ -25,11 +25,15 @@ var
begin
C := TClient.Create;
C.Num := 2;
C.St := [ckVip, ckNormal]; // the numeric representation is 5
C.St := [ckVip, ckNormal]; // the numeric representation is 5 (on little endian systems)
V := C.St;
writeln(sizeof(V), ' ', byte(V)); // It's OK
writeln(sizeof(C.St), ' ', byte(C.St)); // It's OK
{$ifdef FPC_LITTLE_ENDIAN}
if GetOrdProp(C, 'St')<>5 then
{$else}
if GetOrdProp(C, 'St')<>160 then
{$endif}
halt(1);
if GetSetProp(C, 'St')<>'ckNormal,ckVip' then
halt(1);