Короче повозился с отладчиком, прошёлся по тексту и понял, что метод Canvas.Lock(), видимо, не отрабатывает до конца, т.е. не блокирует обращение к свойствам Canvas (конкретно к объекту Canvas.Pen) из других потоков.
Ошибка возникает при установке цвета пера в потоке:
- Код: Выделить всё
with FForm.Canvas do
begin
Lock;
Pen.Color:= FColor; // <-- вызов приводящий к исключению
MoveTo(P1);
LineTo(P2);
Unlock;
Sleep(1);
end;
дальше вызов переходит к методу Pen.SetColor:
- Код: Выделить всё
procedure TPen.SetColor(const NewColor: TColor; const NewFPColor: TFPColor);
begin
if (NewColor = Color) and (NewFPColor = FPColor) then Exit; // если цвет не изменился то выходим процедуры
FreeReference; // <-- а если изменился, то удаляем ссылку на существующее перо из кэша ресурсов?
FColor := NewColor;
inherited SetFPColor(NewFPColor);
Changed;
end;
дальше вызывается Pen.FreeReference:
- Код: Выделить всё
procedure TPen.FreeReference;
begin
if not FReference.Allocated then Exit;
Changing;
if FPenHandleCached then
begin
PenResourceCache.FindPen(FReference.Handle).DecreaseRefCount; //<-- здесь вызывается исключение т.к. "кто-то" уже удалил из кэша ресурсов предыдущие перо и RefCount = 0.
FPenHandleCached := False;
end else
DeleteObject(HGDIOBJ(FReference.Handle));
FReference._lclHandle := 0;
end;
Думаю, что "кто-то" - это основной поток выполнения (GUI). После того как Pen "закэшировался", происходит переключение между потоками в момент после вызова TPen.FreeReference, но до вызова PenResourceCache.FindPen(FReference.Handle).DecreaseRefCount; и следующий поток несмотря на canvas.lock() получает доступ к canvas.pen и выполняет DecreaseRefCount раньше прерванного потока.
Добавлено спустя 8 минут 16 секунд:В связи с этим сделал вызов отрисовки на Canvas в синхронизированном методе (т.е. в основном потоке выполнения приложения) - и теперь проблема исчезла! Таким образом это косвенно подтверждает что именно главный поток управления не обращал внимание на Canvas.lock().
Вот изменённый код TDrawThread из main.pas (всё остальное осталось без изменений):
- Код: Выделить всё
TDrawThread = class(TThread)
private
P1, P2: TPoint;
FColor: TColor;
FForm: TForm;
procedure DrawLine;
procedure GetRandCoords;
public
constructor Create(AForm: TForm; AColor: TColor);
procedure Execute; override;
end;
procedure TDrawThread.DrawLine;
begin
with FForm.Canvas do
begin
Pen.Color:= FColor;
MoveTo(P1);
LineTo(P2);
end;
end;
procedure TDrawThread.Execute;
begin
//FreeOnTerminate:= True;
while not (self.Terminated or Application.Terminated) do
begin
Synchronize(@GetRandCoords);
Synchronize(@DrawLine);
Sleep(1);
end;
self.Free;
self:= nil;
end;
Добавлено спустя 1 час 37 минут 49 секунд:ещё немного подумал и понял, что в таком варианте - приложение по факту однопоточное, т.к. параллельно потоки только "спят"
немного изменил приложение, так, чтоб в разных потоках, хотя бы координаты для линий параллельно "считались".:
- Код: Выделить всё
unit Main;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
Menus;
type
{ TMainForm }
TMainForm = class(TForm)
ColorDialog1: TColorDialog;
MainMenu1: TMainMenu;
AddThread: TMenuItem;
Add10: TMenuItem;
RemoveAll: TMenuItem;
RemoveThread: TMenuItem;
Options1: TMenuItem;
procedure Add10Click(Sender: TObject);
procedure AddThreadClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure RemoveAllClick(Sender: TObject);
procedure RemoveThreadClick(Sender: TObject);
private
{ private declarations }
ThreadList: TList;
public
{ public declarations }
end;
{ TDrawThread }
TDrawThread = class(TThread)
private
P1, P2: TPoint;
FColor: TColor;
FForm: TForm;
MaxX, MaxY: Integer;
procedure DrawLine;
procedure GetFormCoords;
public
constructor Create(AForm: TForm; AColor: TColor);
procedure Execute; override;
end;
var
MainForm: TMainForm;
implementation
{ TMainForm }
procedure TMainForm.FormCreate(Sender: TObject);
begin
ThreadList:= TList.Create;
self.Caption:= Format('Num. of Treads [%u]',[ThreadList.Count]);
end;
procedure TMainForm.AddThreadClick(Sender: TObject);
begin
if ColorDialog1.Execute then
ThreadList.Add(TDrawThread.Create(Self, ColorDialog1.Color));
self.Caption:= Format('Num. of Treads [%u]',[ThreadList.Count]);
end;
procedure TMainForm.Add10Click(Sender: TObject);
var
i: integer;
begin
for i:= 1 to 10 do
ThreadList.Add(TDrawThread.Create(Self, Random(MaxInt)));
self.Caption:= Format('Num. of Treads [%u]',[ThreadList.Count]);
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
RemoveAllClick(nil);
ThreadList.Free;
end;
procedure TMainForm.RemoveAllClick(Sender: TObject);
var
i: integer;
begin
Cursor:= crHourGlass;
try
for i:= ThreadList.Count - 1 downto 0 do
begin
TDrawThread(ThreadList[i]).Terminate;
// TDrawThread(ThreadList[i]).WaitFor;
end;
ThreadList.Clear;
finally
Cursor:= crDefault;
end;
self.Caption:= Format('Num. of Treads [%u]',[ThreadList.Count]);
end;
procedure TMainForm.RemoveThreadClick(Sender: TObject);
begin
if ThreadList.Count < 1 then exit;
TDrawThread(ThreadList[ThreadList.Count - 1]).Terminate;
ThreadList.Delete(ThreadList.Count - 1);
self.Caption:= Format('Num. of Treads [%u]',[ThreadList.Count]);
end;
{ TDrawThread }
constructor TDrawThread.Create(AForm: TForm; AColor: TColor);
begin
FColor:= AColor;
FForm := AForm;
inherited Create(False);
end;
procedure TDrawThread.GetFormCoords;
begin
self.MaxX:= FForm.ClientWidth;
self.MaxY:= FForm.ClientHeight;
end;
procedure TDrawThread.DrawLine;
begin
with FForm.Canvas do
begin
Pen.Color:= FColor;
MoveTo(P1);
LineTo(P2);
end;
end;
procedure TDrawThread.Execute;
begin
FreeOnTerminate:= True;
while not (self.Terminated or Application.Terminated) do
begin
Synchronize(@GetFormCoords);
P1.x:= Random(self.MaxX);
P2.x:= Random(self.MaxX);
P1.y:= Random(self.MaxY);
P2.y:= Random(self.MaxY);
Synchronize(@DrawLine);
Sleep(1);
end;
end;
initialization
{$I main.lrs}
Randomize;
end.
и на счёт что лучше для лазаруса:
- Код: Выделить всё
FreeOnTerminate:=True;
или
- Код: Выделить всё
Free;
Self:=Nil;
при втором варианте в windows XP 32b при удалении потоков в приложении - в диспетчере задач количество потоков в процессе не уменьшается! в первом же случае всё корректно.
Чтобы посмотреть количество потоков в приложении нужно в диспетчере задач win xp зайти и выбрать View->Select Coluns -> Thread Count. после этого на вкладке Processes появится дополнительный столбец Threads.
Так что чтобы не допускать утечек ресурсов системы я думаю лучше использовать вариант с FreeOnTerminate:=True;
