real case test MM parallel 4x scalable (i7 6700)
(on the newer processors will be linear)

I did a small test with real code scenario,
look at parallel zlib with my patch, zcompress loop 1000 of a 1100KB text file:

uses System.Zlib;

threadvar
INS: TMemoryStream;
OUTS: pointer;
SizeIn: integer;
SizeOUT: integer;

procedure TForm.CompressClick(Sender: TObject);
var
Count: integer;
begin
Count := GetTickCount;
TParallel.For(1,1000,procedure(I:integer)
begin
INS := TMemoryStream.Create;
INS.LoadFromFile('c:\teststream.txt');
SizeIn := INS.Size;
GetMem(OUTS, SizeIn);
SizeOUT := SizeIn;
ZCompress(INS.Memory, SizeIn, OUTS, SizeOUT, zcFastest);
INS.Free;
FreeMem(OUTS);
end);
ShowMessage(IntToStr(GetTickCount - Count));
end;

- fastmm4 900-1000msec
- brainMM 563msec
- msheap 532msec
- my patch Intel IPP + TTB 281 msec

procedure TForm1.Button1Click(Sender: TObject);
var
task: ITask;
begin
Task := TTask.Create(
procedure()
var
context: TRTTIContext;
methods: TArray<TRTTIMethod>;
method: TRTTIMethod;
arg: TValue;
begin
methods := context.GetType(Self.ClassType).GetMethods;
for method in methods do
begin
if method.Name = 'Test' then
begin
arg := 'Hello World!';
method.Invoke(Self, [arg]);

Exit;
end;
end;
end);
Task.Start;
end;

procedure TForm1.Test(Text: string);
begin
TThread.Synchronize(nil,
procedure
begin
Self.Caption := Text;
end);
end;

program Project1;

{$APPTYPE CONSOLE}
{$MAXSTACKSIZE $10000000} // 256Mb

procedure surprise;
var a: array[1 .. 1024 * 1024 * 128] of byte; // 128Mb
begin
 writeln(sizeOf(a), ' bytes on the stack');
end;

begin

 surprise;
 readln;

end.

  p := VirtualAlloc(nil, 8 * 200000000, MEM_COMMIT, PAGE_READWRITE);

procedure T();
var p2,p:PData;
    i :longint;
begin       
  p:=VirtualAlloc(nil,8*100000000,MEM_COMMIT ,PAGE_READWRITE); 
   
  for i:=0 to 100000000  do p^[i]:=1;
  writeln(p^[200002]);
  readln();

  VirtualFree(p,0,MEM_RELEASE);

end;

  p := VirtualAlloc(nil, SizeOf(Real) * 200000000, MEM_COMMIT, PAGE_READWRITE);

procedure T();
var p2,p:PData;
    i :longint;
begin       
  p:=VirtualAlloc(nil,8*100000000,MEM_COMMIT ,PAGE_READWRITE); 
  writeln(0);
  p2:=VirtualAlloc(nil,8*100000000,MEM_COMMIT ,PAGE_READWRITE); 
  writeln(1);   
  for i:=0 to 100000000  do p^[i]:=1;
  writeln(2);
  for i:=0 to 100000000  do p2^[i]:=1;
  writeln(p^[200002]);
  readln();

  VirtualFree(p,0,MEM_RELEASE);
  VirtualFree(p2,0,MEM_RELEASE);

end;

  TLargeArray<T> = record
    Items: array of array of T;
  private
    FCount: int64;
    function GetElements(n: int64): T;
    procedure SetElements(n: int64; const Value: T);
    procedure SetCount(const Value: int64);
  public
    procedure Clear;
    property Elements[n: int64]: T read GetElements write SetElements; default;
    property Count: int64 read FCount write SetCount;
  end;

procedure T2();
var p: array of real;
    i :longint;
begin       
  SetLength(p,100000000);
  for i:=0 to 100000000-1  do p[i]:=1;
  writeln(p[200002]);
  readln();  
end;

procedure T2();
var p: array of real;
    i :longint;
begin       
  SetLength(p,200000000);
  for i:=0 to 200000000-1  do p[i]:=1;
  writeln(p[200002]);
  readln();  
end;

 try
   start:=GetTickCount;
   with ibquery2 do
   for i := 1 to 3 do
     for j := 1 to 2 do
      for k := 1 to 163 do
        for l := 1 to 60 do
          for m := 1 to 10 do
   begin
     sql.text:=     //   'execute procedure NEW_FLUX ('+inttostr(i)+','+inttostr(j)+','+inttostr(k)+','+inttostr(l)+','+inttostr(m)+','''+inttostr(1)+''',''' + inttostr(1)+ ''')';
       'insert into flux ("Кампания","Время","ТВС","Слой","ТвЭл","FLUX E<1МэВ","FLUX E>1МэВ") values ('+
        inttostr(i)+','+inttostr(j)+','+inttostr(k)+','+inttostr(l)+','+inttostr(m)+','''+inttostr(1)+''',''' + inttostr(1)+ ''')';
    transaction.starttransaction;
    execSQL;
    transaction.commit;
    transaction.Active:=false;
   end;
   IBquery1.Close;
   ibquery1.Open;
   finish:=GetTickCount;
   form2.TimeLabel.Caption:=('Время заполнения: '+floattostr((finish-start)/1000)+' секунд');
  except
   if ibquery1.active then
    ibquery2.transaction.rollback;
   showmessage ('Ошибка');
  end;

 try
   start:=GetTickCount;
   with ibquery2 do
   transaction.starttransaction;
   sql.text:=  
       'insert into flux ("Кампания","Время","ТВС","Слой","ТвЭл","FLUX E<1МэВ","FLUX E>1МэВ") values ('
        +':Pi, :Pj, :Pk, :Pl, :Pm, 1, 1,)';
   Prepare;
   for i := 1 to 3 do
     for j := 1 to 2 do
      for k := 1 to 163 do
        for l := 1 to 60 do
          for m := 1 to 10 do
   begin
     sql.ParamByName('Pi').AsInteger := i;
     sql.ParamByName('Pj').AsInteger := j;
...
    execSQL;
   end;
    transaction.commit;
    transaction.Active:=false;

   IBquery1.Close;
   ibquery1.Open;
   finish:=GetTickCount;
   form2.TimeLabel.Caption:=('Время заполнения: '+floattostr((finish-start)/1000)+' секунд');
  except
   if ibquery1.active then
    ibquery2.transaction.rollback;
   showmessage ('Ошибка');
  end;

try
   start:=GetTickCount;
   ibquery2.transaction.starttransaction;
   with ibquery2 do
    begin
      sql.text:=
       'insert into flux ("Кампания","Время","ТВС","Слой","ТвЭл","FLUX E<1МэВ","FLUX E>1МэВ") values (:Pi, :Pj, :Pk, :Pl, :Pm, 1, 1)';
      Prepare;

     for i := 1 to 3 do
      for j := 1 to 2 do
       for k := 1 to 163 do
        for l := 1 to 60 do
          for m := 1 to 10 do
           begin
              ParamByName('Pi').AsInteger := i;
              ParamByName('Pj').AsInteger := j;
              ParamByName('Pk').AsInteger := k;
              ParamByName('Pl').AsInteger := l;
              ParamByName('Pm').AsInteger := m;
              execSQL;
            end;
    end;

   //  ibquery2.
    ibquery2.transaction.commit;
    ibquery2.transaction.Active:=false;

   IBquery1.Close;
   ibquery1.Open;
   finish:=GetTickCount;
   form2.TimeLabel.Caption:=('Время заполнения: '+floattostr((finish-start)/1000)+' секунд');

  except
   if ibquery1.active then
    ibquery2.transaction.rollback;
   showmessage ('Ошибка');
  end;

 try
   start:=GetTickCount;
   ibquery2.transaction.starttransaction;

  // fPn:= ibquery2.ParamByName('Pn');
   with ibquery2 do
    begin
      sql.text:=
     //  'insert into flux ("Кампания","Время","ТВС","Слой","ТвЭл","FLUX E<1МэВ","FLUX E>1МэВ") values (:Pi, :Pj, :Pk, :Pl, :Pm, 1, 1)';
    'execute block ('+
    'PI1 int = :PI1, '+
    'PJ1 int = :PJ1, '+
    'PK1 int = :PK1, '+
    'Pl1 int = :Pl1, '+
    'Pm1 int = :Pm1, '+

    'PI2 int = :PI2, '+
    'PJ2 int = :PJ2, '+
    'PK2 int = :PK2, '+
    'Pl2 int = :Pl2, '+
    'Pm2 int = :Pm2, '+

    'PI3 int = :PI3, '+
    'PJ3 int = :PJ3, '+
    'PK3 int = :PK3, '+
    'Pl3 int = :Pl3, '+
    'Pm3 int = :Pm3) '+

   ' as              '+
   '  begin          '+
   '   insert into flux ("Кампания","Время","ТВС","Слой","ТвЭл","FLUX E<1МэВ","FLUX E>1МэВ")'+
   '   values (:PI1, :PJ1, :PK1, :Pl1, :Pm1, 1, 1);                      '+
   '   insert into flux ("Кампания","Время","ТВС","Слой","ТвЭл","FLUX E<1МэВ","FLUX E>1МэВ")'+
   '   values (:PI2, :PJ2, :PK2, :Pl2, :Pm2, 1, 1);                      '+
   '   insert into flux ("Кампания","Время","ТВС","Слой","ТвЭл","FLUX E<1МэВ","FLUX E>1МэВ")'+
   '   values (:PI3, :PJ3, :PK3, :Pl3, :Pm3, 1, 1);                      '+
   '  end  ';

     Prepare;

   fPi1:= ibquery2.ParamByName('Pi1');
   fPj1:= ibquery2.ParamByName('Pj1');
   fPk1:= ibquery2.ParamByName('Pk1');
   fPl1:= ibquery2.ParamByName('Pl1');
   fPm1:= ibquery2.ParamByName('Pm1');

   fPi2:= ibquery2.ParamByName('Pi2');
   fPj2:= ibquery2.ParamByName('Pj2');
   fPk2:= ibquery2.ParamByName('Pk2');
   fPl2:= ibquery2.ParamByName('Pl2');
   fPm2:= ibquery2.ParamByName('Pm2');

   fPi3:= ibquery2.ParamByName('Pi3');
   fPj3:= ibquery2.ParamByName('Pj3');
   fPk3:= ibquery2.ParamByName('Pk3');
   fPl3:= ibquery2.ParamByName('Pl3');
   fPm3:= ibquery2.ParamByName('Pm3');

     for i := 1 to 3 do
      for j := 1 to 2 do
       for k := 1 to 163 do
        for l := 1 to 60 do
          for m := 1 to 10 do
            begin
              fPi1.AsInteger:= i;
              fPj1.AsInteger := j;
              fPk1.AsInteger:= k;
              fPl1.AsInteger := l;
              fPm1.AsInteger := m;

              fPi2.AsInteger:= i;
              fPj2.AsInteger := j;
              fPk2.AsInteger:= k;
              fPl2.AsInteger := l;
              fPm2.AsInteger := m+10;

              fPi3.AsInteger:= i;
              fPj3.AsInteger := j;
              fPk3.AsInteger:= k;
              fPl3.AsInteger := l;
              fPm3.AsInteger := m+20;
              execSQL;
            end;
    end;

   //  ibquery2.
    ibquery2.transaction.commit;
    ibquery2.transaction.Active:=false;

   IBquery1.Close;
   ibquery1.Open;
   finish:=GetTickCount;
   form2.TimeLabel.Caption:=('Время заполнения: '+floattostr((finish-start)/1000)+' секунд');

  except
   if ibquery1.active then
    ibquery2.transaction.rollback;
   showmessage ('Ошибка');
  end;

var t: TextFile;

    s1: UnicodeString;
    s2: AnsiString;
    s3, s4: RawByteString;
    s5: UTF8String;

begin
  try
//    AssignFile(t, 'd:\write.txt');
//    AssignFile(t, 'd:\write.txt', 866);
//    AssignFile(t, 'd:\write.txt', 1251);
    AssignFile(t, 'd:\write.txt', 65001);

    s1 := 'Мама мыла раму';
    s2 := s1;
    s3 := s2; SetCodePage(s3, 866);
    s4 := s3; SetCodePage(s4, 65001);
    s5 := s2;

    Rewrite(t);
    Writeln(t, s1);
      Writeln(t, s2);
        Writeln(t, s3);
          Writeln(t, s4);
            Writeln(t, s5);
    Writeln(t, s1, s2, s3, s4, s5);

    CloseFile(t);

var
 mSize    :NativeUInt;
 tResult  :string;

procedure Test(aVoid:Pointer);
var 
 i,n:NativeInt;
 t:Cardinal;
 pA,pB:Pointer;
 zA,zB:PNativeInt;
begin
 tResult := 'Error?!';

 pA := GetMemory(mSize); // VirtualAlloc(nil,mSize,MEM_COMMIT or MEM_RESERVE,PAGE_READWRITE);//
 pB := GetMemory(mSize); // VirtualAlloc(nil,mSize,MEM_COMMIT or MEM_RESERVE,PAGE_READWRITE);//

 if (pA <> nil) and (pB <> nil) then begin
 
  n := mSize div sizeOf(zA^) - 1;

  t := GetTickCount();
   zA := pA; for i := 0 to n do begin zA^:=i; inc(zA);  end;
   zB := pB; for i := 0 to n do begin zB^:=i; inc(zB);  end;
  t := GetTickCount() - t; 
  tResult := IntToStr(mSize div (1024*1024))+'::'#9'Zz ' + IntToStr(t);

  
  t := GetTickCount();
   NonCollisionMove(pA^,pB^,mSize);
  t := GetTickCount() - t; 
  tResult :=tResult + #9'Na ' + IntToStr(t);

  t := GetTickCount();
   Move(pA^,pB^,mSize);
  t := GetTickCount() - t; 
  tResult := tResult + #9'Ma ' + IntToStr(t);

  t := GetTickCount();
   NonCollisionMove(pA^,pB^,mSize);
  t := GetTickCount() - t; 
  tResult := tResult + #9'Nb ' + IntToStr(t);

  t := GetTickCount();
   Move(pA^,pB^,mSize);
  t := GetTickCount() - t; 
  tResult := tResult + #9'Mb ' + IntToStr(t);  

  t := GetTickCount();
   NonCollisionMove(pA^,pB^,mSize);
  t := GetTickCount() - t; 
  tResult :=tResult + #9'Nc ' + IntToStr(t);
  
  
 end;
 FreeMemory(pB); // VirtualFree(pB,0,MEM_RELEASE); // 
 FreeMemory(pA); // VirtualFree(pA,0,MEM_RELEASE); //  
 
 SendMessage(Form1.Handle,WM_USER,0,0); 
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
 Caption := 'Go...';  
 Button1.Enabled := False;
 mSize := StrToInt64Def(Edit1.Text,512)*(1024*1024);
 CloseHandle(BeginThread(nil,0,@Test,nil,0,PCardinal(nil)^));
end;

procedure TForm1.WmUser(var Message: TMessage);
begin
 Caption := 'SuperTest!';
 Memo1.Lines.Add(tResult);
 Button1.Enabled := True;
end;

var
 mSize     :Cardinal;
 mOffsetS  :Cardinal;
 mOffsetD  :Cardinal;
 tResult  :string;

procedure Test(aVoid:Pointer);
const 
 GB = UInt64(8)*1024*1024*1024;
var 
 i,n,t :NativeUInt;
 pS,pD :Pointer;
begin

 tResult := 'Error?!';

 pS := VirtualAlloc(nil,mSize,MEM_COMMIT or MEM_RESERVE,PAGE_READWRITE); // pS := GetMemory(mSize); 
 pD := VirtualAlloc(nil,mSize,MEM_COMMIT or MEM_RESERVE,PAGE_READWRITE); // pD := GetMemory(mSize); 

 if (pS <> nil) and (pD <> nil) then begin

  ZeroMemory(pS,mSize);
  ZeroMemory(pD,mSize);
 
  n := GB div mSize - 1;
  tResult := IntToStr( mSize div 1024) +'KB x ' +IntToStr((n+1) div 1024) +'Kn S+' +IntToStr(mOffsetS) +' D+' +IntToStr(mOffsetD) +' :';

  pS := PByte(pS) + mOffsetS;
  pD := PByte(pD) + mOffsetD;
  if (mOffsetS > mOffsetD) then Dec(mSize, mOffsetS) else Dec(mSize, mOffsetD);
  
  t := GetTickCount();
   for i := 0 to n do NonCollisionMove(pS^,pD^,mSize);
  tResult := tResult + #9'Na ' + IntToStr(GetTickCount() - t);

  t := GetTickCount();
   for i := 0 to n do Move(pS^,pD^,mSize);
  tResult := tResult + #9'Ma ' + IntToStr(GetTickCount() - t);

  t := GetTickCount();
   for i := 0 to n do NonCollisionMove(pS^,pD^,mSize);
  tResult := tResult + #9'Nb ' + IntToStr(GetTickCount() - t);

  t := GetTickCount();
   for i := 0 to n do Move(pS^,pD^,mSize);
  tResult := tResult + #9'Mb ' + IntToStr(GetTickCount() - t);

  t := GetTickCount();
   for i := 0 to n do  NonCollisionMove(pS^,pD^,mSize);
  tResult := tResult + #9'Nc ' + IntToStr(GetTickCount() - t);

 end;
 
 pS:=PByte(pS)-mOffsetS;
 pD:=PByte(pD)-mOffsetD;

 VirtualFree(pD,0,MEM_RELEASE); // FreeMemory(pS);
 VirtualFree(pS,0,MEM_RELEASE); // FreeMemory(pD); 
 
 PostMessage(Form1.Handle,WM_USER,0,0); 
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 mSize := StrToIntDef(Edit1.Text,4); 
 mOffsetS := StrToIntDef(Edit2.Text,0);
 mOffsetD := StrToIntDef(Edit3.Text,0);   
 mSize:=mSize * 1024; 
 Button1.Enabled := False;
 CloseHandle(BeginThread(nil,0,@Test,nil,0,PCardinal(nil)^));
end;

procedure TForm1.WmUser(var Message: TMessage);
begin
 Memo1.Lines.Add(tResult);
 Button1.Enabled := True;                                  
end;

function Q_PStrScan(P: PWideChar; Ch: WideChar; Size: Integer): Integer; // x32
asm
  test    eax, eax   // P=nil?
  jz      @@exit

  push    ecx
  lea     eax, [eax + 2*ecx]
  neg     ecx
  jnl     @@zero

@@loop:
  cmp dx, [eax + 2*ecx]
  je @@found

  inc ecx
  jne @@loop

@@zero:
  pop ecx
  xor eax, eax
@@exit:
  ret

@@found:
  pop eax
  lea eax, [eax + ecx + 1]
end;

function MyMove(const Source; var Dest; Count: NativeInt): Integer;
asm
  push ebx
  cmp ecx, 15
  jbe @@Move8
@@Move16:
  mov ebx, DWORD PTR [eax]
  mov DWORD PTR [edx], ebx
  mov ebx, DWORD PTR [eax+4]
  mov DWORD PTR [edx+4], ebx
  add edx, 16
  add eax, 16
  sub ecx, 16
  cmp ecx, 15
  ja @@Move16
@@Move8:
  test ecx, ecx
  je @@Exit
  test cl, 8
  je @@Move4
  mov ebx, DWORD PTR [eax]
  mov DWORD PTR [edx], ebx
  add edx, 8
  add eax, 8
@@Move4:
  test cl, 4
  je @@Move2
  mov ebx, DWORD PTR [eax]
  mov DWORD PTR [edx], ebx
  add edx, 4
  add eax, 4
@@Move2:
  test cl, 2
  je @@Move1
  movzx ebx, WORD PTR [eax]
  mov WORD PTR [edx], bx
  add edx, 2
  add eax, 2
@@Move1:
  test cl, 1
  je @@Exit
  movzx eax, BYTE PTR [eax]
  mov BYTE PTR [edx], al
@@Exit:
  pop ebx
end;

program Project71;

uses
  Windows;

function sprintf(S: PAnsiChar; const Format: PAnsiChar): Integer; cdecl;
  varargs; external 'msvcrt.dll';
function QueryPerformanceCounter(var lpPerformanceCount: Int64): LongBool;
  stdcall; external 'kernel32.dll' name 'QueryPerformanceCounter';
function QueryPerformanceFrequency(var lpFrequency: Int64): LongBool; stdcall;
  external 'kernel32.dll' name 'QueryPerformanceFrequency';

function PrintTime(time: Single): AnsiString;
begin
  Result := '';
  SetLength(Result, 25);
  SetLength(Result, sprintf(PAnsiChar(Result), '%f', time));
end;

function MyMove(const Source; var Dest; Count: NativeInt): Integer;
asm
  push ebx
  cmp ecx, 15
  jbe @@Move8
@@Move16:
  mov ebx, DWORD PTR [eax]
  mov DWORD PTR [edx], ebx
  mov ebx, DWORD PTR [eax+4]
  mov DWORD PTR [edx+4], ebx
  add edx, 16
  add eax, 16
  sub ecx, 16
  cmp ecx, 15
  ja @@Move16
@@Move8:
  test ecx, ecx
  je @@Exit
  test cl, 8
  je @@Move4
  mov ebx, DWORD PTR [eax]
  mov DWORD PTR [edx], ebx
  add edx, 8
  add eax, 8
@@Move4:
  test cl, 4
  je @@Move2
  mov ebx, DWORD PTR [eax]
  mov DWORD PTR [edx], ebx
  add edx, 4
  add eax, 4
@@Move2:
  test cl, 2
  je @@Move1
  movzx ebx, WORD PTR [eax]
  mov WORD PTR [edx], bx
  add edx, 2
  add eax, 2
@@Move1:
  test cl, 1
  je @@Exit
  movzx eax, BYTE PTR [eax]
  mov BYTE PTR [edx], al
@@Exit:
  pop ebx
end;

procedure NonCollisionMove(const Source; var Dest; const size: NativeUInt);
asm
  // basic routine
  {$IFDEF CPUX86}
  cmp ecx, 32
  {$ELSE .CPUX64}
  cmp r8, 32
  // make Source = eax/rax, Dest = edx/rdx, Size = ecx/rcx
  mov rax, rcx
  xchg rcx, r8
  // r9 as pointer to @move_03_items
  lea r9, [@move_03_items]
  {$ENDIF}

  // is big/large (32...inf)
  jae @move_big

  // is small (0..3)
  cmp ecx, 4
  jb @move_03

  // move middle(4..31) = move 16(0..16) + move dwords(0..12) + move small(0..3)
  cmp ecx, 16
  jb @move_015

  {$IFDEF CPUX86}
  movups xmm0, [eax]
  movups [edx], xmm0
  jne @move_015_offset
  ret
@move_015_offset:
  sub ecx, 16
  add eax, 16
  add edx, 16
@move_015:
  push ecx
  and ecx, -4
  add eax, ecx
  add edx, ecx
  jmp [ecx + @move_dwords]
@move_dwords: DD @rw_0,@rw_4,@rw_8,@rw_12
@rw_12:
  mov ecx, [eax-12]
  mov [edx-12], ecx
@rw_8:
  mov ecx, [eax-8]
  mov [edx-8], ecx
@rw_4:
  mov ecx, [eax-4]
  mov [edx-4], ecx
@rw_0:
  pop ecx
  and ecx, 3
  {$ELSE .CPUX64}
  movups xmm0, [rax]
  movups [rdx], xmm0
  jne @move_015_offset
  ret
@move_015_offset:
  sub rcx, 16
  add rax, 16
  add rdx, 16
@move_015:
  // make r9 = dest 0..3 pointer, rcx = dwords count
  mov r8, rcx
  shr rcx, 2
  and r8, 3
  lea r9, [r9 + r8*8]
  // case jump
  lea r8, [@move_dwords]
  jmp qword ptr [r8 + rcx*8]
@move_dwords: DQ @rw_0,@rw_4,@rw_8,@rw_12
@rw_8:
  mov rcx, [rax]
  mov [rdx], rcx
  add rax, 8
  add rdx, 8
  jmp qword ptr [r9]
@rw_12:
  mov rcx, [rax]
  mov [rdx], rcx
  add rax, 8
  add rdx, 8
@rw_4:
  mov ecx, [rax]
  mov [rdx], ecx
  add rax, 4
  add rdx, 4
@rw_0:
  jmp qword ptr [r9]
  {$ENDIF}

@move_03:
  {$IFDEF CPUX86}
  jmp [offset @move_03_items + ecx*4]
@move_03_items: DD @0,@1,@2,@3
@2: mov cx, [eax]
  mov [edx], cx
  ret
@3: mov cx, [eax]
  mov [edx], cx
  add eax, 2
  add edx, 2
@1: mov cl, [eax]
  mov [edx], cl
@0: ret
  {$ELSE .CPUX64}
  jmp qword ptr [r9 + rcx*8]
@move_03_items: DQ @0,@1,@2,@3
@2: mov cx, [rax]
  mov [rdx], cx
  ret
@3: mov cx, [rax]
  mov [rdx], cx
  add rax, 2
  add rdx, 2
@1: mov cl, [rax]
  mov [rdx], cl
@0: ret
  {$ENDIF}

@move_big:
  {$IFDEF CPUX86}
  cmp ecx, 16*4
  {$ELSE .CPUX64}
  cmp rcx, 16*4
  {$ENDIF}
  jae @move_large

  // big memory move by SSE (32..63) = (32..48) + (0..15)
  {$IFDEF CPUX86}
  test ecx, 15
  jz @move_32_48

  push ecx
  and ecx, 15
  movups xmm0, [eax]
  movups [edx], xmm0
  add eax, ecx
  add edx, ecx

  pop ecx
  and ecx, -16
  {$ELSE .CPUX64}
  mov r8, rcx
  test rcx, 15
  jz @move_32_48

  and r8, 15
  movups xmm0, [rax]
  movups [rdx], xmm0
  add rax, r8
  add rdx, r8

  and rcx, -16
  {$ENDIF}

@move_32_48:
  {$IFDEF CPUX86}
  add eax, ecx
  add edx, ecx
  cmp ecx, 48
  jb @rw_32
@rw_48: movups xmm2, [eax - 2*16 - 16]
  movups [edx - 2*16 - 16], xmm2
@rw_32: movups xmm1, [eax - 1*16 - 16]
  movups xmm0, [eax - 0*16 - 16]
  movups [edx - 1*16 - 16], xmm1
  movups [edx - 0*16 - 16], xmm0
  {$ELSE .CPUX64}
  add rax, rcx
  add rdx, rcx
  cmp rcx, 48
  jb @rw_32
@rw_48: movups xmm2, [rax - 2*16 - 16]
  movups [rdx - 2*16 - 16], xmm2
@rw_32: movups xmm1, [rax - 1*16 - 16]
  movups xmm0, [rax - 0*16 - 16]
  movups [rdx - 1*16 - 16], xmm1
  movups [rdx - 0*16 - 16], xmm0
  {$ENDIF}

  ret
@move_large:
  // large memory move by SSE (64..inf)

  // destination alignment
  {$IFDEF CPUX86}
  push ebx
  test edx, 15
  jz @move_16128_initialize

  mov ebx, edx
  movups xmm0, [eax]
  movups [ebx], xmm0

  add edx, 15
  and edx, -16
  sub ebx, edx
  sub eax, ebx
  add ecx, ebx
  {$ELSE .CPUX64}
  test rdx, 15
  jz @move_16128_initialize

  mov r8, rdx
  movups xmm0, [rax]
  movups [r8], xmm0

  add rdx, 15
  and rdx, -16
  sub r8, rdx
  sub rax, r8
  add rcx, r8
  {$ENDIF}

@move_16128_initialize:
  {$IFDEF CPUX86}
  push ecx
  mov ebx, offset @aligned_reads
  shr ecx, 4
  test eax, 15
  jz @move_16128
  mov ebx, offset @unaligned_reads
  {$ELSE .CPUX64}
  movaps [rsp-8-16], xmm6
  movaps [rsp-8-32], xmm7
  mov r8, rcx
  lea r9, [@aligned_reads]
  shr rcx, 4
  test rax, 15
  jz @move_16128
  lea r9, [@unaligned_reads]
  {$ENDIF}

@move_16128:
  {$IFDEF CPUX86}
  cmp ecx, 8
  jae @move_128

  lea ecx, [ecx + ecx]
  lea eax, [eax + ecx*8]
  lea edx, [edx + ecx*8]
  lea ebx, [ebx + 8*4]
  neg ecx
  lea ebx, [ebx + ecx*2]
  jmp ebx
@move_128:
  lea eax, [eax + 128]
  lea edx, [edx + 128]
  lea ecx, [ecx - 8]
  jmp ebx
  {$ELSE .CPUX64}
  cmp rcx, 8
  jae @move_128

  lea rcx, [rcx + rcx]
  lea rax, [rax + rcx*8]
  lea rdx, [rdx + rcx*8]
  lea r9, [r9 + 8*4]
  neg rcx
  lea r9, [r9 + rcx*2]
  jmp r9
@move_128:
  lea rax, [rax + 128]
  lea rdx, [rdx + 128]
  lea rcx, [rcx - 8]
  jmp r9
  {$ENDIF}

  // aligned sse read
@aligned_reads:
  {$IFDEF CPUX86}
  movaps xmm7, [eax - 7*16 - 16]
  movaps xmm6, [eax - 6*16 - 16]
  movaps xmm5, [eax - 5*16 - 16]
  movaps xmm4, [eax - 4*16 - 16]
  movaps xmm3, [eax - 3*16 - 16]
  movaps xmm2, [eax - 2*16 - 16]
  movaps xmm1, [eax - 1*16 - 16]
  movaps xmm0, [eax - 0*16 - 16]
  {$ELSE .CPUX64}
  movaps xmm7, [rax - 7*16 - 16]
  movaps xmm6, [rax - 6*16 - 16]
  movaps xmm5, [rax - 5*16 - 16]
  movaps xmm4, [rax - 4*16 - 16]
  movaps xmm3, [rax - 3*16 - 16]
  movaps xmm2, [rax - 2*16 - 16]
  movaps xmm1, [rax - 1*16 - 16]
  movaps xmm0, [rax - 0*16 - 16]
  {$ENDIF}
  jae @aligned_writes
  jmp @write_16112

  // unaligned sse read
@unaligned_reads:
  {$IFDEF CPUX86}
  movups xmm7, [eax - 7*16 - 16]
  movups xmm6, [eax - 6*16 - 16]
  movups xmm5, [eax - 5*16 - 16]
  movups xmm4, [eax - 4*16 - 16]
  movups xmm3, [eax - 3*16 - 16]
  movups xmm2, [eax - 2*16 - 16]
  movups xmm1, [eax - 1*16 - 16]
  movups xmm0, [eax - 0*16 - 16]
  jae @aligned_writes
@write_16112:
  lea ebx, [offset @aligned_writes + 8*4 + ecx*2]
  jmp ebx
  {$ELSE .CPUX64}
  movups xmm7, [rax - 7*16 - 16]
  movups xmm6, [rax - 6*16 - 16]
  movups xmm5, [rax - 5*16 - 16]
  movups xmm4, [rax - 4*16 - 16]
  movups xmm3, [rax - 3*16 - 16]
  movups xmm2, [rax - 2*16 - 16]
  movups xmm1, [rax - 1*16 - 16]
  movups xmm0, [rax - 0*16 - 16]
  jae @aligned_writes
@write_16112:
  lea r9, [@aligned_writes + 8*4]
  lea r9, [r9 + rcx*2]
  jmp r9
  {$ENDIF}

  // aligned sse write, loop
@aligned_writes:
  {$IFDEF CPUX86}
  movaps [edx - 7*16 - 16], xmm7
  movaps [edx - 6*16 - 16], xmm6
  movaps [edx - 5*16 - 16], xmm5
  movaps [edx - 4*16 - 16], xmm4
  movaps [edx - 3*16 - 16], xmm3
  movaps [edx - 2*16 - 16], xmm2
  movaps [edx - 1*16 - 16], xmm1
  movaps [edx - 0*16 - 16], xmm0
  test ecx, ecx
  {$ELSE .CPUX64}
  movaps [rdx - 7*16 - 16], xmm7
  movaps [rdx - 6*16 - 16], xmm6
  movaps [rdx - 5*16 - 16], xmm5
  movaps [rdx - 4*16 - 16], xmm4
  movaps [rdx - 3*16 - 16], xmm3
  movaps [rdx - 2*16 - 16], xmm2
  movaps [rdx - 1*16 - 16], xmm1
  movaps [rdx - 0*16 - 16], xmm0
  test rcx, rcx
  {$ENDIF}
  jg @move_16128

  // last 0..15 bytes
  {$IFDEF CPUX86}
  pop ecx
  pop ebx
  and ecx, 15
  jnz @move_115
  ret
@move_115:
  add eax, ecx
  add edx, ecx
  movups xmm0, [eax - 0*16 - 16]
  movups [edx - 0*16 - 16], xmm0
  {$ELSE .CPUX64}
  movaps xmm6, [rsp-8-16]
  movaps xmm7, [rsp-8-32]
  and r8, 15
  jnz @move_115
  ret
@move_115:
  add rax, r8
  add rdx, r8
  movups xmm0, [rax - 0*16 - 16]
  movups [rdx - 0*16 - 16], xmm0
  {$ENDIF}
end;

type
  TCall = procedure(const Source; var Dest; Count: NativeInt);

var
  i, g: Integer;

  Str1, Str2: AnsiString;
  StartTime, StopTime: Int64;
  iCounterPerSec: Int64;

procedure Speed(const n: string; c: Pointer; i: Integer);
begin
  QueryPerformanceCounter(StartTime);

  for g := 0 to 10000000 do
  begin
    TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
    TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
    TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
    TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
    TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
    TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
    TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
    TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
    TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
    TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
    TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
    TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
    TCall(c)(Str2[1], Str1[i + 1], Length(Str2) - i);
  end;

  if QueryPerformanceCounter(StopTime) and QueryPerformanceFrequency
    (iCounterPerSec) then
    Writeln(n, ':: ', PrintTime((StopTime - StartTime) / iCounterPerSec));
end;

begin
{$IFNDEF DEBUG}
  Write('Release');
{$ELSE}
  Write('Debug');
{$ENDIF}
{$IF Defined(CPUX64) or Defined(CPUARM64)}
  Writeln(' 64bit');
{$ELSE}
  Writeln(' 32Bit');
{$IFEND}
  System.SetMinimumBlockAlignment(mba16Byte);

  Str1 := 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx'
    + 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx';

  Str2 := '------------------------------------------------------------------------------------------------------------------------------------------------'
    + '------------------------------------------------------------------------------------------------------------------------------------------------';


  i := 9;
  Writeln('-- ', i ,' -- ');
  Speed('MyMove', @MyMove, i);
  Speed('Move', @Move, i);
  Speed('NonCollisionMove', @NonCollisionMove, i);


  i := 0;
  Writeln('-- ', i ,' -- ');
  Speed('MyMove', @MyMove, i);
  Speed('Move', @Move, i);
  Speed('NonCollisionMove', @NonCollisionMove, i);

  i := 3;
  Writeln('-- ', i ,' -- ');
  Speed('MyMove', @MyMove, i);
  Speed('Move', @Move, i);
  Speed('NonCollisionMove', @NonCollisionMove, i);

  Readln;

end.

program console;

{$APPTYPE CONSOLE}

uses
  SysUtils;

var
  Sum: int64;
  S: string;
  F: TextFile;
begin
  Sum := 0;
  AssignFile(F, 'correct_file.txt');
  Reset(F);
  while not Eof(F) do
  begin
    Readln(F, S);
    Sum := Sum + StrToIntDef(S, 0);
  end;
  writeln(Format('Sum is %d, %x', [Sum, Sum]));
end.

procedure Init;
 var
  Start: Cardinal;
  Step : Integer;
  Temp : PString;
 begin
  Start:=GetTickCount;
  for Step:=1 to 22000000
   do   begin
         New(Temp);
         Temp^:='123';
         StrToInt(Temp^);
         Dispose(Temp)
        end;
  WriteLn('Init: ', GetTickCount-Start, 'ms.')
 end;

procedure Test;
var
  i     : integer;
  Count : integer;
  CF    : TCachedFileReader;
begin
  CF:=TCachedFileReader.Create('D:\Test.dat'); // Название файла прямо сюда
  try
    while CF.Position<CF.Size do begin // Реальный файл с данными скопирован для тестов ~100 раз
      CF.ReadWord; // Пошли данные о заголовке, читаем в /dev/null
      CF.ReadByte;
      Count:=CF.ReadInteger; // Кол-во объектов
      for i:=1 to Count do begin // Куча объектов
        CF.ReadDouble;  // Опять привет /dev/null
        CF.ReadDouble;
        CF.ReadInteger;
        CF.ReadInteger;
        CF.ReadAnsiString(0,1); // Заголовок - 1й байт (длина строки)
        CF.ReadBoolean;
        CF.ReadSmallInt;
      end;
    end;
  finally
    CF.Free; // Очищаем все.
  end;
end;

  TCachedFileReader = class(TFileStream)
  public
    constructor Create(FN: string); overload;

    Function ReadByte: Byte;
    Function ReadWord: Word;
    Function ReadSmallInt: SmallInt;
    Function ReadInteger: integer;
    Function ReadIntegerEx(Bytes: integer): integer;
    function ReadInt64: int64;
    Function ReadSingle: single;
    Function ReadDouble: double;
    Function ReadAnsiString(CharCount: integer = 0; HeaderSize: byte = 4): AnsiString;
    Function ReadBoolean: boolean;
  end;

implementation

{ TCachedFileReader }

constructor TCachedFileReader.Create(FN: string);
begin
  inherited Create(FN,0);
end;

function TCachedFileReader.ReadAnsiString(CharCount: integer; HeaderSize: byte): AnsiString;
begin
  if CharCount=0 then begin
    Read(CharCount,HeaderSize);
  end;

  SetLength(Result,CharCount);
  Read(Result[1],CharCount);
end;

function TCachedFileReader.ReadBoolean: boolean;
begin
  Read(Result,1);
end;

function TCachedFileReader.ReadByte: Byte;
begin
  Read(Result,1);
end;

function TCachedFileReader.ReadDouble: double;
begin
  Read(Result,8);
end;

function TCachedFileReader.ReadInt64: int64;
begin
  Read(Result,8);
end;

function TCachedFileReader.ReadInteger: integer;
begin
  Read(Result,4);
end;

function TCachedFileReader.ReadIntegerEx(Bytes: integer): integer;
begin
  Read(Result,Bytes);
end;

function TCachedFileReader.ReadSingle: single;
begin
  Read(Result,4);
end;

function TCachedFileReader.ReadSmallInt: SmallInt;
begin
  Read(Result,2);
end;

function TCachedFileReader.ReadWord: Word;
begin
  Read(Result,2);
end;

procedure Test;
var
  i        : integer;
  t1,t2,t3 : cardinal;

  a1,s1    : RawByteString;
  a2,s2    : TBytes;
  a3,s3    : Pointer;
const
  BlockLen = 1000000;
begin
  SetLength(s1,BlockLen);
  SetLength(s2,BlockLen);
  GetMem(s3,BlockLen);

  t1:=GetTickCount;
  for i:=0 to 10000 do begin
    a1:=Copy(s1,1,BlockLen);
    a1:='';
  end;
  t1:=GetTickCount-t1;

  t2:=GetTickCount;
  for i:=0 to 10000 do begin
    SetLength(a2,BlockLen);
    Move(s2[1],a2[1],BlockLen);
    SetLength(a2,0);
  end;
  t2:=GetTickCount-t2;

  t3:=GetTickCount;
  for i:=0 to 10000 do begin
    GetMem(a3,BlockLen);
    Move(s3^,a3^,BlockLen);
    FreeMem(a3);
  end;
  t3:=GetTickCount-t3;

  ShowMessage(Format('%d,%d,%d',[t1,t2,t3]));
end;

const
  ID_UNKNOWN = 0;
  ID_CELL = 1;
  ID_DATA = 2;
  ID_ROW = 3;
  ID_SHEET = 4;
  ID_STYLE = 5;
  ID_VALUE = 6;

function ValueToID(const S: AnsiString): Cardinal;
begin
  // default value
  Result := ID_UNKNOWN;

  // byte ascii
  with PMemoryItems(S)^ do
  case Length(S) of 
    3: if (Words[0] + Bytes[2] shl 16 = $776F72) then Result := ID_ROW; // "row"
    4: case (Cardinals[0]) of // "cell", "data"
         $6C6C6563: Result := ID_CELL; // "cell"
         $61746164: Result := ID_DATA; // "data"
       end;
    5: case (Cardinals[0]) of // "sheet", "style", "value"
         $65656873: if (Bytes[4] = $74) then Result := ID_SHEET; // "sheet"
         $6C797473: if (Bytes[4] = $65) then Result := ID_STYLE; // "style"
         $756C6176: if (Bytes[4] = $65) then Result := ID_VALUE; // "value"
       end;
  end;
end;

procedure TFindMatchThread.Execute;
var
    Q: TpFIBQuery;
    D: TpFIBDataSet;
    i, w1, w2, Dist, C, F, RELDENUM: Integer;
    SL1, SL2: TStringList; S: String;
    REL, MaxRelFound, RelForIns, RELNUM: Double;
    TradeMarkDone: Boolean;

function IsTradeMark(S: String): Boolean;
var i: Integer;
  B1, B2: Boolean;
begin
  Result := False; B1 := False; B2 := False;
  for i := 1 to length(S) do
  if StrToIntDef(S[i], -1) in [0,1,2,3,4,5,6,7,8,9] then
  begin
    B1 := True; //содержит цифры
    Break;
  end;
  for i := 1 to length(S) do
  if StrToIntDef(S[i], -1) = -1 then
  begin
    B2 := True; //содержит буквы, дефис, слешы
    Break;
  end;
  Result := B1 and B2; //маркой считаем буквы+цифры
end;

function NoQ(S: String): String;
begin
  S := StringReplace(S, '. ', ' ', [rfReplaceAll]);
  S := StringReplace(S, ', ', ' ', [rfReplaceAll]);
  S := StringReplace(S, '"', '', [rfReplaceAll]);
  while Pos('  ', S) > 0 do S := StringReplace(S, '  ', ' ', [rfReplaceAll]);
  Result := S;
end;

begin
  inherited;
//  FreeOnTerminate := True;

  try
    LaDB := TFIBDatabase.Create(MainForm);
    LaTRN := TFIBTransaction.Create(MainForm);
    Q := TpFIBQuery.Create(LaDB);
    Q.Database := LaDB;
    Q.Transaction := LaTRN;

    D := TpFIBDataSet.Create(LaDB);
    D.Database := LaDB;
    D.Transaction := LaTRN;

    LaDB.UseLoginPrompt := False;
    LaDB.DatabaseName := DM.FIBDB.DatabaseName;
    LaDB.DBParams := DM.FIBDB.DBParams;
    LaDB.SQLDialect := DM.FIBDB.SQLDialect;
    LaDB.DefaultTransaction := LaTRN;
    LaTRN.DefaultDatabase := LaDB;
    LaTRN.TRParams := DM.TRNShort.TRParams;
    LaDB.Connected := True;
    LaTRN.StartTransaction;

    SL1 := TStringList.Create; SL1.Delimiter := ' ';
    SL2 := TStringList.Create; SL2.Delimiter := ' ';

    D.SelectSQL.Text := 'select * from TPRICEIMPORT where IDPRICE='+IntToStr(dlgPriceImportMatch.IDPrice)+' order by ID';
    D.Open; MyI := 0;

    while not D.EOF do
    begin
      for i := 0 to dlgPriceImportMatch.ResList.Count - 1 do
        if (i mod MaxT) = MyT - 1 then
        begin
          if Terminated then Exit;

          S := NoQ(D.FieldByName('NAME').AsString);
          SL1.Clear; SL1.DelimitedText := AnsiUpperCase(S);

          SL2.Clear; SL2.DelimitedText := AnsiUpperCase(dlgPriceImportMatch.ResList[i]);
          RelForIns := 1/SL1.Count; if RelForIns<0.3 then RelForIns := 0.3;
          C := 0; MaxRelFound := 0; F := 0; RELNUM := 0; RELDENUM := 0;
          for w1 := 1 to SL1.Count do
          begin
            for w2 := 1 to SL2.Count do
            begin
              if Terminated then Exit;

              TradeMarkDone := False;
              if IsTradeMark(SL1[w1-1]) then
              begin
                if SL1[w1-1] = SL2[w2-1] then
                begin //полные совпадения марок оцениваем в 2 раза
                  TradeMarkDone := True;
                  RelNum := RelNum + 2;
                  Break;
                end;
              end;

              if not TradeMarkDone then //как марка слово не обработано, ищем по расстоянию
              begin
                Dist := EditDistance(SL1[w1-1], SL2[w2-1]); //находим кол-во редактирований (расстояние левенштейна)
                if Dist <= Round(Length(SL1[w1-1])*0.2) then //слово схоже более чем на 80% (1 буква в 5 буквах, 2 в 10и)
                begin
                  RelNum := RelNum + (Length(SL1[w1-1]) - Dist)/Length(SL1[w1-1]); //складываем числитель для вычисления схожести строки
                  Break; //чтобы второе слово такое же не шло в расчет (иначе опоры 50х50х50 обгоняют задвижки 50)
                end;
              end;
            end;
            RelDenum := RelDenum + 1; //знаменатель (кол-во слов в прайс-позиции)
          end;
            if RelDenum>0 then REL := RelNum / RelDenum else REL := 0;
            MaxRelFound := Max(REL, MaxRelFound);
            if REL > RelForIns then
            begin
              Q.SQL.Text := 'update or insert into TPRICEIMPORTMATCH (IDPI, IDRES, REL) values (:IDPI, :IDRES, :REL) matching (IDPI, IDRES)';
              Q.ParamByName('IDPI').AsInteger := D.FieldByName('ID').AsInteger;
              Q.ParamByName('IDRES').AsInteger := Integer(dlgPriceImportMatch.ResList.Objects[i]);
              Q.ParamByName('REL').AsFloat := REL;
              Q.ExecQuery; InterlockedIncrement(dlgPriceImportMatch.MatchFound);
              Inc(F);
            end;
        end;

      MyI := D.RecNo;
      D.Next;

    end;
    D.Close;
    LaTRN.Commit;
  finally
    LaDB.Close;
    FreeAndNil(SL1);
    FreeAndNil(SL2);
    FreeAndNil(Q);
    FreeAndNil(D);
    FreeAndNil(LaDB);
    Terminate;
  end;
end;

function EditDistance(s, t: string): integer;
var
  d : array of array of integer;
  i,j,cost : integer;
begin
  {
  Compute the edit-distance between two strings.
  Algorithm and description may be found at either of these two links:
  http://en.wikipedia.org/wiki/Levenshtein_distance
  http://www.google.com/search?q=Levenshtein+distance
  }

  //initialize our cost array
  SetLength(d,Length(s)+1);
  for i := Low(d) to High(d) do begin
    SetLength(d[i],Length(t)+1);
  end;

  for i := Low(d) to High(d) do begin
    d[i,0] := i;
    for j := Low(d[i]) to High(d[i]) do begin
      d[0,j] := j;
    end;
  end;

  //store our costs in a 2-d grid
  for i := Low(d)+1 to High(d) do begin
    for j := Low(d[i])+1 to High(d[i]) do begin
      if s[i] = t[j] then begin
        cost := 0;
      end
      else begin
        cost := 1;
      end;

      //to use "Min", add "Math" to your uses clause!
      d[i,j] := Min(Min(
                 d[i-1,j]+1,      //deletion
                 d[i,j-1]+1),     //insertion
                 d[i-1,j-1]+cost  //substitution
                 );
    end;  //for j
  end;  //for i

  //now that we've stored the costs, return the final one
  Result := d[Length(s),Length(t)];

  //dynamic arrays are reference counted.
  //no need to deallocate them
end;

function EditDistance(const s, t: string): integer;
var
  d : PInteger;
  i,j,cost : integer;
  LRowSize: Integer;
  LColSize: Integer;
  function Idx(ARow, ACol: Integer): PInteger;
  begin
    Result := PInteger(WPARAM(d) + ARow * LRowSize + ACol);
  end;
begin
  {
  Compute the edit-distance between two strings.
  Algorithm and description may be found at either of these two links:
  http://en.wikipedia.org/wiki/Levenshtein_distance
  http://www.google.com/search?q=Levenshtein+distance
  }

  //initialize our cost array
  LRowSize := Length(s) + 1;
  LColSize := Length(t) + 1;
  d := HeapAlloc(GetProcessHeap, 0, LRowSize * LColSize * SizeOf(d^));
  Win32Check(d <> nil);
  try
    for i := 0 to LRowSize do begin
      Idx(i, 0)^ := i;
      for j := 0 to LColSize do 
        Idx(0, j)^ := j;
    end;

    //store our costs in a 2-d grid
    for i := 1 to LRowSize do begin
      for j := 1 to LColSize do begin
        cost := Ord(s[i] <> t[j]);

        //to use "Min", add "Math" to your uses clause!
        Idx(i, j)^ := Min(Min(
                   Idx(i -1, j)^ + 1,      //deletion
                   Idx(i, j-1)^ + 1),     //insertion
                   Idx(i - 1, j - 1)^ + cost  //substitution
                 );
      end;  //for j
    end;  //for i
    //now that we've stored the costs, return the final one
    Result := Idx(Length(s),Length(t))^;
  finally
    HeapFree(GetProcessHeap, 0, d);
  end;
end;

  function Idx(d, LRowSize, ARow, ACol: Integer): PInteger; inline;
  begin
    Result := PInteger(WPARAM(d) + ARow * LRowSize + ACol);
  end;

type
  TTagKind = (tkUnknown, tkCell, tkData, tkRow, tkSheet, tkStyle, tkValue);

function ValueToEnum(const S: ByteString): TTagKind;
begin
  // default value
  Result := tkUnknown;

  // byte ascii
  with PMemoryItems(S.Chars)^ do
  case S.Length of 
    3: if (Words[0] + Bytes[2] shl 16 = $776F72) then Result := tkRow; // "row"
    4: case (Cardinals[0]) of // "cell", "data"
         $6C6C6563: Result := tkCell; // "cell"
         $61746164: Result := tkData; // "data"
       end;
    5: case (Cardinals[0]) of // "sheet", "style", "value"
         $65656873: if (Bytes[4] = $74) then Result := tkSheet; // "sheet"
         $6C797473: if (Bytes[4] = $65) then Result := tkStyle; // "style"
         $756C6176: if (Bytes[4] = $65) then Result := tkValue; // "value"
       end;
  end;
end;

function ReplaceSubstring(const ASourceText, APattern, ANewText: string): string;
var
  L1, L2, L3, Count: Integer;
  Site, Source: PChar;
  Position, X, Y, Delta: Integer;
begin
  L2 := Length(APattern);
  Count := 0;
  Position := PosEx(APattern, ASourceText, 1);
  while Position <> 0 do
  begin
    Inc(Position, L2);
    asm
      PUSH POSITION
    end;
    Inc(Count);
    Position := PosEx(APattern, ASourceText, Position)
  end;
  if Count = 0 then
    Result := ASourceText
  else
  begin
    L1 := Length(ASourceText);
    L3 := Length(ANewText);
    X := Succ(L1);
    Inc(L1, (L3 - L2) * Count);
    if L1 = 0 then
    begin
      for Position := 0 to Pred(Count) do
        asm
          POP Y
        end;
      Result := EmptyStr
    end
    else
    begin
      SetLength(Result, L1);
      Site := Pointer(Result);
      Inc(Site, L1);
      Source := Pointer(ASourceText);
      Dec(Source);
      for Position := 0 to Pred(Count) do
      begin
        asm
          POP Y
        end;
        Delta := X - Y;
        if Delta > 0 then
        begin
          Dec(Site, Delta);
          Move(Source[Y], Site^, Delta shl 1);
        end;
        Dec(Site, L3);
        Move(Pointer(ANewText)^, Site^, L3 shl 1);
        X := Y - L2
      end;
      Dec(X);
      if X <> 0 then
        Move(Pointer(ASourceText)^, Pointer(Result)^, X shl 1)
    end
  end
end;

function StringReplace(const S, OldPattern, NewPattern: String; Flags: TReplaceFlags): String;
var
  SearchStr   : String;
  Patt        : String;
  Offset,P    : Integer;
  ROffset     : Integer;
  SLen        : Integer;
  RLen        : Integer;
  PLen        : Integer;
  NLen        : Integer;
  DSize       : Integer;
  SingleCheck : Boolean;
begin
  if length(s)=0 then begin
    Result:='';
    Exit;
  end;

  SingleCheck:=not (rfReplaceAll in Flags);

  if rfIgnoreCase in Flags then begin
    SearchStr:=AnsiUpperCase(S);
    Patt:=AnsiUpperCase(OldPattern);
  end else begin
    SearchStr:=S;
    Patt:=OldPattern;
  end;

  DSize:=Length(NewPattern)-Length(OldPattern);

  Offset:=1;
  ROffset:=1;
  SLen:=Length(SearchStr);
  RLen:=SLen;
  NLen:=Length(NewPattern);
  PLen:=Length(Patt);

  SetLength(Result,RLen);
  while Offset<SLen do begin
    P:=Pos(Patt,SearchStr,Offset);
    if P=0 then begin
      Break;
    end else begin
      Move(S[Offset],Result[ROffset],P-Offset);
      inc(ROffset,P-Offset);
      if DSize>0 then begin
        inc(Rlen,DSize);
        SetLength(Result,RLen);
      end;
      if NLen>0 then Move(NewPattern[1],Result[ROffset],NLen);
      inc(ROffset,NLen);
      inc(Offset,P+PLen-Offset);
      if SingleCheck then Break;
    end;
  end;

  if (SLen-Offset+1)>0 then Move(S[Offset],Result[ROffset],SLen-Offset+1);
  inc(ROffset,SLen-Offset+1);
  SetLength(Result,ROffset-1);
end;

procedure TForm5.Button1Click(Sender: TObject);
var
  t1,t2 : Cardinal;
  i     : Integer;
  L     : TStringList;
  s1,s2 : string;
begin
  L:=TStringList.Create;
  L.LoadFromFile('d:\book1.txt');

  T1:=GetTickCount;
  for i:=0 to 9 do begin
    s1:=System.SysUtils.StringReplace(L.Text,'Пьер','Петька',[rfReplaceAll]);
  end;
  T1:=GetTickCount-T1;

  T2:=GetTickCount;
  for i:=0 to 9 do begin
    s2:=StringReplace(L.Text,'Пьер','Петька',[rfReplaceAll]);
  end;
  T2:=GetTickCount-T2;

  Assert(s1<>s2,'Разные строки!');

  LabeledEdit2.Text:=T1.ToString+' '+T2.ToString;
end;

function StringReplace(const S, OldPattern, NewPattern: String; Flags: TReplaceFlags): String;
var
  SearchStr   : String;
  Patt        : String;
  Offset,P    : Integer;
  ROffset     : Integer;
  SLen        : Integer;
  RLen        : Integer;
  PLen        : Integer;
  NLen        : Integer;
  DSize       : Integer;
  SingleCheck : Boolean;
begin

  if length(s)=0 then begin
    Result:='';
    Exit;
  end;

  SingleCheck:=not (rfReplaceAll in Flags);

  if rfIgnoreCase in Flags then begin
    SearchStr:=AnsiUpperCase(S);
    Patt:=AnsiUpperCase(OldPattern);
  end else begin
    SearchStr:=S;
    Patt:=OldPattern;
  end;

  DSize:=Length(NewPattern)-Length(OldPattern);

  Offset:=1;
  ROffset:=1;
  SLen:=Length(SearchStr);
  RLen:=SLen;
  NLen:=Length(NewPattern);
  PLen:=Length(Patt);

  SetLength(Result,RLen);
  while Offset<SLen do begin
   // if
    P:=Pos(Patt,SearchStr,Offset);
    if P=0 then begin
      Break;
    end else begin
      Move(S[Offset],Result[ROffset],(P-Offset)*SizeOf(Char));
      inc(ROffset,P-Offset);
      if DSize>0 then begin
        inc(Rlen,DSize);
        SetLength(Result,RLen);
      end;
      if NLen>0 then Move(NewPattern[1],Result[ROffset],NLen*SizeOf(Char));
      inc(ROffset,NLen);
      inc(Offset,P+PLen-Offset);
      if SingleCheck then Break;
    end;
  end;

  if (SLen-Offset+1)>0 then Move(S[Offset],Result[ROffset],(SLen-Offset+1)*SizeOf(Char));
  inc(ROffset,SLen-Offset+1);
  SetLength(Result,ROffset-1);
end;

function StringReplace(const S, OldPattern, NewPattern: String; Flags: TReplaceFlags): String;
var
  SearchStr   : String;
  Patt        : String;
  Offset,P    : Integer;
  ROffset     : Integer;
  SLen        : Integer;
  RLen        : Integer;
  PLen        : Integer;
  NLen        : Integer;
  DSize       : Integer;
  SingleCheck : Boolean;
begin
  if length(s)=0 then begin
    Result:='';
    Exit;
  end;

  SingleCheck:=not (rfReplaceAll in Flags);

  if rfIgnoreCase in Flags then begin
    SearchStr:=AnsiUpperCase(S);
    Patt:=AnsiUpperCase(OldPattern);
  end else begin
    SearchStr:=S;
    Patt:=OldPattern;
  end;

  DSize:=Length(NewPattern)-Length(OldPattern);

  Offset:=1;
  ROffset:=1;
  SLen:=Length(SearchStr);
  RLen:=SLen;
  NLen:=Length(NewPattern);
  PLen:=Length(Patt);

  SetLength(Result,RLen);
  while Offset<SLen do begin
    P:=Pos(Patt,SearchStr,Offset);
    if P=0 then begin
      Break;
    end else begin
      Move(S[Offset],Result[ROffset],(P-Offset)*SizeOf(Char));
      inc(ROffset,P-Offset);
      if DSize>0 then begin
        inc(Rlen,DSize);
        if Length(Result)<RLen then begin
          SetLength(Result,RLen+65535);
        end;
      end;
      if NLen>0 then Move(NewPattern[1],Result[ROffset],NLen*SizeOf(Char));
      inc(ROffset,NLen);
      inc(Offset,P+PLen-Offset);
      if SingleCheck then Break;
    end;
  end;

  if (SLen-Offset+1)>0 then Move(S[Offset],Result[ROffset],(SLen-Offset+1)*SizeOf(Char));
  inc(ROffset,SLen-Offset+1);
  SetLength(Result,ROffset-1);
end;

function ReplaceStr(const s, OldPattern, NewPattern: hstring): hstring;
var
  Offset, SL, OL, NL{$IFNDEF AUTOREFCOUNT}, SI, RI,  RL, n{$ENDIF}: int;
begin
  OL := length(OldPattern);
  SL := length(s);
  if (OL = 0) or (SL < OL) then
  begin
    result := s;
    exit;
  end;
  NL := length(NewPattern);
  if (OL = 1) and (NL = 1) then
  begin
    result := s;
    ReplaceChar(result, OldPattern[StringStart], NewPattern[StringStart]);
    exit
  end;
  if OL = 1 then
    Offset := FindChar(OldPattern[StringStart], s)
  else
    Offset := Pos(OldPattern, s);
  if Offset = 0 then
  begin
    result := s;
    exit
  end;
{$IFDEF NEXTGEN}
  result := AnsiReplaceStr(s, OldPattern, NewPattern);
{$ELSE}
  RL := SL - OL + NL;
  SetLength(result, RL);
  SI := StringStart;
  RI := StringStart;
  repeat
    if RI + (Offset - SI) + NL > RL then
    begin
      n := min(integer(65535), integer(RL div 2));
      if RL + n < RI + (Offset - SI) + NL then
        n := RI + (Offset - SI) + NL - RL;
      Inc(RL, n);
      SetLength(result, RL);
    end;
    Move(s[SI], result[RI], (Offset - SI - 1 + StringStart) * SizeOf(hchar));
    Inc(RI, Offset - SI - 1 + StringStart);
    SI := Offset + OL - 1 + StringStart;
    if NL > 0 then
    begin
      Move(pointer(NewPattern)^, result[RI], NL * SizeOf(hchar));
      Inc(RI, length(NewPattern));
    end;
    if OL = 1 then
      Offset := FindChar(OldPattern[StringStart], s, SI + 1 - StringStart)
    else
      Offset := PosEx(OldPattern, s, SI + 1 - StringStart);
  until Offset = 0;
  if SI + 1 - StringStart <= SL then
  begin
    if RI + SL - SI > RL then
    begin
      RL := RI + SL - SI;
      SetLength(result, RL);
    end;
    Move(s[SI], result[RI], (SL - SI + 2 - StringStart) * SizeOf(hchar));
  end;
  if RL <> RI + SL - SI then
    SetLength(result, RI + SL - SI);
{$ENDIF}
end;

unit Unit4;

interface

uses
  Winapi.Windows, Winapi.Messages, System.Diagnostics,
  System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TForm4 = class(TForm)
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form4: TForm4;

implementation

{$R *.dfm}

uses
  StrUtils;

type
  TReplaceFunc = function(const ASourceText, APattern, ANewText: string; Flags: TReplaceFlags): string;

function ReplaceSubstring_Quaid(const ASourceText, APattern, ANewText: string; Flags: TReplaceFlags): string;
var
  L1, L2, L3, Count: Integer;
  Site, Source: PChar;
  Position, X, Y, Delta: Integer;
begin
  L2 := Length(APattern);
  Count := 0;
  Position := PosEx(APattern, ASourceText, 1);
  while Position <> 0 do
  begin
    Inc(Position, L2);
    asm
      PUSH POSITION
    end;
    Inc(Count);
    Position := PosEx(APattern, ASourceText, Position)
  end;
  if Count = 0 then
    Result := ASourceText
  else
  begin
    L1 := Length(ASourceText);
    L3 := Length(ANewText);
    X := Succ(L1);
    Inc(L1, (L3 - L2) * Count);
    if L1 = 0 then
    begin
      for Position := 0 to Pred(Count) do
        asm
          POP Y
        end;
      Result := EmptyStr
    end
    else
    begin
      SetLength(Result, L1);
      Site := Pointer(Result);
      Inc(Site, L1);
      Source := Pointer(ASourceText);
      Dec(Source);
      for Position := 0 to Pred(Count) do
      begin
        asm
          POP Y
        end;
        Delta := X - Y;
        if Delta > 0 then
        begin
          Dec(Site, Delta);
          Move(Source[Y], Site^, Delta shl 1);
        end;
        Dec(Site, L3);
        Move(Pointer(ANewText)^, Site^, L3 shl 1);
        X := Y - L2
      end;
      Dec(X);
      if X <> 0 then
        Move(Pointer(ASourceText)^, Pointer(Result)^, X shl 1)
    end
  end
end;

function ReplaceSubstring_rgreat(const S, OldPattern, NewPattern: String; Flags: TReplaceFlags): String;
var
  SearchStr   : String;
  Patt        : String;
  Offset,P    : Integer;
  ROffset     : Integer;
  SLen        : Integer;
  RLen        : Integer;
  PLen        : Integer;
  NLen        : Integer;
  DSize       : Integer;
  SingleCheck : Boolean;
begin
  if length(s)=0 then begin
    Result:='';
    Exit;
  end;

  SingleCheck:=not (rfReplaceAll in Flags);

  if rfIgnoreCase in Flags then begin
    SearchStr:=AnsiUpperCase(S);
    Patt:=AnsiUpperCase(OldPattern);
  end else begin
    SearchStr:=S;
    Patt:=OldPattern;
  end;

  DSize:=Length(NewPattern)-Length(OldPattern);

  Offset:=1;
  ROffset:=1;
  SLen:=Length(SearchStr);
  RLen:=SLen;
  NLen:=Length(NewPattern);
  PLen:=Length(Patt);

  SetLength(Result,RLen);
  while Offset<SLen do begin
    P:=Pos(Patt,SearchStr,Offset);
    if P=0 then begin
      Break;
    end else begin
      Move(S[Offset],Result[ROffset],(P-Offset)*SizeOf(Char));
      inc(ROffset,P-Offset);
      if DSize>0 then begin
        inc(Rlen,DSize);
        if Length(Result)<RLen then begin
          SetLength(Result,RLen+65535);
        end;
      end;
      if NLen>0 then Move(NewPattern[1],Result[ROffset],NLen*SizeOf(Char));
      inc(ROffset,NLen);
      inc(Offset,P+PLen-Offset);
      if SingleCheck then Break;
    end;
  end;

  if (SLen-Offset+1)>0 then Move(S[Offset],Result[ROffset],(SLen-Offset+1)*SizeOf(Char));
  inc(ROffset,SLen-Offset+1);
  SetLength(Result,ROffset-1);
end;


procedure TForm4.FormCreate(Sender: TObject);
var
  SS: TStringStream;
  S: string;

  function TestReplace(AReplaceFunc: TReplaceFunc): Cardinal;
  var
    T: TStopwatch;
    I: Integer;
    Txt: string;
  begin
    T := TStopwatch.StartNew;
    for I := 1 to 100 do
      Txt := AReplaceFunc(S, 'Пьер', 'Петька', [rfReplaceAll]);
    T.Stop;
    Result := T.ElapsedMilliseconds
  end;


begin
  SS := TStringStream.Create;
  try
    SS.LoadFromFile('D:\Война и beer.txt');
    S := SS.DataString;
    Memo1.Lines.Add('ReplaceSubstring_VCL - ' + TestReplace(StringReplace).ToString + ' msec');
    Memo1.Lines.Add('ReplaceSubstring_rgreat - ' + TestReplace(ReplaceSubstring_rgreat).ToString + ' msec');
    Memo1.Lines.Add('ReplaceSubstring_Quaid - ' + TestReplace(ReplaceSubstring_Quaid).ToString + ' msec');
  finally
    SS.Free
  end
end;

end.

function G_ReplaceStr(const SourceStr, FindStr, ReplacementStr: string): string;
var
  P, PS: PChar;
  L, L1, L2, Count: Integer;
  I, J, K, M: Integer;
begin
  L1 := Length(FindStr);
  Count := 0;
  I := G_PosStr(FindStr, SourceStr, 1);
  while I <> 0 do
  begin
    Inc(I, L1);
    asm
      PUSH    I
    end;
    Inc(Count);
    I := G_PosStr(FindStr, SourceStr, I);
  end;
  if Count <> 0 then
  begin
    L := Length(SourceStr);
    L2 := Length(ReplacementStr);
    J := L + 1;
    Inc(L, (L2 - L1) * Count);
    if L <> 0 then
    begin
      SetString(Result, nil, L);
      P := Pointer(Result);
      Inc(P, L);
      PS := Pointer(LongWord(SourceStr) - 1);
      for I := 0 to Count - 1 do
      begin
        asm
          POP     K
        end;
        M := J - K;
        if M > 0 then
        begin
          Dec(P, M);
          G_CopyMem(@PS[K], P, M);
        end;
        Dec(P, L2);
        G_CopyMem(Pointer(ReplacementStr), P, L2);
        J := K - L1;
      end;
      Dec(J);
      if J > 0 then
        G_CopyMem(Pointer(SourceStr), Pointer(Result), J);
    end else
    begin
      Result := '';
      for I := 0 to Count - 1 do
      asm
            POP     K
      end;
    end;
  end else
    Result := SourceStr;
end;

function StringReplace(const S, OldPattern, NewPattern: string;
  Flags: TReplaceFlags): string;
const
  FirstIndex = Low(string);
var
  SearchStr, Patt, NewStr: string;
  Offset, I, L: Integer;
begin
  if rfIgnoreCase in Flags then
  begin
    SearchStr := AnsiUpperCase(S);
    Patt := AnsiUpperCase(OldPattern);
  end else
  begin
    SearchStr := S;
    Patt := OldPattern;
  end;
  NewStr := S;
  Result := '';
  if SearchStr.Length <> S.Length then
  begin
    I := FirstIndex;
    L := OldPattern.Length;
    while I <= High(S) do
    begin
      if string.Compare(S, I - FirstIndex, OldPattern, 0, L, True) = 0 then
      begin
        Result := Result + NewPattern;
        Inc(I, L);
        if not (rfReplaceAll in Flags) then
        begin
          Result := Result + S.Substring(I - FirstIndex, MaxInt);
          Break;
        end;
      end
      else
      begin
        Result := Result + S[I];
        Inc(I);
      end;
    end;
  end
  else
  begin
    while SearchStr <> '' do
    begin
      Offset := AnsiPos(Patt, SearchStr);
      if Offset = 0 then
      begin
        Result := Result + NewStr;
        Break;
      end;
      Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern;
      NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt);
      if not (rfReplaceAll in Flags) then
      begin
        Result := Result + NewStr;
        Break;
      end;
      SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt);
    end;
  end;
end;

uses
  CachedTexts, UniConv, CachedBuffers;

const
  BUFFER_ITEMS_COUNT = 512;

type
  PBuffer = ^TBuffer;
  TBuffer = packed record
    Next: PBuffer;
    Items: array[0..BUFFER_ITEMS_COUNT - 1] of NativeUInt;
  end;

  TInternalData = record
    S: Pointer;
    SLength: NativeUInt;
    Result: PUnicodeString;
    Str, Ptn, NewPtn: UTF16String;
    Count: NativeUInt;
    First: PBuffer;
  end;

procedure InternalReplaceStr(var Data: TInternalData; const LastBuffer: PBuffer);
label
  last_buffer;
var
  P, i: NativeInt;
  Size: NativeUInt;
  Buffer: TBuffer;
  Current: PNativeUInt;
  Dest, Source: PByte;
begin
  Current := @Buffer.Items[High(Buffer.Items)];
  if (LastBuffer <> nil) then
  begin
    LastBuffer.Next := @Buffer;
  end else
  begin
    Data.First := @Buffer;
  end;

  repeat
    P := Data.Str.Pos(Data.Ptn);
    if (P < 0) then Break;

    Current^ := P;
    Dec(Current);
    Data.Str.Skip(NativeUInt(P) + Data.Ptn.Length);
    Inc(Data.Count);

    if (Current = Pointer(@Buffer)) then
    begin
      InternalReplaceStr(Data, @Buffer);
      Exit;
    end;
  until (False);

  if (Data.Count <> 0) then
  begin
    Dest := UnicodeStringAlloc(Pointer(Data.Result^),
      NativeInt(Data.SLength) +
      NativeInt(Data.Count) * (NativeInt(Data.NewPtn.Length) - NativeInt(Data.Ptn.Length)), 0);
    Pointer(Data.Result^) := Dest;

    Source := Data.S;
    if (Data.Count < BUFFER_ITEMS_COUNT) then
    begin
    last_buffer:
      Current := @Buffer.Items[High(Buffer.Items)];
      for i := 0 to NativeInt(Data.Count and (BUFFER_ITEMS_COUNT - 1)) - 1 do
      begin
        Size := Current^ shl 1;
        Dec(Current);
        NcMove(Source^, Dest^, Size);
        Inc(Dest, Size);
        Inc(Source, Size);

        Size := Data.NewPtn.Length shl 1;
        NcMove(Data.NewPtn.Chars^, Dest^, Size);
        Inc(Dest, Size);
        Inc(Source, Data.Ptn.Length shl 1);
      end;

      Size := Data.Str.Length shl 1;
      NcMove(Data.Str.Chars^, Dest^, Size);
    end else
    begin
      Current := Pointer(Data.First);
      repeat
        Inc(Current, BUFFER_ITEMS_COUNT - 1 + 1);
        for i := 0 to BUFFER_ITEMS_COUNT - 1 do
        begin
          Size := Current^ shl 1;
          Dec(Current);
          NcMove(Source^, Dest^, Size);
          Inc(Dest, Size);
          Inc(Source, Size);

          Size := Data.NewPtn.Length shl 1;
          NcMove(Data.NewPtn.Chars^, Dest^, Size);
          Inc(Dest, Size);
          Inc(Source, Data.Ptn.Length shl 1);
        end;

        Current := Pointer(PBuffer(Current).Next);
        if (Current = Pointer(@Buffer)) then goto last_buffer;
      until (False);
    end;

  end else
  begin
    Data.Result^ := UnicodeString(Data.S);
  end;
end;


function ReplaceStr(const S, OldPattern, NewPattern: UnicodeString): UnicodeString;
var
  Data: TInternalData;
begin
  if (Pointer(S) <> nil) and (Pointer(OldPattern) <> nil) then
  begin
    Data.S := Pointer(S);
    Data.Result := @Result;
    Data.Str.Assign(S);
    Data.Ptn.Assign(OldPattern);
    Data.NewPtn.Assign(NewPattern);
    Data.SLength := Data.Str.Length;
    Data.Count := 0;

    InternalReplaceStr(Data, nil);
  end else
  begin
    Result := S;
  end;
end;

function ReplaceStrEx(const AText,AFromText,AToText:string):string;
var
P     : PByte;
//W     : PWideChar absolute P;  //for viewing in debugger
I     : Integer;
J     : Integer;
K     : Integer;
D     : Integer;
Delta : Integer;
LText : Integer;
LFrom : Integer;
LTo   : Integer;
LSafe : Integer;
label
LOOP, DONE;
begin
LText := Length(AText);
LFrom := Length(AFromText);
if LText<=0 then Exit('') else
if (LFrom<=0) or (LFrom>LText) then Exit(AText);
LTo := Length(AToText);
LSafe := (LText div LFrom) * LTo + LText;
GetMem(P,LSafe);
I := 1;
D := 0;
repeat
  K := I-1;
LOOP:
  while AText[I] <> AFromText[1] do
  begin
    Inc(I);
    if I>LText then goto DONE;
  end;
  for J := 0 to LFrom-1 do
    if AText[I+J] <> AFromText[J+1] then
    begin
      Inc(I,J);
      goto LOOP;
    end;
  Delta := I-K-1;
  System.Move(PByte(@AText[K+1])^, PByte(P+D*2)^, Delta * SizeOf(WideChar));
  System.Move(PByte(@AToText[1])^, PByte(P+(D+Delta)*2)^, LTo * SizeOf(WideChar));
  Inc(D,Delta);
  Inc(D,LTo);
  Inc(I,LFrom);
until I>LText;
DONE:
PWord(P+D*2)^ := 0;
Result := string(PWideChar(P));
FreeMem(P);
end;

function ReplaceStr(const S, OldPattern, NewPattern: UnicodeString): UnicodeString;
label
  store_p_char, store_p_str, big_new_pattern, _3, _2, _1, str_assign;
const
  BUFFER_ITEMS_COUNT = 1024;
type
  PBuffer = ^TBuffer;
  TBuffer = packed record
    Next: PBuffer;
    Items: array[0..BUFFER_ITEMS_COUNT - 1] of NativeUInt;
  end;
var
  Data: record
    Buffer: TBuffer;
    S: Pointer;
    SLength: NativeUInt;
    Result: PUnicodeString;
    Str, Ptn, NewPtn: UTF16String;
    Count, P: NativeUInt;
    Bottom: PNativeUInt;
  end;
  P, Size, i: NativeUInt;
  Current, Bottom: PNativeUInt;
  Dest, NewPtnSrc: PByte;
  TopSource: PNativeUInt;
  WDest: PWideChar;
  LastChar, NewChar: WideChar;
begin
  Data.S := Pointer(S);
  Data.Result := @Result;
  if (Pointer(S) = nil) or (Pointer(OldPattern) = nil) then goto str_assign;
  Data.Str.Assign(S);
  Data.Ptn.Assign(OldPattern);
  Data.NewPtn.Assign(NewPattern);
  Data.SLength := Data.Str.Length;
  Data.Count := 0;

  Current := Pointer(@Data.Buffer);
  Bottom := Current;
  Inc(Current, BUFFER_ITEMS_COUNT + 1);

  if (Data.Ptn.Length = 1) then
  begin
    if (Data.NewPtn.Length = 1) then
    begin
      Dest := {$ifdef UNICODE}UnicodeStringAlloc{$else}WideStringAlloc{$endif}(Pointer(Data.Result^), Data.SLength, 0);
      Pointer(Data.Result^) := Dest;
      NcMove(Data.S^, Dest^, Data.SLength shl 1);

      WDest := Pointer(Dest);
      LastChar := Data.Ptn.Chars^;
      NewChar := Data.NewPtn.Chars^;

      i := Data.SLength;
      repeat
        Dec(i);
        if (WDest^ <> LastChar) then
        begin
          Inc(WDest);
          if (i <> 0) then Continue;
          Break;
        end else
        begin
          WDest^ := NewChar;
          Inc(WDest);
        end;
      until (i = 0);

      Exit;
    end;

    repeat
      P := Data.Str.CharPos(Data.Ptn.Chars^);
      Dec(Current);
      if (NativeInt(P) < 0) then Break;

      if (Current <> Bottom) then
      begin
      store_p_char:
        Current^ := P;
        P := P + 1;
        Data.Str.Length := Data.Str.Length - P;
        Data.Str.Chars := Pointer(@PWideChar(Data.Str.Chars)[P]);
        Inc(Data.Count);
      end else
      begin
        Data.P := P;
        GetMem(Current, SizeOf(TBuffer));
        PBuffer(Bottom).Next := Pointer(Bottom);
        Bottom := Current;
        Inc(Current, BUFFER_ITEMS_COUNT);
        P := Data.P;
        goto store_p_char;
      end;
    until (False);
  end else
  begin
    repeat
      P := Data.Str.Pos(Data.Ptn);
      Dec(Current);
      if (NativeInt(P) < 0) then Break;

      if (Current <> Bottom) then
      begin
      store_p_str:
        Current^ := P;
        P := P + Data.Ptn.Length;
        Data.Str.Length := Data.Str.Length - P;
        Data.Str.Chars := Pointer(@PWideChar(Data.Str.Chars)[P]);
        Inc(Data.Count);
      end else
      begin
        Data.P := P;
        GetMem(Current, SizeOf(TBuffer));
        PBuffer(Bottom).Next := Pointer(Current);
        Bottom := Current;
        Inc(Current, BUFFER_ITEMS_COUNT);
        P := Data.P;
        goto store_p_str;
      end;
    until (False);
  end;

  if (Data.Count <> 0) then
  begin
    Dest := {$ifdef UNICODE}UnicodeStringAllo