在线时间:8:00-16:00
迪恩网络APP
随时随地掌握行业动态
扫描二维码
关注迪恩网络微信公众号
real case test MM parallel 4x scalable (i7 6700)
procedure TForm1.Button1Click(Sender: TObject);
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;
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;
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 |
2023-10-27
2022-08-15
2022-08-17
2022-09-23
2022-08-13
请发表评论