您好，线程怎么用信号量同步 ？ 以下代码不行......谢谢 (50分)

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Edit1: TEdit;
Timer1: TTimer;
procedure Timer1Timer(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

type
TMyThread = class(TThread)
private

protected
procedure Execute; override;
public

constructor Create; virtual;
end;


var
Form1 : TForm1;
HSem : THandle = 0 ;
implementation

{$R *.dfm}

procedure TMyThread.Execute;
var
WaitReturn : DWord ;
begin
WaitReturn := WaitForSingleObject(HSem,INFINITE) ;
Form1.Edit1.Text := DateTimeToStr(Now);
ReleaseSemaphore(HSem, 1, Nil)
end;

constructor TMyThread.Create;
begin
inherited Create(False);
FreeOnTerminate := True;
end;


procedure TForm1.Timer1Timer(Sender: TObject);
var
i: Integer;
begin
for i := 0 to 1000 do
begin
TMyThread.Create;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
HSem := CreateSemaphore(Nil,1,1,Nil) ;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
CloseHandle(HSem) ;
end;

end.

当然实现这个功能完全可以不用线程，这是一段测试用的代码

执行一会儿就报 内存不足

谢谢您

[red]for i := 0 to 1000 do
begin
TMyThread.Create;
end; [/red]
这内存没法足，什么机器也经不起这么折腾.

try FreeOnTerminal = true

for i := 0 to 1000 do
//
换小点也可以呀，我是觉得我的信号量用的有问题 ，
请指导

问题很多吧！
HSem := CreateSemaphore(Nil,1,1,Nil) ;
////
只建立了一次，释放了1000次，当然会出错。

jsxjd :

您好， 应该怎么做 ？ 我是看书上的，我对那个函数也不熟悉，望指导

估计是这里的问题
Form1.Edit1.Text := DateTimeToStr(Now);

你把她注释掉, 如果不出问题就是VCL的问题．．．一般涉及VCL的要用
Synchronize，这个和信号量无关

这样子 还是不行，就是注释掉那句也不行
----------------------------------
unit Unit1;

interface

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

type
TMyThread = class(TThread)
private

protected
procedure Execute; override;
public

constructor Create; virtual;
end;


type
TForm1 = class(TForm)
Edit1: TEdit;
Timer1: TTimer;
procedure Timer1Timer(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
MyThread : Array of TMyThread ;
procedure ShowTime(sender: TObject) ;
{ Private declarations }
public
{ Public declarations }
end;



var
Form1 : TForm1;
HSem : THandle = 0 ;
implementation

{$R *.dfm}

procedure TMyThread.Execute;
var
WaitReturn : DWord ;
begin
FreeOnTerminate := True;
WaitReturn := WaitForSingleObject(HSem,INFINITE) ;
end;

constructor TMyThread.Create;
begin
inherited Create(False);
end;


procedure TForm1.Timer1Timer(Sender: TObject);
var
I: Integer;
begin
SetLength(MyThread,256) ;
for I := 0 to 255 do
begin
HSem := CreateSemaphore(Nil,1,1,Nil) ;
MyThread := TMyThread.Create ;
MyThread.OnTerMinate := ShowTime ;
end;
end;

procedure TForm1.ShowTime(Sender : TObject);
begin
// Edit1.Text := DateTimeToStr(Now); //注释掉也不行
ReleaseSemaphore(HSem, 1, Nil)
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
HSem := CreateSemaphore(Nil,1,1,Nil) ;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
CloseHandle(HSem) ;
end;

end.


该怎么办 ？

就用你原来的代码，把信号量的初值设大点,使你更多的线程能同时执行:
HSem := CreateSemaphore(Nil,50,50,Nil) ;
另外别创建海量的线程，什么 CPU 也受不了这个.

xeen : 那样不行，上面的代码还能运行一会儿......

该怎么办 ？

不是告诉你别创建太多线程吗：
for i := 0 to 10 do
begin
TMyThread.Create;
end;
另外 timer的interval 也设大点.

xeen ：

谢谢您 ：） ，我设为 10 ，用原来的程序可以了 。但 1000 不行 ：），能告诉我原因吗 ？

谢谢，如果我需要大量使用线程呢（像 1000 个） ？该怎么办 ，有没有好的解决方法 ？

还有，CreateSemaphore 的参数能否讲解一下，谢谢

我试试！

给段代码你参考：

unit MultiSearchThreadUnit;

interface

uses Windows, Messages, SysUtils, Classes,ComCtrls,Dialogs;

type
TMultiSearchHostThread=class(TThread)
private
StartNum,GroupIndex,ImageIndex:integer;
tnode:TTreeNode;
GroupName:string;
protected
procedure Execute; override;
procedure GetTreeInfo;
Procedure AddGroup;
end;

TMainThread=class(TThread)
protected
procedure Execute; override;
Procedure EndSearch;
end;

implementation
uses main,SearchGroupThreadUnit;

procedure TMultiSearchHostThread.GetTreeInfo;
begin
with MainForm do
begin
ImageIndex:=SearchTree.Items[0].item[GroupIndex].ImageIndex;
tnode:=SearchTree.Items[0].item[GroupIndex];
GroupName:=tnode.Text;
end;
end;

procedure TMultiSearchHostThread.AddGroup;
begin
with MainForm do
begin
StatusBar.Panels[0].Text := '正在搜索工作组：'+GroupName;
end;
end;

procedure TMultiSearchHostThread.Execute;
var i:integer;
searchers:array[1..100]of TSearchGroupThread;
bDo:array[1..100]of boolean;
begin
for i:=1 to 100 do bDo:=false;

for i:=1 to ThreadNum do
begin
//if stop then exit;
if terminated then exit;

if StartNum+i<GroupNum then
begin
GroupIndex:=StartNum+i;
synchronize(GetTreeInfo);
if (ImageIndex <> 9) and(ImageIndex <> 16) then
begin
//gn:=AllGroups[start+i];
if terminated then exit;
//node:=treeview1.Items[0].Item[start+i];
Synchronize(AddGroup);
//if stop then exit;
if terminated then exit;
bDo:=true;
searchers:=TSearchGroupThread.create(true);
searchers.MyGroup := GroupName;
//searchers.choice :=0;
searchers.MyTree := MainForm.SearchTree;
searchers.mynode := tnode;
searchers.mynode.ImageIndex := 16;
searchers.mynode.selectedIndex := 16;
searchers.FreeOnTerminate := true;
searchers.Resume;
//if threadMode=0 then searchers.WaitFor; //单线程
end;
end else exit;
end; //end of for

//if threadMode=1 then
//begin

for i:=1 to ThreadNum do
if bDo and (searchers<>nil) then
begin
if not searchers.Terminated then
begin
searchers.WaitFor;
{if ver>4 then
begin
searchers.Terminate;
searchers.free //win98下free会出错。

end
else //searchers.Terminate;
TerminateThread(searchers.handle,0);}
end;
end;

//end;

end;

procedure TMainThread.EndSearch;
begin

with MainForm do
begin
ToolBtnStop.Enabled := false;
ToolBtnPause.Enabled := false;
ToolBtnAuto.Enabled := true;
Timer1.Enabled := false;
end;

end;

procedure TMainThread.Execute;
var i:integer;
Multisearcherhost:TMultiSearchHostThread;
begin

i:=SearchBeginNum;
repeat
if stop then exit;
if terminated then exit;
Multisearcherhost:=TMultiSearchHostThread.create(true);
Multisearcherhost.StartNum := i;
Multisearcherhost.FreeOnTerminate := true;
Multisearcherhost.Resume;
Multisearcherhost.WaitFor;
i:=i+ThreadNum;
SearchProgress:=i; //timer
until i>= GroupNum;
synchronize(EndSearch);

end;

end.

设置 为 100 后 10多分钟还会出错，没有更本解决 。 是不是释放问题 ？ 我设置了

FreeOnTerminate := True 呀

请继续，谢谢

以下已通过， timer1.interval=1000

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Timer1: TTimer;
Edit1: TEdit;
Edit2: TEdit;
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

type
TMyThread = class(TThread)
private
{ Private declarations }
protected
procedure Execute; override;
end;

var
Form1: TForm1;

implementation


{$R *.DFM}
var
x:integer=0;
procedure TMyThread.Execute;
var
h:THandle;
begin
h:=CreateSemaphore(Nil,1,1,'MySyn');

while h=ERROR_ALREADY_EXISTS
do begin
sleep(10);
h:=CreateSemaphore(Nil,1,1,'MySyn');
end;
Form1.Edit1.Text := DateTimeToStr(Now);
inc(x);
Form1.Edit2.Text := inttoStr(x);
application.processMessages;
ReleaseSemaphore(H, 1, Nil)

end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
i: Integer;
begin
for i := 0 to 10 do //不能太大，资源消耗太厉害。
begin
TMyThread.Create(false);
end;
end;

end.

一般的线程同步等待的是Mutex或者Event对象。而并不象你那个直接置一个Handle

书上说信号量也可以呀

我不清楚你为什么要设立Timer来建立线程，给我感觉这是不好的方式，因为你很难去控制它。
以下是我改的代码。完全可以实现线程同步
unit Unit1;

interface

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

type
TForm1 = class(TForm)
Edit1: TEdit;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

type
TMyThread = class(TThread)
private

protected
procedure Execute; override;
public

constructor Create; virtual;
end;


var
Form1 : TForm1;
HSem : THandle = 0 ;
implementation

{$R *.dfm}

var
tick: Integer = 0;
procedure TMyThread.Execute;
var
WaitReturn : DWord ;
begin
WaitReturn := WaitForSingleObject(HSem,INFINITE) ;
Form1.Edit1.Text := IntToStr(tick);
Inc(tick);
Sleep(10);
ReleaseSemaphore(HSem, 1, Nil)
end;

constructor TMyThread.Create;
begin
inherited Create(False);
FreeOnTerminate := True;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
HSem := CreateSemaphore(Nil,1,1,Nil) ;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
CloseHandle(HSem) ;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
index: Integer;
begin
for index := 0 to 10 do
begin
TMyThread.Create;
end;
end;

end.
一般的同步对象使用Mutex对象，是因为Mutex有一个特别之处：当一个持有对象的线程DOWN掉的时候，mutex对象可以自动让其它等待这个对象的线程接受，而其它的内核对象则不具体这个功能。
之所要使用Semaphore则是因为Semaphore可以提供一个活动线程的上限，即lMaximumCount参数，这才是它的真正有用之处。

agaree liguang:
用信号量一般的用处就是对访问一定资源的线程数量进行限制.