Быстрые WideString в Delphi. Ускоряем операции со строками

Источник: narod

Дмитрий Игнатьев

Немного теории

В Delphi есть удобный механизм для работы со строковыми данными. Для этого есть несколько типов строковых переменных: AnsiString, WideString и UnicodeString. Они удобны тем что, в операциях присваивания и конкатенации, компилятор генерирует код, который неявно выделяет или освобождает память под строки, а также автоматически преобразует один тип данных в другой.

AnsiString и UnicodeString - это внутренний формат представления строки в Delphi . Для выделения памяти под строку используется собственный, очень производительный менеджер памяти. Также, при копировании строк используется подсчет ссылок без перераспределения памяти. Таким образом, компилятор генерирует максимально производительный код.

WideString - это неявный формат BSTR и является стандартным строковым типом в COM/DCOM. Это его основное достоинство. Недостатком является отсутствие подсчета ссылок. Компилятор неявно использует API-функции при операциях с данными этого типа. Поэтому операции с WideString очень медленны.

По ряду объективных причин многие проекты пишутся на старых версиях Delphi , в которых нет быстрых UnicodeString. А поддержка юникода необходима, вот и приходится использовать WideString.

Внедряем механизм подсчета ссылок

В WideString есть структура, в ней хранится длина строки в байтах. Эта структура размещена в памяти непосредственно перед данными строки. Для выделения и освобождения памяти под строку вместо системных API-функций будем использовать собственный менеджер памяти. При этом мы сами можем определить структуру, добавив все необходимые поля. Добавим счетчик ссылок и специальный идентификатор, чтоб отличать строки созданные нами от всех других строк.

type
  PWideStr = ^TWideStr;
  TWideStr = record
    refcnt : integer; //счетчик ссылок
    id0    : integer; //наш идентификатор
    id1    : integer; //наш идентификатор
    id2    : integer; //наш идентификатор
    length : integer; //размер строки (как и положено)
end;

const
  str_id_0 = integer($96969696);
  str_id_1 = integer($75757575);
  str_id_2 = integer($38383838);

  size_str = sizeof(TWideStr);

ПРИМЕЧАНИЕ

Данная структура удовлетворяет условию, что длина строки должна быть непосредственно перед самой строкой.

Идентификатор нужен, чтоб мы могли отличать нашу строку от других строк. Только так мы можем знать, для каких строк можно использовать подсчет ссылок.

В system.pas есть множество функций, который компилятор вызывает при операциях со строками. Нам необходимо всего несколько.

function  _NewWideString(CharLength: Longint): Pointer;
procedure _WStrClr(var S);
procedure _WStrArrayClr(var StrArray; Count: Integer);
procedure _WStrAsg(var Dest: WideString; const Source: WideString);
procedure _WStrLAsg(var Dest: WideString; const Source: WideString);
procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; CharLength: Integer);
procedure _WStrFromWChar(var Dest: WideString; Source: WideChar);
procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar);
function  _WStrAddRef(var str: WideString): Pointer;

Можно заменить код этих функций, а можно в режиме выполнения программы перехватить их и выполнить свои функции. Второй метод более универсален, поэтому и выберем его.

Чтоб не было проблем с COM/DCOM, также перехватим системные функции:

function  SysAllocString(psz: POleStr): TBStr; stdcall;
procedure SysFreeString(bstr: TBStr); stdcall;
function  SysReAllocString(var bstr: TBStr; psz: POleStr): Integer;
function  SysAllocStringLen(psz: POleStr; len: Integer): TBStr;
function  SysReAllocStringLen(var bstr: TBStr; psz: POleStr; len: Integer): Integer; function SysAllocStringByteLen(psz: PChar; len: Integer): TBStr; stdcall;

Базовые функции

Их всего три типа: выделение памяти, освобождение памяти и копирование строки.

//Инициализация строки.
function doWStrAlloc(len: Integer): PWideStr; inline;
begin
  GetMem(result, size_str + len + 2);
  result.refcnt := 1;
  result.Id0 := str_id_0;
  result.Id1 := str_id_1;
  result.Id2 := str_id_2;
  result.length := len;
  PWideChar(@PAnsiChar(result)[size_str+len])^ := #0;
end;
 
//Освобождение строки
procedure doWStrFree(s: PWideStr); inline;
begin
  if (s.Id2 = str_id_2) and
     (s.Id1 = str_id_1) and
     (s.Id0 = str_id_0)
  then
  if InterlockedDecrement(s.refcnt) = 0 then
    FreeMem(s);
end;

procedure WStrFree(s: PWideStr); inline;
begin
  if Assigned(s) then begin
    Dec(s);
    if (s.Id2 = str_id_2) and
       (s.Id1 = str_id_1) and
       (s.Id0 = str_id_0)
    then
    if InterlockedDecrement(s.refcnt) = 0 then
      FreeMem(s);
  end;
end;
 
//Копирование строки
function doWStrCopy(s: PWideStr): PWideStr; inline;
begin
  if (s.Id2 = str_id_2) and
     (s.Id1 = str_id_1) and
     (s.Id0 = str_id_0)
  then begin
    InterlockedIncrement(s.refcnt);
    result := s;
  end
  else begin
    result := doWStrAlloc(s.length);
    Move(PAnsiChar(s)[size_str], PAnsiChar(result)[size_str], s.length);
  end;
end;

function WStrCopy(s: PWideStr): PWideStr; inline;
begin
  if s = nil then
    result := nil
  else begin
    Dec(S);
    if (s.Id2 = str_id_2) and
       (s.Id1 = str_id_1) and
       (s.Id0 = str_id_0)
    then begin
      InterlockedIncrement(s.refcnt);
      result := @PAnsiChar(s)[size_str];
    end
    else begin
      result := @PAnsiChar(doWStrAlloc(s.length))[size_str];
      Move(PAnsiChar(s)[size_str], result^, s.length);
    end;
  end;
end;

function WStrLCopy(s: PWideStr; len: integer): PWideStr; inline;
begin
  result := doWStrAlloc(len);
  Inc(result);
  if Assigned(s) then
    Move(s^, result^, len);
end;

Подставные функции

Все подставные функции являются обвертками над базовыми функциями. Для удобства восприятия имена подставных функций будут начинаться на букву "х".

// system.pas

function xWStrClr(var S: PWideStr): PWideStr;
begin
  result := @S;
  WStrFree(s);
  S := nil;
end;

procedure xWStrAsg(var Dest: PWideStr; Source: PWideStr);
var
  t   : PWideStr;
begin
  t := Dest;
  if t <> Source then begin
    WStrFree(t);
    if Source = nil then
      Dest := nil
    else begin
      Dec(Source);
      t := doWStrCopy(Source);
      Dest := @PAnsiChar(t)[size_str];
    end;
  end;
end;

function xWStrAddRef(var s: PWideStr): Pointer;
begin
  result := WStrCopy(s);
end;

procedure xWStrArrayClr(s: PPWideStr; Count: Integer);
var
  t : PWideStr;
begin
  while Count > 0 do begin
    t := s^;
    WStrFree(t);
    Inc(s);
    Dec(count);
  end;
end;

procedure xWStrFromPWCharLen(var Dest: PWideStr; Source: PWideStr; Len: Integer);
begin
  WStrFree(Dest);
  Dest := WStrLCopy(Source, Len*2);
end;

procedure xWStrFromWChar(var Dest: PWideStr; Source: WideChar);
var
  t : PWideStr;
begin
  if (Dest = nil) or (PWideChar(Dest)^ <> Source) then begin
    WStrFree(Dest);
    t := doWStrAlloc(2);
    Inc(t);
    Move(Source, t^, 2);
    Dest := t;
  end;
end;

procedure xWStrFromPWChar(var Dest: PWideStr; Source: PWideStr);
var
  t : PWideStr;
begin
  t := WStrLCopy(Source, WStrSize(PWideChar(Source)));
  WStrFree(Dest);
  Dest := t;
end;

function xNewWideString(Len: Longint): PWideStr;
begin
  result := doWStrAlloc(Len*2);
  Inc(result);
end;

 
// oleaut32.dll

procedure xSysFreeString(s: PWideStr); stdcall;
begin
  WStrFree(s);
end;

function xSysAllocString(s: PWideStr): PWideStr; stdcall;
begin
  result := WStrLCopy(s, WStrSize(PWideChar(s)));
end;

function xSysAllocStringLen(s: PWideStr; len: Integer): PWideStr; stdcall;
begin
  result := WStrLCopy(s, len * 2);
end;

function  xSysAllocStringByteLen (s: pointer; len: Integer): PWideStr; stdcall;
begin
  result := WStrLCopy(s, len);
end;

function xSysReAllocStringLen(var p: PWideStr; s: PWideStr; len: Integer): LongBool; stdcall;
begin
  if s <> p then begin
    WStrFree(p);
    p := WStrLCopy(s, len * 2);
  end;
  result := true;
end;

Код перехвата

Перехват функций будет осуществляться методом сплайсинга. Это когда в начало кода перехватываемой функции вставляем переход на нашу функцию. Обычно это команда jmp offset.

type
  POffsJmp = ^TOffsJmp;
  TOffsJmp = packed record
    code : byte;     //$E9
    offs : cardinal;
end;

procedure HookCode(Src, Dst: pointer); inline;
begin
  if Assigned(Src) then begin
    poffsjmp(Src).code := $E9;
    poffsjmp(Src).offs := cardinal(Dst) - cardinal(Src) - 5;
  end;
end;

procedure HookProc(handle: cardinal; Name: PAnsiChar; Hook: pointer); inline;
begin
  HookCode(GetProcAddress(handle, Name), Hook);
end;

Адреса функций в system.pas можно узнать, только используя вставки ассемблера.

function pWStrClr: pointer;
asm
  mov eax, OFFSET System.@WStrClr
end;

function pWStrAddRef: pointer;
asm
  mov eax, OFFSET System.@WStrAddRef
end;

function pWStrAsg: pointer;
asm
  mov eax, OFFSET System.@WStrAsg
end;

function pWStrLAsg: pointer;
asm
  mov eax, OFFSET System.@WStrLAsg
end;

function pWStrArrayClr : pointer;
asm
  mov eax, OFFSET System.@WStrArrayClr
end;

function pWStrFromPWCharLen : pointer;
asm
  mov eax, OFFSET System.@WStrFromPWCharLen
end;

function pWStrFromWChar : pointer;
asm
  mov eax, OFFSET System.@WStrFromWChar
end;

function pWStrFromPWChar : pointer;
asm
  mov eax, OFFSET System.@WStrFromPWChar
end;

function pNewWideString : pointer;
asm
  mov eax, OFFSET System.@NewWideString
end;

Перед перехватом необходимо дать разрешение на запись память, где находятся перехватываемые функции.

procedure FastWideStringInit;
var
  handle  : cardinal;
  protect : cardinal;
  mem     : TMemoryBasicInformation;
begin
  //получить начальный адрес и размер секции памяти
  VirtualQuery(pWStrAddRef, mem, sizeof(mem));
  //разрешить запись 
  VirtualProtect(mem.AllocationBase, mem.RegionSize, PAGE_EXECUTE_READWRITE, protect);

  HookCode(pWStrClr,           @xWStrClr);
  HookCode(pWStrAsg,           @xWStrAsg);
  HookCode(pWStrLAsg,          @xWStrAsg);
  HookCode(pWStrAddRef,        @xWStrAddRef);
  HookCode(pWStrArrayClr,      @xWStrArrayClr);
  HookCode(pWStrFromPWCharLen, @xWStrFromPWCharLen);
  HookCode(pWStrFromWChar,     @xWStrFromWChar);
  HookCode(pWStrFromPWChar,    @xWStrFromPWChar);
  HookCode(pNewWideString,     @xNewWideString);

  //восстановить атрибут защиты памяти
  VirtualProtect(mem.AllocationBase, mem.RegionSize, protect, protect);

  handle := GetModuleHandle(oleaut);
  if handle = 0 then
    handle := LoadLibrary(oleaut);

  VirtualQuery(GetProcAddress(handle, 'SysAllocString'), mem, sizeof(mem));

  VirtualProtect(mem.AllocationBase, mem.RegionSize, PAGE_EXECUTE_READWRITE, protect);

  HookProc(handle, 'SysAllocString',        @xSysAllocString);
  HookProc(handle, 'SysAllocStringLen',     @xSysAllocStringLen);
  HookProc(handle, 'SysAllocStringByteLen', @xSysAllocStringByteLen);
  HookProc(handle, 'SysReAllocStringLen',   @xSysReAllocStringLen);
  HookProc(handle, 'SysFreeString',         @xSysFreeString);

  VirtualProtect(mem.AllocationBase, mem.RegionSize, protect, protect);
end;

Для инициализации нашего механизма достаточно вызвать FastWideStringInit(). И чем раньше, тем лучше.

Тестирование

Для тестирования нужен код, в который в основном состоит из операций со строками. Под рукой оказалась часто используемая библиотека WideStrings.pas. Там есть замечательный класс TWideStringList. А в нем свойство

property Text: WideString read GetTextStr write SetTextStr;

Засечем время выполнения TWideStringList.GetTextStr() и TWideStringList.SetTextStr() до и после инициализации быстрых WideString. Вот часть кода.

const
  rep_count := 40;

procedure TestWideString(var s: widestring);
var
  i : integer;
begin
  with TWideStringList.Create do
  try
    for i := 0 to rep_count do begin
      Text := s;
      s := Text;
    end;
  finally
    Free;
  end;
end;

Прирост скорости составляет около 80%. И это только за счет механизма подсчета ссылок.

Подводные камни

Рассмотрим по шагам следующий пример.

procedure Test1;
var
  s1, s2 : WideString;
begin
  s1 := 'test';        // 1
  s2 := s1;            // 2
  s2[1] := 'b';        // 3
end;

Присваивая s1 := "test" , выделяем память.
Присваивая s2 := s1, выделяем память.
Меняем значение первого символа s2[1] := "b" . В итоге s2 = "best" , а s1 = "test" .

А что будет, когда включим подсчет ссылок?

procedure Test2;
var
  s1, s2 : WideString;
begin
  FastWideStringInit;  // 1
  s1 := 'test';        // 2
  s2 := s1;            // 3
  s2[1] := 'b';        // 4
end;

Инициализируем быстрые WideString
Присваивая s1 := "test" , выделяем память.
Присваивая s2 := s1, мы только увеличиваем счетчик. s2 указывает на тот же участок памяти, что и s1.
Меняем значение первого символа s2[1] := "b" . В итоге s2 = "best" , и s1 = "best" .

Вот этого мы и не ожидали.

Рассмотрим реальный пример из жизни и вариант его решения.

const
  shlwapi32 = 'SHLWAPI.DLL';

{ Функция выделяет путь из имени файла, путем замены последующего за путем символа на #0 }
function PathRemoveFileSpecW(pszPath: PWideChar): BOOL; stdcall; external shlwapi32;

{ А это наша удобная обвертка }
function MyPathRemoveFileSpec(s: WideString): WideString;
begin
  result := s;
  if PathRemoveFileSpecW(PWideChar(result)) then
    result := PWideChar(result);
end;

var
  a : widestring;
  b : widestring;
begin
  FastWideStringInit;
  a := 'c:\myfolder\myfile.txt';
  b := MyPathRemoveFileSpec(a);
end;

Функция PathRemoveFileSpecW() если удачно отработает, модифицирует строку result 'c:\myfolder\myfile.txt' на 'c:\myfolder'#0'myfile.txt' ;

Операция result := PWideChar(result) выделит новую память, и скопирует в нее 'c:\myfolder' .

В итоге, b = 'c:\myfolder' , а = 'c:\myfolder'#0'myfile.txt' .

Переменная a испорчена и если ее использование дальше приведет к неопределенным ситуациям. А все потому, что на момент выполнения PathRemoveFileSpecW() переменные a, s и result указывали на одну и туже строку в памяти. Значит, нам надо уметь копировать без использования подсчета ссылок. А делается это просто, вот так.

function MyPathRemoveFileSpec(s: WideString): WideString;
begin
  result := s + '';  //при конкатинации всегда содается новая копия строки
  if PathRemoveFileSpecW(PWideChar(result)) then
    result := PWideChar(result);
end;

Данная реализация функции будет работать без вышеописанной проблемы.

Примечания

Данный код писался на Delphi 2007. Для других версий, возможно, придется код немного модифицировать. Это касается инструкций inline и названий функций из system.pas.

Замете, деинициализации механизма нет. Если он запущен, то должен работать до конца, пока есть последняя WideString в памяти. Также желательно, чтоб инициализация была как можно раньше. Например, разместите в секции initialization того юнита, который раньше всех будет инициализироваться.

Ссылки по теме