1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:

unit Main;

{
  This is an example program demonstrating a possible deadlock within Delphi's
  memory manager, caused when suspending a thread while it is proceeding a call
  to GetMem / FreeMem / ReallocMem, in which it enters the critical section
  heapLock defined in GETMEM.INC.
  To deadlock the program, resume the thread, suspend it and then try to use
  GetMem or FreeMem (these are called in the context of the main VCL thread).
  If you are lucky (or unlucky), you suspended the thread while it was in the
  critical section, causing the program to deadlock because the VCL thread waits
  at EnterCriticalSection while the thread owning this section is suspended.
  If not, just try again (resume the thread, suspend it and click GetMem/FreeMem).
}

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TSomeThread = class(TThread)
  protected
    procedure Execute; override;
  end;

  TForm1 = class(TForm)
    BtnSuspend: TButton;
    BtnResume: TButton;
    BtnGetMem: TButton;
    BtnFreeMem: TButton;
    procedure BtnSuspendClick(Sender: TObject);
    procedure BtnResumeClick(Sender: TObject);
    procedure BtnGetMemClick(Sender: TObject);
    procedure BtnFreeMemClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    FSomeThread: TSomeThread;
    FSomeMem: Pointer;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TSomeThread }

procedure TSomeThread.Execute;
var
  SomeMem: Pointer;
begin
  inherited;
  while not Terminated do
  begin
    GetMem(SomeMem, 1024);
    Sleep(0);
    FreeMem(SomeMem, 1024);
    Sleep(0);
  end;
end;

{ TForm1 }

procedure TForm1.BtnSuspendClick(Sender: TObject);
begin
  FSomeThread.Suspend;
  BtnSuspend.Enabled := False;
  BtnResume.Enabled := True;
end;

procedure TForm1.BtnResumeClick(Sender: TObject);
begin
  FSomeThread.Resume;
  BtnSuspend.Enabled := True;
  BtnResume.Enabled := False;
end;

procedure TForm1.BtnGetMemClick(Sender: TObject);
begin
  GetMem(FSomeMem, 1024);
  BtnGetMem.Enabled := False;
  BtnFreeMem.Enabled := True;
end;

procedure TForm1.BtnFreeMemClick(Sender: TObject);
begin
  FreeMem(FSomeMem);
  FSomeMem := nil;
  BtnGetMem.Enabled := True;
  BtnFreeMem.Enabled := False;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FSomeThread := TSomeThread.Create(True);
  FSomeThread.FreeOnTerminate := True;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  with FSomeThread do
  begin
    Terminate;
    if Suspended then
      Resume;
    WaitFor;
  end;
  if Assigned(FSomeMem) then
    FreeMem(FSomeMem);
end;

end.