Неправильное использование атомов и трудноуловимая бага в VCL

Поиск бага

Мучила меня долгое время бага, связанная с неадекватным поведением дельфийских контролов после длительного аптайма системы и интенсивной отладки. Списки переставали обновляться, кнопки нажиматься, поля ввода терять фокус. И все было печально, и перезапуск IDE не помогал. Более того, после перезапуска IDE — она сама начинала так же глючить. Приходилось перезагружаться.
Сегодня меня это достало, и я принялся её искать. Надо сказать не безрезультатно.
Залогировав оконные сообщения я стал анализировать что же пошло не так.
Выяснилось, что в модуле Control.pas есть такие строки:

function FindControl(Handle: HWnd): TWinControl; var   OwningProcess: DWORD; begin   Result := nil;   if (Handle <> 0) and (GetWindowThreadProcessID(Handle, OwningProcess) <> 0) and      (OwningProcess = GetCurrentProcessId) then   begin     if GlobalFindAtom(PChar(ControlAtomString)) = ControlAtom then       Result := Pointer(GetProp(Handle, MakeIntAtom(ControlAtom)))     else       Result := ObjectFromHWnd(Handle);   end; end;

и GetProp(Handle, MakeIntAtom(ControlAtom)) всегда возвращает 0. Тут же выяснилось что ControlAtom почему то 0, и GlobalFindAtom(PChar(ControlAtomString)) возвращает тоже 0.
Инициализируются ControlAtomString и ControlAtom в процедуре InitControls, которая вызывается в секции инициализации модуля:

procedure InitControls; var   UserHandle: HMODULE; begin {$IF NOT DEFINED(CLR)}   WindowAtomString := Format('Delphi%.8X',[GetCurrentProcessID]);   WindowAtom := GlobalAddAtom(PChar(WindowAtomString));   ControlAtomString := Format('ControlOfs%.8X%.8X', [HInstance, GetCurrentThreadID]);   ControlAtom := GlobalAddAtom(PChar(ControlAtomString));   RM_GetObjectInstance := RegisterWindowMessage(PChar(ControlAtomString)); {$IFEND}

ControlAtomString заполняется корректно, а вот ControlAtom заполняется нулем. Проверок на ошибки тут нет, поэтому это аукнулось гораздо позже, увы. Если вставить GetLastError после GlobalAddAtom, то он вернет ERROR_NOT_ENOUGH_MEMORY. А если еще внимательно почитать ремарку на MSDN к GlobalAddAtom, то можно заметить:

Global atoms are not deleted automatically when the application terminates. For every call to the GlobalAddAtom function, there must be a corresponding call to the GlobalDeleteAtom function.

Все сразу становится понятно. Если некорректно завершить приложение — то утекут глобальные атомы. А именованных атомов у нас кот наплакал: 0xC000-0xFFFF, то есть всего 4 тысячи. Т.е. каждая dll, и каждый exe-шник написанный на Delphi с использованием VCL при некорректном завершении оставляет после себя утекшие глобальные атомы. Если быть точнее — то по 2-3 атома на каждый инстанс:
ControlAtom и WindowAtom в Controls.pas, и WndProcPtrAtom в Dialogs.pas

Workaround

Посмотреть созданные атомы не составит труда. Вот код простенького приложения, перечисляющего глобальные строковые атомы:

program EnumAtomsSample;  {$APPTYPE CONSOLE}  uses   Windows,   SysUtils;  function GetAtomName(nAtom: TAtom): string; var n: Integer;     tmpstr: array [0..255] of Char; begin   n := GlobalGetAtomName(nAtom, PChar(@tmpstr[0]), 256);   if n = 0 then     Result := ''   else     Result := tmpstr; end;  procedure EnumAtoms; var i: Integer;     s: string; begin   for i := MAXINTATOM to MAXWORD do     begin       s := GetAtomName(i);       if (s <> '') then WriteLn(s);     end; end;  begin   try     EnumAtoms;     ReadLn;   except     on E: Exception do       Writeln(E.ClassName, ': ', E.Message);   end; end.

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

Поскольку атомы глобальные, то мы их можем прибивать вне зависимости от того кем они были созданы. Осталось как-то научиться определять что атом утекший.
Если обратить внимание на имена атомов, то для
WndProcPtrAtom — это WndProcPtr [HInstance] [ThreadID]
ControlAtom — это ControlOfs [HInstance] [ThreadID]
WindowAtom — это Delphi [ProcessID]
Во всех случаях мы можем понять что атом скорее всего создан Delphi по специфичному префиксу + одно или два 32-х битных числа в HEX-е. Кроме того в HEX записан либо ProcessID либо ThreadID. Мы легко можем проверить есть такой процесс или поток в системе. Если нет — то у нас явно утекший атом, и мы можем рискнуть его освободить. Да да, именно рискнуть. Дело в том, что после того как мы убедились что потока/процесса с таким ID нет, и собрались удалять атом — этот процесс может появиться, с ровно таким же ID, и оказаться процессом Delphi. Если в промежуток между проверкой и удалением такое произойдет — то мы прибьем атом у валидного приложения. Ситуация крайне маловероятна, ибо в промежуток между проверкой должен создаться обязательно дельфийский процесс, обязательно ровно по тому же ID, и обязательно успеть проинициализировать свои атомы. Других workaround-ов (без правки VCL кода) для решения этой проблемы я не вижу.

Я написал консольную тулзу, для чистки таких утекших глобальных атомов.

program AtomCleaner;  {$APPTYPE CONSOLE}  uses   Windows,   SysUtils;  const   THREAD_QUERY_INFORMATION = $0040;  function OpenThread(dwDesiredAccess: DWORD; bInheritHandle: BOOL; dwThreadId: DWORD): THandle; stdcall; external kernel32;  function ThreadExists(const ThreadID: Cardinal): Boolean; var h: THandle; begin   h := OpenThread(THREAD_QUERY_INFORMATION, False, ThreadID);   if h = 0 then   begin     Result := False;   end   else   begin     Result := True;     CloseHandle(h);   end; end;  function TryHexChar(c: Char; out b: Byte): Boolean; begin   Result := True;   case c of     '0'..'9':  b := Byte(c) - Byte('0');     'a'..'f':  b := (Byte(c) - Byte('a')) + 10;     'A'..'F':  b := (Byte(c) - Byte('A')) + 10;   else     Result := False;   end; end;  function TryHexToInt(const s: string; out value: Cardinal): Boolean; var i: Integer;     chval: Byte; begin   Result := True;   value := 0;   for i := 1 to Length(s) do   begin     if not TryHexChar(s[i], chval) then       begin         Result := False;         Exit;       end;     value := value shl 4;     value := value + chval;   end; end;  function GetAtomName(nAtom: TAtom): string; var n: Integer;     tmpstr: array [0..255] of Char; begin   n := GlobalGetAtomName(nAtom, PChar(@tmpstr[0]), 256);   if n = 0 then     Result := ''   else     Result := tmpstr; end;   function CloseAtom(nAtom: TAtom): Boolean; var n: Integer;     s: string; begin   Result := False;   s := GetAtomName(nAtom);   if s = '' then Exit;   WriteLn('Closing atom: ', IntToHex(nAtom, 4), ' ', s);   GlobalDeleteAtom(nAtom);   Result := True; end;  function ProcessAtom(nAtom: TAtom): Boolean; var s: string;     n: Integer;     id: Cardinal; begin   Result := False;   s := GetAtomName(nAtom);    n := Pos('ControlOfs', s);   if n = 1 then   begin     Delete(s, 1, Length('ControlOfs'));     if Length(s) <> 16 then Exit;     Delete(s, 1, 8);     if not TryHexToInt(s, id) then Exit;     if not ThreadExists(id) then         Exit(CloseAtom(nAtom));     Exit;   end;    n := Pos('WndProcPtr', s);   if n = 1 then   begin     Delete(s, 1, Length('WndProcPtr'));     if Length(s) <> 16 then Exit;     Delete(s, 1, 8);     if not TryHexToInt(s, id) then Exit;     if not ThreadExists(id) then         Exit(CloseAtom(nAtom));     Exit;   end;    n := Pos('Delphi', s);   if n = 1 then   begin     Delete(s, 1, Length('Delphi'));     if Length(s) <> 8 then Exit;     if not TryHexToInt(s, id) then Exit;     if GetProcessVersion(id) = 0 then       if GetLastError = ERROR_INVALID_PARAMETER then         Exit(CloseAtom(nAtom));     Exit;   end; end;  procedure EnumAndCloseAtoms; var i: Integer; begin   i := MAXINTATOM;   while i <= MAXWORD do   begin     if not ProcessAtom(i) then         Inc(i);   end; end;  begin   try     EnumAndCloseAtoms;   except     on E: Exception do       Writeln(E.ClassName, ': ', E.Message);   end; end.

Просто запускаем, утекшие атомы чистятся. Проверьтесь, возможно прямо сейчас у вас в системе уже есть утекшие атомы.

В заключение

Инспекция кода показала, что данные глобальные атомы используются только для SetProp и GetProp функций. Совершенно непонятно почему разработчики Delphi решили использовать атомы. Ведь обе эти функции прекрасно работают с указателями на строки. Достаточно передавать уникальную строку, которая сама по себе уже есть, ведь с ней инициализируется атом.
Так же непонятна логика вот таких сравнений в VCL коде:
if GlobalFindAtom(PChar(ControlAtomString)) = ControlAtom then
Обе переменных инициализируются в одном месте. Строка собирается уникальной (из HInstance и ThreadID). Проверка всегда будет возвращать True. Увы, Delphi сейчас продвигает новые фичи, FMX-ы всякие. Вряд ли они будут фиксить эту багу. Лично у меня даже желания на QC репортить нет, зная как оно фиксится. Но жить с этим как-то надо. Желающие могут выполнять код вышеприведенной тулзы при старте своего приложения. На мой взгляд это всяко лучше, чем дожидаться утекших атомов.
Ну и в собственных разработках нужно стараться избегать глобальных атомов, ибо ОС не контролирует их утечки.

Тулзы + исходники