blob: 481533b0cc84db00fcadd65957f85ac56bc00b7e (
plain)
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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
{$include execd.inc}
{$include execf.inc}
{$include timerd.inc}
{$include doslibd.inc}
{$include doslibf.inc}
{$include arosthreads.inc}
function ThreadFunc(Data: Pointer): Pointer; cdecl;
var
LThread: TThread;
LFreeOnTerminate: Boolean;
ISuspended: Boolean;
begin
//Debugln('Enter ThreadFunc');
Result := nil;
LThread := TThread(Data);
ISuspended := LThread.FInitialSuspended;
if ISuspended then
begin
if not LThread.FTerminated then
begin
LockMutex(LThread.FSem);
WaitCondition(LThread.FCond, LThread.FSem);
UnlockMutex(LThread.FSem);
end;
end;
//Sleep(1);
if not LThread.FTerminated then
begin
//Debugln('Execute Thread');
try
LThread.Execute;
except
on E: Exception do
begin
//DebugLn('Exception in Thread '+ e.Classname + e.MEssage);
LThread.FFatalException := TObject(AcquireExceptionObject);
if E is EThreadDestroyCalled then
LThread.FFreeOnTerminate := true;
end;
end;
//Debugln('Back from Thread');
//Sleep(1);
end;
LFreeOnTerminate := LThread.FreeOnTerminate;
LThread.DoTerminate;
LThread.FFinished := True;
if LFreeOnTerminate then
LThread.Free;
//debugln('Finished Thread?, then what to do now?')
end;
procedure TThread.SysCreate(CreateSuspended: Boolean; const StackSize: SizeUInt);
begin
if not Assigned(AROSThreadStruct) then
raise EThread.CreateFmt(SThreadCreateError, ['ThreadLib not found']);
FSuspended := CreateSuspended;
FInitialSuspended := CreateSuspended;
// Mutex for suspend actions
FSem := CreateMutex;
FCond := CreateCondition;
FHandle := AROSCreateThread(@ThreadFunc, Self, StackSize);
FThreadID := FHandle;
if FHandle = 0 then
raise EThread.CreateFmt(SThreadCreateError, ['Cannot Create Thread']);
// exception if Thread cannot be created
FFatalException := nil;
end;
procedure TThread.SysDestroy;
begin
if FHandle <> 0 then
begin
if not FFinished then
begin
Terminate;
if FSuspended then
begin
SignalCondition(FCond);
Sleep(0);
end;
WaitFor;
end;
end;
FHandle := 0;
DestroyCondition(FCond);
DestroyMutex(FSem);
FFatalException := nil;
end;
procedure TThread.CallOnTerminate;
begin
FOnTerminate(Self);
end;
procedure TThread.DoTerminate;
begin
if Assigned(FOnTerminate) then
Synchronize(@CallOnTerminate);
end;
function TThread.GetPriority: TThreadPriority;
begin
//
end;
procedure TThread.SetPriority(Value: TThreadPriority);
begin
//
end;
procedure TThread.SetSuspended(Value: Boolean);
begin
if Value <> FSuspended then
if Value then
Suspend
else
Resume;
end;
procedure TThread.Suspend;
begin
if FThreadID = GetCurrentThreadID then
begin
FSuspended := True;
LockMutex(FSem);
WaitCondition(FCond, FSem);
UnlockMutex(FSem);
end else
Raise EThread.create('Suspending one thread from inside another one is unsupported (because it is unsafe and deadlock prone) by AROS');
end;
procedure TThread.Resume;
begin
if FSuspended then
begin
SignalCondition(FCond);
Sleep(100);
end;
FSuspended := False;
FInitialSuspended := False;
end;
procedure TThread.Terminate;
begin
FTerminated := True;
end;
function TThread.WaitFor: Integer;
begin
Result := 0;
if (not FSuspended) and (FHandle <> 0) then
begin
Sleep(1);
AROSWaitThread(FHandle);
end;
end;
|
