ошибка 203 (переполнение кучи) , GetMem

[Romtek]

Как избавиться (предотвратить) от ошибки 203 (переполнение кучи) при вызове GetMem ?

Программа работает с коллекциями (TCollection) и требует немало памяти, поэтому её в некоторый момент просто нехватает.

Нужен механизм предотвращения вылетания программы с ошибкой 203, чтобы я мог перехватить и что-то предпринять.

Добавлено 16.01.07, 21:42

Цитата Справка

If there is not enough free space in the heap to allocate the new variable,
a run-time error occurs.

Добавлено 16.01.07, 21:44
Кроме как каждый раз вызывать MaxAvail переда запросом памяти пока не вижу выхода.

Сообщение отредактировано: Romtek - 16.01.07, 21:44

[volvo877]

HeapFunc переопределить не пробовал?

{$F+}
Function HeapFunc(Size: Word): Integer;
Begin
  HeapFunc := 1;
End;
{$F-}

И подставить в монитор кучи... Теперь при запросе очередной порции памяти, если ее мало - не будет #203, а указатель будет равен nil-у... Можно попробовать что-то ненужное убрать и повторить запрос...

[Romtek]

Я такой не встречал никогда. Где можно об этом почитать?

[volvo877]

Help по слову HeapError... Вот небольшая цитата оттуда:

Цитата

The HeapError function returns
■ 0 to indicate failure, and causes a run-time error to occur immediately.
■ 1 to indicate failure, and causes New or GetMem to return a nil pointer.
■ 2 to indicate success, and causes a retry (which could also cause
another call to the heap error function).

[Romtek]

Спасибо, уже сам нашёл. Ушёл экспериментировать..

Добавлено 16.01.07, 22:07
Дело такое: когда я в основной программе, использующей разные модули, написал HeapError := @HeapFunc;
с определённой

function HeapFunc(Size: word): Integer; far;
Begin
   HeapFunc:=1;
End;

ничего не изменилось.

Добавлено 16.01.07, 22:14
Испытываю программу в жёстких условиях, когда мало памяти (< 60 KB) с интерфейсом Turbo Vision, Real Mode.

[volvo877]

Какие модули используешь? Не TVision, часом? У него, по-моему, свой менеджер кучи...

Добавлено 16.01.07, 22:20
Ага... Значит, все-таки, TV... Тогда смотри хелп по InitMemory + LowMemory... Я бы копал в этом направлении...

[Romtek]

Использую многие модули TV.
Для конструктора есть процедура Fail, но она мне не подходит.

Мне нужно сделать так, чтобы при нахватке памяти я прерывал процесс считывания записей из файла в коллекцию и выдавал сообщение о нехватке памяти (MessageBox).

Добавлено 16.01.07, 22:21

Цитата volvo877 @ 16.01.07, 22:14

Тогда смотри хелп по InitMemory + LowMemory...

Ok...

[volvo877]

Кроме этого, можно вызовы GetMem заменить на MemAlloc, что опять же вернет тебе nil в случае невозможности выделения запрошенного блока памяти, и это можно будет обработать (фрагменты, выделенные через MemAlloc могут освобождаться обычным FreeMem)

[Romtek]

Цитата volvo877 @ 16.01.07, 22:26

Кроме этого, можно вызовы GetMem заменить на MemAlloc

Я использую готовые коллекции из Objects.tpu, так что этот вариант отпадает.

Добавлено 16.01.07, 22:31

function HeapNotify(Size: Word): Integer; far;
begin
  if FreeCache then HeapNotify := 2 else
    if DisablePool then HeapNotify := 1 else
      if FreeSafetyPool then HeapNotify := 2 else HeapNotify := 0;
end;
procedure InitMemory;
begin
  HeapError := @HeapNotify;
  SafetyPoolSize := LowMemSize * 16;
  LowMemory;
end;

Это и есть менеджер памяти TV. Но я что-то неврубаюсь как мне это может помочь выдать сообщение о нехватке памяти.

Добавлено 16.01.07, 22:36
Вот конструктор объекта, который я вставляю в коллекцию

constructor TCSVinfo.Init;
begin
     Inherited Init;
     New (TransferRecord); { в некоторый момент выдаёт ошибку 203 }
end;

[volvo877]

http://citforum.ru/programming/tv_doc/tvdoc_06.shtml

Прочти про "пул надежности"...

Добавлено 16.01.07, 22:37
P.S. Размер у TransferRecord какой?

[Romtek]

Также трудность проверки на наличие памяти ещё из-за неизвестного кол-ва считываемых записей.

Размер = 107 байт.

Добавлено 16.01.07, 22:43

Цитата volvo877 @ 16.01.07, 22:36

http://citforum.ru/programming/tv_doc/tvdoc_06.shtml

Читал уже

Добавлено 16.01.07, 22:44
Пул надёжности работает с элементами TView, но не коллекциями. Тут другой подход нужен.

[volvo877]

Цитата Romtek @ 16.01.07, 22:41

Тут другой подход нужен.

А чего ты не воспользуешься MemAlloc для того случая, который привел? Это как раз то, что нужно... Вот я тут набросал небольшую программку, Test #1 - это с new, Test #2 - с MemAlloc, посмотри...

uses
  App, Memory, MsgBox, Objects, Menus, Drivers, Views;
 
const
  cmTest1 = 251;
  cmTest2 = 252;
 
type
  PRec = ^Rec;
  Rec = record
    name: string;
    surname: string;
    data: array[1 .. 1000] of char;
  end;
 
  PMyObj = ^TMyObj;
  TMyObj = object(TObject)
    R: PRec;
 
    constructor init;
    constructor create;
  end;
 
constructor TMyObj.init;
begin
  inherited init;
  New(R);
end;
constructor TMyObj.create;
begin
  inherited init;
  R := MemAlloc(sizeof(Rec));
  if R = nil then Fail;
end;
 
type
  TTutorApp = object(TApplication)
    list: PCollection;
 
    constructor init;
    procedure InitStatusLine; virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure OutOfMemory; virtual;
 
    procedure Test1;
    procedure Test2;
  end;
 
constructor TTutorApp.init;
begin
  inherited init;
  list := New(PCollection, Init(10, 5));
end;
 
procedure TTutorApp.OutOfMemory;
begin
  MessageBox('Not enough memory to complete operation.',
    nil, mfError + mfOKButton);
end;
 
 
procedure TTutorApp.InitStatusLine;
var
  R: TRect;
begin
  GetExtent(R);
  R.A.Y := R.B.Y - 1;
  New(StatusLine, Init(R,
    NewStatusDef(0, $EFFF,
      NewStatusKey('~F3~ Test #1', kbF3, cmTest1,
      NewStatusKey('~F4~ Test #2', kbF4, cmTest2,
      NewStatusKey('~Alt+F3~ Close', kbAltF3, cmClose,
      StdStatusKeys(nil)))),
    NewStatusDef($F000, $FFFF,
      StdStatusKeys(nil), nil))));
end;
 
procedure TTutorApp.HandleEvent(var Event: TEvent);
var
  R: TRect;
begin
  inherited HandleEvent(Event);
 
  if Event.What = evCommand then begin
    case Event.Command of
      cmTest1:
        begin
          Test1;
          ClearEvent(Event);
        end;
      cmTest2:
        begin
          Test2;
          ClearEvent(Event);
        end;
    end;
  end;
 
end;
 
procedure TTutorApp.Test1;
var i: integer;
begin
  for i := 1 to 10000 do
    list^.insert(new(PMyObj, init));
end;
 
procedure TTutorApp.Test2;
var ToBeAdded: PMyObj;
begin
  while true do begin
    ToBeAdded := new(PMyObj, create);
    if ToBeAdded = nil then begin
      OutOfMemory; break;
    end
    else list^.insert(ToBeAdded);
  end;
end;
 
var
  TutorApp: TTutorApp;
 
begin
  TutorApp.Init;
  TutorApp.Run;
  TutorApp.Done;
end.

[Romtek]

volvo877
немного доработал оттачиваемый пример:

uses
  App, Memory, MsgBox, Objects, Menus, Drivers, Views;
 
const
  cmTest1 = 251;
  cmTest2 = 252;
 
type
  PRec = ^Rec;
  Rec = record
    name: string;
    surname: string;
    data: array[1 .. 1000] of char;
  end;
 
  PMyObj = ^TMyObj;
  TMyObj = object(TObject)
    R: PRec;
 
    constructor init;
    constructor create;
  end;
 
constructor TMyObj.init;
begin
  inherited init;
  New(R);
  if R = nil then Fail;
end;
constructor TMyObj.create;
begin
  inherited init;
  R := MemAlloc(sizeof(Rec));
  if R = nil then Fail;
end;
 
type
  TTutorApp = object(TApplication)
    list: PCollection;
 
    constructor init;
    procedure InitStatusLine; virtual;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure OutOfMemory; virtual;
 
    procedure Test1;
    procedure Test2;
  end;
 
function HeapFunc (size: word): integer; far;
begin
  HeapFunc := 1
end;
 
constructor TTutorApp.init;
begin
  inherited init;
  list := New(PCollection, Init(10, 5));
end;
 
procedure TTutorApp.OutOfMemory;
begin
  MessageBox('No enough memory to complete operation!',
    nil, mfError + mfOKButton);
end;
 
 
procedure TTutorApp.InitStatusLine;
var
  R: TRect;
begin
  GetExtent(R);
  R.A.Y := R.B.Y - 1;
  New(StatusLine, Init(R,
    NewStatusDef(0, $EFFF,
      NewStatusKey('~F3~ Test #1', kbF3, cmTest1,
      NewStatusKey('~F4~ Test #2', kbF4, cmTest2,
      NewStatusKey('~Alt+F3~ Close', kbAltF3, cmClose,
      StdStatusKeys(nil)))),
    NewStatusDef($F000, $FFFF,
      StdStatusKeys(nil), nil))));
end;
 
procedure TTutorApp.HandleEvent(var Event: TEvent);
var
  R: TRect;
begin
  inherited HandleEvent(Event);
 
  if Event.What = evCommand then begin
    case Event.Command of
      cmTest1:
        begin
          Test1;
          ClearEvent(Event);
        end;
      cmTest2:
        begin
          Test2;
          ClearEvent(Event);
        end;
    end;
  end;
 
end;
 
procedure TTutorApp.Test1;
var i: integer;
    ToBeAdded: PMyObj;
begin
  for i := 1 to 10000 do
  begin
    ToBeAdded := new(PMyObj, init);
    if ToBeAdded = nil then begin
      OutOfMemory; break;
    end
    else list^.insert(ToBeAdded);
  end;
end;
 
procedure TTutorApp.Test2;
var ToBeAdded: PMyObj;
begin
  while true do begin
    ToBeAdded := new(PMyObj, create);
    if ToBeAdded = nil then begin
      OutOfMemory; break;
    end
    else list^.insert(ToBeAdded);
  end;
end;
 
var
  TutorApp: TTutorApp;
 
begin
  TutorApp.Init;
  HeapError := @HeapFunc; { <== добавляем обработчик ПОСЛЕ инициализации менеджера памяти, переопределяя результат }
  TutorApp.Run;
  TutorApp.Done;
end.

Получаю и в первом случае сообщение о нехватке памяти, но на экране вот такая фигня:
Прикреплённый файлscreen.PNG (11.17 Кбайт, скачиваний: 331)

[volvo877]

Romtek, странно... У меня ничего на экран не добавляется, чистое сообщение, при вызове тестов в любом порядке, хотя перемешивать менеджеры куч, конечно, не очень хорошо...

[Romtek]

В таком случае стоит перекрыть constructor Init.

Добавлено 17.01.07, 10:47
Чёрт. Никак не получается.
Пробовал переопределить constructor TTutorApp.init:

constructor TTutorApp.init;
begin
  InitMemory;
  HeapError := @HeapFunc;
  InitVideo;
  InitEvents;
  InitSysError;
  InitHistory;
  TProgram.Init;
 
  list := New(PCollection, Init(10, 5));
end;

даёт тот же результат (что неудивительно).
А так:

constructor TTutorApp.init;
begin
  HeapError := @HeapFunc;
  SafetyPoolSize := LowMemSize*16;
  LowMemory;
 
  InitVideo;
  InitEvents;
  InitSysError;
  InitHistory;
  TProgram.Init;
 
  list := New(PCollection, Init(10, 5));
end;

компилятор сообщает о незнакомой SafetyPoolSize...

Добавлено 17.01.07, 11:02
Кстати, когда зыпускаю не из IDE, a EXE, прога вообще зависает при 1-м способе.

Добавлено 17.01.07, 11:04
Ладно, оставлю экскреперименты и сделаю с помощью MemAlloc.