FastCountBits.dpr

program FastCountBits;

{$APPTYPE CONSOLE}

uses
  SysUtils, het.Utils, het.FileSys;

function CountBits_Cyclic_B(value:byte):integer;
begin
  result:=0;
  while value<>0 do begin
    inc(result);
    value:=value and (value-1);
  end;
end;

function CountBits_Cyclic(var Data;const Len:integer):integer;var P,PEnd:PByte;
begin
  result:=0;if Len<=0 then exit;
  P:=@Data;PEnd:=PSucc(P,Len);while P<>PEnd do begin
    inc(result,CountBits_Cyclic_B(P^));inc(P);end;
end;

function _CountBits_Arith_B(const value:byte):integer;
begin
  result:=value  and $55+value  shr 1 and $55;
  result:=result and $33+result shr 2 and $33;
  result:=result and  $F+result shr 4;
end;

function _CountBits_Arith_W(const value:word):integer;
begin
  result:=value  and $5555+value  shr 1 and $5555;
  result:=result and $3333+result shr 2 and $3333;
  result:=result and $0F0F+result shr 4 and $0F0F;
  result:=result and $00FF+result shr 8;
end;

function _CountBits_Arith_DW(const value:cardinal):integer;
begin
  result:=value  and $55555555+value  shr 1 and $55555555;
  result:=result and $33333333+result shr 2 and $33333333;
  result:=result and $0F0F0F0F+result shr 4 and $0F0F0F0F;
  result:=result and $00FF00FF+result shr 8 and $00FF00FF;
  result:=result and $FFFF    +result shr 16;
end;

function CountBits_Arith(var Data;const Len:integer):integer;var P,PEnd:PByte;
begin
  result:=0;if Len<=0 then exit;
  P:=@Data;PEnd:=PSucc(P,Len);while P<>PEnd do begin
    inc(result,_CountBits_Arith_B(P^));inc(P);end;
end;

function CountBits_Arith_W(var Data;const Len:integer):integer;var P,PEnd:PWord;
begin
  result:=0;if Len<=0 then exit;
  P:=@Data;PEnd:=PSucc(P,Len);while P<>PEnd do begin
    inc(result,_CountBits_Arith_W(P^));inc(P);end;
end;

function CountBits_Arith_DW(var Data;const Len:integer):integer;var P,PEnd:PCardinal;
begin
  result:=0;if Len<=0 then exit;
  P:=@Data;PEnd:=PSucc(P,Len);while P<>PEnd do begin
    inc(result,_CountBits_Arith_DW(P^));inc(P);end;
end;

var lookup:array[0..$FF]of byte;

function CountBits_Lookup(var Data;const Len:integer):integer;var P,PEnd:PByte;
begin
  result:=0;if Len<=0 then exit;
  P:=@Data;PEnd:=PSucc(P,Len);while P<>PEnd do begin
    inc(result,Lookup[P^]);inc(P);end;
end;

var lookupW:array[0..$FFFF]of byte;

function CountBits_Lookup_W(var Data;const Len:integer):integer;var P,PEnd:PWord;
begin
  result:=0;if Len<=0 then exit;
  P:=@Data;PEnd:=PSucc(P,Len);while P<>PEnd do begin
    inc(result,LookupW[P^]);inc(P);end;
end;

function _CountBits_SSE_Aligned(P,PEnd:pointer):integer;
const countfetch=30;
asm
  push esi;  xor esi,esi //counter

  mov ecx,$55555555 movd xmm4,ecx pshufd xmm4,xmm4,0
  mov ecx,$33333333 movd xmm5,ecx pshufd xmm5,xmm5,0
  mov ecx,$0F0F0F0F movd xmm6,ecx pshufd xmm6,xmm6,0

  @@1:
    lea ecx,[eax+$10*countfetch]
    cmp ecx,edx
    cmova ecx,edx //ecx:next segment end

    cmp eax,ecx jae @@3//exit

    pxor xmm7,xmm7//byte sum
    @@2:
      movdqa xmm0,[eax]                  movdqa xmm2,[eax+$10]

                       movdqa xmm1,xmm0                   movdqa xmm3,xmm2
      pand xmm0,xmm4   psrld  xmm1,1     pand xmm2,xmm4   psrld  xmm3,1
                       pand xmm1,xmm4                     pand xmm3,xmm4
      paddb xmm0,xmm1                    paddb xmm2,xmm3

                       movdqa xmm1,xmm0                   movdqa xmm3,xmm2
      pand xmm0,xmm5   psrld  xmm1,2     pand xmm2,xmm5   psrld  xmm3,2
                       pand xmm1,xmm5                     pand xmm3,xmm5
      paddb xmm0,xmm1                    paddb xmm2,xmm3                 prefetchnta [eax+$100]
                                                                         add eax,$20
                       movdqa xmm1,xmm0                   movdqa xmm3,xmm2
      pand xmm0,xmm6   psrld  xmm1,4     pand xmm2,xmm6   psrld  xmm3,4
                       pand xmm1,xmm6                     pand xmm3,xmm6
      paddb xmm0,xmm1                    paddb xmm2,xmm3

      paddb xmm7,xmm0                    paddb xmm7,xmm2

    cmp eax,ecx jb @@2

    movdqa xmm0,xmm7  pslld xmm0,24  psrld xmm0,24
    movdqa xmm1,xmm7  pslld xmm1,16  psrld xmm1,24  paddd xmm0,xmm1
    movdqa xmm1,xmm7  pslld xmm1, 8  psrld xmm1,24  paddd xmm0,xmm1
    movdqa xmm1,xmm7  pslld xmm1, 0  psrld xmm1,24  paddd xmm0,xmm1

    pshufd xmm1,xmm0,2+3 shl 2
    paddd xmm0,xmm1
    pshufd xmm1,xmm0,1
    paddd xmm0,xmm1
    movd ecx,xmm0
    add esi,ecx

  jmp @@1
  @@3:

  mov eax,esi
  pop esi
end;

function CountBits_SSE(var Data;const Len:integer):integer;var P,PEnd,PSSEEnd:PByte;
begin
  result:=0;if Len<=0 then exit;
  P:=@Data;PEnd:=PSucc(P,Len);while(P<>PEnd)and(cardinal(P)and $F<>0)do begin
    inc(result,_CountBits_Arith_B(P^));inc(P);end;

  PSSEEnd:=pAlignDown(pEnd,$20);
  if cardinal(PSSEEnd)>cardinal(P)then begin
    inc(result,_CountBits_SSE_Aligned(P,PSSEEnd));
    P:=PSSEEnd;
  end;

  while(P<>PEnd)do begin
    inc(result,_CountBits_Arith_B(P^));inc(P);end;
end;

type
  TCountBits=function(var Data;const Len:integer):integer;

procedure Test(name:string;proc:TCountBits);
var Data:AnsiString;
    res,i:integer;
begin
  Data:=FileReadStr('c:\opticalillusion.bmp');
  for i:=0 to 0 do begin
    perfStart(name);
    res:=proc(Data[1],length(Data)and -4);
    Writeln(perfReport+' res='+tostr(res));
  end;
end;

var i:integer;
begin
  try
    for i:=0 to high(lookup)do lookup[i]:=CountBits_Cyclic_B(i);
    for i:=0 to high(lookupw)do lookupw[i]:=CountBits_Cyclic(i,2);

    for i:=0 to 3 do begin
      writeln('-------- round#'+tostr(i));
      Test('byte, ciklusos ',@CountBits_Cyclic);
      Test('byte, szamolos ',@CountBits_Arith);
      Test('byte, lookup   ',@CountBits_Lookup);
      Test('word, szamolos ',@CountBits_Arith_W);
      Test('word, lookup   ',@CountBits_Lookup_W);
      Test('dword, szamolos',@CountBits_Arith_DW);
      Test('sse, szamolos  ',@CountBits_SSE);
    end;
    readln;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
end.