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

* implementation of bit scan intrinsics by Richard Vida, resolves #17592

Browse Source 
git-svn-id: trunk@16174 -
This commit is contained in:
florian 2010-10-16 15:03:30 +00:00
parent 6cb12d0efc
commit 5dae691c96
12 changed files with 328 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -9086,6 +9086,7 @@ tests/test/tasout.pp svneol=native#text/plain
tests/test/tassignmentoperator1.pp svneol=native#text/pascal
tests/test/tbopr.pp svneol=native#text/plain
tests/test/tbrtlevt.pp svneol=native#text/plain
tests/test/tbsx1.pp svneol=native#text/plain
tests/test/tcase0.pp svneol=native#text/pascal
tests/test/tcase1.pp svneol=native#text/plain
tests/test/tcase10.pp svneol=native#text/pascal

3
compiler/cgobj.pas
View File

@ -288,6 +288,9 @@ unit cgobj;
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);
{ bit scan instructions }
procedure a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: tcgsize; src, dst: TRegister); virtual; abstract;
{ 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;

2
compiler/compinnr.inc
View File

@ -81,6 +81,8 @@ const
in_objc_encode_x = 71;
in_sar_x_y = 72;
in_sar_x = 73;
in_bsf_x = 74;
in_bsr_x = 75;
{ Internal constant functions }
in_const_sqr = 100;

27
compiler/ncginl.pas
View File

@ -56,6 +56,7 @@ interface
procedure second_abs_long; virtual;
procedure second_rox; virtual;
procedure second_sar; virtual;
procedure second_bsfbsr; virtual;
end;
implementation
@ -169,6 +170,9 @@ implementation
in_sar_x,
in_sar_x_y:
second_sar;
in_bsf_x,
in_bsr_x:
second_BsfBsr;
else internalerror(9);
end;
end;
@ -806,6 +810,29 @@ implementation
end;
end;
procedure tcginlinenode.second_BsfBsr;
var
reverse: boolean;
opsize: tcgsize;
begin
reverse:=(inlinenumber = in_bsr_x);
secondpass(left);
opsize:=tcgsize2unsigned[left.location.size];
if opsize < OS_32 then
opsize:=OS_32;
if (left.location.loc <> LOC_REGISTER) or
(left.location.size <> opsize) then
location_force_reg(current_asmdata.CurrAsmList,left.location,opsize,true);
location_reset(location,LOC_REGISTER,opsize);
location.register := cg.getintregister(current_asmdata.CurrAsmList,opsize);
cg.a_bit_scan_reg_reg(current_asmdata.CurrAsmList,reverse,opsize,left.location.register,location.register);
end;
begin
cinlinenode:=tcginlinenode;
end.

16
compiler/ninl.pas
View File

@ -2597,6 +2597,18 @@ implementation
set_varstate(tcallparanode(tcallparanode(left).right).left,vs_read,[vsf_must_be_valid]);
resultdef:=tcallparanode(tcallparanode(left).right).left.resultdef;
end;
in_bsf_x,
in_bsr_x:
begin
set_varstate(left,vs_read,[vsf_must_be_valid]);
if not is_integer(left.resultdef) then
CGMessage1(type_e_integer_expr_expected,left.resultdef.typename);
if torddef(left.resultdef).ordtype in [u64bit, s64bit] then
resultdef:=u64inttype
else
resultdef:=u32inttype
end;
in_objc_selector_x:
begin
result:=cobjcselectornode.create(left);
@ -3007,7 +3019,9 @@ implementation
in_ror_x,
in_ror_x_x,
in_sar_x,
in_sar_x_y:
in_sar_x_y,
in_bsf_x,
in_bsr_x:
expectloc:=LOC_REGISTER;
else
internalerror(89);

5
compiler/options.pas
View File

@ -2432,6 +2432,11 @@ begin
def_system_macro('FPC_HAS_INTERNAL_SAR');
{ $endif}
{ inline bsf/bsr implementation }
{$if defined(x86) or defined(x86_64)}
def_system_macro('FPC_HAS_INTERNAL_BSX');
{$endif}
{$ifdef powerpc64}
def_system_macro('FPC_HAS_LWSYNC');
{$endif}

13
compiler/x86/cgx86.pas
View File

@ -71,6 +71,9 @@ unit cgx86;
procedure a_load_reg_reg(list : TAsmList;fromsize,tosize: tcgsize;reg1,reg2 : tregister);override;
procedure a_loadaddr_ref_reg(list : TAsmList;const ref : treference;r : tregister);override;
{ bit scan instructions }
procedure a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: TCGSize; src, dst: TRegister); override;
{ fpu move instructions }
procedure a_loadfpu_reg_reg(list: TAsmList; fromsize, tosize: tcgsize; reg1, reg2: tregister); override;
procedure a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tcgsize; const ref: treference; reg: tregister); override;
@ -1631,6 +1634,16 @@ unit cgx86;
end;
end;
procedure tcgx86.a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: TCGSize; src, dst: TRegister);
var
opsize: topsize;
begin
opsize:=tcgsize2opsize[size];
if not reverse then
list.concat(taicpu.op_reg_reg(A_BSF,opsize,src,dst))
else
list.concat(taicpu.op_reg_reg(A_BSR,opsize,src,dst));
end;
{*************** compare instructructions ****************}

23
rtl/i386/i386.inc
View File

@ -1653,3 +1653,26 @@ end;
{$endif}
{$ifndef FPC_SYSTEM_HAS_BSX_QWORD}
{$define FPC_SYSTEM_HAS_BSX_QWORD}
function BsfQWord(Const AValue : QWord): cardinal; assembler; nostackframe;
asm
bsfl 4(%esp),%eax
jnz .L2
.L1: bsfl 8(%esp),%eax
add $32,%eax
.L2:
end;
function BsrQWord(Const AValue : QWord): cardinal; assembler; nostackframe;
asm
bsrl 8(%esp),%eax
jz .L1
add $32,%eax
jmp .L2
.L1: bsrl 4(%esp),%eax
.L2:
end;
{$endif}

93
rtl/inc/generic.inc
View File

@ -2269,3 +2269,96 @@ function SarInt64(Const AValue : Int64;Shift : Byte): Int64;
{$endif FPC_HAS_INTERNAL_SAR_QWORD}
{$endif FPC_SYSTEM_HAS_SAR_QWORD}
{$ifndef FPC_HAS_INTERNAL_BSX_BYTE}
{$ifndef FPC_SYSTEM_HAS_BSX_BYTE}
function BsfByte(Const AValue: Byte): Byte;
const bsf8bit: array [Byte] of Byte = (
$ff,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,
5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,
6,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,
5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,
7,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,
5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,
6,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,
5,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0,4,0,1,0,2,0,1,0,3,0,1,0,2,0,1,0
);
begin
result:=bsf8bit[AValue];
end;
function BsrByte(Const AValue: Byte): Byte;
const bsr8bit: array [Byte] of Byte = (
$ff,0,1,1,2,2,2,2,3,3,3,3,3,3,3,3,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,4,
5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,
6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7
);
begin
result:=bsr8bit[AValue];
end;
{$endif}
{$endif}
{$ifndef FPC_SYSTEM_HAS_BSX_WORD}
{$ifndef FPC_HAS_INTERNAL_BSX_WORD}
function BsfWord(Const AValue: Word): cardinal;
begin
if lo(AValue)<>0 then
result:=BsfByte(lo(AValue))
else
result:=BsfByte(hi(AValue))+8
end;
function BsrWord(Const AValue: Word): cardinal;
begin
if hi(AValue)<>0 then
result:=BsrByte(hi(AValue))+8
else
result:=BsrByte(lo(AValue))
end;
{$endif}
{$endif}
{$ifndef FPC_HAS_INTERNAL_BSX_DWORD}
{$ifndef FPC_SYSTEM_HAS_BSX_DWORD}
function BsfDWord(Const AValue : DWord): cardinal;
begin
if lo(AValue)<>0 then
result:=BsfWord(lo(AValue))
else
result:=BsfWord(hi(AValue))+16
end;
function BsrDWord(Const AValue : DWord): cardinal;
begin
if hi(AValue)<>0 then
result:=BsrWord(hi(AValue))+16
else
result:=BsrWord(lo(AValue))
end;
{$endif}
{$endif}
{$ifndef FPC_HAS_INTERNAL_BSX_QWORD}
{$ifndef FPC_SYSTEM_HAS_BSX_QWORD}
function BsfQWord(Const AValue : QWord): cardinal;
begin
if lo(AValue) <> 0 then
result:=BsfDWord(lo(AValue))
else
result:=BsfDWord(hi(AValue)) + 32
end;
function BsrQWord(Const AValue : QWord): cardinal;
begin
if hi(AValue) <> 0 then
result:=BsrDWord(hi(AValue)) + 32
else
result:=BsrDWord(lo(AValue))
end;
{$endif}
{$endif}

2
rtl/inc/innr.inc
View File

@ -82,6 +82,8 @@ const
fpc_objc_encode_x = 71;
fpc_in_sar_x_y = 72;
fpc_in_sar_x = 73;
fpc_in_bsf_x = 74;
fpc_in_bsr_x = 75;
{ Internal constant functions }
fpc_in_const_sqr = 100;

42
rtl/inc/systemh.inc
View File

@ -756,6 +756,48 @@ function SarInt64(Const AValue : Int64;Shift : Byte): Int64;[internproc:fpc_in_s
function SarInt64(Const AValue : Int64;Shift : Byte = 1): Int64;
{$endif FPC_HAS_INTERNAL_SAR_QWORD}
{$ifdef FPC_HAS_INTERNAL_BSX}
{$if defined(cpui386) or defined(cpux86_64)}
{$define FPC_HAS_INTERNAL_BSX_BYTE}
{$define FPC_HAS_INTERNAL_BSX_WORD}
{$define FPC_HAS_INTERNAL_BSX_DWORD}
{$endif}
{$if defined(cpux86_64)}
{$define FPC_HAS_INTERNAL_BSX_QWORD}
{$endif}
{$endif}
{$ifdef FPC_HAS_INTERNAL_BSX_BYTE}
function BsfByte(Const AValue: Byte): Byte;[internproc:fpc_in_bsf_x];
function BsrByte(Const AValue: Byte): Byte;[internproc:fpc_in_bsr_x];
{$else}
function BsfByte(Const AValue: Byte): Byte;{$ifdef SYSTEMINLINE}inline;{$endif}
function BsrByte(Const AValue: Byte): Byte;{$ifdef SYSTEMINLINE}inline;{$endif}
{$endif}
{$ifdef FPC_HAS_INTERNAL_BSX_WORD}
function BsfWord(Const AValue: Word): cardinal;[internproc:fpc_in_bsf_x];
function BsrWord(Const AValue: Word): cardinal;[internproc:fpc_in_bsr_x];
{$else}
function BsfWord(Const AValue: Word): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}
function BsrWord(Const AValue: Word): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}
{$endif}
{$ifdef FPC_HAS_INTERNAL_BSX_DWORD}
function BsfDWord(Const AValue : DWord): cardinal;[internproc:fpc_in_bsf_x];
function BsrDWord(Const AValue : DWord): cardinal;[internproc:fpc_in_bsr_x];
{$else}
function BsfDWord(Const AValue : DWord): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}
function BsrDWord(Const AValue : DWord): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}
{$endif FPC_HAS_INTERNAL_BSX_DWORD}
{$ifdef FPC_HAS_INTERNAL_BSX_QWORD}
function BsfQWord(Const AValue : QWord): cardinal;[internproc:fpc_in_bsf_x];
function BsrQWord(Const AValue : QWord): cardinal;[internproc:fpc_in_bsr_x];
{$else}
function BsfQWord(Const AValue : QWord): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}
function BsrQWord(Const AValue : QWord): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}
{$endif FPC_HAS_INTERNAL_BSF_QWORD}
{$ifndef FPUNONE}
{ float math routines }

102
tests/test/tbsx1.pp Normal file
View File

@ -0,0 +1,102 @@
program testbitscan;
function test_byte: boolean;
var
x8,f,r: byte;
i: integer;
begin
for i:=0 to 7 do
begin
x8:=1 shl i;
f:=BsfByte(x8);
if (f<>i) then
begin
writeln('BsfByte(',x8,') returned ',f,', should be ',i);
exit(false);
end;
r:=BsrByte(x8);
if r<>i then
begin
writeln('BsrByte(',x8,') returned ',f,', should be ',i);
exit(false);
end;
end;
result:=true;
end;
function test_word: boolean;
var
x16: word;
i,f,r: integer;
begin
for i:=0 to 15 do
begin
x16:=1 shl i;
f:=BsfWord(x16);
if (f<>i) then
begin
writeln('BsfWord(',x16,') returned ',f,', should be ',i);
exit(false);
end;
r:=BsrWord(x16);
if r<>i then
begin
writeln('BsrWord(',x16,') returned ',f,', should be ',i);
exit(false);
end;
end;
result:=true;
end;
function test_dword: boolean;
var
x32: cardinal;
i,f,r: integer;
begin
for i:=0 to 31 do
begin
x32:=1 shl i;
f:=BsfDWord(x32);
if (f<>i) then
begin
writeln('BsfDWord(',x32,') returned ',f,', should be ',i);
exit(false);
end;
r:=BsrDWord(x32);
if r<>i then
begin
writeln('BsrDWord(',x32,') returned ',f,', should be ',i);
exit(false);
end;
end;
result:=true;
end;
function test_qword: boolean;
var
x64: qword;
i, f, r: integer;
begin
for i:=0 to 63 do
begin
x64:=uint64(1) shl i;
f:=BsfQWord(x64);
if f<>i then begin
writeln('BsfQWord(',x64,') returned ',f,', should be ',i);
exit(false);
end;
r:=BsrQWord(x64);
if r<>i then begin
writeln('BsrQWord(',x64,') returned ',r,', should be ',i);
exit(false);
end;
end;
result:=true;
end;
begin
if test_byte then writeln('passed') else halt(1);
if test_word then writeln('passed') else halt(1);
if test_dword then writeln('passed') else halt(1);
if test_qword then writeln('passed') else halt(1);
end.