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
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468 | ------------------------------------------------------------------------------
-- --
-- GLADE COMPONENTS --
-- --
-- S Y S T E M . G A R L I C . T A S K I N G --
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2020 Free Software Foundation, Inc. --
-- --
-- GARLIC is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GARLIC is distributed in the hope that it will be useful, but --
-- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABI- --
-- LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
-- License for more details. You should have received a copy of the GNU --
-- General Public License distributed with GARLIC; see file COPYING. If --
-- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, --
-- Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
------------------------------------------------------------------------------
-- with Ada.Calendar;
with Ada.Dynamic_Priorities;
-- with Ada.Task_Attributes;
with System; use System;
with System.Garlic.Debug; use System.Garlic.Debug;
with System.Garlic.Soft_Links; use System.Garlic.Soft_Links;
with System.Garlic.Types; use System.Garlic.Types;
with System.Tasking;
pragma Elaborate_All (System.Tasking);
with System.Tasking.Debug;
pragma Elaborate_All (System.Tasking.Debug);
with System.Tasking.Utilities;
pragma Elaborate_All (System.Tasking.Utilities);
package body System.Garlic.Tasking is
Private_Debug_Key : constant Debug_Key :=
Debug_Initialize ("S_GARTAS", "(s-gartas): ");
procedure D
(Message : String;
Key : Debug_Key := Private_Debug_Key)
renames Print_Debug_Info_Nolock;
use Ada.Task_Identification;
use type System.Tasking.Task_Id;
-- package Stamp_Task_Attributes is
-- new Ada.Task_Attributes (Stamp_Type, No_Stamp);
-- use Stamp_Task_Attributes;
Environment_Task : constant System.Tasking.Task_Id := System.Tasking.Self;
-- The environment task. Self will be set to it at elaboration time.
type Protected_Mutex_Access is access all Protected_Mutex_Type;
type Protected_Watcher_Access is access all Protected_Watcher_Type;
Critical_Section : Clever_Lock;
-----------------
-- Clever_Lock --
-----------------
protected body Clever_Lock is
----------------
-- Contention --
----------------
entry Contention when Count = 0 is
begin
Owner := Contention'Caller;
Count := 1;
pragma Debug (D (Image (Contention'Caller) &
" is out from contention"));
end Contention;
----------
-- Lock --
----------
entry Lock when True is
begin
if Count = 0 or else Lock'Caller = Owner then
Count := Count + 1;
Owner := Lock'Caller;
pragma Debug (D ("Locked by " & Image (Owner) &
", count is now " & Count'Img));
else
pragma Debug (D ("Contention in lock" &
", locker is " & Image (Owner) &
", waiting is " & Image (Lock'Caller) &
", count is" & Count'Img));
pragma Assert (not Is_Terminated (Owner));
requeue Contention with abort;
end if;
end Lock;
------------
-- Unlock --
------------
entry Unlock when True is
begin
pragma Assert (Unlock'Caller = Owner);
pragma Assert (Count > 0);
Count := Count - 1;
pragma Debug (D ("Unlocked by " & Image (Owner) &
", count is now " & Count'Img));
end Unlock;
end Clever_Lock;
------------
-- Create --
------------
function Create (V : Version_Id) return Watcher_Access is
W : constant Protected_Watcher_Access := new Protected_Watcher_Type;
begin
W.P.Init (V);
return Watcher_Access (W);
end Create;
------------
-- Create --
------------
function Create return Adv_Mutex_Access is
begin
return new Protected_Adv_Mutex_Type;
end Create;
------------
-- Create --
------------
function Create return Mutex_Access is
M : constant Protected_Mutex_Access := new Protected_Mutex_Type;
begin
M.X := new Mutex_PO;
return Mutex_Access (M);
end Create;
-------------
-- Destroy --
-------------
procedure Destroy (W : in out Protected_Watcher_Type)
is
pragma Unreferenced (W);
begin
null;
end Destroy;
-------------
-- Destroy --
-------------
procedure Destroy (M : in out Protected_Adv_Mutex_Type)
is
pragma Unreferenced (M);
begin
null;
end Destroy;
-------------
-- Destroy --
-------------
procedure Destroy (M : in out Protected_Mutex_Type) is
begin
if M.X /= null then
Free (M.X);
end if;
end Destroy;
------------
-- Differ --
------------
procedure Differ (W : in out Protected_Watcher_Type; V : Version_Id)
is
begin
W.P.Differ (V);
end Differ;
-----------
-- Enter --
-----------
procedure Enter (M : Protected_Mutex_Type) is
begin
pragma Assert (M.X /= null);
M.X.Enter;
end Enter;
-----------
-- Enter --
-----------
procedure Enter (M : in out Protected_Adv_Mutex_Type) is
begin
M.X.Lock;
end Enter;
----------------------------
-- Enter_Critical_Section --
----------------------------
procedure Enter_Critical_Section is
begin
Critical_Section.Lock;
end Enter_Critical_Section;
--------------------------
-- Env_Task_Awake_Count --
--------------------------
function Env_Task_Awake_Count return Natural is
begin
return Environment_Task.Awake_Count;
end Env_Task_Awake_Count;
------------------
-- Get_Priority --
------------------
function Get_Priority return Natural is
begin
return Natural (Ada.Dynamic_Priorities.Get_Priority);
end Get_Priority;
-- --------------------
-- -- Get_Task_Stamp --
-- --------------------
-- function Get_Task_Stamp return Stamp_Type is
-- begin
-- return Value;
-- end Get_Task_Stamp;
----------------------------
-- Independent_Task_Count --
----------------------------
function Independent_Task_Count return Natural is
begin
return System.Tasking.Utilities.Independent_Task_Count;
end Independent_Task_Count;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
pragma Debug (D ("Registering soft links"));
Register_Enter_Critical_Section (Enter_Critical_Section'Access);
Register_Leave_Critical_Section (Leave_Critical_Section'Access);
Register_Watcher_Creation_Function (Create'Access);
Register_Mutex_Creation_Function (Create'Access);
Register_Adv_Mutex_Creation_Function (Create'Access);
Register_Is_Environment_Task (Is_Environment_Task'Access);
Register_Env_Task_Awake_Count (Env_Task_Awake_Count'Access);
Register_Independent_Task_Count (Independent_Task_Count'Access);
Register_List_Tasks (List_Tasks'Access);
Register_Get_Priority (Get_Priority'Access);
Register_Set_Priority (Set_Priority'Access);
-- Register_Get_Stamp (Get_Task_Stamp'Access);
-- Register_Set_Stamp (Set_Task_Stamp'Access);
end Initialize;
-------------------------
-- Is_Environment_Task --
-------------------------
function Is_Environment_Task return Boolean
is
Self : constant System.Tasking.Task_Id := System.Tasking.Self;
begin
return Self = Environment_Task;
end Is_Environment_Task;
-----------
-- Leave --
-----------
procedure Leave (M : in out Protected_Adv_Mutex_Type) is
begin
M.X.Unlock;
end Leave;
-----------
-- Leave --
-----------
procedure Leave (M : Protected_Mutex_Type) is
begin
M.X.Leave;
end Leave;
----------------------------
-- Leave_Critical_Section --
----------------------------
procedure Leave_Critical_Section is
begin
Critical_Section.Unlock;
end Leave_Critical_Section;
----------------
-- List_Tasks --
----------------
procedure List_Tasks is
begin
System.Tasking.Debug.List_Tasks;
end List_Tasks;
------------
-- Lookup --
------------
procedure Lookup (W : Protected_Watcher_Type; V : out Version_Id) is
begin
V := W.P.Lookup;
end Lookup;
--------------
-- Mutex_PO --
--------------
protected body Mutex_PO is
-----------
-- Enter --
-----------
entry Enter when not Held is
begin
Held := True;
end Enter;
-------------
-- Is_Held --
-------------
function Is_Held return Boolean is
begin
return Held;
end Is_Held;
-----------
-- Leave --
-----------
procedure Leave is
begin
pragma Assert (Held);
Held := False;
end Leave;
end Mutex_PO;
------------------
-- Set_Priority --
------------------
procedure Set_Priority (P : Natural) is
begin
Ada.Dynamic_Priorities.Set_Priority (Any_Priority (P));
end Set_Priority;
-- --------------------
-- -- Set_Task_Stamp --
-- --------------------
-- procedure Set_Task_Stamp (S : Float) is
-- X : Stamp_Type := S;
-- begin
-- if S = No_Stamp and then Value = No_Stamp then
-- X := Stamp_Type (Ada.Calendar.Seconds (Ada.Calendar.Clock));
-- end if;
-- Set_Value (X);
-- end Set_Task_Stamp;
------------
-- Update --
------------
procedure Update (W : in out Protected_Watcher_Type) is
begin
W.P.Update;
end Update;
----------------
-- Watcher_PO --
----------------
protected body Watcher_PO is
------------
-- Differ --
------------
entry Differ (From : Version_Id) when not Updated is
begin
if From = Value then
requeue Wait_For_Update with abort;
end if;
end Differ;
----------
-- Init --
----------
procedure Init (Initial_Value : Version_Id) is
begin
Value := Initial_Value;
end Init;
------------
-- Lookup --
------------
function Lookup return Version_Id is
begin
return Value;
end Lookup;
------------
-- Update --
------------
procedure Update is
begin
Value := Value + 1;
if Wait_For_Update'Count > 0 then
Updated := True;
end if;
end Update;
---------------------
-- Wait_For_Update --
---------------------
entry Wait_For_Update (From : Version_Id) when Updated is
begin
if Wait_For_Update'Count = 0 then
Updated := False;
end if;
requeue Differ;
end Wait_For_Update;
end Watcher_PO;
end System.Garlic.Tasking;
|