Implementation of a queue class (70 times times faster than Delphi comes with) (thread-safe version)

Unit Sfcontnrs;

Interface

{$DEFINE Multi_thread_queue}//thread-safe version, if thread safety is not required, comment out this line of code

{$IFDEF Multi_thread_queue}
Uses
Windows;
{$ENDIF}

Type
Tsfqueue=class
Private
Fcapacity:integer;
Ftmpbuff:pointer;
Fbuff:pointer;
Fposition:integer;
{$IFDEF Multi_thread_queue}
Fcs:trtlcriticalsection;
{$ENDIF}
//\\
Fpushindex:integer;
Fpopindex:integer;

Procedure Lock ();
Procedure UnLock ();
Procedure inernal_setcapacity (const value:integer);
//\\
Procedure setcapacity (const value:integer);
function Getcapacity:integer;
Public
Constructor Create (initcapacity:integer=1024);
destructor Destroy (); override;
//\\
function Push (aitem:pointer): Pointer;
function Pop (): Pointer;
Public
Property Capacity:integer read Getcapacity write setcapacity;
End

Implementation

{Tsfqueue}

Constructor Tsfqueue.create (Initcapacity:integer);
Begin
{$IFDEF Multi_thread_queue}
InitializeCriticalSection (FCS);
{$ENDIF}

If initcapacity < 1024x768 then initcapacity: = 1024;

Inernal_setcapacity (initcapacity);

End

destructor Tsfqueue.destroy;
Begin
Freemem (Fbuff);
If Ftmpbuff <> Nil Then
Freemem (Ftmpbuff);
//\\
{$IFDEF Multi_thread_queue}
DeleteCriticalSection (FCS);
{$ENDIF}

inherited;
End

Procedure Tsfqueue.lock;
Begin
{$IFDEF Multi_thread_queue}
EnterCriticalSection (FCS);
{$ENDIF}
End

Procedure Tsfqueue.unlock;
Begin
{$IFDEF Multi_thread_queue}
LeaveCriticalSection (FCS);
{$ENDIF}
End

Procedure tsfqueue.inernal_setcapacity (const value:integer);
Var
Pagecount,asize:integer;
Begin
If Value > Fcapacity Then
Begin
If Ftmpbuff <> Nil Then
Freemem (Ftmpbuff);

Expansion
Asize: = Value * 4;//calculates the required number of bytes
PageCount: = asize div 4096;
if (asize mod 4096) > 0 Then INC (pagecount);

Transfer data
Getmem (Ftmpbuff,pagecount * 4096);
Fillchar (Ftmpbuff^,pagecount * 4096, #0);

If Fbuff <> Nil Then
Begin
Move (fbuff^,ftmpbuff^,fcapacity * 4);
Freemem (Fbuff);
End

Fbuff: = Ftmpbuff;

Calculate the new capacity
Fcapacity: = (PageCount * 4096) Div 4;

If fcapacity >= 2048 then
Begin
Ftmpbuff allocated for pop, mobile memory
Getmem (Ftmpbuff,pagecount * 4096);
End
Else
Ftmpbuff: = nil;
End
End

function TsfQueue.Pop:Pointer;
Procedure Adjuestmem ();
Var
Psrc:pinteger;
Ptmp:pointer;
Begin
Fillchar (ftmpbuff^,fcapacity * 4, #0);
PSRC: = Pinteger (Fbuff);
INC (Psrc,fpopindex);
Move (psrc^,ftmpbuff^, (fcapacity-fpopindex) * 4);
//\\
Exchange pointers
Ptmp: = Fbuff;
Fbuff: = Ftmpbuff;
Ftmpbuff: = ptmp;
//\\
End

Const
_moverange_ = 2048;

Var
  P:pinteger;
Begin
  Lock ();
  Try
    Result: = nil;
    if (fpopindex = fpushindex) then
      Exit;
    P: = Pinteger (Fbuff);
    Inc (P,fpopindex);
    Result: = Pointer (p^);
    Inc (Fpopindex);
   //Queue bottom free memory up to 8192 overall relocation
    if Fpopindex = _moverange_ then
     BEGIN
      adjuestmem ();
      Fpopindex: = 0;
      Dec (Fpushindex,_moverange_);
    end;
  finally
    UnLock ();
  END;
End;

function Tsfqueue.push (aitem:pointer): Pointer;
Var
P:pinteger;
Begin
Lock ();
Try
P: = Pinteger (Fbuff);
INC (P,fpushindex);
p^: = Integer (AItem);
INC (Fpushindex);
If Fpushindex >= fcapacity Then
Begin
Expansion Plus 1024 Locations
Inernal_setcapacity (fcapacity + 1024);
End
Finally
UnLock ();
End
End

Procedure tsfqueue.setcapacity (const value:integer);
Begin
Lock ();
Try
Inernal_setcapacity (Value);
Finally
UnLock ();
End
End

function TsfQueue.getCapacity:Integer;
Begin
Lock ();
Try
Result: = self.fcapacity;
Finally
UnLock ();
End
End

End.

Test function

Procedure Tfrmmain.btnqueueclick (Sender:tobject);
Var
A:tsfqueue; Optimized high-Speed team class implementation (thread-safe)
B:tqueue;
Index:integer;
Begin
A: = Tsfqueue.create ();
B: = Tqueue.create ();
SW. Start ();
For Index: = 1 to 10000 * 2 do
Begin
B.push (0);
End
For Index: = 1 to 10000 * 2 do
Begin
B.pop ();
End

SW. Stop ();

ShowMessage (IntToStr (SW). Elapsedmiliseconds));

End

Transferred from: http://www.cnblogs.com/lwm8246/archive/2011/10/06/2200009.html

Implementation of a queue class (70 times times faster than Delphi comes with) (thread-safe version)